diff --git a/.dir-locals.el b/.dir-locals.el
deleted file mode 100644
index e9d4c92f06ae7a00e47bc6ac8a4d30a84b1ae4b4..0000000000000000000000000000000000000000
--- a/.dir-locals.el
+++ /dev/null
@@ -1,8 +0,0 @@
-;;; Directory Local Variables
-;;; See Info node `(emacs) Directory Variables' for more information.
-
-((coq-mode
- (coq-load-path
- (rec "." "_"))))
-
-
diff --git a/.gitignore b/.gitignore
index 3060a4bcb97219063b0bf96ce7c6b64a70b1599e..a6c7e3145be75736bc809867b7a72b08baff490a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,10 @@
-*.v~
*.vo
*.v.d
*.glob
-guide
-html
+*.cache
+*.aux
+\#*\#
+*~
+*.bak
+.coq-native/
+Makefile
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000000000000000000000000000000000000..1f85999fb2575996d980ef1629737c5929d89466
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,28 @@
+All files in this development, excluding those in docs/, are distributed
+under the terms of the BSD license, included below.
+
+------------------------------------------------------------------------------
+
+ BSD LICENCE
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ * Neither the name of the <organization> nor the
+ names of its contributors may be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Makefile b/Makefile
deleted file mode 100644
index 4e9173dbe06acf2c47b5f8b166cc0a37e9dbc597..0000000000000000000000000000000000000000
--- a/Makefile
+++ /dev/null
@@ -1,202 +0,0 @@
-# This Makefile started being auto-generated, but now it's hand-crafted and automatically finds all the files.
-# YOU SHOULD NOT HAVE TO EDIT THIS FILE.
-
-.DEFAULT_GOAL := all
-
-#
-# This Makefile may take arguments passed as environment variables:
-# COQBIN to specify the directory where Coq binaries resides;
-# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;
-# DSTROOT to specify a prefix to install path.
-
-# Here is a hack to make $(eval $(shell works:
-define donewline
-
-
-endef
-includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\r' | tr '\n' '@'; })))
-$(call includecmdwithout@,$(COQBIN)coqtop -config)
-
-##########################
-# #
-# Libraries definitions. #
-# #
-##########################
-
-COQLIBS?=-I . -R . _
-COQDOCLIBS?=-I lib
-
-##########################
-# #
-# Variables definitions. #
-# #
-##########################
-
-
-OPT?=
-COQDEP?="$(COQBIN)coqdep" -c
-COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)
-COQCHKFLAGS?=-silent -o
-COQDOCFLAGS?=-interpolate -utf8
-COQC?="$(COQBIN)coqc"
-GALLINA?="$(COQBIN)gallina"
-COQDOC?="$(COQBIN)coqdoc"
-COQCHK?="$(COQBIN)coqchk"
-
-##################
-# #
-# Install Paths. #
-# #
-##################
-
-ifdef USERINSTALL
-XDG_DATA_HOME?="$(HOME)/.local/share"
-COQLIBINSTALL=$(XDG_DATA_HOME)/coq
-COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq
-else
-COQLIBINSTALL="${COQLIB}user-contrib"
-COQDOCINSTALL="${DOCDIR}user-contrib"
-endif
-
-######################
-# #
-# Files dispatching. #
-# #
-######################
-
-LIBVFILES:=$(wildcard lib/*/*.v)
-VFILES:=$(wildcard *.v) $(LIBVFILES)
-
--include $(addsuffix .d,$(VFILES))
-.SECONDARY: $(addsuffix .d,$(VFILES))
-
-VOFILES:=$(VFILES:.v=.vo)
-LIBVOFILES:=$(LIBVFILES:.v=.vo)
-VOFILESINC=$(filter $(wildcard ./*),$(VOFILES))
-GLOBFILES:=$(VFILES:.v=.glob)
-VIFILES:=$(VFILES:.v=.vi)
-GFILES:=$(VFILES:.v=.g)
-HTMLFILES:=$(VFILES:.v=.html)
-GHTMLFILES:=$(VFILES:.v=.g.html)
-ifeq '$(HASNATDYNLINK)' 'true'
-HASNATDYNLINK_OR_EMPTY := yes
-else
-HASNATDYNLINK_OR_EMPTY :=
-endif
-
-#######################################
-# #
-# Definition of the toplevel targets. #
-# #
-#######################################
-
-all: $(VOFILES)
-
-lib: $(LIBVOFILES)
-
-spec: $(VIFILES)
-
-gallina: $(GFILES)
-
-html: $(GLOBFILES) $(VFILES)
- - mkdir -p html
- $(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)
-
-gallinahtml: $(GLOBFILES) $(VFILES)
- - mkdir -p html
- $(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)
-
-all.ps: $(VFILES)
- $(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`
-
-all-gal.ps: $(VFILES)
- $(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`
-
-all.pdf: $(VFILES)
- $(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`
-
-all-gal.pdf: $(VFILES)
- $(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`
-
-validate: $(VOFILES)
- $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))
-
-beautify: $(VFILES:=.beautified)
- for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done
- @echo 'Do not do "make clean" until you are sure that everything went well!'
- @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/'
-
-.PHONY: all lib opt byte archclean clean install userinstall depend html validate
-
-####################
-# #
-# Special targets. #
-# #
-####################
-
-byte:
- $(MAKE) all "OPT:=-byte"
-
-opt:
- $(MAKE) all "OPT:=-opt"
-
-userinstall:
- +$(MAKE) USERINSTALL=true install
-
-clean:
- rm -f $(VOFILES) $(VIFILES) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)
- rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex
- - rm -rf html mlihtml
-
-archclean:
- rm -f *.cmx *.o
-
-printenv:
- @"$(COQBIN)coqtop" -config
- @echo 'CAMLC = $(CAMLC)'
- @echo 'CAMLOPTC = $(CAMLOPTC)'
- @echo 'PP = $(PP)'
- @echo 'COQFLAGS = $(COQFLAGS)'
- @echo 'COQLIBINSTALL = $(COQLIBINSTALL)'
- @echo 'COQDOCINSTALL = $(COQDOCINSTALL)'
-
-###################
-# #
-# Implicit rules. #
-# #
-###################
-
-%.vo %.glob: %.v
- $(COQC) $(COQDEBUG) $(COQFLAGS) $*
-
-%.vi: %.v
- $(COQC) -i $(COQDEBUG) $(COQFLAGS) $*
-
-%.g: %.v
- $(GALLINA) $<
-
-%.tex: %.v
- $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@
-
-%.html: %.v %.glob
- $(COQDOC) $(COQDOCFLAGS) -html $< -o $@
-
-%.g.tex: %.v
- $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@
-
-%.g.html: %.v %.glob
- $(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@
-
-%.v.d: %.v Makefile
- $(COQDEP) -slash $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} )
-
-%.v.beautified:
- $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*
-
-# WARNING
-#
-# This Makefile has been automagically generated
-# Edit at your own risks !
-#
-# END OF WARNING
-
diff --git a/README b/README
new file mode 100644
index 0000000000000000000000000000000000000000..53ccfc1bb8d08577edb61b5243af406f8a5acae1
--- /dev/null
+++ b/README
@@ -0,0 +1,22 @@
+PREREQUISITES
+-------------
+
+This version is known to compile with:
+
+ - Coq 8.5
+ - Ssreflect 1.6
+ - Autosubst 1.4
+
+For development, better make sure you have a version of Ssreflect that includes
+commit be724937 (no such version has been released so far, you will have to
+fetch the development branch yourself). Iris compiles fine even without this
+patch, but proof bullets will only be in 'strict' (enforcing) mode with the
+fixed version of Ssreflect.
+
+BUILDING INSTRUCTIONS
+---------------------
+
+Run the following commands to build the full development:
+
+ ./configure
+ make
diff --git a/README.txt b/README.txt
deleted file mode 100644
index 6f0c8257fb7921430b53506759812d0655087cd4..0000000000000000000000000000000000000000
--- a/README.txt
+++ /dev/null
@@ -1,121 +0,0 @@
-
-DESCRIPTION
-
- This folder contains the Coq development for
- Iris: Monoids and Invariants as an Orthogonal Basis for Concurrent Reasoning
-
- by
-
- Ralf Jung <jung@mpi-sws.org>
- David Swasey <swasey@mpi-sws.org>
- Filip Sieczkowski <filips@cs.au.dk>
- Kasper Svendsen <ksvendsen@cs.au.dk>
- Aaron Turon <turon@mpi-sws.org>
- Lars Birkedal <birkedal@cs.au.dk>
- Derek Dreyer <dreyer@mpi-sws.org>
-
-
-CONTENTS
-
- Our artifact is a Coq formalization of the model of our Iris logic,
- together with a proof of adequacy (establishing that the model is
- faithful wrt the operational semantics) and a proof of soundness of
- the primitive rules of the logic wrt the model.
-
- NOTE: We have just mechanized the *soundness* of the *primitive*
- rules of Iris in Coq. We have not mechanized the proofs of derived
- rules (i.e. those derivable from the primitive rules), nor have we
- mechanized the case study or other examples that are proven within
- the logic. Proof outlines for the latter are given in the appendix
- that accompanied the POPL submission, and will be fleshed out even
- further for the final version of the appendix.
-
- The reason we focused on the primitive rules is that those are the
- rules whose soundness is proven by direct appeal to the semantic
- model of Iris. For space reasons, we did not want to present the
- semantic model of Iris in any detail in the paper, but we still
- wanted to give the reader confidence in the results of the paper.
- With our Coq mechanization in hand, the reader can safely ignore the
- semantic model and instead focus on how to *use* the primitive rules
- of the logic (to derive more sophisticated rules or prove
- interesting examples).
-
- Mechanizing Iris proofs is a very interesting and important
- direction for future work, but it is beyond the scope of the paper.
-
-
- The folder is organized as follows:
-
- * core_lang.v contains the axioms about the language
-
- * lang.v defines the threadpool reduction and derives some lemmas
- from core_lang.v
-
- * world_prop_recdom.v uses the ModuRes Coq library to construct the domain
- for Iris propositions, satisfying the interface to the Iris domain
- defined in world_prop.v
-
- * iris_core.v constructs the BI structure on the Iris domain, and defines
- some additional connectives (box, later, ownership).
-
- * iris_plog.v adds the programming logic: World satisfaction, primitive view shifts,
- weakest precondition.
-
- * iris_vs_rules.v and iris_wp_rules.v contain proofs of the primitive proof
- rules for primitive view shifts and weakest precondition, respectively.
-
- * iris_derived_rules.v derives rules for Hoare triples and view shifts
- (as presented in the appendix).
-
- * iris_meta.v proves adequacy and the lifting lemmas
-
- The development uses ModuRes, a Coq library by Sieczkowski et al. to
- solve the recursive domain equation (see the paper for a reference)
- and prove some of the standard separation logic rules. It is located
- in the lib/ subdirectory.
-
-
-REQUIREMENTS
-
- Coq
-
- We have tested the development using Coq 8.4pl4 on Linux and Mac
- machines. The entire compilation took less than 15 minutes.
-
-
-HOW TO COMPILE
-
- To compile the development, run
-
- > make -j
-
- in the folder containing this README.
-
-
-
-OVERVIEW OF LEMMAS
-
- Below we give a mapping from proof rules in the paper to Coq lemma's.
-
- RULE Coq lemma
- -----------------------
- VSTimeless iris_derived_rules.v:vsTimeless
- NewInv iris_derived_rules.v:vsNewInv
- InvOpen iris_derived_rules.v:vsOpen
- InvClose iris_derived_rules.v:vsClose
- VSTrans iris_derived_rules.v:vsTrans
- VSImp iris_derived_rules.v:vsEnt
- VSFrame iris_derived_rules.v:vsFrame
- FpUpd iris_derived_rules.v:vsGhostUpd
-
- Ret iris_derived_rules.v:htRet
- Bind iris_derived_rules.v:htBind
- Frame iris_derived_rules.v:htFrame
- AFrame iris_derived_rules.v:htAFrame
- Csq iris_derived_rules.v:htCons
- ACSQ iris_derived_rules.v:htACons
- Fork iris_derived_rules.v:htFork
-
- The main adequacy result is expressed by Theorem
- iris_meta.v:adequacy_obs.
-
diff --git a/_CoqProject b/_CoqProject
new file mode 100644
index 0000000000000000000000000000000000000000..1757f9d37abf659873e57e41e329f8520bd296e1
--- /dev/null
+++ b/_CoqProject
@@ -0,0 +1,70 @@
+-Q . ""
+prelude/option.v
+prelude/fin_map_dom.v
+prelude/bsets.v
+prelude/fin_maps.v
+prelude/vector.v
+prelude/pmap.v
+prelude/stringmap.v
+prelude/fin_collections.v
+prelude/mapset.v
+prelude/proof_irrel.v
+prelude/hashset.v
+prelude/pretty.v
+prelude/countable.v
+prelude/orders.v
+prelude/natmap.v
+prelude/strings.v
+prelude/relations.v
+prelude/collections.v
+prelude/listset.v
+prelude/streams.v
+prelude/gmap.v
+prelude/base.v
+prelude/tactics.v
+prelude/prelude.v
+prelude/listset_nodup.v
+prelude/finite.v
+prelude/numbers.v
+prelude/nmap.v
+prelude/zmap.v
+prelude/co_pset.v
+prelude/lexico.v
+prelude/sets.v
+prelude/decidable.v
+prelude/list.v
+prelude/error.v
+algebra/option.v
+algebra/cmra.v
+algebra/cmra_big_op.v
+algebra/cmra_tactics.v
+algebra/sts.v
+algebra/auth.v
+algebra/fin_maps.v
+logic/upred.v
+algebra/cofe.v
+algebra/base.v
+algebra/dra.v
+algebra/cofe_solver.v
+algebra/agree.v
+algebra/excl.v
+program_logic/model.v
+program_logic/adequacy.v
+program_logic/hoare_lifting.v
+program_logic/lifting.v
+program_logic/namespace.v
+program_logic/viewshifts.v
+program_logic/wsat.v
+program_logic/ownership.v
+program_logic/weakestpre.v
+program_logic/pviewshifts.v
+program_logic/resources.v
+program_logic/hoare.v
+program_logic/language.v
+program_logic/functor.v
+program_logic/tests.v
+heap_lang/heap_lang.v
+heap_lang/heap_lang_tactics.v
+heap_lang/lifting.v
+heap_lang/sugar.v
+heap_lang/tests.v
diff --git a/algebra/agree.v b/algebra/agree.v
new file mode 100644
index 0000000000000000000000000000000000000000..65464cdd1f56cc45e7340b298be7693e53a470bc
--- /dev/null
+++ b/algebra/agree.v
@@ -0,0 +1,176 @@
+Require Export algebra.cmra.
+Local Hint Extern 10 (_ ≤ _) => omega.
+
+Record agree (A : Type) : Type := Agree {
+ agree_car :> nat → A;
+ agree_is_valid : nat → Prop;
+ agree_valid_0 : agree_is_valid 0;
+ agree_valid_S n : agree_is_valid (S n) → agree_is_valid n
+}.
+Arguments Agree {_} _ _ _ _.
+Arguments agree_car {_} _ _.
+Arguments agree_is_valid {_} _ _.
+
+Section agree.
+Context {A : cofeT}.
+
+Instance agree_validN : ValidN (agree A) := λ n x,
+ agree_is_valid x n ∧ ∀ n', n' ≤ n → x n' ={n'}= x n.
+Lemma agree_valid_le (x : agree A) n n' :
+ agree_is_valid x n → n' ≤ n → agree_is_valid x n'.
+Proof. induction 2; eauto using agree_valid_S. Qed.
+Instance agree_equiv : Equiv (agree A) := λ x y,
+ (∀ n, agree_is_valid x n ↔ agree_is_valid y n) ∧
+ (∀ n, agree_is_valid x n → x n ={n}= y n).
+Instance agree_dist : Dist (agree A) := λ n x y,
+ (∀ n', n' ≤ n → agree_is_valid x n' ↔ agree_is_valid y n') ∧
+ (∀ n', n' ≤ n → agree_is_valid x n' → x n' ={n'}= y n').
+Program Instance agree_compl : Compl (agree A) := λ c,
+ {| agree_car n := c n n; agree_is_valid n := agree_is_valid (c n) n |}.
+Next Obligation. intros; apply agree_valid_0. Qed.
+Next Obligation.
+ intros c n ?; apply (chain_cauchy c n (S n)), agree_valid_S; auto.
+Qed.
+Definition agree_cofe_mixin : CofeMixin (agree A).
+Proof.
+ split.
+ * intros x y; split.
+ + by intros Hxy n; split; intros; apply Hxy.
+ + by intros Hxy; split; intros; apply Hxy with n.
+ * split.
+ + by split.
+ + by intros x y Hxy; split; intros; symmetry; apply Hxy; auto; apply Hxy.
+ + intros x y z Hxy Hyz; split; intros n'; intros.
+ - transitivity (agree_is_valid y n'). by apply Hxy. by apply Hyz.
+ - transitivity (y n'). by apply Hxy. by apply Hyz, Hxy.
+ * intros n x y Hxy; split; intros; apply Hxy; auto.
+ * intros x y; split; intros n'; rewrite Nat.le_0_r; intros ->; [|done].
+ by split; intros; apply agree_valid_0.
+ * by intros c n; split; intros; apply (chain_cauchy c).
+Qed.
+Canonical Structure agreeC := CofeT agree_cofe_mixin.
+
+Lemma agree_car_ne (x y : agree A) n : ✓{n} x → x ={n}= y → x n ={n}= y n.
+Proof. by intros [??] Hxy; apply Hxy. Qed.
+Lemma agree_cauchy (x : agree A) n i : ✓{n} x → i ≤ n → x i ={i}= x n.
+Proof. by intros [? Hx]; apply Hx. Qed.
+
+Program Instance agree_op : Op (agree A) := λ x y,
+ {| agree_car := x;
+ agree_is_valid n := agree_is_valid x n ∧ agree_is_valid y n ∧ x ={n}= y |}.
+Next Obligation. by intros; simpl; split_ands; try apply agree_valid_0. Qed.
+Next Obligation. naive_solver eauto using agree_valid_S, dist_S. Qed.
+Instance agree_unit : Unit (agree A) := id.
+Instance agree_minus : Minus (agree A) := λ x y, x.
+Instance: Commutative (≡) (@op (agree A) _).
+Proof. intros x y; split; [naive_solver|by intros n (?&?&Hxy); apply Hxy]. Qed.
+Definition agree_idempotent (x : agree A) : x ⋅ x ≡ x.
+Proof. split; naive_solver. Qed.
+Instance: ∀ n : nat, Proper (dist n ==> impl) (@validN (agree A) _ n).
+Proof.
+ intros n x y Hxy [? Hx]; split; [by apply Hxy|intros n' ?].
+ rewrite -(proj2 Hxy n') 1?(Hx n'); eauto using agree_valid_le.
+ by apply dist_le with n; try apply Hxy.
+Qed.
+Instance: ∀ x : agree A, Proper (dist n ==> dist n) (op x).
+Proof.
+ intros n x y1 y2 [Hy' Hy]; split; [|done].
+ split; intros (?&?&Hxy); repeat (intro || split);
+ try apply Hy'; eauto using agree_valid_le.
+ * etransitivity; [apply Hxy|apply Hy]; eauto using agree_valid_le.
+ * etransitivity; [apply Hxy|symmetry; apply Hy, Hy'];
+ eauto using agree_valid_le.
+Qed.
+Instance: Proper (dist n ==> dist n ==> dist n) (@op (agree A) _).
+Proof. by intros n x1 x2 Hx y1 y2 Hy; rewrite Hy !(commutative _ _ y2) Hx. Qed.
+Instance: Proper ((≡) ==> (≡) ==> (≡)) op := ne_proper_2 _.
+Instance: Associative (≡) (@op (agree A) _).
+Proof.
+ intros x y z; split; simpl; intuition;
+ repeat match goal with H : agree_is_valid _ _ |- _ => clear H end;
+ by cofe_subst; rewrite !agree_idempotent.
+Qed.
+Lemma agree_includedN (x y : agree A) n : x ≼{n} y ↔ y ={n}= x ⋅ y.
+Proof.
+ split; [|by intros ?; exists y].
+ by intros [z Hz]; rewrite Hz (associative _) agree_idempotent.
+Qed.
+Definition agree_cmra_mixin : CMRAMixin (agree A).
+Proof.
+ split; try (apply _ || done).
+ * by intros n x1 x2 Hx y1 y2 Hy.
+ * intros x; split; [apply agree_valid_0|].
+ by intros n'; rewrite Nat.le_0_r; intros ->.
+ * intros n x [? Hx]; split; [by apply agree_valid_S|intros n' ?].
+ rewrite (Hx n'); last auto.
+ symmetry; apply dist_le with n; try apply Hx; auto.
+ * intros x; apply agree_idempotent.
+ * by intros x y n [(?&?&?) ?].
+ * by intros x y n; rewrite agree_includedN.
+Qed.
+Lemma agree_op_inv (x1 x2 : agree A) n : ✓{n} (x1 ⋅ x2) → x1 ={n}= x2.
+Proof. intros Hxy; apply Hxy. Qed.
+Lemma agree_valid_includedN (x y : agree A) n : ✓{n} y → x ≼{n} y → x ={n}= y.
+Proof.
+ move=> Hval [z Hy]; move: Hval; rewrite Hy.
+ by move=> /agree_op_inv->; rewrite agree_idempotent.
+Qed.
+Definition agree_cmra_extend_mixin : CMRAExtendMixin (agree A).
+Proof.
+ intros n x y1 y2 Hval Hx; exists (x,x); simpl; split.
+ * by rewrite agree_idempotent.
+ * by move: Hval; rewrite Hx; move=> /agree_op_inv->; rewrite agree_idempotent.
+Qed.
+Canonical Structure agreeRA : cmraT :=
+ CMRAT agree_cofe_mixin agree_cmra_mixin agree_cmra_extend_mixin.
+
+Program Definition to_agree (x : A) : agree A :=
+ {| agree_car n := x; agree_is_valid n := True |}.
+Solve Obligations with done.
+Global Instance to_agree_ne n : Proper (dist n ==> dist n) to_agree.
+Proof. intros x1 x2 Hx; split; naive_solver eauto using @dist_le. Qed.
+Global Instance to_agree_proper : Proper ((≡) ==> (≡)) to_agree := ne_proper _.
+Global Instance to_agree_inj n : Injective (dist n) (dist n) (to_agree).
+Proof. by intros x y [_ Hxy]; apply Hxy. Qed.
+Lemma to_agree_car n (x : agree A) : ✓{n} x → to_agree (x n) ={n}= x.
+Proof. intros [??]; split; naive_solver eauto using agree_valid_le. Qed.
+End agree.
+
+Arguments agreeC : clear implicits.
+Arguments agreeRA : clear implicits.
+
+Program Definition agree_map {A B} (f : A → B) (x : agree A) : agree B :=
+ {| agree_car n := f (x n); agree_is_valid := agree_is_valid x |}.
+Solve Obligations with auto using agree_valid_0, agree_valid_S.
+Lemma agree_map_id {A} (x : agree A) : agree_map id x = x.
+Proof. by destruct x. 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. done. Qed.
+
+Section agree_map.
+ Context {A B : cofeT} (f : A → B) `{Hf: ∀ n, Proper (dist n ==> dist n) f}.
+ Global Instance agree_map_ne n : Proper (dist n ==> dist n) (agree_map f).
+ Proof. by intros x1 x2 Hx; split; simpl; intros; [apply Hx|apply Hf, Hx]. Qed.
+ Global Instance agree_map_proper :
+ Proper ((≡) ==> (≡)) (agree_map f) := ne_proper _.
+ Lemma agree_map_ext (g : A → B) x :
+ (∀ x, f x ≡ g x) → agree_map f x ≡ agree_map g x.
+ Proof. by intros Hfg; split; simpl; intros; rewrite ?Hfg. Qed.
+ Global Instance agree_map_monotone : CMRAMonotone (agree_map f).
+ Proof.
+ split; [|by intros n x [? Hx]; split; simpl; [|by intros n' ?; rewrite Hx]].
+ intros x y n; rewrite !agree_includedN; intros Hy; rewrite Hy.
+ split; last done; split; simpl; last tauto.
+ by intros (?&?&Hxy); repeat split; intros;
+ try apply Hxy; try apply Hf; eauto using @agree_valid_le.
+ Qed.
+End agree_map.
+
+Definition agreeRA_map {A B} (f : A -n> B) : agreeRA A -n> agreeRA B :=
+ CofeMor (agree_map f : agreeRA A → agreeRA B).
+Instance agreeRA_map_ne A B n : Proper (dist n ==> dist n) (@agreeRA_map A B).
+Proof.
+ intros f g Hfg x; split; simpl; intros; first done.
+ by apply dist_le with n; try apply Hfg.
+Qed.
diff --git a/algebra/auth.v b/algebra/auth.v
new file mode 100644
index 0000000000000000000000000000000000000000..32e76cd48c8b2a06d1214a3b8a8a0b27cf4eeb18
--- /dev/null
+++ b/algebra/auth.v
@@ -0,0 +1,198 @@
+Require Export algebra.excl.
+Local Arguments validN _ _ _ !_ /.
+
+Record auth (A : Type) : Type := Auth { authoritative : excl A ; own : A }.
+Add Printing Constructor auth.
+Arguments Auth {_} _ _.
+Arguments authoritative {_} _.
+Arguments own {_} _.
+Notation "â—¯ a" := (Auth ExclUnit a) (at level 20).
+Notation "◠a" := (Auth (Excl a) ∅) (at level 20).
+
+(* COFE *)
+Section cofe.
+Context {A : cofeT}.
+Implicit Types a b : A.
+Implicit Types x y : auth A.
+
+Instance auth_equiv : Equiv (auth A) := λ x y,
+ authoritative x ≡ authoritative y ∧ own x ≡ own y.
+Instance auth_dist : Dist (auth A) := λ n x y,
+ authoritative x ={n}= authoritative y ∧ own x ={n}= own y.
+
+Global Instance Auth_ne : Proper (dist n ==> dist n ==> dist n) (@Auth A).
+Proof. by split. Qed.
+Global Instance Auth_proper : Proper ((≡) ==> (≡) ==> (≡)) (@Auth A).
+Proof. by split. Qed.
+Global Instance authoritative_ne: Proper (dist n ==> dist n) (@authoritative A).
+Proof. by destruct 1. Qed.
+Global Instance authoritative_proper : Proper ((≡) ==> (≡)) (@authoritative A).
+Proof. by destruct 1. Qed.
+Global Instance own_ne : Proper (dist n ==> dist n) (@own A).
+Proof. by destruct 1. Qed.
+Global Instance own_proper : Proper ((≡) ==> (≡)) (@own A).
+Proof. by destruct 1. Qed.
+
+Instance auth_compl : Compl (auth A) := λ c,
+ Auth (compl (chain_map authoritative c)) (compl (chain_map own c)).
+Definition auth_cofe_mixin : CofeMixin (auth A).
+Proof.
+ split.
+ * intros x y; unfold dist, auth_dist, equiv, auth_equiv.
+ rewrite !equiv_dist; naive_solver.
+ * intros n; split.
+ + by intros ?; split.
+ + by intros ?? [??]; split; symmetry.
+ + intros ??? [??] [??]; split; etransitivity; eauto.
+ * by intros ? [??] [??] [??]; split; apply dist_S.
+ * by split.
+ * intros c n; split. apply (conv_compl (chain_map authoritative c) n).
+ apply (conv_compl (chain_map own c) n).
+Qed.
+Canonical Structure authC := CofeT auth_cofe_mixin.
+Instance Auth_timeless (ea : excl A) (b : A) :
+ Timeless ea → Timeless b → Timeless (Auth ea b).
+Proof. by intros ?? [??] [??]; split; simpl in *; apply (timeless _). Qed.
+Global Instance auth_leibniz : LeibnizEquiv A → LeibnizEquiv (auth A).
+Proof. by intros ? [??] [??] [??]; f_equal'; apply leibniz_equiv. Qed.
+End cofe.
+
+Arguments authC : clear implicits.
+
+(* CMRA *)
+Section cmra.
+Context {A : cmraT}.
+Implicit Types a b : A.
+Implicit Types x y : auth A.
+
+Global Instance auth_empty `{Empty A} : Empty (auth A) := Auth ∅ ∅.
+Instance auth_validN : ValidN (auth A) := λ n x,
+ match authoritative x with
+ | Excl a => own x ≼{n} a ∧ ✓{n} a
+ | ExclUnit => ✓{n} (own x)
+ | ExclBot => n = 0
+ end.
+Global Arguments auth_validN _ !_ /.
+Instance auth_unit : Unit (auth A) := λ x,
+ Auth (unit (authoritative x)) (unit (own x)).
+Instance auth_op : Op (auth A) := λ x y,
+ Auth (authoritative x â‹… authoritative y) (own x â‹… own y).
+Instance auth_minus : Minus (auth A) := λ x y,
+ Auth (authoritative x ⩪ authoritative y) (own x ⩪ own y).
+Lemma auth_included (x y : auth A) :
+ x ≼ y ↔ authoritative x ≼ authoritative y ∧ own x ≼ own y.
+Proof.
+ split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
+ intros [[z1 Hz1] [z2 Hz2]]; exists (Auth z1 z2); split; auto.
+Qed.
+Lemma auth_includedN n (x y : auth A) :
+ x ≼{n} y ↔ authoritative x ≼{n} authoritative y ∧ own x ≼{n} own y.
+Proof.
+ split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
+ intros [[z1 Hz1] [z2 Hz2]]; exists (Auth z1 z2); split; auto.
+Qed.
+Lemma authoritative_validN n (x : auth A) : ✓{n} x → ✓{n} (authoritative x).
+Proof. by destruct x as [[]]. Qed.
+Lemma own_validN n (x : auth A) : ✓{n} x → ✓{n} (own x).
+Proof. destruct x as [[]]; naive_solver eauto using cmra_validN_includedN. Qed.
+
+Definition auth_cmra_mixin : CMRAMixin (auth A).
+Proof.
+ split.
+ * by intros n x y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
+ * by intros n y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
+ * intros n [x a] [y b] [Hx Ha]; simpl in *;
+ destruct Hx as [[][]| | |]; intros ?; cofe_subst; auto.
+ * by intros n x1 x2 [Hx Hx'] y1 y2 [Hy Hy'];
+ split; simpl; rewrite ?Hy ?Hy' ?Hx ?Hx'.
+ * by intros [[] ?]; simpl.
+ * intros n [[] ?] ?; naive_solver eauto using cmra_includedN_S, cmra_validN_S.
+ * by split; simpl; rewrite associative.
+ * by split; simpl; rewrite commutative.
+ * by split; simpl; rewrite ?cmra_unit_l.
+ * by split; simpl; rewrite ?cmra_unit_idempotent.
+ * intros n ??; rewrite! auth_includedN; intros [??].
+ by split; simpl; apply cmra_unit_preservingN.
+ * assert (∀ n (a b1 b2 : A), b1 ⋅ b2 ≼{n} a → b1 ≼{n} a).
+ { intros n a b1 b2 <-; apply cmra_includedN_l. }
+ intros n [[a1| |] b1] [[a2| |] b2];
+ naive_solver eauto using cmra_validN_op_l, cmra_validN_includedN.
+ * by intros n ??; rewrite auth_includedN;
+ intros [??]; split; simpl; apply cmra_op_minus.
+Qed.
+Definition auth_cmra_extend_mixin : CMRAExtendMixin (auth A).
+Proof.
+ intros n x y1 y2 ? [??]; simpl in *.
+ destruct (cmra_extend_op n (authoritative x) (authoritative y1)
+ (authoritative y2)) as (ea&?&?&?); auto using authoritative_validN.
+ destruct (cmra_extend_op n (own x) (own y1) (own y2))
+ as (b&?&?&?); auto using own_validN.
+ by exists (Auth (ea.1) (b.1), Auth (ea.2) (b.2)).
+Qed.
+Canonical Structure authRA : cmraT :=
+ CMRAT auth_cofe_mixin auth_cmra_mixin auth_cmra_extend_mixin.
+
+(** The notations â—¯ and â— only work for CMRAs with an empty element. So, in
+what follows, we assume we have an empty element. *)
+Context `{Empty A, !CMRAIdentity A}.
+
+Global Instance auth_cmra_identity : CMRAIdentity authRA.
+Proof.
+ split; simpl.
+ * by apply (@cmra_empty_valid A _).
+ * by intros x; constructor; rewrite /= left_id.
+ * apply Auth_timeless; apply _.
+Qed.
+Lemma auth_frag_op a b : ◯ (a ⋅ b) ≡ ◯ a ⋅ ◯ b.
+Proof. done. Qed.
+
+Lemma auth_update a a' b b' :
+ (∀ n af, ✓{n} a → a ={n}= a' ⋅ af → b ={n}= b' ⋅ af ∧ ✓{n} b) →
+ â— a â‹… â—¯ a' ~~> â— b â‹… â—¯ b'.
+Proof.
+ move=> Hab [[] bf1] n // =>-[[bf2 Ha] ?]; do 2 red; simpl in *.
+ destruct (Hab (S n) (bf1 â‹… bf2)) as [Ha' ?]; auto.
+ { by rewrite Ha left_id associative. }
+ split; [by rewrite Ha' left_id associative; apply cmra_includedN_l|done].
+Qed.
+Lemma auth_update_op_l a a' b :
+ ✓ (b ⋅ a) → ◠a ⋅ ◯ a' ~~> ◠(b ⋅ a) ⋅ ◯ (b ⋅ a').
+Proof.
+ intros; apply auth_update.
+ by intros n af ? Ha; split; [by rewrite Ha associative|].
+Qed.
+Lemma auth_update_op_r a a' b :
+ ✓ (a ⋅ b) → ◠a ⋅ ◯ a' ~~> ◠(a ⋅ b) ⋅ ◯ (a' ⋅ b).
+Proof. rewrite -!(commutative _ b); apply auth_update_op_l. Qed.
+End cmra.
+
+Arguments authRA : clear implicits.
+
+(* Functor *)
+Instance auth_fmap : FMap auth := λ A B f x,
+ Auth (f <$> authoritative x) (f (own x)).
+Arguments auth_fmap _ _ _ !_ /.
+Lemma auth_fmap_id {A} (x : auth A) : id <$> x = x.
+Proof. by destruct x; rewrite /= excl_fmap_id. Qed.
+Lemma excl_fmap_compose {A B C} (f : A → B) (g : B → C) (x : auth A) :
+ g ∘ f <$> x = g <$> f <$> x.
+Proof. by destruct x; rewrite /= excl_fmap_compose. Qed.
+Instance auth_fmap_cmra_ne {A B : cmraT} n :
+ Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@fmap auth _ A B).
+Proof.
+ intros f g Hf [??] [??] [??]; split; [by apply excl_fmap_cmra_ne|by apply Hf].
+Qed.
+Instance auth_fmap_cmra_monotone {A B : cmraT} (f : A → B) :
+ (∀ n, Proper (dist n ==> dist n) f) → CMRAMonotone f →
+ CMRAMonotone (fmap f : auth A → auth B).
+Proof.
+ split.
+ * by intros n [x a] [y b]; rewrite !auth_includedN /=;
+ intros [??]; split; simpl; apply: includedN_preserving.
+ * intros n [[a| |] b]; rewrite /= /cmra_validN;
+ naive_solver eauto using @includedN_preserving, @validN_preserving.
+Qed.
+Definition authRA_map {A B : cmraT} (f : A -n> B) : authRA A -n> authRA B :=
+ CofeMor (fmap f : authRA A → authRA B).
+Lemma authRA_map_ne A B n : Proper (dist n ==> dist n) (@authRA_map A B).
+Proof. intros f f' Hf [[a| |] b]; repeat constructor; apply Hf. Qed.
diff --git a/algebra/base.v b/algebra/base.v
new file mode 100644
index 0000000000000000000000000000000000000000..28ba9cc272f4d46bfecc870d7333bea6757ff535
--- /dev/null
+++ b/algebra/base.v
@@ -0,0 +1,4 @@
+Require Export mathcomp.ssreflect.ssreflect.
+Require Export prelude.prelude.
+Global Set Bullet Behavior "Strict Subproofs".
+Global Open Scope general_if_scope.
\ No newline at end of file
diff --git a/algebra/cmra.v b/algebra/cmra.v
new file mode 100644
index 0000000000000000000000000000000000000000..8e1bbdff9697da2054894e3f811dbbe78600bc51
--- /dev/null
+++ b/algebra/cmra.v
@@ -0,0 +1,575 @@
+Require Export algebra.cofe.
+
+Class Unit (A : Type) := unit : A → A.
+Instance: Params (@unit) 2.
+
+Class Op (A : Type) := op : A → A → A.
+Instance: Params (@op) 2.
+Infix "â‹…" := op (at level 50, left associativity) : C_scope.
+Notation "(â‹…)" := op (only parsing) : C_scope.
+
+Definition included `{Equiv A, Op A} (x y : A) := ∃ z, y ≡ x ⋅ z.
+Infix "≼" := included (at level 70) : C_scope.
+Notation "(≼)" := included (only parsing) : C_scope.
+Hint Extern 0 (?x ≼ ?y) => reflexivity.
+Instance: Params (@included) 3.
+
+Class Minus (A : Type) := minus : A → A → A.
+Instance: Params (@minus) 2.
+Infix "⩪" := minus (at level 40) : C_scope.
+
+Class ValidN (A : Type) := validN : nat → A → Prop.
+Instance: Params (@validN) 3.
+Notation "✓{ n }" := (validN n) (at level 1, format "✓{ n }").
+
+Class Valid (A : Type) := valid : A → Prop.
+Instance: Params (@valid) 2.
+Notation "✓" := valid (at level 1).
+Instance validN_valid `{ValidN A} : Valid A := λ x, ∀ n, ✓{n} x.
+
+Definition includedN `{Dist A, Op A} (n : nat) (x y : A) := ∃ z, y ={n}= x ⋅ z.
+Notation "x ≼{ n } y" := (includedN n x y)
+ (at level 70, format "x ≼{ n } y") : C_scope.
+Instance: Params (@includedN) 4.
+Hint Extern 0 (?x ≼{_} ?y) => reflexivity.
+
+Record CMRAMixin A `{Dist A, Equiv A, Unit A, Op A, ValidN A, Minus A} := {
+ (* setoids *)
+ mixin_cmra_op_ne n (x : A) : Proper (dist n ==> dist n) (op x);
+ mixin_cmra_unit_ne n : Proper (dist n ==> dist n) unit;
+ mixin_cmra_validN_ne n : Proper (dist n ==> impl) (✓{n});
+ mixin_cmra_minus_ne n : Proper (dist n ==> dist n ==> dist n) minus;
+ (* valid *)
+ mixin_cmra_validN_0 x : ✓{0} x;
+ mixin_cmra_validN_S n x : ✓{S n} x → ✓{n} x;
+ (* monoid *)
+ mixin_cmra_associative : Associative (≡) (⋅);
+ mixin_cmra_commutative : Commutative (≡) (⋅);
+ mixin_cmra_unit_l x : unit x ⋅ x ≡ x;
+ mixin_cmra_unit_idempotent x : unit (unit x) ≡ unit x;
+ mixin_cmra_unit_preservingN n x y : x ≼{n} y → unit x ≼{n} unit y;
+ mixin_cmra_validN_op_l n x y : ✓{n} (x ⋅ y) → ✓{n} x;
+ mixin_cmra_op_minus n x y : x ≼{n} y → x ⋅ y ⩪ x ={n}= y
+}.
+Definition CMRAExtendMixin A `{Equiv A, Dist A, Op A, ValidN A} := ∀ n x y1 y2,
+ ✓{n} x → x ={n}= y1 ⋅ y2 →
+ { z | x ≡ z.1 ⋅ z.2 ∧ z.1 ={n}= y1 ∧ z.2 ={n}= y2 }.
+
+(** Bundeled version *)
+Structure cmraT := CMRAT {
+ cmra_car :> Type;
+ cmra_equiv : Equiv cmra_car;
+ cmra_dist : Dist cmra_car;
+ cmra_compl : Compl cmra_car;
+ cmra_unit : Unit cmra_car;
+ cmra_op : Op cmra_car;
+ cmra_validN : ValidN cmra_car;
+ cmra_minus : Minus cmra_car;
+ cmra_cofe_mixin : CofeMixin cmra_car;
+ cmra_mixin : CMRAMixin cmra_car;
+ cmra_extend_mixin : CMRAExtendMixin cmra_car
+}.
+Arguments CMRAT {_ _ _ _ _ _ _ _} _ _ _.
+Arguments cmra_car : simpl never.
+Arguments cmra_equiv : simpl never.
+Arguments cmra_dist : simpl never.
+Arguments cmra_compl : simpl never.
+Arguments cmra_unit : simpl never.
+Arguments cmra_op : simpl never.
+Arguments cmra_validN : simpl never.
+Arguments cmra_minus : simpl never.
+Arguments cmra_cofe_mixin : simpl never.
+Arguments cmra_mixin : simpl never.
+Arguments cmra_extend_mixin : simpl never.
+Add Printing Constructor cmraT.
+Existing Instances cmra_unit cmra_op cmra_validN cmra_minus.
+Coercion cmra_cofeC (A : cmraT) : cofeT := CofeT (cmra_cofe_mixin A).
+Canonical Structure cmra_cofeC.
+
+(** Lifting properties from the mixin *)
+Section cmra_mixin.
+ Context {A : cmraT}.
+ Implicit Types x y : A.
+ Global Instance cmra_op_ne n (x : A) : Proper (dist n ==> dist n) (op x).
+ Proof. apply (mixin_cmra_op_ne _ (cmra_mixin A)). Qed.
+ Global Instance cmra_unit_ne n : Proper (dist n ==> dist n) (@unit A _).
+ Proof. apply (mixin_cmra_unit_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.
+ Global Instance cmra_minus_ne n :
+ Proper (dist n ==> dist n ==> dist n) (@minus A _).
+ Proof. apply (mixin_cmra_minus_ne _ (cmra_mixin A)). Qed.
+ Lemma cmra_validN_0 x : ✓{0} x.
+ Proof. apply (mixin_cmra_validN_0 _ (cmra_mixin A)). Qed.
+ Lemma cmra_validN_S n x : ✓{S n} x → ✓{n} x.
+ Proof. apply (mixin_cmra_validN_S _ (cmra_mixin A)). Qed.
+ Global Instance cmra_associative : Associative (≡) (@op A _).
+ Proof. apply (mixin_cmra_associative _ (cmra_mixin A)). Qed.
+ Global Instance cmra_commutative : Commutative (≡) (@op A _).
+ Proof. apply (mixin_cmra_commutative _ (cmra_mixin A)). Qed.
+ Lemma cmra_unit_l x : unit x ⋅ x ≡ x.
+ Proof. apply (mixin_cmra_unit_l _ (cmra_mixin A)). Qed.
+ Lemma cmra_unit_idempotent x : unit (unit x) ≡ unit x.
+ Proof. apply (mixin_cmra_unit_idempotent _ (cmra_mixin A)). Qed.
+ Lemma cmra_unit_preservingN n x y : x ≼{n} y → unit x ≼{n} unit y.
+ Proof. apply (mixin_cmra_unit_preservingN _ (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_op_minus n x y : x ≼{n} y → x ⋅ y ⩪ x ={n}= y.
+ Proof. apply (mixin_cmra_op_minus _ (cmra_mixin A)). Qed.
+ Lemma cmra_extend_op n x y1 y2 :
+ ✓{n} x → x ={n}= y1 ⋅ y2 →
+ { z | x ≡ z.1 ⋅ z.2 ∧ z.1 ={n}= y1 ∧ z.2 ={n}= y2 }.
+ Proof. apply (cmra_extend_mixin A). Qed.
+End cmra_mixin.
+
+Hint Extern 0 (✓{0} _) => apply cmra_validN_0.
+
+(** * CMRAs with a global identity element *)
+(** We use the notation ∅ because for most instances (maps, sets, etc) the
+`empty' element is the global identity. *)
+Class CMRAIdentity (A : cmraT) `{Empty A} : Prop := {
+ cmra_empty_valid : ✓ ∅;
+ cmra_empty_left_id :> LeftId (≡) ∅ (⋅);
+ cmra_empty_timeless :> Timeless ∅
+}.
+
+(** * Morphisms *)
+Class CMRAMonotone {A B : cmraT} (f : A → B) := {
+ includedN_preserving n x y : x ≼{n} y → f x ≼{n} f y;
+ validN_preserving n x : ✓{n} x → ✓{n} (f x)
+}.
+
+(** * Frame preserving updates *)
+Definition cmra_updateP {A : cmraT} (x : A) (P : A → Prop) := ∀ z n,
+ ✓{S n} (x ⋅ z) → ∃ y, P y ∧ ✓{S n} (y ⋅ z).
+Instance: Params (@cmra_updateP) 1.
+Infix "~~>:" := cmra_updateP (at level 70).
+Definition cmra_update {A : cmraT} (x y : A) := ∀ z n,
+ ✓{S n} (x ⋅ z) → ✓{S n} (y ⋅ z).
+Infix "~~>" := cmra_update (at level 70).
+Instance: Params (@cmra_update) 1.
+
+(** * Properties **)
+Section cmra.
+Context {A : cmraT}.
+Implicit Types x y z : A.
+Implicit Types xs ys zs : list A.
+
+(** ** Setoids *)
+Global Instance cmra_unit_proper : Proper ((≡) ==> (≡)) (@unit A _).
+Proof. apply (ne_proper _). Qed.
+Global Instance cmra_op_ne' n : Proper (dist n ==> dist n ==> dist n) (@op A _).
+Proof.
+ intros x1 x2 Hx y1 y2 Hy.
+ by rewrite Hy (commutative _ x1) Hx (commutative _ y2).
+Qed.
+Global Instance ra_op_proper' : Proper ((≡) ==> (≡) ==> (≡)) (@op A _).
+Proof. apply (ne_proper_2 _). Qed.
+Global Instance cmra_validN_ne' : Proper (dist n ==> iff) (@validN A _ n) | 1.
+Proof. by split; apply cmra_validN_ne. Qed.
+Global Instance cmra_validN_proper : Proper ((≡) ==> iff) (@validN A _ n) | 1.
+Proof. by intros n x1 x2 Hx; apply cmra_validN_ne', equiv_dist. Qed.
+Global Instance cmra_minus_proper : Proper ((≡) ==> (≡) ==> (≡)) (@minus A _).
+Proof. apply (ne_proper_2 _). Qed.
+
+Global Instance cmra_valid_proper : Proper ((≡) ==> iff) (@valid A _).
+Proof. by intros x y Hxy; split; intros ? n; [rewrite -Hxy|rewrite Hxy]. Qed.
+Global Instance cmra_includedN_ne n :
+ Proper (dist n ==> dist n ==> iff) (@includedN 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 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_update_proper :
+ Proper ((≡) ==> (≡) ==> iff) (@cmra_update A).
+Proof.
+ intros x1 x2 Hx y1 y2 Hy; split=>? z n; [rewrite -Hx -Hy|rewrite Hx Hy]; auto.
+Qed.
+Global Instance cmra_updateP_proper :
+ Proper ((≡) ==> pointwise_relation _ iff ==> iff) (@cmra_updateP A).
+Proof.
+ intros x1 x2 Hx P1 P2 HP; split=>Hup z n;
+ [rewrite -Hx; setoid_rewrite <-HP|rewrite Hx; setoid_rewrite HP]; auto.
+Qed.
+
+(** ** Validity *)
+Lemma cmra_valid_validN x : ✓ x ↔ ∀ n, ✓{n} x.
+Proof. done. Qed.
+Lemma cmra_validN_le x n n' : ✓{n} x → n' ≤ n → ✓{n'} x.
+Proof. induction 2; eauto using cmra_validN_S. 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 x y n : ✓{n} (x ⋅ y) → ✓{n} y.
+Proof. rewrite (commutative _ 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.
+
+(** ** Units *)
+Lemma cmra_unit_r x : x ⋅ unit x ≡ x.
+Proof. by rewrite (commutative _ x) cmra_unit_l. Qed.
+Lemma cmra_unit_unit x : unit x ⋅ unit x ≡ unit x.
+Proof. by rewrite -{2}(cmra_unit_idempotent x) cmra_unit_r. Qed.
+Lemma cmra_unit_validN x n : ✓{n} x → ✓{n} (unit x).
+Proof. rewrite -{1}(cmra_unit_l x); apply cmra_validN_op_l. Qed.
+Lemma cmra_unit_valid x : ✓ x → ✓ (unit x).
+Proof. rewrite -{1}(cmra_unit_l x); apply cmra_valid_op_l. Qed.
+
+(** ** Order *)
+Lemma cmra_included_includedN x y : x ≼ y ↔ ∀ n, x ≼{n} y.
+Proof.
+ split; [by intros [z Hz] n; exists z; rewrite Hz|].
+ intros Hxy; exists (y ⩪ x); apply equiv_dist; intros n.
+ symmetry; apply cmra_op_minus, Hxy.
+Qed.
+Global Instance cmra_includedN_preorder n : PreOrder (@includedN A _ _ n).
+Proof.
+ split.
+ * by intros x; exists (unit x); rewrite cmra_unit_r.
+ * intros x y z [z1 Hy] [z2 Hz]; exists (z1 â‹… z2).
+ by rewrite (associative _) -Hy -Hz.
+Qed.
+Global Instance cmra_included_preorder: PreOrder (@included A _ _).
+Proof.
+ split; red; intros until 0; rewrite !cmra_included_includedN; first done.
+ intros; etransitivity; eauto.
+Qed.
+Lemma cmra_validN_includedN x y n : ✓{n} y → x ≼{n} y → ✓{n} x.
+Proof. intros Hyv [z ?]; cofe_subst y; eauto using cmra_validN_op_l. Qed.
+Lemma cmra_validN_included x y n : ✓{n} y → x ≼ y → ✓{n} x.
+Proof. rewrite cmra_included_includedN; eauto using cmra_validN_includedN. Qed.
+
+Lemma cmra_includedN_0 x y : x ≼{0} y.
+Proof. by exists (unit x). Qed.
+Lemma cmra_includedN_S x y n : x ≼{S n} y → x ≼{n} y.
+Proof. by intros [z Hz]; exists z; apply dist_S. Qed.
+Lemma cmra_includedN_le x y n n' : x ≼{n} y → n' ≤ n → x ≼{n'} y.
+Proof. induction 2; auto using cmra_includedN_S. 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 (commutative op); apply cmra_includedN_l. Qed.
+Lemma cmra_included_r x y : y ≼ x ⋅ y.
+Proof. rewrite (commutative op); apply cmra_included_l. Qed.
+
+Lemma cmra_unit_preserving x y : x ≼ y → unit x ≼ unit y.
+Proof. rewrite !cmra_included_includedN; eauto using cmra_unit_preservingN. Qed.
+Lemma cmra_included_unit x : unit x ≼ x.
+Proof. by exists x; rewrite cmra_unit_l. Qed.
+Lemma cmra_preserving_l x y z : x ≼ y → z ⋅ x ≼ z ⋅ y.
+Proof. by intros [z1 Hz1]; exists z1; rewrite Hz1 (associative op). Qed.
+Lemma cmra_preserving_r x y z : x ≼ y → x ⋅ z ≼ y ⋅ z.
+Proof. by intros; rewrite -!(commutative _ z); apply cmra_preserving_l. Qed.
+
+Lemma cmra_included_dist_l x1 x2 x1' n :
+ 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.
+
+(** ** Minus *)
+Lemma cmra_op_minus' x y : x ≼ y → x ⋅ y ⩪ x ≡ y.
+Proof.
+ rewrite cmra_included_includedN equiv_dist; eauto using cmra_op_minus.
+Qed.
+
+(** ** Timeless *)
+Lemma cmra_timeless_included_l x y : Timeless x → ✓{1} y → x ≼{1} y → x ≼ y.
+Proof.
+ intros ?? [x' ?].
+ destruct (cmra_extend_op 1 y x x') as ([z z']&Hy&Hz&Hz'); auto; simpl in *.
+ by exists z'; rewrite Hy (timeless x z).
+Qed.
+Lemma cmra_timeless_included_r n x y : Timeless y → x ≼{1} y → x ≼{n} y.
+Proof. intros ? [x' ?]. exists x'. by apply equiv_dist, (timeless y). Qed.
+Lemma cmra_op_timeless x1 x2 :
+ ✓ (x1 ⋅ x2) → Timeless x1 → Timeless x2 → Timeless (x1 ⋅ x2).
+Proof.
+ intros ??? z Hz.
+ destruct (cmra_extend_op 1 z x1 x2) as ([y1 y2]&Hz'&?&?); auto; simpl in *.
+ { by rewrite -?Hz. }
+ by rewrite Hz' (timeless x1 y1) // (timeless x2 y2).
+Qed.
+
+(** ** RAs with an empty element *)
+Section identity.
+ Context `{Empty A, !CMRAIdentity A}.
+ Lemma cmra_empty_leastN n x : ∅ ≼{n} x.
+ Proof. by exists x; rewrite left_id. Qed.
+ Lemma cmra_empty_least x : ∅ ≼ x.
+ Proof. by exists x; rewrite left_id. Qed.
+ Global Instance cmra_empty_right_id : RightId (≡) ∅ (⋅).
+ Proof. by intros x; rewrite (commutative op) left_id. Qed.
+ Lemma cmra_unit_empty : unit ∅ ≡ ∅.
+ Proof. by rewrite -{2}(cmra_unit_l ∅) right_id. Qed.
+End identity.
+
+(** ** Updates *)
+Global Instance cmra_update_preorder : PreOrder (@cmra_update A).
+Proof. split. by intros x y. intros x y y' ?? z ?; naive_solver. Qed.
+Lemma cmra_update_updateP x y : x ~~> y ↔ x ~~>: (y =).
+Proof.
+ split.
+ * by intros Hx z ?; exists y; split; [done|apply (Hx z)].
+ * by intros Hx z n ?; destruct (Hx z n) as (?&<-&?).
+Qed.
+Lemma cmra_updateP_id (P : A → Prop) x : P x → x ~~>: P.
+Proof. by intros ? z n ?; exists x. Qed.
+Lemma cmra_updateP_compose (P Q : A → Prop) x :
+ x ~~>: P → (∀ y, P y → y ~~>: Q) → x ~~>: Q.
+Proof.
+ intros Hx Hy z n ?. destruct (Hx z n) as (y&?&?); auto. by apply (Hy y).
+Qed.
+Lemma cmra_updateP_weaken (P Q : A → Prop) x : x ~~>: P → (∀ y, P y → Q y) → x ~~>: Q.
+Proof. eauto using cmra_updateP_compose, cmra_updateP_id. Qed.
+
+Lemma cmra_updateP_op (P1 P2 Q : A → Prop) x1 x2 :
+ x1 ~~>: P1 → x2 ~~>: P2 → (∀ y1 y2, P1 y1 → P2 y2 → Q (y1 ⋅ y2)) → x1 ⋅ x2 ~~>: Q.
+Proof.
+ intros Hx1 Hx2 Hy z n ?.
+ destruct (Hx1 (x2 â‹… z) n) as (y1&?&?); first by rewrite associative.
+ destruct (Hx2 (y1 â‹… z) n) as (y2&?&?);
+ first by rewrite associative (commutative _ x2) -associative.
+ exists (y1 â‹… y2); split; last rewrite (commutative _ y1) -associative; auto.
+Qed.
+Lemma cmra_updateP_op' (P1 P2 : A → Prop) x1 x2 :
+ x1 ~~>: P1 → x2 ~~>: P2 → x1 ⋅ x2 ~~>: λ y, ∃ y1 y2, y = y1 ⋅ y2 ∧ P1 y1 ∧ P2 y2.
+Proof. eauto 10 using cmra_updateP_op. Qed.
+Lemma cmra_update_op x1 x2 y1 y2 : x1 ~~> y1 → x2 ~~> y2 → x1 ⋅ x2 ~~> y1 ⋅ y2.
+Proof.
+ rewrite !cmra_update_updateP; eauto using cmra_updateP_op with congruence.
+Qed.
+End cmra.
+
+Hint Extern 0 (_ ≼{0} _) => apply cmra_includedN_0.
+
+(** * Properties about monotone functions *)
+Instance cmra_monotone_id {A : cmraT} : CMRAMonotone (@id A).
+Proof. by split. Qed.
+Instance cmra_monotone_compose {A B C : cmraT} (f : A → B) (g : B → C) :
+ CMRAMonotone f → CMRAMonotone g → CMRAMonotone (g ∘ f).
+Proof.
+ split.
+ * move=> n x y Hxy /=. by apply includedN_preserving, includedN_preserving.
+ * move=> n x Hx /=. by apply validN_preserving, validN_preserving.
+Qed.
+
+Section cmra_monotone.
+ Context {A B : cmraT} (f : A → B) `{!CMRAMonotone f}.
+ Lemma included_preserving x y : x ≼ y → f x ≼ f y.
+ Proof.
+ rewrite !cmra_included_includedN; eauto using includedN_preserving.
+ Qed.
+ Lemma valid_preserving x : ✓ x → ✓ (f x).
+ Proof. rewrite !cmra_valid_validN; eauto using validN_preserving. Qed.
+End cmra_monotone.
+
+(** * Instances *)
+(** ** Discrete CMRA *)
+Class RA A `{Equiv A, Unit A, Op A, Valid A, Minus A} := {
+ (* setoids *)
+ ra_op_ne (x : A) : Proper ((≡) ==> (≡)) (op x);
+ ra_unit_ne :> Proper ((≡) ==> (≡)) unit;
+ ra_validN_ne :> Proper ((≡) ==> impl) ✓;
+ ra_minus_ne :> Proper ((≡) ==> (≡) ==> (≡)) minus;
+ (* monoid *)
+ ra_associative :> Associative (≡) (⋅);
+ ra_commutative :> Commutative (≡) (⋅);
+ ra_unit_l x : unit x ⋅ x ≡ x;
+ ra_unit_idempotent x : unit (unit x) ≡ unit x;
+ ra_unit_preserving x y : x ≼ y → unit x ≼ unit y;
+ ra_valid_op_l x y : ✓ (x ⋅ y) → ✓ x;
+ ra_op_minus x y : x ≼ y → x ⋅ y ⩪ x ≡ y
+}.
+
+Section discrete.
+ Context {A : cofeT} `{∀ x : A, Timeless x}.
+ Context `{Unit A, Op A, Valid A, Minus A} (ra : RA A).
+
+ Instance discrete_validN : ValidN A := λ n x,
+ match n with 0 => True | S n => ✓ x end.
+ Definition discrete_cmra_mixin : CMRAMixin A.
+ Proof.
+ destruct ra; split; unfold Proper, respectful, includedN;
+ repeat match goal with
+ | |- ∀ n : nat, _ => intros [|?]
+ end; try setoid_rewrite <-(timeless_S _ _ _ _); try done.
+ by intros x y ?; exists x.
+ Qed.
+ Definition discrete_extend_mixin : CMRAExtendMixin A.
+ Proof.
+ intros [|n] x y1 y2 ??.
+ * by exists (unit x, x); rewrite /= ra_unit_l.
+ * exists (y1,y2); split_ands; auto.
+ apply (timeless _), dist_le with (S n); auto with lia.
+ Qed.
+ Definition discreteRA : cmraT :=
+ CMRAT (cofe_mixin A) discrete_cmra_mixin discrete_extend_mixin.
+ Lemma discrete_updateP (x : discreteRA) (P : A → Prop) :
+ (∀ z, ✓ (x ⋅ z) → ∃ y, P y ∧ ✓ (y ⋅ z)) → x ~~>: P.
+ Proof. intros Hvalid z n; apply Hvalid. Qed.
+ Lemma discrete_update (x y : discreteRA) :
+ (∀ z, ✓ (x ⋅ z) → ✓ (y ⋅ z)) → x ~~> y.
+ Proof. intros Hvalid z n; apply Hvalid. Qed.
+End discrete.
+
+(** ** CMRA for the unit type *)
+Section unit.
+ Instance unit_valid : Valid () := λ x, True.
+ Instance unit_unit : Unit () := λ x, x.
+ Instance unit_op : Op () := λ x y, ().
+ Instance unit_minus : Minus () := λ x y, ().
+ Global Instance unit_empty : Empty () := ().
+ Definition unit_ra : RA ().
+ Proof. by split. Qed.
+ Canonical Structure unitRA : cmraT :=
+ Eval cbv [unitC discreteRA cofe_car] in discreteRA unit_ra.
+ Global Instance unit_cmra_identity : CMRAIdentity unitRA.
+ Proof. by split; intros []. Qed.
+End unit.
+
+(** ** Product *)
+Section prod.
+ Context {A B : cmraT}.
+ Instance prod_op : Op (A * B) := λ x y, (x.1 ⋅ y.1, x.2 ⋅ y.2).
+ Global Instance prod_empty `{Empty A, Empty B} : Empty (A * B) := (∅, ∅).
+ Instance prod_unit : Unit (A * B) := λ x, (unit (x.1), unit (x.2)).
+ Instance prod_validN : ValidN (A * B) := λ n x, ✓{n} (x.1) ∧ ✓{n} (x.2).
+ Instance prod_minus : Minus (A * B) := λ x y, (x.1 ⩪ y.1, x.2 ⩪ y.2).
+ 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.
+ * by intros n y1 y2 [Hy1 Hy2]; split; rewrite /= ?Hy1 ?Hy2.
+ * by intros n y1 y2 [Hy1 Hy2] [??]; split; rewrite /= -?Hy1 -?Hy2.
+ * by intros n x1 x2 [Hx1 Hx2] y1 y2 [Hy1 Hy2];
+ split; rewrite /= ?Hx1 ?Hx2 ?Hy1 ?Hy2.
+ * by split.
+ * by intros n x [??]; split; apply cmra_validN_S.
+ * split; simpl; apply (associative _).
+ * split; simpl; apply (commutative _).
+ * split; simpl; apply cmra_unit_l.
+ * split; simpl; apply cmra_unit_idempotent.
+ * intros n x y; rewrite !prod_includedN.
+ by intros [??]; split; apply cmra_unit_preservingN.
+ * intros n x y [??]; split; simpl in *; eauto using cmra_validN_op_l.
+ * intros x y n; rewrite prod_includedN; intros [??].
+ by split; apply cmra_op_minus.
+ Qed.
+ Definition prod_cmra_extend_mixin : CMRAExtendMixin (A * B).
+ Proof.
+ intros n x y1 y2 [??] [??]; simpl in *.
+ destruct (cmra_extend_op n (x.1) (y1.1) (y2.1)) as (z1&?&?&?); auto.
+ destruct (cmra_extend_op n (x.2) (y1.2) (y2.2)) as (z2&?&?&?); auto.
+ by exists ((z1.1,z2.1),(z1.2,z2.2)).
+ Qed.
+ Canonical Structure prodRA : cmraT :=
+ CMRAT prod_cofe_mixin prod_cmra_mixin prod_cmra_extend_mixin.
+ Global Instance prod_cmra_identity `{Empty A, Empty B} :
+ CMRAIdentity A → CMRAIdentity B → CMRAIdentity prodRA.
+ Proof.
+ split.
+ * split; apply cmra_empty_valid.
+ * by split; rewrite /=left_id.
+ * by intros ? [??]; split; apply (timeless _).
+ Qed.
+ Lemma prod_update x y : x.1 ~~> y.1 → x.2 ~~> y.2 → x ~~> y.
+ Proof. intros ?? z n [??]; split; simpl in *; auto. Qed.
+ Lemma prod_updateP P1 P2 (Q : A * B → Prop) x :
+ x.1 ~~>: P1 → x.2 ~~>: P2 → (∀ a b, P1 a → P2 b → Q (a,b)) → x ~~>: Q.
+ Proof.
+ intros Hx1 Hx2 HP z n [??]; simpl in *.
+ destruct (Hx1 (z.1) n) as (a&?&?), (Hx2 (z.2) n) as (b&?&?); auto.
+ exists (a,b); repeat split; auto.
+ Qed.
+ Lemma prod_updateP' P1 P2 x :
+ x.1 ~~>: P1 → x.2 ~~>: P2 → x ~~>: λ y, P1 (y.1) ∧ P2 (y.2).
+ Proof. eauto using prod_updateP. Qed.
+End prod.
+Arguments prodRA : clear implicits.
+
+Instance prod_map_cmra_monotone {A A' B B' : cmraT} (f : A → A') (g : B → B') :
+ CMRAMonotone f → CMRAMonotone g → CMRAMonotone (prod_map f g).
+Proof.
+ split.
+ * intros n x y; rewrite !prod_includedN; intros [??]; simpl.
+ by split; apply includedN_preserving.
+ * by intros n x [??]; split; simpl; apply validN_preserving.
+Qed.
+Definition prodRA_map {A A' B B' : cmraT}
+ (f : A -n> A') (g : B -n> B') : prodRA A B -n> prodRA A' B' :=
+ CofeMor (prod_map f g : prodRA A B → prodRA A' B').
+Instance prodRA_map_ne {A A' B B'} n :
+ Proper (dist n==> dist n==> dist n) (@prodRA_map A A' B B') := prodC_map_ne n.
+
+(** ** Indexed product *)
+Section iprod_cmra.
+ Context {A} {B : A → cmraT}.
+ Instance iprod_op : Op (iprod B) := λ f g x, f x ⋅ g x.
+ Instance iprod_unit : Unit (iprod B) := λ f x, unit (f x).
+ Instance iprod_validN : ValidN (iprod B) := λ n f, ∀ x, ✓{n} (f x).
+ Instance iprod_minus : Minus (iprod B) := λ f g x, f x ⩪ g x.
+ Lemma iprod_includedN_spec (f g : iprod B) n : f ≼{n} g ↔ ∀ x, f x ≼{n} g x.
+ Proof.
+ split.
+ * by intros [h Hh] x; exists (h x); rewrite /op /iprod_op (Hh x).
+ * intros Hh; exists (g ⩪ f)=> x; specialize (Hh x).
+ by rewrite /op /iprod_op /minus /iprod_minus cmra_op_minus.
+ Qed.
+ Definition iprod_cmra_mixin : CMRAMixin (iprod B).
+ Proof.
+ split.
+ * by intros n f1 f2 f3 Hf x; rewrite /op /iprod_op (Hf x).
+ * by intros n f1 f2 Hf x; rewrite /unit /iprod_unit (Hf x).
+ * by intros n f1 f2 Hf ? x; rewrite -(Hf x).
+ * by intros n f f' Hf g g' Hg i; rewrite /minus /iprod_minus (Hf i) (Hg i).
+ * by intros f x.
+ * intros n f Hf x; apply cmra_validN_S, Hf.
+ * by intros f1 f2 f3 x; rewrite /op /iprod_op associative.
+ * by intros f1 f2 x; rewrite /op /iprod_op commutative.
+ * by intros f x; rewrite /op /iprod_op /unit /iprod_unit cmra_unit_l.
+ * by intros f x; rewrite /unit /iprod_unit cmra_unit_idempotent.
+ * intros n f1 f2; rewrite !iprod_includedN_spec=> Hf x.
+ by rewrite /unit /iprod_unit; apply cmra_unit_preservingN, Hf.
+ * intros n f1 f2 Hf x; apply cmra_validN_op_l with (f2 x), Hf.
+ * intros n f1 f2; rewrite iprod_includedN_spec=> Hf x.
+ by rewrite /op /iprod_op /minus /iprod_minus cmra_op_minus; try apply Hf.
+ Qed.
+ Definition iprod_cmra_extend_mixin : CMRAExtendMixin (iprod B).
+ Proof.
+ intros n f f1 f2 Hf Hf12.
+ set (g x := cmra_extend_op n (f x) (f1 x) (f2 x) (Hf x) (Hf12 x)).
+ exists ((λ x, (proj1_sig (g x)).1), (λ x, (proj1_sig (g x)).2)).
+ split_ands; intros x; apply (proj2_sig (g x)).
+ Qed.
+ Canonical Structure iprodRA : cmraT :=
+ CMRAT iprod_cofe_mixin iprod_cmra_mixin iprod_cmra_extend_mixin.
+End iprod_cmra.
+
+Arguments iprodRA {_} _.
diff --git a/algebra/cmra_big_op.v b/algebra/cmra_big_op.v
new file mode 100644
index 0000000000000000000000000000000000000000..a11ce17f6a84882f99ce798099fddac572d1286c
--- /dev/null
+++ b/algebra/cmra_big_op.v
@@ -0,0 +1,80 @@
+Require Export algebra.cmra.
+Require Import prelude.fin_maps.
+
+Fixpoint big_op {A : cmraT} `{Empty A} (xs : list A) : A :=
+ match xs with [] => ∅ | x :: xs => x ⋅ big_op xs end.
+Arguments big_op _ _ !_ /.
+Instance: Params (@big_op) 2.
+Definition big_opM {A : cmraT} `{FinMapToList K A M, Empty A} (m : M) : A :=
+ big_op (snd <$> map_to_list m).
+Instance: Params (@big_opM) 5.
+
+(** * Properties about big ops *)
+Section big_op.
+Context `{CMRAIdentity A}.
+
+(** * Big ops *)
+Lemma big_op_nil : big_op (@nil A) = ∅.
+Proof. done. Qed.
+Lemma big_op_cons x xs : big_op (x :: xs) = x â‹… big_op xs.
+Proof. done. Qed.
+Global Instance big_op_permutation : Proper ((≡ₚ) ==> (≡)) big_op.
+Proof.
+ induction 1 as [|x xs1 xs2 ? IH|x y xs|xs1 xs2 xs3]; simpl; auto.
+ * by rewrite IH.
+ * by rewrite !(associative _) (commutative _ x).
+ * by transitivity (big_op xs2).
+Qed.
+Global Instance big_op_proper : Proper ((≡) ==> (≡)) big_op.
+Proof. by induction 1; simpl; repeat apply (_ : Proper (_ ==> _ ==> _) op). Qed.
+Lemma big_op_app xs ys : big_op (xs ++ ys) ≡ big_op xs ⋅ big_op ys.
+Proof.
+ induction xs as [|x xs IH]; simpl; first by rewrite ?(left_id _ _).
+ by rewrite IH (associative _).
+Qed.
+Lemma big_op_contains xs ys : xs `contains` ys → big_op xs ≼ big_op ys.
+Proof.
+ induction 1 as [|x xs ys|x y xs|x xs ys|xs ys zs]; rewrite //=.
+ * by apply cmra_preserving_l.
+ * by rewrite !associative (commutative _ y).
+ * by transitivity (big_op ys); last apply cmra_included_r.
+ * by transitivity (big_op ys).
+Qed.
+Lemma big_op_delete xs i x :
+ xs !! i = Some x → x ⋅ big_op (delete i xs) ≡ big_op xs.
+Proof. by intros; rewrite {2}(delete_Permutation xs i x). Qed.
+
+Context `{FinMap K M}.
+Lemma big_opM_empty : big_opM (∅ : M A) ≡ ∅.
+Proof. unfold big_opM. by rewrite map_to_list_empty. Qed.
+Lemma big_opM_insert (m : M A) i x :
+ m !! i = None → big_opM (<[i:=x]> m) ≡ x ⋅ big_opM m.
+Proof. intros ?; by rewrite /big_opM map_to_list_insert. Qed.
+Lemma big_opM_delete (m : M A) i x :
+ m !! i = Some x → x ⋅ big_opM (delete i m) ≡ big_opM m.
+Proof.
+ intros. by rewrite -{2}(insert_delete m i x) // big_opM_insert ?lookup_delete.
+Qed.
+Lemma big_opM_singleton i x : big_opM ({[i ↦ x]} : M A) ≡ x.
+Proof.
+ rewrite -insert_empty big_opM_insert /=; last auto using lookup_empty.
+ by rewrite big_opM_empty (right_id _ _).
+Qed.
+Global Instance big_opM_proper : Proper ((≡) ==> (≡)) (big_opM : M A → _).
+Proof.
+ intros m1; induction m1 as [|i x m1 ? IH] using map_ind.
+ { by intros m2; rewrite (symmetry_iff (≡)) map_equiv_empty; intros ->. }
+ intros m2 Hm2; rewrite big_opM_insert //.
+ rewrite (IH (delete i m2)); last by rewrite -Hm2 delete_insert.
+ destruct (map_equiv_lookup (<[i:=x]> m1) m2 i x)
+ as (y&?&Hxy); auto using lookup_insert.
+ rewrite Hxy -big_opM_insert; last auto using lookup_delete.
+ by rewrite insert_delete.
+Qed.
+Lemma big_opM_lookup_valid n m i x :
+ ✓{n} (big_opM m) → m !! i = Some x → ✓{n} x.
+Proof.
+ intros Hm ?; revert Hm; rewrite -(big_opM_delete _ i x) //.
+ apply cmra_validN_op_l.
+Qed.
+End big_op.
diff --git a/algebra/cmra_tactics.v b/algebra/cmra_tactics.v
new file mode 100644
index 0000000000000000000000000000000000000000..27b6efb85ab1b3457d0966bc38bbbb8413302a0a
--- /dev/null
+++ b/algebra/cmra_tactics.v
@@ -0,0 +1,66 @@
+Require Export algebra.cmra.
+Require Import algebra.cmra_big_op.
+
+(** * Simple solver for validity and inclusion by reflection *)
+Module ra_reflection. Section ra_reflection.
+ Context `{CMRAIdentity A}.
+
+ Inductive expr :=
+ | EVar : nat → expr
+ | EEmpty : expr
+ | EOp : expr → expr → expr.
+ Fixpoint eval (Σ : list A) (e : expr) : A :=
+ match e with
+ | EVar n => from_option ∅ (Σ !! n)
+ | EEmpty => ∅
+ | EOp e1 e2 => eval Σ e1 ⋅ eval Σ e2
+ end.
+ Fixpoint flatten (e : expr) : list nat :=
+ match e with
+ | EVar n => [n]
+ | EEmpty => []
+ | EOp e1 e2 => flatten e1 ++ flatten e2
+ end.
+ Lemma eval_flatten Σ e :
+ eval Σ e ≡ big_op ((λ n, from_option ∅ (Σ !! n)) <$> flatten e).
+ Proof.
+ by induction e as [| |e1 IH1 e2 IH2];
+ rewrite /= ?(right_id _ _) ?fmap_app ?big_op_app ?IH1 ?IH2.
+ Qed.
+ Lemma flatten_correct Σ e1 e2 :
+ flatten e1 `contains` flatten e2 → eval Σ e1 ≼ eval Σ e2.
+ Proof.
+ by intros He; rewrite !eval_flatten; apply big_op_contains; rewrite ->He.
+ Qed.
+
+ Class Quote (Σ1 Σ2 : list A) (l : A) (e : expr) := {}.
+ Global Instance quote_empty: Quote E1 E1 ∅ EEmpty.
+ Global Instance quote_var Σ1 Σ2 e i:
+ rlist.QuoteLookup Σ1 Σ2 e i → Quote Σ1 Σ2 e (EVar i) | 1000.
+ Global Instance quote_app Σ1 Σ2 Σ3 x1 x2 e1 e2 :
+ Quote Σ1 Σ2 x1 e1 → Quote Σ2 Σ3 x2 e2 → Quote Σ1 Σ3 (x1 ⋅ x2) (EOp e1 e2).
+ End ra_reflection.
+
+ Ltac quote :=
+ match goal with
+ | |- @included _ _ _ ?x ?y =>
+ lazymatch type of (_ : Quote [] _ x _) with Quote _ ?Σ2 _ ?e1 =>
+ lazymatch type of (_ : Quote Σ2 _ y _) with Quote _ ?Σ3 _ ?e2 =>
+ change (eval Σ3 e1 ≼ eval Σ3 e2)
+ end end
+ end.
+End ra_reflection.
+
+Ltac solve_included :=
+ ra_reflection.quote;
+ apply ra_reflection.flatten_correct, (bool_decide_unpack _);
+ vm_compute; apply I.
+
+Ltac solve_validN :=
+ match goal with
+ | H : ✓{?n} ?y |- ✓{?n'} ?x =>
+ let Hn := fresh in let Hx := fresh in
+ assert (n' ≤ n) as Hn by omega;
+ assert (x ≼ y) as Hx by solve_included;
+ eapply cmra_validN_le, Hn; eapply cmra_validN_included, Hx; apply H
+ end.
diff --git a/algebra/cofe.v b/algebra/cofe.v
new file mode 100644
index 0000000000000000000000000000000000000000..2b48fcc6a5bc1a2551e39e16d48dd3655572d269
--- /dev/null
+++ b/algebra/cofe.v
@@ -0,0 +1,402 @@
+Require Export algebra.base.
+
+(** Unbundeled version *)
+Class Dist A := dist : nat → relation A.
+Instance: Params (@dist) 3.
+Notation "x ={ n }= y" := (dist n x y)
+ (at level 70, n at next level, format "x ={ n }= y").
+Hint Extern 0 (?x ={_}= ?y) => reflexivity.
+Hint Extern 0 (_ ={_}= _) => symmetry; assumption.
+
+Tactic Notation "cofe_subst" ident(x) :=
+ repeat match goal with
+ | _ => progress simplify_equality'
+ | H:@dist ?A ?d ?n x _ |- _ => setoid_subst_aux (@dist A d n) x
+ | H:@dist ?A ?d ?n _ x |- _ => symmetry in H;setoid_subst_aux (@dist A d n) x
+ end.
+Tactic Notation "cofe_subst" :=
+ repeat match goal with
+ | _ => progress simplify_equality'
+ | H:@dist ?A ?d ?n ?x _ |- _ => setoid_subst_aux (@dist A d n) x
+ | H:@dist ?A ?d ?n _ ?x |- _ => symmetry in H;setoid_subst_aux (@dist A d n) x
+ end.
+
+Record chain (A : Type) `{Dist A} := {
+ chain_car :> nat → A;
+ chain_cauchy n i : n ≤ i → chain_car n ={n}= chain_car i
+}.
+Arguments chain_car {_ _} _ _.
+Arguments chain_cauchy {_ _} _ _ _ _.
+Class Compl A `{Dist A} := compl : chain A → A.
+
+Record CofeMixin A `{Equiv A, Compl A} := {
+ mixin_equiv_dist x y : x ≡ y ↔ ∀ n, x ={n}= y;
+ mixin_dist_equivalence n : Equivalence (dist n);
+ mixin_dist_S n x y : x ={S n}= y → x ={n}= y;
+ mixin_dist_0 x y : x ={0}= y;
+ mixin_conv_compl (c : chain A) n : compl c ={n}= c n
+}.
+Class Contractive `{Dist A, Dist B} (f : A -> B) :=
+ contractive n : Proper (dist n ==> dist (S n)) f.
+
+(** Bundeled version *)
+Structure cofeT := CofeT {
+ cofe_car :> Type;
+ cofe_equiv : Equiv cofe_car;
+ cofe_dist : Dist cofe_car;
+ cofe_compl : Compl cofe_car;
+ cofe_mixin : CofeMixin cofe_car
+}.
+Arguments CofeT {_ _ _ _} _.
+Add Printing Constructor cofeT.
+Existing Instances cofe_equiv cofe_dist cofe_compl.
+Arguments cofe_car : simpl never.
+Arguments cofe_equiv : simpl never.
+Arguments cofe_dist : simpl never.
+Arguments cofe_compl : simpl never.
+Arguments cofe_mixin : simpl never.
+
+(** Lifting properties from the mixin *)
+Section cofe_mixin.
+ Context {A : cofeT}.
+ Implicit Types x y : A.
+ Lemma equiv_dist x y : x ≡ y ↔ ∀ n, x ={n}= y.
+ Proof. apply (mixin_equiv_dist _ (cofe_mixin A)). Qed.
+ Global Instance dist_equivalence n : Equivalence (@dist A _ n).
+ Proof. apply (mixin_dist_equivalence _ (cofe_mixin A)). Qed.
+ Lemma dist_S n x y : x ={S n}= y → x ={n}= y.
+ Proof. apply (mixin_dist_S _ (cofe_mixin A)). Qed.
+ Lemma dist_0 x y : x ={0}= y.
+ Proof. apply (mixin_dist_0 _ (cofe_mixin A)). Qed.
+ Lemma conv_compl (c : chain A) n : compl c ={n}= c n.
+ Proof. apply (mixin_conv_compl _ (cofe_mixin A)). Qed.
+End cofe_mixin.
+
+Hint Extern 0 (_ ={0}= _) => apply dist_0.
+
+(** General properties *)
+Section cofe.
+ Context {A : cofeT}.
+ Implicit Types x y : A.
+ Global Instance cofe_equivalence : Equivalence ((≡) : relation A).
+ Proof.
+ split.
+ * by intros x; rewrite equiv_dist.
+ * by intros x y; rewrite !equiv_dist.
+ * by intros x y z; rewrite !equiv_dist; intros; transitivity y.
+ Qed.
+ Global Instance dist_ne n : Proper (dist n ==> dist n ==> iff) (@dist A _ n).
+ Proof.
+ intros x1 x2 ? y1 y2 ?; split; intros.
+ * by transitivity x1; [|transitivity y1].
+ * by transitivity x2; [|transitivity y2].
+ Qed.
+ Global Instance dist_proper n : Proper ((≡) ==> (≡) ==> iff) (@dist A _ n).
+ Proof.
+ by move => x1 x2 /equiv_dist Hx y1 y2 /equiv_dist Hy; rewrite (Hx n) (Hy n).
+ Qed.
+ Global Instance dist_proper_2 n x : Proper ((≡) ==> iff) (dist n x).
+ Proof. by apply dist_proper. Qed.
+ Lemma dist_le (x y : A) n n' : x ={n}= y → n' ≤ n → x ={n'}= y.
+ Proof. induction 2; eauto using dist_S. Qed.
+ Instance ne_proper {B : cofeT} (f : A → B)
+ `{!∀ n, Proper (dist n ==> dist n) f} : Proper ((≡) ==> (≡)) f | 100.
+ Proof. by intros x1 x2; rewrite !equiv_dist; intros Hx n; rewrite (Hx n). Qed.
+ Instance ne_proper_2 {B C : cofeT} (f : A → B → C)
+ `{!∀ n, Proper (dist n ==> dist n ==> dist n) f} :
+ Proper ((≡) ==> (≡) ==> (≡)) f | 100.
+ Proof.
+ unfold Proper, respectful; setoid_rewrite equiv_dist.
+ by intros x1 x2 Hx y1 y2 Hy n; rewrite (Hx n) (Hy n).
+ Qed.
+ Lemma compl_ne (c1 c2: chain A) n : c1 n ={n}= c2 n → compl c1 ={n}= compl c2.
+ Proof. intros. by rewrite (conv_compl c1 n) (conv_compl c2 n). Qed.
+ Lemma compl_ext (c1 c2 : chain A) : (∀ i, c1 i ≡ c2 i) → compl c1 ≡ compl c2.
+ Proof. setoid_rewrite equiv_dist; naive_solver eauto using compl_ne. Qed.
+ Global Instance contractive_ne {B : cofeT} (f : A → B) `{!Contractive f} n :
+ Proper (dist n ==> dist n) f | 100.
+ Proof. by intros x1 x2 ?; apply dist_S, contractive. Qed.
+ Global Instance contractive_proper {B : cofeT} (f : A → B) `{!Contractive f} :
+ Proper ((≡) ==> (≡)) f | 100 := _.
+End cofe.
+
+(** Mapping a chain *)
+Program Definition chain_map `{Dist A, Dist B} (f : A → B)
+ `{!∀ n, Proper (dist n ==> dist n) f} (c : chain A) : chain B :=
+ {| chain_car n := f (c n) |}.
+Next Obligation. by intros ? A ? B f Hf c n i ?; apply Hf, chain_cauchy. Qed.
+
+(** Timeless elements *)
+Class Timeless {A : cofeT} (x : A) := timeless y : x ={1}= y → x ≡ y.
+Arguments timeless {_} _ {_} _ _.
+Lemma timeless_S {A : cofeT} (x y : A) n : Timeless x → x ≡ y ↔ x ={S n}= y.
+Proof.
+ split; intros; [by apply equiv_dist|].
+ apply (timeless _), dist_le with (S n); auto with lia.
+Qed.
+
+(** Fixpoint *)
+Program Definition fixpoint_chain {A : cofeT} `{Inhabited A} (f : A → A)
+ `{!Contractive f} : chain A := {| chain_car i := Nat.iter i f inhabitant |}.
+Next Obligation.
+ intros A ? f ? n; induction n as [|n IH]; intros i ?; first done.
+ destruct i as [|i]; simpl; first lia; apply contractive, IH; auto with lia.
+Qed.
+Program Definition fixpoint {A : cofeT} `{Inhabited A} (f : A → A)
+ `{!Contractive f} : A := compl (fixpoint_chain f).
+
+Section fixpoint.
+ Context {A : cofeT} `{Inhabited A} (f : A → A) `{!Contractive f}.
+ Lemma fixpoint_unfold : fixpoint f ≡ f (fixpoint f).
+ Proof.
+ apply equiv_dist; intros n; unfold fixpoint.
+ rewrite (conv_compl (fixpoint_chain f) n).
+ by rewrite {1}(chain_cauchy (fixpoint_chain f) n (S n)); last lia.
+ Qed.
+ Lemma fixpoint_ne (g : A → A) `{!Contractive g} n :
+ (∀ z, f z ={n}= g z) → fixpoint f ={n}= fixpoint g.
+ Proof.
+ intros Hfg; unfold fixpoint.
+ rewrite (conv_compl (fixpoint_chain f) n) (conv_compl (fixpoint_chain g) n).
+ induction n as [|n IH]; simpl in *; first done.
+ rewrite Hfg; apply contractive, IH; auto using dist_S.
+ Qed.
+ Lemma fixpoint_proper (g : A → A) `{!Contractive g} :
+ (∀ x, f x ≡ g x) → fixpoint f ≡ fixpoint g.
+ Proof. setoid_rewrite equiv_dist; naive_solver eauto using fixpoint_ne. Qed.
+End fixpoint.
+Global Opaque fixpoint.
+
+(** Function space *)
+Record cofeMor (A B : cofeT) : Type := CofeMor {
+ cofe_mor_car :> A → B;
+ cofe_mor_ne n : Proper (dist n ==> dist n) cofe_mor_car
+}.
+Arguments CofeMor {_ _} _ {_}.
+Add Printing Constructor cofeMor.
+Existing Instance cofe_mor_ne.
+
+Section cofe_mor.
+ Context {A B : cofeT}.
+ Global Instance cofe_mor_proper (f : cofeMor A B) : Proper ((≡) ==> (≡)) f.
+ Proof. apply ne_proper, cofe_mor_ne. Qed.
+ Instance cofe_mor_equiv : Equiv (cofeMor A B) := λ f g, ∀ x, f x ≡ g x.
+ Instance cofe_mor_dist : Dist (cofeMor A B) := λ n f g, ∀ x, f x ={n}= g x.
+ Program Definition fun_chain `(c : chain (cofeMor A B)) (x : A) : chain B :=
+ {| chain_car n := c n x |}.
+ Next Obligation. intros c x n i ?. by apply (chain_cauchy c). Qed.
+ Program Instance cofe_mor_compl : Compl (cofeMor A B) := λ c,
+ {| cofe_mor_car x := compl (fun_chain c x) |}.
+ Next Obligation.
+ intros c n x y Hx.
+ rewrite (conv_compl (fun_chain c x) n) (conv_compl (fun_chain c y) n) /= Hx.
+ apply (chain_cauchy c); lia.
+ Qed.
+ Definition cofe_mor_cofe_mixin : CofeMixin (cofeMor A B).
+ Proof.
+ split.
+ * intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
+ intros Hfg k; apply equiv_dist; intros n; apply Hfg.
+ * intros n; split.
+ + by intros f x.
+ + by intros f g ? x.
+ + by intros f g h ?? x; transitivity (g x).
+ * by intros n f g ? x; apply dist_S.
+ * by intros f g x.
+ * intros c n x; simpl.
+ rewrite (conv_compl (fun_chain c x) n); apply (chain_cauchy c); lia.
+ Qed.
+ Canonical Structure cofe_mor : cofeT := CofeT cofe_mor_cofe_mixin.
+
+ Global Instance cofe_mor_car_ne n :
+ Proper (dist n ==> dist n ==> dist n) (@cofe_mor_car A B).
+ Proof. intros f g Hfg x y Hx; rewrite Hx; apply Hfg. Qed.
+ Global Instance cofe_mor_car_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@cofe_mor_car A B) := ne_proper_2 _.
+ Lemma cofe_mor_ext (f g : cofeMor A B) : f ≡ g ↔ ∀ x, f x ≡ g x.
+ Proof. done. Qed.
+End cofe_mor.
+
+Arguments cofe_mor : clear implicits.
+Infix "-n>" := cofe_mor (at level 45, right associativity).
+Instance cofe_more_inhabited {A B : cofeT} `{Inhabited B} :
+ Inhabited (A -n> B) := populate (CofeMor (λ _, inhabitant)).
+
+(** Identity and composition *)
+Definition cid {A} : A -n> A := CofeMor id.
+Instance: Params (@cid) 1.
+Definition ccompose {A B C}
+ (f : B -n> C) (g : A -n> B) : A -n> C := CofeMor (f ∘ g).
+Instance: Params (@ccompose) 3.
+Infix "â—Ž" := ccompose (at level 40, left associativity).
+Lemma ccompose_ne {A B C} (f1 f2 : B -n> C) (g1 g2 : A -n> B) n :
+ f1 ={n}= f2 → g1 ={n}= g2 → f1 ◎ g1 ={n}= f2 ◎ g2.
+Proof. by intros Hf Hg x; rewrite /= (Hg x) (Hf (g2 x)). Qed.
+
+(** unit *)
+Section unit.
+ Instance unit_dist : Dist unit := λ _ _ _, True.
+ Instance unit_compl : Compl unit := λ _, ().
+ Definition unit_cofe_mixin : CofeMixin unit.
+ Proof. by repeat split; try exists 0. Qed.
+ Canonical Structure unitC : cofeT := CofeT unit_cofe_mixin.
+ Global Instance unit_timeless (x : ()) : Timeless x.
+ Proof. done. Qed.
+End unit.
+
+(** Product *)
+Section product.
+ Context {A B : cofeT}.
+
+ Instance prod_dist : Dist (A * B) := λ n, prod_relation (dist n) (dist n).
+ Global Instance pair_ne :
+ Proper (dist n ==> dist n ==> dist n) (@pair A B) := _.
+ Global Instance fst_ne : Proper (dist n ==> dist n) (@fst A B) := _.
+ Global Instance snd_ne : Proper (dist n ==> dist n) (@snd A B) := _.
+ Instance prod_compl : Compl (A * B) := λ c,
+ (compl (chain_map fst c), compl (chain_map snd c)).
+ Definition prod_cofe_mixin : CofeMixin (A * B).
+ Proof.
+ split.
+ * intros x y; unfold dist, prod_dist, equiv, prod_equiv, prod_relation.
+ rewrite !equiv_dist; naive_solver.
+ * apply _.
+ * by intros n [x1 y1] [x2 y2] [??]; split; apply dist_S.
+ * by split.
+ * intros c n; split. apply (conv_compl (chain_map fst c) n).
+ apply (conv_compl (chain_map snd c) n).
+ Qed.
+ Canonical Structure prodC : cofeT := CofeT prod_cofe_mixin.
+ Global Instance pair_timeless (x : A) (y : B) :
+ Timeless x → Timeless y → Timeless (x,y).
+ Proof. by intros ?? [x' y'] [??]; split; apply (timeless _). Qed.
+End product.
+
+Arguments prodC : clear implicits.
+Typeclasses Opaque prod_dist.
+
+Instance prod_map_ne {A A' B B' : cofeT} n :
+ Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==>
+ dist n ==> dist n) (@prod_map A A' B B').
+Proof. by intros f f' Hf g g' Hg ?? [??]; split; [apply Hf|apply Hg]. Qed.
+Definition prodC_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
+ prodC A B -n> prodC A' B' := CofeMor (prod_map f g).
+Instance prodC_map_ne {A A' B B'} n :
+ Proper (dist n ==> dist n ==> dist n) (@prodC_map A A' B B').
+Proof. intros f f' Hf g g' Hg [??]; split; [apply Hf|apply Hg]. Qed.
+
+(** Discrete cofe *)
+Section discrete_cofe.
+ Context `{Equiv A, @Equivalence A (≡)}.
+ Instance discrete_dist : Dist A := λ n x y,
+ match n with 0 => True | S n => x ≡ y end.
+ Instance discrete_compl : Compl A := λ c, c 1.
+ Definition discrete_cofe_mixin : CofeMixin A.
+ Proof.
+ split.
+ * intros x y; split; [by intros ? []|intros Hn; apply (Hn 1)].
+ * intros [|n]; [done|apply _].
+ * by intros [|n].
+ * done.
+ * intros c [|n]; [done|apply (chain_cauchy c 1 (S n)); lia].
+ Qed.
+ Definition discreteC : cofeT := CofeT discrete_cofe_mixin.
+ Global Instance discrete_timeless (x : A) : Timeless (x : discreteC).
+ Proof. by intros y. Qed.
+End discrete_cofe.
+Arguments discreteC _ {_ _}.
+
+Definition leibnizC (A : Type) : cofeT := @discreteC A equivL _.
+Instance leibnizC_leibniz : LeibnizEquiv (leibnizC A).
+Proof. by intros A x y. Qed.
+
+Canonical Structure natC := leibnizC nat.
+Canonical Structure boolC := leibnizC bool.
+
+(** Later *)
+Inductive later (A : Type) : Type := Later { later_car : A }.
+Add Printing Constructor later.
+Arguments Later {_} _.
+Arguments later_car {_} _.
+Lemma later_eta {A} (x : later A) : Later (later_car x) = x.
+Proof. by destruct x. Qed.
+
+Section later.
+ Context {A : cofeT}.
+ Instance later_equiv : Equiv (later A) := λ x y, later_car x ≡ later_car y.
+ Instance later_dist : Dist (later A) := λ n x y,
+ match n with 0 => True | S n => later_car x ={n}= later_car y end.
+ Program Definition later_chain (c : chain (later A)) : chain A :=
+ {| chain_car n := later_car (c (S n)) |}.
+ Next Obligation. intros c n i ?; apply (chain_cauchy c (S n)); lia. Qed.
+ Instance later_compl : Compl (later A) := λ c, Later (compl (later_chain c)).
+ Definition later_cofe_mixin : CofeMixin (later A).
+ Proof.
+ split.
+ * intros x y; unfold equiv, later_equiv; rewrite !equiv_dist.
+ split. intros Hxy [|n]; [done|apply Hxy]. intros Hxy n; apply (Hxy (S n)).
+ * intros [|n]; [by split|split]; unfold dist, later_dist.
+ + by intros [x].
+ + by intros [x] [y].
+ + by intros [x] [y] [z] ??; transitivity y.
+ * intros [|n] [x] [y] ?; [done|]; unfold dist, later_dist; by apply dist_S.
+ * done.
+ * intros c [|n]; [done|by apply (conv_compl (later_chain c) n)].
+ Qed.
+ Canonical Structure laterC : cofeT := CofeT later_cofe_mixin.
+ Global Instance Later_contractive : Contractive (@Later A).
+ Proof. by intros n ??. Qed.
+ Global Instance Later_inj n : Injective (dist n) (dist (S n)) (@Later A).
+ Proof. by intros x y. Qed.
+End later.
+
+Arguments laterC : clear implicits.
+
+Definition later_map {A B} (f : A → B) (x : later A) : later B :=
+ Later (f (later_car x)).
+Instance later_map_ne {A B : cofeT} (f : A → B) n :
+ Proper (dist (pred n) ==> dist (pred n)) f →
+ Proper (dist n ==> dist n) (later_map f) | 0.
+Proof. destruct n as [|n]; intros Hf [x] [y] ?; do 2 red; simpl; auto. Qed.
+Lemma later_map_id {A} (x : later A) : later_map id x = x.
+Proof. by destruct x. Qed.
+Lemma later_map_compose {A B C} (f : A → B) (g : B → C) (x : later A) :
+ later_map (g ∘ f) x = later_map g (later_map f x).
+Proof. by destruct x. Qed.
+Definition laterC_map {A B} (f : A -n> B) : laterC A -n> laterC B :=
+ CofeMor (later_map f).
+Instance laterC_map_contractive (A B : cofeT) : Contractive (@laterC_map A B).
+Proof. intros n f g Hf n'; apply Hf. Qed.
+
+(** Indexed product *)
+(** Need to put this in a definition to make canonical structures to work. *)
+Definition iprod {A} (B : A → cofeT) := ∀ x, B x.
+
+Section iprod_cofe.
+ Context {A} {B : A → cofeT}.
+ Instance iprod_equiv : Equiv (iprod B) := λ f g, ∀ x, f x ≡ g x.
+ Instance iprod_dist : Dist (iprod B) := λ n f g, ∀ x, f x ={n}= g x.
+ Program Definition iprod_chain (c : chain (iprod B)) (x : A) : chain (B x) :=
+ {| chain_car n := c n x |}.
+ Next Obligation. by intros c x n i ?; apply (chain_cauchy c). Qed.
+ Program Instance iprod_compl : Compl (iprod B) := λ c x,
+ compl (iprod_chain c x).
+ Definition iprod_cofe_mixin : CofeMixin (iprod B).
+ Proof.
+ split.
+ * intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
+ intros Hfg k; apply equiv_dist; intros n; apply Hfg.
+ * intros n; split.
+ + by intros f x.
+ + by intros f g ? x.
+ + by intros f g h ?? x; transitivity (g x).
+ * intros n f g Hfg x; apply dist_S, Hfg.
+ * by intros f g x.
+ * intros c n x.
+ rewrite /compl /iprod_compl (conv_compl (iprod_chain c x) n).
+ apply (chain_cauchy c); lia.
+ Qed.
+ Canonical Structure iprodC : cofeT := CofeT iprod_cofe_mixin.
+End iprod_cofe.
+
+Arguments iprodC {_} _.
diff --git a/algebra/cofe_solver.v b/algebra/cofe_solver.v
new file mode 100644
index 0000000000000000000000000000000000000000..b0c1543a48c0acf26afc5d08119f2a0af1c0ef86
--- /dev/null
+++ b/algebra/cofe_solver.v
@@ -0,0 +1,234 @@
+Require Export algebra.cofe.
+
+Record solution (F : cofeT → cofeT → cofeT) := Solution {
+ solution_car :> cofeT;
+ solution_unfold : solution_car -n> F solution_car solution_car;
+ solution_fold : F solution_car solution_car -n> solution_car;
+ solution_fold_unfold X : solution_fold (solution_unfold X) ≡ X;
+ solution_unfold_fold X : solution_unfold (solution_fold X) ≡ X
+}.
+Arguments solution_unfold {_} _.
+Arguments solution_fold {_} _.
+
+Module solver. Section solver.
+Context (F : cofeT → cofeT → cofeT).
+Context `{Finhab : Inhabited (F unitC unitC)}.
+Context (map : ∀ {A1 A2 B1 B2 : cofeT},
+ ((A2 -n> A1) * (B1 -n> B2)) → (F A1 B1 -n> F A2 B2)).
+Arguments map {_ _ _ _} _.
+Instance: Params (@map) 4.
+Context (map_id : ∀ {A B : cofeT} (x : F A B), map (cid, cid) x ≡ x).
+Context (map_comp : ∀ {A1 A2 A3 B1 B2 B3 : cofeT}
+ (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x,
+ map (f ◎ g, g' ◎ f') x ≡ map (g,g') (map (f,f') x)).
+Context (map_contractive : ∀ {A1 A2 B1 B2}, Contractive (@map A1 A2 B1 B2)).
+
+Lemma map_ext {A1 A2 B1 B2 : cofeT}
+ (f : A2 -n> A1) (f' : A2 -n> A1) (g : B1 -n> B2) (g' : B1 -n> B2) x x' :
+ (∀ x, f x ≡ f' x) → (∀ y, g y ≡ g' y) → x ≡ x' →
+ map (f,g) x ≡ map (f',g') x'.
+Proof. by rewrite -!cofe_mor_ext; intros -> -> ->. Qed.
+
+Fixpoint A (k : nat) : cofeT :=
+ match k with 0 => unitC | S k => F (A k) (A k) end.
+Fixpoint f {k} : A k -n> A (S k) :=
+ match k with 0 => CofeMor (λ _, inhabitant) | S k => map (g,f) end
+with g {k} : A (S k) -n> A k :=
+ match k with 0 => CofeMor (λ _, ()) | S k => map (f,g) end.
+Definition f_S k (x : A (S k)) : f x = map (g,f) x := eq_refl.
+Definition g_S k (x : A (S (S k))) : g x = map (f,g) x := eq_refl.
+Lemma gf {k} (x : A k) : g (f x) ≡ x.
+Proof.
+ induction k as [|k IH]; simpl in *; [by destruct x|].
+ rewrite -map_comp -{2}(map_id _ _ x); by apply map_ext.
+Qed.
+Lemma fg {n k} (x : A (S k)) : n ≤ k → f (g x) ={n}= x.
+Proof.
+ intros Hnk; apply dist_le with k; auto; clear Hnk.
+ induction k as [|k IH]; simpl; [apply dist_0|].
+ rewrite -{2}(map_id _ _ x) -map_comp; by apply map_contractive.
+Qed.
+Arguments A _ : simpl never.
+Arguments f {_} : simpl never.
+Arguments g {_} : simpl never.
+
+Record tower := {
+ tower_car k :> A k;
+ g_tower k : g (tower_car (S k)) ≡ tower_car k
+}.
+Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
+Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ={n}= Y k.
+Program Definition tower_chain (c : chain tower) (k : nat) : chain (A k) :=
+ {| chain_car i := c i k |}.
+Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
+Program Instance tower_compl : Compl tower := λ c,
+ {| tower_car n := compl (tower_chain c n) |}.
+Next Obligation.
+ intros c k; apply equiv_dist; intros n.
+ rewrite (conv_compl (tower_chain c k) n).
+ by rewrite (conv_compl (tower_chain c (S k)) n) /= (g_tower (c n) k).
+Qed.
+Definition tower_cofe_mixin : CofeMixin tower.
+Proof.
+ split.
+ * intros X Y; split; [by intros HXY n k; apply equiv_dist|].
+ intros HXY k; apply equiv_dist; intros n; apply HXY.
+ * intros k; split.
+ + by intros X n.
+ + by intros X Y ? n.
+ + by intros X Y Z ?? n; transitivity (Y n).
+ * intros k X Y HXY n; apply dist_S.
+ by rewrite -(g_tower X) (HXY (S n)) g_tower.
+ * intros X Y k; apply dist_0.
+ * intros c n k; rewrite /= (conv_compl (tower_chain c k) n).
+ apply (chain_cauchy c); lia.
+Qed.
+Definition T : cofeT := CofeT tower_cofe_mixin.
+
+Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
+ match i with 0 => cid | S i => f â—Ž ff i end.
+Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
+ match i with 0 => cid | S i => gg i â—Ž g end.
+Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
+Proof. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
+Lemma f_tower {n k} (X : tower) : n ≤ k → f (X k) ={n}= X (S k).
+Proof. intros. by rewrite -(fg (X (S k))) // -(g_tower X). Qed.
+Lemma ff_tower {n} k i (X : tower) : n ≤ k → ff i (X k) ={n}= X (i + k).
+Proof.
+ intros; induction i as [|i IH]; simpl; [done|].
+ by rewrite IH (f_tower X); last lia.
+Qed.
+Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
+Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.
+
+Instance tower_car_ne n k : Proper (dist n ==> dist n) (λ X, tower_car X k).
+Proof. by intros X Y HX. Qed.
+Definition project (k : nat) : T -n> A k := CofeMor (λ X : T, tower_car X k).
+
+Definition coerce {i j} (H : i = j) : A i -n> A j :=
+ eq_rect _ (λ i', A i -n> A i') cid _ H.
+Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
+Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
+Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
+ x = y → coerce H1 x = coerce H2 y.
+Proof. by destruct H1; rewrite !coerce_id. Qed.
+Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
+ g (coerce H x) = coerce (Nat.succ_inj _ _ H) (g x).
+Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
+Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
+ coerce H (f x) = f (coerce (Nat.succ_inj _ _ H) x).
+Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
+Lemma gg_gg {k i i1 i2 j} (H1 : k = i + j) (H2 : k = i2 + (i1 + j)) (x : A k) :
+ gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
+Proof.
+ assert (i = i2 + i1) by lia; simplify_equality'. revert j x H1.
+ induction i2 as [|i2 IH]; intros j X H1; simplify_equality';
+ [by rewrite coerce_id|by rewrite g_coerce IH].
+Qed.
+Lemma ff_ff {k i i1 i2 j} (H1 : i + k = j) (H2 : i1 + (i2 + k) = j) (x : A k) :
+ coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
+Proof.
+ assert (i = i1 + i2) by lia; simplify_equality'.
+ induction i1 as [|i1 IH]; simplify_equality';
+ [by rewrite coerce_id|by rewrite coerce_f IH].
+Qed.
+
+Definition embed' {k} (i : nat) : A k -n> A i :=
+ match le_lt_dec i k with
+ | left H => gg (k-i) â—Ž coerce (eq_sym (Nat.sub_add _ _ H))
+ | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) â—Ž ff (i-k)
+ end.
+Lemma g_embed' {k i} (x : A k) : g (embed' (S i) x) ≡ embed' i x.
+Proof.
+ unfold embed'; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
+ * symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
+ * exfalso; lia.
+ * assert (i = k) by lia; subst.
+ rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
+ by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
+ * assert (H : 1 + ((i - k) + k) = S i) by lia.
+ rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
+ by erewrite coerce_proper by done.
+Qed.
+Program Definition embed_inf (k : nat) (x : A k) : T :=
+ {| tower_car n := embed' n x |}.
+Next Obligation. intros k x i. apply g_embed'. Qed.
+Instance embed_inf_ne k n : Proper (dist n ==> dist n) (embed_inf k).
+Proof. by intros x y Hxy i; rewrite /= Hxy. Qed.
+Definition embed (k : nat) : A k -n> T := CofeMor (embed_inf k).
+Lemma embed_f k (x : A k) : embed (S k) (f x) ≡ embed k x.
+Proof.
+ rewrite equiv_dist; intros n i.
+ unfold embed_inf, embed; simpl; unfold embed'.
+ destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
+ * assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
+ by erewrite g_coerce, gf, coerce_proper by done.
+ * assert (S k = 0 + (0 + i)) as H by lia.
+ rewrite (gg_gg _ H); simplify_equality'.
+ by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
+ * exfalso; lia.
+ * assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
+ by erewrite coerce_proper by done.
+Qed.
+Lemma embed_tower j n (X : T) : n ≤ j → embed j (X j) ={n}= X.
+Proof.
+ move=> Hn i; rewrite /= /embed'; destruct (le_lt_dec i j) as [H|H]; simpl.
+ * rewrite -(gg_tower i (j - i) X).
+ apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
+ * rewrite (ff_tower j (i-j) X); last lia. by destruct (Nat.sub_add _ _ _).
+Qed.
+
+Program Definition unfold_chain (X : T) : chain (F T T) :=
+ {| chain_car n := map (project n,embed n) (f (X n)) |}.
+Next Obligation.
+ intros X n i Hi.
+ assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
+ induction k as [|k Hk]; simpl; [done|].
+ rewrite Hk (f_tower X); last lia; rewrite f_S -map_comp.
+ apply dist_S, map_contractive.
+ split; intros Y; symmetry; apply equiv_dist; [apply g_tower|apply embed_f].
+Qed.
+Definition unfold (X : T) : F T T := compl (unfold_chain X).
+Instance unfold_ne : Proper (dist n ==> dist n) unfold.
+Proof. by intros n X Y HXY; apply compl_ne; rewrite /= (HXY n). Qed.
+
+Program Definition fold (X : F T T) : T :=
+ {| tower_car n := g (map (embed n,project n) X) |}.
+Next Obligation.
+ intros X k; apply (_ : Proper ((≡) ==> (≡)) g).
+ rewrite -(map_comp _ _ _ _ _ _ (embed (S k)) f (project (S k)) g).
+ apply map_ext; [apply embed_f|intros Y; apply g_tower|done].
+Qed.
+Instance fold_ne : Proper (dist n ==> dist n) fold.
+Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.
+
+Theorem result : solution F.
+Proof.
+ apply (Solution F T (CofeMor unfold) (CofeMor fold)).
+ * move=> X.
+ assert (map_ff_gg : ∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
+ map (ff i, gg i) x ≡ gg i (coerce H x)).
+ { intros i; induction i as [|i IH]; intros k x H; simpl.
+ { by rewrite coerce_id map_id. }
+ rewrite map_comp g_coerce; apply IH. }
+ rewrite equiv_dist; intros n k; unfold unfold, fold; simpl.
+ rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) g).
+ transitivity (map (ff n, gg n) (X (S (n + k)))).
+ { rewrite /unfold (conv_compl (unfold_chain X) n).
+ rewrite (chain_cauchy (unfold_chain X) n (n + k)) /=; last lia.
+ rewrite (f_tower X); last lia; rewrite -map_comp.
+ apply dist_S. apply map_contractive; split; intros x; simpl; unfold embed'.
+ * destruct (le_lt_dec _ _); simpl.
+ { assert (n = 0) by lia; subst. apply dist_0. }
+ by rewrite (ff_ff _ (eq_refl (n + (0 + k)))).
+ * destruct (le_lt_dec _ _); [|exfalso; lia]; simpl.
+ by rewrite (gg_gg _ (eq_refl (0 + (n + k)))). }
+ assert (H: S n + k = n + S k) by lia; rewrite (map_ff_gg _ _ _ H).
+ apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
+ * move=>X; rewrite equiv_dist=> n.
+ rewrite /(unfold) /= /(unfold) (conv_compl (unfold_chain (fold X)) n) /=.
+ rewrite (fg (map (embed _,project n) X)); last lia.
+ rewrite -map_comp -{2}(map_id _ _ X).
+ apply dist_S, map_contractive; split; intros Y i; apply embed_tower; lia.
+Qed.
+End solver. End solver.
diff --git a/algebra/dra.v b/algebra/dra.v
new file mode 100644
index 0000000000000000000000000000000000000000..0e61179dac2bb483184e77cc9489aa2491c4d6f8
--- /dev/null
+++ b/algebra/dra.v
@@ -0,0 +1,139 @@
+Require Export algebra.cmra.
+
+(** From disjoint pcm *)
+Record validity {A} (P : A → Prop) : Type := Validity {
+ validity_car : A;
+ validity_is_valid : Prop;
+ validity_prf : validity_is_valid → P validity_car
+}.
+Arguments Validity {_ _} _ _ _.
+Arguments validity_car {_ _} _.
+Arguments validity_is_valid {_ _} _.
+
+Definition to_validity {A} {P : A → Prop} (x : A) : validity P :=
+ Validity x (P x) id.
+Instance validity_valid {A} (P : A → Prop) : Valid (validity P) :=
+ validity_is_valid.
+Instance validity_equiv `{Equiv A} (P : A → Prop) : Equiv (validity P) := λ x y,
+ (valid x ↔ valid y) ∧ (valid x → validity_car x ≡ validity_car y).
+Instance validity_equivalence `{Equiv A,!Equivalence ((≡) : relation A)} P :
+ Equivalence ((≡) : relation (validity P)).
+Proof.
+ split; unfold equiv, validity_equiv.
+ * by intros [x px ?]; simpl.
+ * intros [x px ?] [y py ?]; naive_solver.
+ * intros [x px ?] [y py ?] [z pz ?] [? Hxy] [? Hyz]; simpl in *.
+ split; [|intros; transitivity y]; tauto.
+Qed.
+Instance validity_valid_proper `{Equiv A} (P : A → Prop) :
+ Proper ((≡) ==> iff) (✓ : validity P → Prop).
+Proof. intros ?? [??]; naive_solver. Qed.
+
+Definition dra_included `{Equiv A, Valid A, Disjoint A, Op A} := λ x y,
+ ∃ z, y ≡ x ⋅ z ∧ ✓ z ∧ x ⊥ z.
+Instance: Params (@dra_included) 4.
+Local Infix "≼" := dra_included.
+
+Class DRA A `{Equiv A, Valid A, Unit A, Disjoint A, Op A, Minus A} := {
+ (* setoids *)
+ dra_equivalence :> Equivalence ((≡) : relation A);
+ dra_op_proper :> Proper ((≡) ==> (≡) ==> (≡)) (⋅);
+ dra_unit_proper :> Proper ((≡) ==> (≡)) unit;
+ dra_disjoint_proper :> ∀ x, Proper ((≡) ==> impl) (disjoint x);
+ dra_minus_proper :> Proper ((≡) ==> (≡) ==> (≡)) minus;
+ (* validity *)
+ dra_op_valid x y : ✓ x → ✓ y → x ⊥ y → ✓ (x ⋅ y);
+ dra_unit_valid x : ✓ x → ✓ (unit x);
+ dra_minus_valid x y : ✓ x → ✓ y → x ≼ y → ✓ (y ⩪ x);
+ (* monoid *)
+ dra_associative :> Associative (≡) (⋅);
+ dra_disjoint_ll x y z : ✓ x → ✓ y → ✓ z → x ⊥ y → x ⋅ y ⊥ z → x ⊥ z;
+ dra_disjoint_move_l x y z : ✓ x → ✓ y → ✓ z → x ⊥ y → x ⋅ y ⊥ z → x ⊥ y ⋅ z;
+ dra_symmetric :> Symmetric (@disjoint A _);
+ dra_commutative x y : ✓ x → ✓ y → x ⊥ y → x ⋅ y ≡ y ⋅ x;
+ dra_unit_disjoint_l x : ✓ x → unit x ⊥ x;
+ dra_unit_l x : ✓ x → unit x ⋅ x ≡ x;
+ dra_unit_idempotent x : ✓ x → unit (unit x) ≡ unit x;
+ dra_unit_preserving x y : ✓ x → ✓ y → x ≼ y → unit x ≼ unit y;
+ dra_disjoint_minus x y : ✓ x → ✓ y → x ≼ y → x ⊥ y ⩪ x;
+ dra_op_minus x y : ✓ x → ✓ y → x ≼ y → x ⋅ y ⩪ x ≡ y
+}.
+
+Section dra.
+Context A `{DRA A}.
+Arguments valid _ _ !_ /.
+Hint Immediate dra_op_proper : typeclass_instances.
+
+Instance: Proper ((≡) ==> (≡) ==> iff) (⊥).
+Proof.
+ intros x1 x2 Hx y1 y2 Hy; split.
+ * by rewrite Hy (symmetry_iff (⊥) x1) (symmetry_iff (⊥) x2) Hx.
+ * by rewrite -Hy (symmetry_iff (⊥) x2) (symmetry_iff (⊥) x1) -Hx.
+Qed.
+Lemma dra_disjoint_rl x y z : ✓ x → ✓ y → ✓ z → y ⊥ z → x ⊥ y ⋅ z → x ⊥ y.
+Proof. intros ???. rewrite !(symmetry_iff _ x). by apply dra_disjoint_ll. Qed.
+Lemma dra_disjoint_lr x y z : ✓ x → ✓ y → ✓ z → x ⊥ y → x ⋅ y ⊥ z → y ⊥ z.
+Proof. intros ????. rewrite dra_commutative //. by apply dra_disjoint_ll. Qed.
+Lemma dra_disjoint_move_r x y z :
+ ✓ x → ✓ y → ✓ z → y ⊥ z → x ⊥ y ⋅ z → x ⋅ y ⊥ z.
+Proof.
+ intros; symmetry; rewrite dra_commutative; eauto using dra_disjoint_rl.
+ apply dra_disjoint_move_l; auto; by rewrite dra_commutative.
+Qed.
+Hint Immediate dra_disjoint_move_l dra_disjoint_move_r.
+Hint Unfold dra_included.
+
+Notation T := (validity (✓ : A → Prop)).
+Lemma validity_valid_car_valid (z : T) : ✓ z → ✓ (validity_car z).
+Proof. apply validity_prf. Qed.
+Hint Resolve validity_valid_car_valid.
+Program Instance validity_unit : Unit T := λ x,
+ Validity (unit (validity_car x)) (✓ x) _.
+Solve Obligations with naive_solver auto using dra_unit_valid.
+Program Instance validity_op : Op T := λ x y,
+ Validity (validity_car x â‹… validity_car y)
+ (✓ x ∧ ✓ y ∧ validity_car x ⊥ validity_car y) _.
+Solve Obligations with naive_solver auto using dra_op_valid.
+Program Instance validity_minus : Minus T := λ x y,
+ Validity (validity_car x ⩪ validity_car y)
+ (✓ x ∧ ✓ y ∧ validity_car y ≼ validity_car x) _.
+Solve Obligations with naive_solver auto using dra_minus_valid.
+
+Definition validity_ra : RA (discreteC T).
+Proof.
+ split.
+ * intros ??? [? Heq]; split; simpl; [|by intros (?&?&?); rewrite Heq].
+ split; intros (?&?&?); split_ands';
+ first [rewrite ?Heq; tauto|rewrite -?Heq; tauto|tauto].
+ * by intros ?? [? Heq]; split; [done|]; simpl; intros ?; rewrite Heq.
+ * by intros ?? -> ?.
+ * intros x1 x2 [? Hx] y1 y2 [? Hy];
+ split; simpl; [|by intros (?&?&?); rewrite Hx // Hy].
+ split; intros (?&?&z&?&?); split_ands'; try tauto.
+ + exists z. by rewrite -Hy // -Hx.
+ + exists z. by rewrite Hx ?Hy; tauto.
+ * intros [x px ?] [y py ?] [z pz ?]; split; simpl;
+ [intuition eauto 2 using dra_disjoint_lr, dra_disjoint_rl
+ |intros; apply (associative _)].
+ * intros [x px ?] [y py ?]; split; naive_solver eauto using dra_commutative.
+ * intros [x px ?]; split;
+ naive_solver eauto using dra_unit_l, dra_unit_disjoint_l.
+ * intros [x px ?]; split; naive_solver eauto using dra_unit_idempotent.
+ * intros x y Hxy; exists (unit y ⩪ unit x).
+ destruct x as [x px ?], y as [y py ?], Hxy as [[z pz ?] [??]]; simpl in *.
+ assert (py → unit x ≼ unit y)
+ by intuition eauto 10 using dra_unit_preserving.
+ constructor; [|symmetry]; simpl in *;
+ intuition eauto using dra_op_minus, dra_disjoint_minus, dra_unit_valid.
+ * by intros [x px ?] [y py ?] (?&?&?).
+ * intros [x px ?] [y py ?] [[z pz ?] [??]]; split; simpl in *;
+ intuition eauto 10 using dra_disjoint_minus, dra_op_minus.
+Qed.
+Definition validityRA : cmraT := discreteRA validity_ra.
+Definition validity_update (x y : validityRA) :
+ (∀ z, ✓ x → ✓ z → validity_car x ⊥ z → ✓ y ∧ validity_car y ⊥ z) → x ~~> y.
+Proof.
+ intros Hxy. apply discrete_update.
+ intros z (?&?&?); split_ands'; try eapply Hxy; eauto.
+Qed.
+End dra.
diff --git a/algebra/excl.v b/algebra/excl.v
new file mode 100644
index 0000000000000000000000000000000000000000..a0be19baf60fa079e29e5923df257a8805f523ee
--- /dev/null
+++ b/algebra/excl.v
@@ -0,0 +1,180 @@
+Require Export algebra.cmra.
+Local Arguments validN _ _ _ !_ /.
+Local Arguments valid _ _ !_ /.
+
+Inductive excl (A : Type) :=
+ | Excl : A → excl A
+ | ExclUnit : excl A
+ | ExclBot : excl A.
+Arguments Excl {_} _.
+Arguments ExclUnit {_}.
+Arguments ExclBot {_}.
+Instance maybe_Excl {A} : Maybe (@Excl A) := λ x,
+ match x with Excl a => Some a | _ => None end.
+
+Section excl.
+Context {A : cofeT}.
+
+(* Cofe *)
+Inductive excl_equiv : Equiv (excl A) :=
+ | Excl_equiv (x y : A) : x ≡ y → Excl x ≡ Excl y
+ | ExclUnit_equiv : ExclUnit ≡ ExclUnit
+ | ExclBot_equiv : ExclBot ≡ ExclBot.
+Existing Instance excl_equiv.
+Inductive excl_dist `{Dist A} : Dist (excl A) :=
+ | excl_dist_0 (x y : excl A) : x ={0}= y
+ | Excl_dist (x y : A) n : x ={n}= y → Excl x ={n}= Excl y
+ | ExclUnit_dist n : ExclUnit ={n}= ExclUnit
+ | ExclBot_dist n : ExclBot ={n}= ExclBot.
+Existing Instance excl_dist.
+Global Instance Excl_ne : Proper (dist n ==> dist n) (@Excl A).
+Proof. by constructor. Qed.
+Global Instance Excl_proper : Proper ((≡) ==> (≡)) (@Excl A).
+Proof. by constructor. Qed.
+Global Instance Excl_inj : Injective (≡) (≡) (@Excl A).
+Proof. by inversion_clear 1. Qed.
+Global Instance Excl_dist_inj n : Injective (dist n) (dist n) (@Excl A).
+Proof. by inversion_clear 1. Qed.
+Program Definition excl_chain
+ (c : chain (excl A)) (x : A) (H : maybe Excl (c 1) = Some x) : chain A :=
+ {| chain_car n := match c n return _ with Excl y => y | _ => x end |}.
+Next Obligation.
+ intros c x ? n i ?; simpl; destruct (c 1) eqn:?; simplify_equality'.
+ destruct (decide (i = 0)) as [->|].
+ { by replace n with 0 by lia. }
+ feed inversion (chain_cauchy c 1 i); auto with lia congruence.
+ feed inversion (chain_cauchy c n i); simpl; auto with lia congruence.
+Qed.
+Instance excl_compl : Compl (excl A) := λ c,
+ match Some_dec (maybe Excl (c 1)) with
+ | inleft (exist x H) => Excl (compl (excl_chain c x H)) | inright _ => c 1
+ end.
+Definition excl_cofe_mixin : CofeMixin (excl A).
+Proof.
+ split.
+ * intros mx my; split; [by destruct 1; constructor; apply equiv_dist|].
+ intros Hxy; feed inversion (Hxy 1); subst; constructor; apply equiv_dist.
+ by intros n; feed inversion (Hxy n).
+ * intros n; split.
+ + by intros [x| |]; constructor.
+ + by destruct 1; constructor.
+ + destruct 1; inversion_clear 1; constructor; etransitivity; eauto.
+ * by inversion_clear 1; constructor; apply dist_S.
+ * constructor.
+ * intros c n; unfold compl, excl_compl.
+ destruct (decide (n = 0)) as [->|]; [constructor|].
+ destruct (Some_dec (maybe Excl (c 1))) as [[x Hx]|].
+ { assert (c 1 = Excl x) by (by destruct (c 1); simplify_equality').
+ assert (∃ y, c n = Excl y) as [y Hy].
+ { feed inversion (chain_cauchy c 1 n); try congruence; eauto with lia. }
+ rewrite Hy; constructor.
+ by rewrite (conv_compl (excl_chain c x Hx) n); simpl; rewrite Hy. }
+ feed inversion (chain_cauchy c 1 n); auto with lia; constructor.
+ destruct (c 1); simplify_equality'.
+Qed.
+Canonical Structure exclC : cofeT := CofeT excl_cofe_mixin.
+
+Global Instance Excl_timeless (x : A) : Timeless x → Timeless (Excl x).
+Proof. by inversion_clear 2; constructor; apply (timeless _). Qed.
+Global Instance ExclUnit_timeless : Timeless (@ExclUnit A).
+Proof. by inversion_clear 1; constructor. Qed.
+Global Instance ExclBot_timeless : Timeless (@ExclBot A).
+Proof. by inversion_clear 1; constructor. Qed.
+Global Instance excl_timeless :
+ (∀ x : A, Timeless x) → ∀ x : excl A, Timeless x.
+Proof. intros ? []; apply _. Qed.
+Global Instance excl_leibniz : LeibnizEquiv A → LeibnizEquiv (excl A).
+Proof. by destruct 2; f_equal; apply leibniz_equiv. Qed.
+
+(* CMRA *)
+Instance excl_validN : ValidN (excl A) := λ n x,
+ match x with Excl _ | ExclUnit => True | ExclBot => n = 0 end.
+Global Instance excl_empty : Empty (excl A) := ExclUnit.
+Instance excl_unit : Unit (excl A) := λ _, ∅.
+Instance excl_op : Op (excl A) := λ x y,
+ match x, y with
+ | Excl x, ExclUnit | ExclUnit, Excl x => Excl x
+ | ExclUnit, ExclUnit => ExclUnit
+ | _, _=> ExclBot
+ end.
+Instance excl_minus : Minus (excl A) := λ x y,
+ match x, y with
+ | _, ExclUnit => x
+ | Excl _, Excl _ => ExclUnit
+ | _, _ => ExclBot
+ end.
+Definition excl_cmra_mixin : CMRAMixin (excl A).
+Proof.
+ split.
+ * by intros n []; destruct 1; constructor.
+ * constructor.
+ * by destruct 1 as [? []| | |]; intros ?.
+ * by destruct 1; inversion_clear 1; constructor.
+ * by intros [].
+ * intros n [?| |]; simpl; auto with lia.
+ * by intros [?| |] [?| |] [?| |]; constructor.
+ * by intros [?| |] [?| |]; constructor.
+ * by intros [?| |]; constructor.
+ * constructor.
+ * by intros n [?| |] [?| |]; exists ∅.
+ * by intros n [?| |] [?| |].
+ * by intros n [?| |] [?| |] [[?| |] Hz]; inversion_clear Hz; constructor.
+Qed.
+Definition excl_cmra_extend_mixin : CMRAExtendMixin (excl A).
+Proof.
+ intros [|n] x y1 y2 ? Hx; [by exists (x,∅); destruct x|].
+ by exists match y1, y2 with
+ | Excl a1, Excl a2 => (Excl a1, Excl a2)
+ | ExclBot, _ => (ExclBot, y2) | _, ExclBot => (y1, ExclBot)
+ | ExclUnit, _ => (ExclUnit, x) | _, ExclUnit => (x, ExclUnit)
+ end; destruct y1, y2; inversion_clear Hx; repeat constructor.
+Qed.
+Canonical Structure exclRA : cmraT :=
+ CMRAT excl_cofe_mixin excl_cmra_mixin excl_cmra_extend_mixin.
+Global Instance excl_cmra_identity : CMRAIdentity exclRA.
+Proof. split. done. by intros []. apply _. Qed.
+Lemma excl_validN_inv_l n x y : ✓{S n} (Excl x ⋅ y) → y = ∅.
+Proof. by destruct y. Qed.
+Lemma excl_validN_inv_r n x y : ✓{S n} (x ⋅ Excl y) → x = ∅.
+Proof. by destruct x. Qed.
+Lemma Excl_includedN n x y : ✓{n} y → Excl x ≼{n} y ↔ y ={n}= Excl x.
+Proof.
+ intros Hvalid; split; [destruct n as [|n]; [done|]|by intros ->].
+ by intros [z ?]; cofe_subst; rewrite (excl_validN_inv_l n x z).
+Qed.
+
+(* Updates *)
+Lemma excl_update (x : A) y : ✓ y → Excl x ~~> y.
+Proof. by destruct y; intros ? [?| |]. Qed.
+Lemma excl_updateP (P : excl A → Prop) x y : ✓ y → P y → Excl x ~~>: P.
+Proof. intros ?? z n ?; exists y. by destruct y, z as [?| |]. Qed.
+End excl.
+
+Arguments exclC : clear implicits.
+Arguments exclRA : clear implicits.
+
+(* Functor *)
+Instance excl_fmap : FMap excl := λ A B f x,
+ match x with
+ | Excl a => Excl (f a) | ExclUnit => ExclUnit | ExclBot => ExclBot
+ end.
+Lemma excl_fmap_id {A} (x : excl A) : id <$> x = x.
+Proof. by destruct x. Qed.
+Lemma excl_fmap_compose {A B C} (f : A → B) (g : B → C) (x : excl A) :
+ g ∘ f <$> x = g <$> f <$> x.
+Proof. by destruct x. Qed.
+Instance excl_fmap_cmra_ne {A B : cofeT} n :
+ Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@fmap excl _ A B).
+Proof. by intros f f' Hf; destruct 1; constructor; apply Hf. Qed.
+Instance excl_fmap_cmra_monotone {A B : cofeT} :
+ (∀ n, Proper (dist n ==> dist n) f) → CMRAMonotone (fmap f : excl A → excl B).
+Proof.
+ split.
+ * intros n x y [z Hy]; exists (f <$> z); rewrite Hy.
+ by destruct x, z; constructor.
+ * by intros n [a| |].
+Qed.
+Definition exclRA_map {A B} (f : A -n> B) : exclRA A -n> exclRA B :=
+ CofeMor (fmap f : exclRA A → exclRA B).
+Lemma exclRA_map_ne A B n : Proper (dist n ==> dist n) (@exclRA_map A B).
+Proof. by intros f f' Hf []; constructor; apply Hf. Qed.
diff --git a/algebra/fin_maps.v b/algebra/fin_maps.v
new file mode 100644
index 0000000000000000000000000000000000000000..d9062626f465bf8f794c5a11efde21763bed82a3
--- /dev/null
+++ b/algebra/fin_maps.v
@@ -0,0 +1,254 @@
+Require Export algebra.cmra prelude.gmap algebra.option.
+
+Section cofe.
+Context `{Countable K} {A : cofeT}.
+
+(* COFE *)
+Instance map_dist : Dist (gmap K A) := λ n m1 m2,
+ ∀ i, m1 !! i ={n}= m2 !! i.
+Program Definition map_chain (c : chain (gmap K A))
+ (k : K) : chain (option A) := {| chain_car n := c n !! k |}.
+Next Obligation. by intros c k n i ?; apply (chain_cauchy c). Qed.
+Instance map_compl : Compl (gmap K A) := λ c,
+ map_imap (λ i _, compl (map_chain c i)) (c 1).
+Definition map_cofe_mixin : CofeMixin (gmap K A).
+Proof.
+ split.
+ * intros m1 m2; split.
+ + by intros Hm n k; apply equiv_dist.
+ + intros Hm k; apply equiv_dist; intros n; apply Hm.
+ * intros n; split.
+ + by intros m k.
+ + by intros m1 m2 ? k.
+ + by intros m1 m2 m3 ?? k; transitivity (m2 !! k).
+ * by intros n m1 m2 ? k; apply dist_S.
+ * by intros m1 m2 k.
+ * intros c n k; unfold compl, map_compl; rewrite lookup_imap.
+ destruct (decide (n = 0)) as [->|]; [constructor|].
+ feed inversion (λ H, chain_cauchy c 1 n H k); simpl; auto with lia.
+ by rewrite conv_compl; simpl; apply reflexive_eq.
+Qed.
+Canonical Structure mapC : cofeT := CofeT map_cofe_mixin.
+
+Global Instance lookup_ne n k :
+ Proper (dist n ==> dist n) (lookup k : gmap K A → option A).
+Proof. by intros m1 m2. Qed.
+Global Instance lookup_proper k :
+ Proper ((≡) ==> (≡)) (lookup k : gmap K A → option A) := _.
+Global Instance insert_ne (i : K) n :
+ Proper (dist n ==> dist n ==> dist n) (insert (M:=gmap K A) i).
+Proof.
+ intros x y ? m m' ? j; destruct (decide (i = j)); simplify_map_equality;
+ [by constructor|by apply lookup_ne].
+Qed.
+Global Instance singleton_ne (i : K) n :
+ Proper (dist n ==> dist n) (singletonM i : A → gmap K A).
+Proof. by intros ???; apply insert_ne. Qed.
+Global Instance delete_ne (i : K) n :
+ Proper (dist n ==> dist n) (delete (M:=gmap K A) i).
+Proof.
+ intros m m' ? j; destruct (decide (i = j)); simplify_map_equality;
+ [by constructor|by apply lookup_ne].
+Qed.
+Instance map_empty_timeless : Timeless (∅ : gmap K A).
+Proof.
+ intros m Hm i; specialize (Hm i); rewrite lookup_empty in Hm |- *.
+ inversion_clear Hm; constructor.
+Qed.
+Global Instance map_lookup_timeless (m : gmap K A) i :
+ Timeless m → Timeless (m !! i).
+Proof.
+ intros ? [x|] Hx; [|by symmetry; apply (timeless _)].
+ assert (m ={1}= <[i:=x]> m)
+ by (by symmetry in Hx; inversion Hx; cofe_subst; rewrite insert_id).
+ by rewrite (timeless m (<[i:=x]>m)) // lookup_insert.
+Qed.
+Global Instance map_ra_insert_timeless (m : gmap K A) i x :
+ Timeless x → Timeless m → Timeless (<[i:=x]>m).
+Proof.
+ intros ?? m' Hm j; destruct (decide (i = j)); simplify_map_equality.
+ { by apply (timeless _); rewrite -Hm lookup_insert. }
+ by apply (timeless _); rewrite -Hm lookup_insert_ne.
+Qed.
+Global Instance map_ra_singleton_timeless (i : K) (x : A) :
+ Timeless x → Timeless ({[ i ↦ x ]} : gmap K A) := _.
+End cofe.
+Arguments mapC _ {_ _} _.
+
+(* CMRA *)
+Section cmra.
+Context `{Countable K} {A : cmraT}.
+
+Instance map_op : Op (gmap K A) := merge op.
+Instance map_unit : Unit (gmap K A) := fmap unit.
+Instance map_validN : ValidN (gmap K A) := λ n m, ∀ i, ✓{n} (m!!i).
+Instance map_minus : Minus (gmap K A) := merge minus.
+Lemma lookup_op m1 m2 i : (m1 â‹… m2) !! i = m1 !! i â‹… m2 !! i.
+Proof. by apply lookup_merge. Qed.
+Lemma lookup_minus m1 m2 i : (m1 ⩪ m2) !! i = m1 !! i ⩪ m2 !! i.
+Proof. by apply lookup_merge. Qed.
+Lemma lookup_unit m i : unit m !! i = unit (m !! i).
+Proof. by apply lookup_fmap. Qed.
+Lemma map_included_spec (m1 m2 : gmap K A) : m1 ≼ m2 ↔ ∀ i, m1 !! i ≼ m2 !! i.
+Proof.
+ split.
+ * by intros [m Hm]; intros i; exists (m !! i); rewrite -lookup_op Hm.
+ * intros Hm; exists (m2 ⩪ m1); intros i.
+ by rewrite lookup_op lookup_minus cmra_op_minus'.
+Qed.
+Lemma map_includedN_spec (m1 m2 : gmap K A) n :
+ m1 ≼{n} m2 ↔ ∀ i, m1 !! i ≼{n} m2 !! i.
+Proof.
+ split.
+ * by intros [m Hm]; intros i; exists (m !! i); rewrite -lookup_op Hm.
+ * intros Hm; exists (m2 ⩪ m1); intros i.
+ by rewrite lookup_op lookup_minus cmra_op_minus.
+Qed.
+Definition map_cmra_mixin : CMRAMixin (gmap K A).
+Proof.
+ split.
+ * by intros n m1 m2 m3 Hm i; rewrite !lookup_op (Hm i).
+ * by intros n m1 m2 Hm i; rewrite !lookup_unit (Hm i).
+ * by intros n m1 m2 Hm ? i; rewrite -(Hm i).
+ * by intros n m1 m1' Hm1 m2 m2' Hm2 i; rewrite !lookup_minus (Hm1 i) (Hm2 i).
+ * by intros m i.
+ * intros n m Hm i; apply cmra_validN_S, Hm.
+ * by intros m1 m2 m3 i; rewrite !lookup_op associative.
+ * by intros m1 m2 i; rewrite !lookup_op commutative.
+ * by intros m i; rewrite lookup_op !lookup_unit cmra_unit_l.
+ * by intros m i; rewrite !lookup_unit cmra_unit_idempotent.
+ * intros n x y; rewrite !map_includedN_spec; intros Hm i.
+ by rewrite !lookup_unit; apply cmra_unit_preservingN.
+ * intros n m1 m2 Hm i; apply cmra_validN_op_l with (m2 !! i).
+ by rewrite -lookup_op.
+ * intros x y n; rewrite map_includedN_spec=> ? i.
+ by rewrite lookup_op lookup_minus cmra_op_minus.
+Qed.
+Definition map_cmra_extend_mixin : CMRAExtendMixin (gmap K A).
+Proof.
+ intros n m m1 m2 Hm Hm12.
+ assert (∀ i, m !! i ={n}= m1 !! i ⋅ m2 !! i) as Hm12'
+ by (by intros i; rewrite -lookup_op).
+ set (f i := cmra_extend_op n (m !! i) (m1 !! i) (m2 !! i) (Hm i) (Hm12' i)).
+ set (f_proj i := proj1_sig (f i)).
+ exists (map_imap (λ i _, (f_proj i).1) m, map_imap (λ i _, (f_proj i).2) m);
+ repeat split; intros i; rewrite /= ?lookup_op !lookup_imap.
+ * destruct (m !! i) as [x|] eqn:Hx; rewrite !Hx /=; [|constructor].
+ rewrite -Hx; apply (proj2_sig (f i)).
+ * destruct (m !! i) as [x|] eqn:Hx; rewrite /=; [apply (proj2_sig (f i))|].
+ pose proof (Hm12' i) as Hm12''; rewrite Hx in Hm12''.
+ by symmetry; apply option_op_positive_dist_l with (m2 !! i).
+ * destruct (m !! i) as [x|] eqn:Hx; simpl; [apply (proj2_sig (f i))|].
+ pose proof (Hm12' i) as Hm12''; rewrite Hx in Hm12''.
+ by symmetry; apply option_op_positive_dist_r with (m1 !! i).
+Qed.
+Canonical Structure mapRA : cmraT :=
+ CMRAT map_cofe_mixin map_cmra_mixin map_cmra_extend_mixin.
+Global Instance map_cmra_identity : CMRAIdentity mapRA.
+Proof.
+ split.
+ * by intros ? n; rewrite lookup_empty.
+ * by intros m i; rewrite /= lookup_op lookup_empty (left_id_L None _).
+ * apply map_empty_timeless.
+Qed.
+
+End cmra.
+Arguments mapRA _ {_ _} _.
+
+Section properties.
+Context `{Countable K} {A: cmraT}.
+Implicit Types m : gmap K A.
+
+Lemma map_lookup_validN n m i x : ✓{n} m → m !! i ={n}= Some x → ✓{n} x.
+Proof. by move=> /(_ i) Hm Hi; move:Hm; rewrite Hi. Qed.
+Lemma map_insert_validN n m i x : ✓{n} x → ✓{n} m → ✓{n} (<[i:=x]>m).
+Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_equality. Qed.
+Lemma map_insert_op m1 m2 i x :
+ m2 !! i = None → <[i:=x]>(m1 ⋅ m2) = <[i:=x]>m1 ⋅ m2.
+Proof. by intros Hi; apply (insert_merge_l _ m1 m2); rewrite Hi. Qed.
+Lemma map_unit_singleton (i : K) (x : A) :
+ unit ({[ i ↦ x ]} : gmap K A) = {[ i ↦ unit x ]}.
+Proof. apply map_fmap_singleton. Qed.
+Lemma map_op_singleton (i : K) (x y : A) :
+ {[ i ↦ x ]} ⋅ {[ i ↦ y ]} = ({[ i ↦ x ⋅ y ]} : gmap K A).
+Proof. by apply (merge_singleton _ _ _ x y). Qed.
+Lemma singleton_includedN n m i x :
+ {[ i ↦ x ]} ≼{n} m ↔ ∃ y, m !! i ={n}= Some y ∧ x ≼ y.
+ (* not m !! i = Some y ∧ x ≼{n} y to deal with n = 0 *)
+Proof.
+ split.
+ * move=> [m' /(_ i)]; rewrite lookup_op lookup_singleton=> Hm.
+ destruct (m' !! i) as [y|];
+ [exists (x â‹… y)|exists x]; eauto using cmra_included_l.
+ * intros (y&Hi&?); rewrite map_includedN_spec=>j.
+ destruct (decide (i = j)); simplify_map_equality.
+ + by rewrite Hi; apply Some_Some_includedN, cmra_included_includedN.
+ + apply None_includedN.
+Qed.
+Lemma map_dom_op m1 m2 : dom (gset K) (m1 ⋅ m2) ≡ dom _ m1 ∪ dom _ m2.
+Proof.
+ apply elem_of_equiv; intros i; rewrite elem_of_union !elem_of_dom.
+ unfold is_Some; setoid_rewrite lookup_op.
+ destruct (m1 !! i), (m2 !! i); naive_solver.
+Qed.
+
+Lemma map_insert_updateP (P : A → Prop) (Q : gmap K A → Prop) m i x :
+ x ~~>: P → (∀ y, P y → Q (<[i:=y]>m)) → <[i:=x]>m ~~>: Q.
+Proof.
+ intros Hx%option_updateP' HP mf n Hm.
+ destruct (Hx (mf !! i) n) as ([y|]&?&?); try done.
+ { by generalize (Hm i); rewrite lookup_op; simplify_map_equality. }
+ exists (<[i:=y]> m); split; first by auto.
+ intros j; move: (Hm j)=>{Hm}; rewrite !lookup_op=>Hm.
+ destruct (decide (i = j)); simplify_map_equality'; auto.
+Qed.
+Lemma map_insert_updateP' (P : A → Prop) (Q : gmap K A → Prop) m i x :
+ x ~~>: P → <[i:=x]>m ~~>: λ m', ∃ y, m' = <[i:=y]>m ∧ P y.
+Proof. eauto using map_insert_updateP. Qed.
+Lemma map_insert_update m i x y : x ~~> y → <[i:=x]>m ~~> <[i:=y]>m.
+Proof.
+ rewrite !cmra_update_updateP; eauto using map_insert_updateP with congruence.
+Qed.
+
+Context `{Fresh K (gset K), !FreshSpec K (gset K)}.
+Lemma map_updateP_alloc (Q : gmap K A → Prop) m x :
+ ✓ x → (∀ i, m !! i = None → Q (<[i:=x]>m)) → m ~~>: Q.
+Proof.
+ intros ? HQ mf n Hm. set (i := fresh (dom (gset K) (m â‹… mf))).
+ assert (i ∉ dom (gset K) m ∧ i ∉ dom (gset K) mf) as [??].
+ { rewrite -not_elem_of_union -map_dom_op; apply is_fresh. }
+ exists (<[i:=x]>m); split; first by apply HQ, not_elem_of_dom.
+ rewrite -map_insert_op; last by apply not_elem_of_dom.
+ by apply map_insert_validN; [apply cmra_valid_validN|].
+Qed.
+Lemma map_updateP_alloc' m x :
+ ✓ x → m ~~>: λ m', ∃ i, m' = <[i:=x]>m ∧ m !! i = None.
+Proof. eauto using map_updateP_alloc. Qed.
+End properties.
+
+Instance map_fmap_ne `{Countable K} {A B : cofeT} (f : A → B) n :
+ Proper (dist n ==> dist n) f → Proper (dist n ==>dist n) (fmap (M:=gmap K) f).
+Proof. by intros ? m m' Hm k; rewrite !lookup_fmap; apply option_fmap_ne. Qed.
+Definition mapC_map `{Countable K} {A B} (f: A -n> B) : mapC K A -n> mapC K B :=
+ CofeMor (fmap f : mapC K A → mapC K B).
+Instance mapC_map_ne `{Countable K} {A B} n :
+ Proper (dist n ==> dist n) (@mapC_map K _ _ A B).
+Proof.
+ intros f g Hf m k; rewrite /= !lookup_fmap.
+ destruct (_ !! k) eqn:?; simpl; constructor; apply Hf.
+Qed.
+
+Instance map_fmap_cmra_monotone `{Countable K} {A B : cmraT} (f : A → B)
+ `{!CMRAMonotone f} : CMRAMonotone (fmap f : gmap K A → gmap K B).
+Proof.
+ split.
+ * intros m1 m2 n; rewrite !map_includedN_spec; intros Hm i.
+ by rewrite !lookup_fmap; apply: includedN_preserving.
+ * by intros n m ? i; rewrite lookup_fmap; apply validN_preserving.
+Qed.
+Definition mapRA_map `{Countable K} {A B : cmraT} (f : A -n> B) :
+ mapRA K A -n> mapRA K B := CofeMor (fmap f : mapRA K A → mapRA K B).
+Instance mapRA_map_ne `{Countable K} {A B} n :
+ Proper (dist n ==> dist n) (@mapRA_map K _ _ A B) := mapC_map_ne n.
+Instance mapRA_map_monotone `{Countable K} {A B : cmraT} (f : A -n> B)
+ `{!CMRAMonotone f} : CMRAMonotone (mapRA_map f) := _.
diff --git a/algebra/option.v b/algebra/option.v
new file mode 100644
index 0000000000000000000000000000000000000000..071ecafb2c0719a064709dce1bf71fe1b0d1afb5
--- /dev/null
+++ b/algebra/option.v
@@ -0,0 +1,168 @@
+Require Export algebra.cmra.
+
+(* COFE *)
+Section cofe.
+Context {A : cofeT}.
+Inductive option_dist : Dist (option A) :=
+ | option_0_dist (x y : option A) : x ={0}= y
+ | Some_dist n x y : x ={n}= y → Some x ={n}= Some y
+ | None_dist n : None ={n}= None.
+Existing Instance option_dist.
+Program Definition option_chain
+ (c : chain (option A)) (x : A) (H : c 1 = Some x) : chain A :=
+ {| chain_car n := from_option x (c n) |}.
+Next Obligation.
+ intros c x ? n i ?; simpl; destruct (decide (i = 0)) as [->|].
+ { by replace n with 0 by lia. }
+ feed inversion (chain_cauchy c 1 i); auto with lia congruence.
+ feed inversion (chain_cauchy c n i); simpl; auto with lia congruence.
+Qed.
+Instance option_compl : Compl (option A) := λ c,
+ match Some_dec (c 1) with
+ | inleft (exist x H) => Some (compl (option_chain c x H)) | inright _ => None
+ end.
+Definition option_cofe_mixin : CofeMixin (option A).
+Proof.
+ split.
+ * intros mx my; split; [by destruct 1; constructor; apply equiv_dist|].
+ intros Hxy; feed inversion (Hxy 1); subst; constructor; apply equiv_dist.
+ by intros n; feed inversion (Hxy n).
+ * intros n; split.
+ + by intros [x|]; constructor.
+ + by destruct 1; constructor.
+ + destruct 1; inversion_clear 1; constructor; etransitivity; eauto.
+ * by inversion_clear 1; constructor; apply dist_S.
+ * constructor.
+ * intros c n; unfold compl, option_compl.
+ destruct (decide (n = 0)) as [->|]; [constructor|].
+ destruct (Some_dec (c 1)) as [[x Hx]|].
+ { assert (is_Some (c n)) as [y Hy].
+ { feed inversion (chain_cauchy c 1 n); try congruence; eauto with lia. }
+ rewrite Hy; constructor.
+ by rewrite (conv_compl (option_chain c x Hx) n); simpl; rewrite Hy. }
+ feed inversion (chain_cauchy c 1 n); auto with lia congruence; constructor.
+Qed.
+Canonical Structure optionC := CofeT option_cofe_mixin.
+Global Instance Some_ne : Proper (dist n ==> dist n) (@Some A).
+Proof. by constructor. Qed.
+Global Instance is_Some_ne n : Proper (dist (S n) ==> iff) (@is_Some A).
+Proof. inversion_clear 1; split; eauto. Qed.
+Global Instance Some_dist_inj : Injective (dist n) (dist n) (@Some A).
+Proof. by inversion_clear 1. Qed.
+Global Instance None_timeless : Timeless (@None A).
+Proof. inversion_clear 1; constructor. Qed.
+Global Instance Some_timeless x : Timeless x → Timeless (Some x).
+Proof. by intros ?; inversion_clear 1; constructor; apply timeless. Qed.
+End cofe.
+
+Arguments optionC : clear implicits.
+
+Instance option_fmap_ne {A B : cofeT} (f : A → B) n:
+ Proper (dist n ==> dist n) f → Proper (dist n==>dist n) (fmap (M:=option) f).
+Proof. by intros Hf; destruct 1; constructor; apply Hf. Qed.
+
+(* CMRA *)
+Section cmra.
+Context {A : cmraT}.
+
+Instance option_validN : ValidN (option A) := λ n mx,
+ match mx with Some x => ✓{n} x | None => True end.
+Instance option_unit : Unit (option A) := fmap unit.
+Instance option_op : Op (option A) := union_with (λ x y, Some (x ⋅ y)).
+Instance option_minus : Minus (option A) :=
+ difference_with (λ x y, Some (x ⩪ y)).
+Lemma option_includedN n (mx my : option A) :
+ mx ≼{n} my ↔ n = 0 ∨ mx = None ∨ ∃ x y, mx = Some x ∧ my = Some y ∧ x ≼{n} y.
+Proof.
+ split.
+ * intros [mz Hmz]; destruct n as [|n]; [by left|right].
+ destruct mx as [x|]; [right|by left].
+ destruct my as [y|]; [exists x, y|destruct mz; inversion_clear Hmz].
+ destruct mz as [z|]; inversion_clear Hmz; split_ands; auto;
+ cofe_subst; eauto using cmra_includedN_l.
+ * intros [->|[->|(x&y&->&->&z&Hz)]];
+ try (by exists my; destruct my; constructor).
+ by exists (Some z); constructor.
+Qed.
+Lemma None_includedN n (mx : option A) : None ≼{n} mx.
+Proof. rewrite option_includedN; auto. Qed.
+Lemma Some_Some_includedN n (x y : A) : x ≼{n} y → Some x ≼{n} Some y.
+Proof. rewrite option_includedN; eauto 10. Qed.
+
+Definition option_cmra_mixin : CMRAMixin (option A).
+Proof.
+ split.
+ * by intros n [x|]; destruct 1; constructor;
+ repeat apply (_ : Proper (dist _ ==> _ ==> _) _).
+ * by destruct 1; constructor; apply (_ : Proper (dist n ==> _) _).
+ * destruct 1 as [[?|] [?|]| |]; unfold validN, option_validN; simpl;
+ intros ?; auto using cmra_validN_0;
+ eapply (_ : Proper (dist _ ==> impl) (✓{_})); eauto.
+ * by destruct 1; inversion_clear 1; constructor;
+ repeat apply (_ : Proper (dist _ ==> _ ==> _) _).
+ * intros [x|]; unfold validN, option_validN; auto using cmra_validN_0.
+ * intros n [x|]; unfold validN, option_validN; eauto using cmra_validN_S.
+ * intros [x|] [y|] [z|]; constructor; rewrite ?associative; auto.
+ * intros [x|] [y|]; constructor; rewrite 1?commutative; auto.
+ * by intros [x|]; constructor; rewrite cmra_unit_l.
+ * by intros [x|]; constructor; rewrite cmra_unit_idempotent.
+ * intros n mx my; rewrite !option_includedN;intros [|[->|(x&y&->&->&?)]];auto.
+ do 2 right; exists (unit x), (unit y); eauto using cmra_unit_preservingN.
+ * intros n [x|] [y|]; rewrite /validN /option_validN /=;
+ eauto using cmra_validN_op_l.
+ * intros n mx my; rewrite option_includedN.
+ intros [->|[->|(x&y&->&->&?)]]; [done|by destruct my|].
+ by constructor; apply cmra_op_minus.
+Qed.
+Definition option_cmra_extend_mixin : CMRAExtendMixin (option A).
+Proof.
+ intros n mx my1 my2; destruct (decide (n = 0)) as [->|].
+ { by exists (mx, None); repeat constructor; destruct mx; constructor. }
+ destruct mx as [x|], my1 as [y1|], my2 as [y2|]; intros Hx Hx';
+ try (by exfalso; inversion Hx'; auto).
+ * destruct (cmra_extend_op n x y1 y2) as ([z1 z2]&?&?&?); auto.
+ { by inversion_clear Hx'. }
+ by exists (Some z1, Some z2); repeat constructor.
+ * by exists (Some x,None); inversion Hx'; repeat constructor.
+ * by exists (None,Some x); inversion Hx'; repeat constructor.
+ * exists (None,None); repeat constructor.
+Qed.
+Canonical Structure optionRA :=
+ CMRAT option_cofe_mixin option_cmra_mixin option_cmra_extend_mixin.
+
+Lemma op_is_Some mx my : is_Some (mx ⋅ my) ↔ is_Some mx ∨ is_Some my.
+Proof.
+ destruct mx, my; rewrite /op /option_op /= -!not_eq_None_Some; naive_solver.
+Qed.
+Lemma option_op_positive_dist_l n mx my : mx ⋅ my ={n}= None → mx ={n}= None.
+Proof. by destruct mx, my; inversion_clear 1. Qed.
+Lemma option_op_positive_dist_r n mx my : mx ⋅ my ={n}= None → my ={n}= None.
+Proof. by destruct mx, my; inversion_clear 1. Qed.
+
+Lemma option_updateP (P : A → Prop) (Q : option A → Prop) x :
+ x ~~>: P → (∀ y, P y → Q (Some y)) → Some x ~~>: Q.
+Proof.
+ intros Hx Hy [y|] n ?.
+ { destruct (Hx y n) as (y'&?&?); auto. exists (Some y'); auto. }
+ destruct (Hx (unit x) n) as (y'&?&?); rewrite ?cmra_unit_r; auto.
+ by exists (Some y'); split; [auto|apply cmra_validN_op_l with (unit x)].
+Qed.
+Lemma option_updateP' (P : A → Prop) x :
+ x ~~>: P → Some x ~~>: λ y, default False y P.
+Proof. eauto using option_updateP. Qed.
+Lemma option_update x y : x ~~> y → Some x ~~> Some y.
+Proof.
+ rewrite !cmra_update_updateP; eauto using option_updateP with congruence.
+Qed.
+End cmra.
+
+Arguments optionRA : clear implicits.
+
+Instance option_fmap_cmra_monotone {A B : cmraT} (f: A → B) `{!CMRAMonotone f} :
+ CMRAMonotone (fmap f : option A → option B).
+Proof.
+ split.
+ * intros n mx my; rewrite !option_includedN.
+ intros [->|[->|(x&y&->&->&?)]]; simpl; eauto 10 using @includedN_preserving.
+ * by intros n [x|] ?; rewrite /cmra_validN /=; try apply validN_preserving.
+Qed.
diff --git a/algebra/sts.v b/algebra/sts.v
new file mode 100644
index 0000000000000000000000000000000000000000..4e699e1d3f92c0e68946ccce691a3b1a6b141973
--- /dev/null
+++ b/algebra/sts.v
@@ -0,0 +1,219 @@
+Require Export algebra.cmra.
+Require Import prelude.sets algebra.dra.
+Local Arguments valid _ _ !_ /.
+Local Arguments op _ _ !_ !_ /.
+Local Arguments unit _ _ !_ /.
+
+Inductive sts {A B} (R : relation A) (tok : A → set B) :=
+ | auth : A → set B → sts R tok
+ | frag : set A → set B → sts R tok.
+Arguments auth {_ _ _ _} _ _.
+Arguments frag {_ _ _ _} _ _.
+
+Module sts.
+Section sts_core.
+Context {A B : Type} (R : relation A) (tok : A → set B).
+Infix "≼" := dra_included.
+
+Inductive sts_equiv : Equiv (sts R tok) :=
+ | auth_equiv s T1 T2 : T1 ≡ T2 → auth s T1 ≡ auth s T2
+ | frag_equiv S1 S2 T1 T2 : T1 ≡ T2 → S1 ≡ S2 → frag S1 T1 ≡ frag S2 T2.
+Global Existing Instance sts_equiv.
+Inductive step : relation (A * set B) :=
+ | Step s1 s2 T1 T2 :
+ R s1 s2 → tok s1 ∩ T1 ≡ ∅ → tok s2 ∩ T2 ≡ ∅ → tok s1 ∪ T1 ≡ tok s2 ∪ T2 →
+ step (s1,T1) (s2,T2).
+Hint Resolve Step.
+Inductive frame_step (T : set B) (s1 s2 : A) : Prop :=
+ | Frame_step T1 T2 :
+ T1 ∩ (tok s1 ∪ T) ≡ ∅ → step (s1,T1) (s2,T2) → frame_step T s1 s2.
+Hint Resolve Frame_step.
+Record closed (T : set B) (S : set A) : Prop := Closed {
+ closed_ne : S ≢ ∅;
+ closed_disjoint s : s ∈ S → tok s ∩ T ≡ ∅;
+ closed_step s1 s2 : s1 ∈ S → frame_step T s1 s2 → s2 ∈ S
+}.
+Lemma closed_steps S T s1 s2 :
+ closed T S → s1 ∈ S → rtc (frame_step T) s1 s2 → s2 ∈ S.
+Proof. induction 3; eauto using closed_step. Qed.
+Global Instance sts_valid : Valid (sts R tok) := λ x,
+ match x with auth s T => tok s ∩ T ≡ ∅ | frag S' T => closed T S' end.
+Definition up (T : set B) (s : A) : set A := mkSet (rtc (frame_step T) s).
+Definition up_set (T : set B) (S : set A) : set A := S ≫= up T.
+Global Instance sts_unit : Unit (sts R tok) := λ x,
+ match x with
+ | frag S' _ => frag (up_set ∅ S') ∅ | auth s _ => frag (up ∅ s) ∅
+ end.
+Inductive sts_disjoint : Disjoint (sts R tok) :=
+ | frag_frag_disjoint S1 S2 T1 T2 :
+ S1 ∩ S2 ≢ ∅ → T1 ∩ T2 ≡ ∅ → frag S1 T1 ⊥ frag S2 T2
+ | auth_frag_disjoint s S T1 T2 : s ∈ S → T1 ∩ T2 ≡ ∅ → auth s T1 ⊥ frag S T2
+ | frag_auth_disjoint s S T1 T2 : s ∈ S → T1 ∩ T2 ≡ ∅ → frag S T1 ⊥ auth s T2.
+Global Existing Instance sts_disjoint.
+Global Instance sts_op : Op (sts R tok) := λ x1 x2,
+ match x1, x2 with
+ | frag S1 T1, frag S2 T2 => frag (S1 ∩ S2) (T1 ∪ T2)
+ | auth s T1, frag _ T2 => auth s (T1 ∪ T2)
+ | frag _ T1, auth s T2 => auth s (T1 ∪ T2)
+ | auth s T1, auth _ T2 => auth s (T1 ∪ T2) (* never happens *)
+ end.
+Global Instance sts_minus : Minus (sts R tok) := λ x1 x2,
+ match x1, x2 with
+ | frag S1 T1, frag S2 T2 => frag (up_set (T1 ∖ T2) S1) (T1 ∖ T2)
+ | auth s T1, frag _ T2 => auth s (T1 ∖ T2)
+ | frag _ T2, auth s T1 => auth s (T1 ∖ T2) (* never happens *)
+ | auth s T1, auth _ T2 => frag (up (T1 ∖ T2) s) (T1 ∖ T2)
+ end.
+
+Hint Extern 10 (equiv (A:=set _) _ _) => solve_elem_of : sts.
+Hint Extern 10 (¬(equiv (A:=set _) _ _)) => solve_elem_of : sts.
+Hint Extern 10 (_ ∈ _) => solve_elem_of : sts.
+Hint Extern 10 (_ ⊆ _) => solve_elem_of : sts.
+Instance: Equivalence ((≡) : relation (sts R tok)).
+Proof.
+ split.
+ * by intros []; constructor.
+ * by destruct 1; constructor.
+ * destruct 1; inversion_clear 1; constructor; etransitivity; eauto.
+Qed.
+Instance framestep_proper : Proper ((≡) ==> (=) ==> (=) ==> impl) frame_step.
+Proof. intros ?? HT ?? <- ?? <-; destruct 1; econstructor; eauto with sts. Qed.
+Instance closed_proper' : Proper ((≡) ==> (≡) ==> impl) closed.
+Proof.
+ intros ?? HT ?? HS; destruct 1;
+ constructor; intros until 0; rewrite -?HS -?HT; eauto.
+Qed.
+Instance closed_proper : Proper ((≡) ==> (≡) ==> iff) closed.
+Proof. by split; apply closed_proper'. Qed.
+Lemma closed_op T1 T2 S1 S2 :
+ closed T1 S1 → closed T2 S2 →
+ T1 ∩ T2 ≡ ∅ → S1 ∩ S2 ≢ ∅ → closed (T1 ∪ T2) (S1 ∩ S2).
+Proof.
+ intros [_ ? Hstep1] [_ ? Hstep2] ?; split; [done|solve_elem_of|].
+ intros s3 s4; rewrite !elem_of_intersection; intros [??] [T3 T4 ?]; split.
+ * apply Hstep1 with s3, Frame_step with T3 T4; auto with sts.
+ * apply Hstep2 with s3, Frame_step with T3 T4; auto with sts.
+Qed.
+Instance up_preserving : Proper (flip (⊆) ==> (=) ==> (⊆)) up.
+Proof.
+ intros T T' HT s ? <-; apply elem_of_subseteq.
+ induction 1 as [|s1 s2 s3 [T1 T2]]; [constructor|].
+ eapply rtc_l; [eapply Frame_step with T1 T2|]; eauto with sts.
+Qed.
+Instance up_proper : Proper ((≡) ==> (=) ==> (≡)) up.
+Proof. by intros ?? [??] ???; split; apply up_preserving. Qed.
+Instance up_set_proper : Proper ((≡) ==> (≡) ==> (≡)) up_set.
+Proof. by intros T1 T2 HT S1 S2 HS; rewrite /up_set HS HT. Qed.
+Lemma elem_of_up s T : s ∈ up T s.
+Proof. constructor. Qed.
+Lemma subseteq_up_set S T : S ⊆ up_set T S.
+Proof. intros s ?; apply elem_of_bind; eauto using elem_of_up. Qed.
+Lemma closed_up_set S T :
+ (∀ s, s ∈ S → tok s ∩ T ≡ ∅) → S ≢ ∅ → closed T (up_set T S).
+Proof.
+ intros HS Hne; unfold up_set; split.
+ * assert (∀ s, s ∈ up T s) by eauto using elem_of_up. solve_elem_of.
+ * intros s; rewrite !elem_of_bind; intros (s'&Hstep&Hs').
+ specialize (HS s' Hs'); clear Hs' Hne S.
+ induction Hstep as [s|s1 s2 s3 [T1 T2 ? Hstep] ? IH]; auto.
+ inversion_clear Hstep; apply IH; clear IH; auto with sts.
+ * intros s1 s2; rewrite !elem_of_bind; intros (s&?&?) ?; exists s.
+ split; [eapply rtc_r|]; eauto.
+Qed.
+Lemma closed_up_set_empty S : S ≢ ∅ → closed ∅ (up_set ∅ S).
+Proof. eauto using closed_up_set with sts. Qed.
+Lemma closed_up s T : tok s ∩ T ≡ ∅ → closed T (up T s).
+Proof.
+ intros; rewrite -(collection_bind_singleton (up T) s).
+ apply closed_up_set; solve_elem_of.
+Qed.
+Lemma closed_up_empty s : closed ∅ (up ∅ s).
+Proof. eauto using closed_up with sts. Qed.
+Lemma up_closed S T : closed T S → up_set T S ≡ S.
+Proof.
+ intros; split; auto using subseteq_up_set; intros s.
+ unfold up_set; rewrite elem_of_bind; intros (s'&Hstep&?).
+ induction Hstep; eauto using closed_step.
+Qed.
+Global Instance sts_dra : DRA (sts R tok).
+Proof.
+ split.
+ * apply _.
+ * by do 2 destruct 1; constructor; setoid_subst.
+ * by destruct 1; constructor; setoid_subst.
+ * by intros ? [|]; destruct 1; inversion_clear 1; constructor; setoid_subst.
+ * by do 2 destruct 1; constructor; setoid_subst.
+ * assert (∀ T T' S s,
+ closed T S → s ∈ S → tok s ∩ T' ≡ ∅ → tok s ∩ (T ∪ T') ≡ ∅).
+ { intros S T T' s [??]; solve_elem_of. }
+ destruct 3; simpl in *; auto using closed_op with sts.
+ * intros []; simpl; eauto using closed_up, closed_up_set, closed_ne with sts.
+ * intros ???? (z&Hy&?&Hxz); destruct Hxz; inversion Hy;clear Hy; setoid_subst;
+ rewrite ?disjoint_union_difference; auto using closed_up with sts.
+ eapply closed_up_set; eauto 2 using closed_disjoint with sts.
+ * intros [] [] []; constructor; rewrite ?(associative _); auto with sts.
+ * destruct 4; inversion_clear 1; constructor; auto with sts.
+ * destruct 4; inversion_clear 1; constructor; auto with sts.
+ * destruct 1; constructor; auto with sts.
+ * destruct 3; constructor; auto with sts.
+ * intros [|S T]; constructor; auto using elem_of_up with sts.
+ assert (S ⊆ up_set ∅ S ∧ S ≢ ∅) by eauto using subseteq_up_set, closed_ne.
+ solve_elem_of.
+ * intros [|S T]; constructor; auto with sts.
+ assert (S ⊆ up_set ∅ S); auto using subseteq_up_set with sts.
+ * intros [s T|S T]; constructor; auto with sts.
+ + rewrite (up_closed (up _ _)); auto using closed_up with sts.
+ + rewrite (up_closed (up_set _ _));
+ eauto using closed_up_set, closed_ne with sts.
+ * intros x y ?? (z&Hy&?&Hxz); exists (unit (x â‹… y)); split_ands.
+ + destruct Hxz;inversion_clear Hy;constructor;unfold up_set; solve_elem_of.
+ + destruct Hxz; inversion_clear Hy; simpl;
+ auto using closed_up_set_empty, closed_up_empty with sts.
+ + destruct Hxz; inversion_clear Hy; constructor;
+ repeat match goal with
+ | |- context [ up_set ?T ?S ] =>
+ unless (S ⊆ up_set T S) by done; pose proof (subseteq_up_set S T)
+ | |- context [ up ?T ?s ] =>
+ unless (s ∈ up T s) by done; pose proof (elem_of_up s T)
+ end; auto with sts.
+ * intros x y ?? (z&Hy&_&Hxz); destruct Hxz; inversion_clear Hy; constructor;
+ repeat match goal with
+ | |- context [ up_set ?T ?S ] =>
+ unless (S ⊆ up_set T S) by done; pose proof (subseteq_up_set S T)
+ | |- context [ up ?T ?s ] =>
+ unless (s ∈ up T s) by done; pose proof (elem_of_up s T)
+ end; auto with sts.
+ * intros x y ?? (z&Hy&?&Hxz); destruct Hxz as [S1 S2 T1 T2| |];
+ inversion Hy; clear Hy; constructor; setoid_subst;
+ rewrite ?disjoint_union_difference; auto.
+ split; [|apply intersection_greatest; auto using subseteq_up_set with sts].
+ apply intersection_greatest; [auto with sts|].
+ intros s2; rewrite elem_of_intersection.
+ unfold up_set; rewrite elem_of_bind; intros (?&s1&?&?&?).
+ apply closed_steps with T2 s1; auto with sts.
+Qed.
+Lemma step_closed s1 s2 T1 T2 S Tf :
+ step (s1,T1) (s2,T2) → closed Tf S → s1 ∈ S → T1 ∩ Tf ≡ ∅ →
+ s2 ∈ S ∧ T2 ∩ Tf ≡ ∅ ∧ tok s2 ∩ T2 ≡ ∅.
+Proof.
+ inversion_clear 1 as [???? HR Hs1 Hs2]; intros [?? Hstep]??; split_ands; auto.
+ * eapply Hstep with s1, Frame_step with T1 T2; auto with sts.
+ * solve_elem_of -Hstep Hs1 Hs2.
+Qed.
+End sts_core.
+End sts.
+
+Section stsRA.
+Context {A B : Type} (R : relation A) (tok : A → set B).
+
+Canonical Structure stsRA := validityRA (sts R tok).
+Definition sts_auth (s : A) (T : set B) : stsRA := to_validity (auth s T).
+Definition sts_frag (S : set A) (T : set B) : stsRA := to_validity (frag S T).
+Lemma sts_update s1 s2 T1 T2 :
+ sts.step R tok (s1,T1) (s2,T2) → sts_auth s1 T1 ~~> sts_auth s2 T2.
+Proof.
+ intros ?; apply validity_update; inversion 3 as [|? S ? Tf|]; subst.
+ destruct (sts.step_closed R tok s1 s2 T1 T2 S Tf) as (?&?&?); auto.
+ repeat (done || constructor).
+Qed.
+End stsRA.
diff --git a/benchmark b/benchmark
deleted file mode 100755
index 35b42e6e8d00b6996365fcc108e9d8cd54d3061d..0000000000000000000000000000000000000000
--- a/benchmark
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/bash
-set -e
-
-TIME() {
- echo "# Preparing $1"
- make -j $(cat "$1".v.d | sed 's/^.*: //')
- rm -f "$1".vo
- echo "# Benchmarking $1"
- time make "$1.vo"
- echo
-}
-
-TIME iris_plog
-TIME iris_meta
-TIME iris_ht_rules
diff --git a/configure b/configure
new file mode 100755
index 0000000000000000000000000000000000000000..eeb3f9d750a6878ff23b94a0ad9a642f575b4267
--- /dev/null
+++ b/configure
@@ -0,0 +1,2 @@
+#!/bin/sh
+coq_makefile -f _CoqProject -o Makefile
diff --git a/core_lang.v b/core_lang.v
deleted file mode 100644
index a5de46c7bd29df7b3acd30a769b9e7063f76a56e..0000000000000000000000000000000000000000
--- a/core_lang.v
+++ /dev/null
@@ -1,49 +0,0 @@
-Module Type CORE_LANG.
-
- (******************************************************************)
- (** ** Syntax, machine state, and atomic reductions **)
- (******************************************************************)
-
- (** Expressions and values **)
- Parameter expr : Type.
-
- Parameter is_value : expr -> Prop.
- Definition value : Type := {e: expr | is_value e}.
- Parameter is_value_dec : forall e, is_value e + ~is_value e.
-
- (** Shared machine state (e.g., the heap) **)
- Parameter state : Type.
-
- (** Primitive (single thread) machine configurations **)
- Definition prim_cfg : Type := (expr * state)%type.
-
- (** The primitive atomic optionally-forking stepping relation **)
- Parameter prim_step : prim_cfg -> prim_cfg -> option expr -> Prop.
-
- (** Some derived notions **)
- Definition reducible e: Prop :=
- exists sigma cfg' ef, prim_step (e, sigma) cfg' ef.
-
- Definition is_ctx (ctx : expr -> expr) : Prop :=
- (forall e, is_value (ctx e) -> is_value e) /\
- (forall e1 σ1 e2 σ2 ef, prim_step (e1, σ1) (e2, σ2) ef -> prim_step (ctx e1, σ1) (ctx e2, σ2) ef) /\
- (forall e1 σ1 e2 σ2 ef, ~is_value e1 -> prim_step (ctx e1, σ1) (e2, σ2) ef ->
- exists e2', e2 = ctx e2' /\ prim_step (e1, σ1) (e2', σ2) ef).
-
-
- (** Atomic expressions **)
- Parameter atomic : expr -> Prop.
-
- (** Things ought to make sense. **)
- Axiom values_stuck :
- forall e, is_value e -> ~reducible e.
-
- Axiom atomic_not_value :
- forall e, atomic e -> ~is_value e.
-
- Axiom atomic_step: forall e σ e' σ' ef,
- atomic e ->
- prim_step (e, σ) (e', σ') ef ->
- is_value e'.
-
-End CORE_LANG.
diff --git a/docs/.gitignore b/docs/.gitignore
new file mode 100644
index 0000000000000000000000000000000000000000..7969c4f55c81e769b2facb814aa4d2e95e681c84
--- /dev/null
+++ b/docs/.gitignore
@@ -0,0 +1,14 @@
+*.pdf
+*.aux
+*.log
+*.out
+*.synctex.gz
+*.txss
+*.thm
+*.toc
+*.bbl
+*.blg
+*.bcf
+*.run.xml
+_*_.tex
+auto/*.el
diff --git a/docs/algebra.tex b/docs/algebra.tex
new file mode 100644
index 0000000000000000000000000000000000000000..4ef34213d1e4e3b8eb642a2354905302337f9d5b
--- /dev/null
+++ b/docs/algebra.tex
@@ -0,0 +1,6 @@
+\section{Algebraic Structures}
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "iris"
+%%% End:
diff --git a/docs/bib.bib b/docs/bib.bib
new file mode 100644
index 0000000000000000000000000000000000000000..03e1cd6a463713c43f545a2bf59154bfbf181cf3
--- /dev/null
+++ b/docs/bib.bib
@@ -0,0 +1,3579 @@
+
+
+@inproceedings{liang-feng,
+ author = {Liang, Hongjin and Feng, Xinyu},
+ title = {Modular Verification of Linearizability with Non-fixed Linearization Points},
+ booktitle = {PLDI},
+ year = {2013}
+}
+
+@INPROCEEDINGS{hlrg,
+ author = {Ming Fu and Yong Li and Xinyu Feng and Zhong Shao and Yu Zhang},
+ title = {Reasoning about optimistic concurrency using a program logic for history},
+ booktitle = {CONCUR},
+ year = {2010}
+}
+
+@Book{Milner1999,
+ author={Robin Milner},
+ title={Communicating and Mobile Systems: the $\pi$-Calculus},
+ publisher={Cambridge University Press},
+ year={1999},
+}
+
+@article{Walker:IC1995,
+ Author = {David Walker},
+ Journal = {Inf. Comput.},
+ Number = {2},
+ Pages = {253--271},
+ Title = {Objects in the pi-Calculus},
+ Volume = {116},
+ Year = {1995}}
+
+@inproceedings{jensen-fsl,
+ author = {Jensen, Jonas Braband and Birkedal, Lars},
+ title = {Fictional Separation Logic},
+ booktitle = {ESOP},
+ year = {2012},
+}
+
+@article{America-Rutten:JCSS89,
+ Author = {Pierre America and Jan Rutten},
+ Journal = {J. Comput. Syst. Sci.},
+ Number = {3},
+ Pages = {343--375},
+ Title = {Solving Reflexive Domain Equations in a Category of Complete Metric Spaces},
+ Volume = {39},
+ Year = {1989}}
+
+@Misc{Sieczkowski+:tutorial14,
+ author = {Filip Sieczkowski and Ale\v{s} Bizjak and Yannick Zakowski and Lars Birkedal},
+ title = {Modular Reasoning about Concurrent Higher-Order Imperative Programs: a {Coq} Tutorial},
+ howpublished = {\url{http://users-cs.au.dk/birke/modures/tutorial/index.html}},
+ year = 2014
+}
+
+@inproceedings{birkedal:popl11,
+ author = "Lars Birkedal and Bernhard Reus and Jan Schwinghammer and Kristian St{\o}vring and Jacob Thamsborg and Hongseok Yang",
+ title = "Step-Indexed {Kripke} Models over Recursive Worlds",
+ booktitle = "POPL",
+ year = 2011,
+}
+
+@inproceedings{parkinson+:popl08,
+ author = "Matthew Parkinson and Gavin Bierman",
+ title = "Separation Logic, Abstraction and Inheritance",
+ booktitle = "POPL",
+ year = 2008,
+}
+
+@Unpublished{mogelberg:2009,
+ author = {Rasmus E. M{\o}gelberg},
+ title = {A Nominal Relational Model for Local Variables},
+ note = {Manuscript},
+ month = {may},
+ year = 2009,
+ annote = {Available at: \url{http://www.itu.dk/people/mogel/papers/nom-rel-model.pdf}}
+}
+
+@InProceedings{mogelberg-simpson:07,
+ author = {Rasmus E. M{\o}gelberg and Alex Simpson},
+ title = {Relational Parametricity for Computational Effects},
+ booktitle = {LICS},
+ year = 2007}
+
+@inproceedings{parkinson05,
+ author = {M. J. Parkinson and G. M. Bierman},
+ title = {Separation logic and abstraction},
+ booktitle = {POPL},
+ year = {2005},
+ pages = {247--258},
+}
+
+@phdthesis{parkinson_thesis,
+ author = "Matthew Parkinson",
+ title = "Local Reasoning for Java",
+ school = "University of Cambridge",
+ month = "November",
+ year = "2005"
+}
+
+
+@Article{honsell+:variable-typed,
+ author = {Furio Honsell and Ian A. Mason and Scott Smith and Carolyn Talcott},
+ title = {A Variable Typed Logic of Effects},
+ journal = {Inf. Comput.},
+ year = {1995},
+ volume = {119},
+ number = {1},
+ pages = {55--90},
+}
+
+@article{sumii-pierce:jacm,
+ author = {Eijiro Sumii and Benjamin Pierce},
+ title = {A Bisimulation for Type Abstraction and Recursion},
+ journal = {JACM},
+ volume = 54,
+ number = 5,
+ year = 2007,
+ pages = {1--43},
+}
+
+@inproceedings{banerjee-naumann:ecoop05,
+ author = "Anindya Banerjee and David A. Naumann",
+ title = "State based ownership, reentrance, and encapsulation",
+ booktitle = {ECOOP},
+ year = 2005,
+}
+
+@InProceedings{koutavas-wand:popl06,
+ author = {Vasileios Koutavas and Mitchell Wand},
+ title = {Small Bisimulations for Reasoning About Higher-Order Imperative Programs},
+ booktitle = {POPL},
+ year = {2006},
+}
+
+@Misc{appendix,
+ title = {Appendix and {Coq} development},
+ note = {\url{http://plv.mpi-sws.org/iris}},
+}
+
+
+@inproceedings{dreyer+:icfp10,
+ author = {Derek Dreyer and Georg Neis and Lars Birkedal},
+ title = {The Impact of Higher-Order State and Control Effects on Local Relational Reasoning},
+ year = 2010,
+ booktitle = {ICFP},
+}
+
+@InProceedings{thamsborg+:icfp11,
+ author = {Jacob Thamsborg and Lars Birkedal},
+ title = {A {Kripke} Logical Relation for Effect-Based Program Transformations},
+ booktitle = {ICFP},
+ year = 2011,
+}
+
+@inproceedings{hur+:popl11,
+ author = {Chung-Kil Hur and Derek Dreyer},
+ title = {A {Kripke} Logical Relation Between {ML} and Assembly},
+ year = {2011},
+ booktitle = {POPL},
+}
+
+@inproceedings{nakano:lics00,
+ author = "Hiroshi Nakano",
+ title = {A modality for recursion},
+ booktitle = {LICS},
+ year = "2000",
+}
+
+
+
+@InProceedings{birkedal+:fossacs09,
+ author = {Lars Birkedal and Kristian St\o{}vring and Jacob Thamsborg},
+ title = {Realizability Semantics of Parametric Polymorphism, General References, and Recursive Types},
+ booktitle = {FOSSACS},
+ year = {2009},
+}
+
+@inproceedings{plotkin-abadi,
+ AUTHOR = {Gordon Plotkin and Mart\'in Abadi},
+ TITLE = {A logic for parametric polymorphism},
+ BOOKTITLE = {TLCA},
+ year = 1993,
+}
+
+@InCollection{pitts:attapl,
+ author = {Andrew Pitts},
+ title = {Typed Operational Reasoning},
+ booktitle = {Advanced Topics in Types and Programming Languages},
+ year = 2005,
+ publisher = {MIT Press},
+ chapter = {7},
+ editor = {B. C. Pierce},
+}
+
+
+
+@Article{yoshida+:lmcs08,
+ author = {Nobuko Yoshida and Kohei Honda and Martin Berger},
+ title = {Logical Reasoning for Higher-Order Functions with Local State},
+ journal = {LMCS},
+ year = {2008},
+ volume = {4},
+ number = {4:2},
+}
+
+@Article{BirkedalL:semslt-lmcs,
+ author = {L. Birkedal and N. Torp-Smith and H. Yang},
+ title = {Semantics of Separation-logic Typing and Higher-order Frame Rules for {Algol}-like Languages},
+ journal = {LMCS},
+ volume = {2},
+ number = {5:1},
+ year = 2006,
+}
+ @Article{BirkedalL:parsepl-journal,
+ author = {L. Birkedal and H. Yang},
+ title = {Relational Parametricity and Separation Logic},
+ journal = {Logical Methods in Computer Science},
+ year = 2008,
+ volume = 4,
+ number = {2:6},
+ pages = {1--27},
+ month = {may}}
+
+
+
+@InProceedings{BirkedalL:bihsl,
+ author = {B. Biering and L. Birkedal and N. Torp-Smith},
+ title = {BI Hyperdoctrines and Higher-order Separation Logic},
+ booktitle = {ESOP},
+ year = 2005,
+}
+
+@InProceedings{Schwinghammer-nested-triples-conf,
+ author = {J. Schwinghammer and L. Birkedal and B. Reus and H. Yang},
+ title = {Nested {H}oare Triples and Frame Rules for Higher-order Store},
+ booktitle = {CSL},
+ year = 2009,
+}
+
+@inproceedings{krishnaswami-tldi09,
+ author = {Neelakantan R. Krishnaswami and
+ Jonathan Aldrich and
+ Lars Birkedal and
+ Kasper Svendsen and
+ Alexandre Buisse},
+ title = {Design patterns in separation logic},
+ booktitle = {TLDI},
+ year = {2009},
+}
+
+@inproceedings{nanevski+:esop07,
+ author = {Aleksandar Nanevski and
+ Amal Ahmed and
+ Greg Morrisett and
+ Lars Birkedal},
+ title = {Abstract Predicates and Mutable {ADTs in Hoare Type Theory}},
+ booktitle = {ESOP},
+ year = {2007},
+}
+
+@inproceedings{petersen-htt,
+ author = {Rasmus Lerchedahl Petersen and
+ Lars Birkedal and
+ Aleksandar Nanevski and
+ Greg Morrisett},
+ title = {A Realizability Model for Impredicative {H}oare Type Theory},
+ booktitle = {ESOP},
+ year = {2008},
+}
+
+@InProceedings{ohearn+:popl04,
+ author = "Peter W. O'Hearn and Hongseok Yang and John C.
+ Reynolds",
+ title = "Separation and Information Hiding",
+ booktitle = "POPL",
+ year = "2004",
+}
+
+@InProceedings{Birkedal:Reus:Schwinghammer:Yang:08,
+ author = "Lars Birkedal and Bernhard Reus and Jan Schwinghammer and Hongseok Yang",
+ title = "A Simple Model of Separation Logic for Higher-order Store",
+ booktitle = "{ICALP'08}",
+ pages = "348--360",
+ year = "2008"
+}
+
+@InProceedings{Banerjee:Naumann:Rosenberg:08,
+ author = "Anindya Banerjee and David Naumann and Stan Rosenberg",
+ title = "Regional Logic for Local Reasoning about Global Invariants",
+ booktitle = "ECOOP",
+ year = "2008",
+ url = "\url{http://www.cs.stevens.edu/~naumann/publications/node2.html}",
+}
+
+
+
+@Article{yang:relational,
+ title = "Relational Separation Logic",
+ author = "Hongseok Yang",
+ journal = "TCS",
+ year = "2007",
+ number = "1--3",
+ volume = "375",
+ pages = "308--334",
+}
+
+@IProceedings{birkedal+:ho-frame-rules,
+ author = {Lars Birkedal and Noah Torp-Smith and Hongseok Yang},
+ title = {Semantics of Separation-logic Typing and
+ Higher-order Frame Rules},
+ booktitle = {Proc. of LICS'05},
+ year = {2005},
+ pages = {260-269}
+}
+
+@InProceedings{aydemir+:popl08,
+ author = {Brian Aydemir and Arthur Chargu\'{e}raud and Benjamin C. Pierce and Randy Pollack and Stephanie Weirich},
+ title = {Engineering Formal Metatheory},
+ booktitle = "POPL",
+ year = 2008
+}
+
+@Article{birkedal+:lmcs06,
+ author = {Lars Birkedal and Noah Torp-Smith and Hongseok Yang},
+ title = {Semantics of Separation-logic Typing and
+ Higher-order Frame Rules},
+ journal = {LMCS},
+ year = {2006},
+ volume = {2},
+ number = {5:1},
+}
+
+@Article{birkedal-yang,
+ author = {Lars Birkedal and Hongseok Yang},
+ title = {Relational Parametricity and Separation Logic},
+ journal = {LMCS},
+ year = {2008},
+ volume = {4},
+ number = {2:6},
+}
+
+@Article{reynolds:types,
+ author = {John C. Reynolds},
+ title = {Types, Abstraction, and Parametric Polymorphism},
+ journal = {Information Processing},
+ year = 1983,
+}
+
+@inproceedings{reynolds:separation,
+ author = "John C. Reynolds",
+ title = "Separation logic: A logic for shared mutable data structures",
+ booktitle = "LICS",
+ year = "2002",
+}
+
+@InProceedings{birkedal-yang-fossacs,
+ title = "Relational Parametricity and Separation Logic",
+ author = "Lars Birkedal and Hongseok Yang",
+ year = "2007",
+ booktitle = "FOSSACS",
+ pages = "",
+ volume = "4423",
+ series = "Lecture Notes in Computer Science",
+ editor = "Helmut Seidl",
+}
+
+@InProceedings{reus-schwinghammer:csl06,
+ author = {Bernhard Reus and Jan Schwinghammer},
+ title = {Separation Logic for Higher-order Store},
+ booktitle = {CSL},
+ year = "2006",
+}
+
+@InProceedings{Birkedal:Torp-Smith:Reynolds:04,
+ author = "Lars Birkedal and Noah Torp-Smith and John C.
+ Reynolds",
+ title = "Local Reasoning about a Copying Garbage Collector",
+ booktitle = "Conference Record of the 31st Annual {ACM}
+ Symposium on Principles of Programming Languages",
+ publisher = "ACM Press",
+ year = 2004,
+ series = "ACM SIGPLAN Notices",
+ pages = "220--231",
+}
+
+@InProceedings{Thielecke:06,
+ author = "Hayo Thielecke",
+ title = "Frame rules from answer types for code pointers",
+ booktitle = "Conference Record of the 33rd Annual ACM Symposium on
+ Principles of Programming Languages",
+ publisher = "ACM Press",
+ pages = "309--319",
+ year = 2006,
+}
+
+
+@Article{Reus:Schwinghammer:MSCS,
+ author = {Bernhard Reus and Jan Schwinghammer},
+ title = {Denotational Semantics for a Program Logic of Objects},
+ journal = {Mathematical Structures in Computer Science},
+ year = 2006,
+ volume = 16,
+ number = 2,
+ pages = {313--358},
+ month = {April},
+}
+
+@InProceedings{Reus:Streicher:05,
+ author = {Bernhard Reus and Thomas Streicher},
+ title = {About {Hoare} Logics for Higher-Order Store},
+ booktitle = {International Colloquium on Automata,
+ Languages and Programming (ICALP'05)},
+pages = "1337--1348",
+ year = 2005,
+ series = {Lecture Notes in Computer Science},
+ publisher = {Springer}
+}
+
+@InProceedings{Reddy:88,
+ author = "Uday S. Reddy",
+ title = "Objects as Closures: Abstract Semantics of
+ Object-oriented Languages",
+ pages = "289--297",
+ editor = "Jerome Chailloux",
+ booktitle = "Proceedings of the {ACM} Conference on {LISP} and
+ Functional Programming",
+ month = jul,
+ year = 1988,
+ publisher = "ACM Press",
+}
+
+@InCollection{OHearn:Tennent:92,
+ author = "Peter W. O'Hearn and Robert D. Tennent",
+ title = "Semantics of Local Variables",
+ pages = "217--238",
+ booktitle = "Applications of Categories in Computer Science",
+ editor = "M. P. Fourman and P. T. Johnstone and A. M. Pitts",
+ year = "1992",
+ publisher = "Cambridge University Press",
+ series = "London Mathematical Society Lecture Note Series",
+ volume = "177",
+}
+
+@InProceedings{Morrisett:Ahmed:Fluet,
+ author = {Greg Morrisett and Amal Ahmed and Matthew Fluet},
+ title = {L3: A Linear Language with Locations},
+ booktitle = {Proceedings of the 7th International Conference on Typed Lambda Calculi and Applications (TLCA '05)},
+ year = 2005,
+ volume = 3461,
+ series = {Lecture Notes in Computer Science},
+ publisher = {Springer}
+}
+
+@InProceedings{Ahmed:Fluet:Morrisett:05,
+ author = {Amal Ahmed and Matthew Fluet and Greg Morrisett},
+ title = {A Step-Indexed Model of Substructural State},
+ booktitle = {Proceedings of the 10th ACM SIGPLAN International Conference on Functional Programming (ICFP '05)},
+ year = 2005,
+ note = {To appear}
+}
+
+@TechReport{Aboul-Hosn:Kozen:05,
+ author = {Kamal Aboul-Hosn and Dexter Kozen},
+ title = {Relational Semantics of Local Variable Scoping},
+ institution = {Computer Science Department, Cornell University},
+ year = 2005,
+ number = {2005-2000},
+ month = jul,
+}
+
+@Article{Abadi:Cardelli:95,
+ author = "Mart{\'\i}n Abadi and Luca Cardelli",
+ title = "A theory of primitive objects: Second-order systems",
+ journal = "Science of Computer Programming",
+ volume = "25",
+ number = "2-3",
+ pages = "81--116",
+ month = dec,
+ year = "1995",
+}
+
+@Book{Davey:Priestley:02,
+ author = "Brian A. Davey and Hilary A. Priestley",
+ publisher = "Cambridge University Press",
+ title = "Introduction to Lattices and Order",
+ edition = "Second",
+ year = 2002,
+}
+
+@Article{Mason:Smith:Talcott:96,
+ author = "Ian A. Mason and Scott F. Smith and Carolyn L.
+ Talcott",
+ title = "From Operational Semantics to Domain Theory",
+ journal = "Information and Computation",
+ volume = "128",
+ number = "1",
+ year = "1996",
+ pages = "26--47",
+}
+
+@InCollection{Talcott:98,
+ author = "Carolyn L. Talcott",
+ title = "Reasoning about Functions with Effects",
+ pages = "347--390",
+ editor = "Andrew D. Gordon and Andrew M. Pitts",
+ booktitle = "Higher Order Operational Techniques in Semantics",
+ publisher = "Cambridge University Press",
+ series = "Publications of the Newton Institute",
+ year = "1998",
+}
+
+
+@Book{Abadi:Cardelli:96,
+ author = "Mart{\'\i}n Abadi and Luca Cardelli",
+ title = "A Theory of Objects",
+ publisher = "Springer",
+ year = "1996",
+}
+
+@Article{Abadi:Cardelli:96a,
+ title = "A Theory of Primitive Objects: Untyped and First-Order
+ Systems",
+ author = "Mart{\'\i}n Abadi and Luca Cardelli",
+ pages = "78--102",
+ journal = "Information and Computation",
+ month = mar,
+ year = "1996",
+ volume = "125",
+ number = "2",
+}
+
+@InProceedings{Mitchell:84,
+ author = "John C. Mitchell",
+ title = "Coercion and type inference",
+ booktitle = "Conference Record of the 11th Annual ACM Symposium on
+ Principles of Programming Languages",
+ pages = "175--185",
+ publisher = "ACM Press",
+ month = jan,
+ year = 1984,
+}
+
+
+@InProceedings{Reynolds:80,
+ author = "John C. Reynolds",
+ title = "Using category theory to design implicit conversions
+ and generic operators",
+ booktitle = "Proceedings of the Aarhus Workshop on
+ Semantics-Directed Compiler Generation",
+ editor = "Neil D. Jones",
+ month = jan,
+ year = 1980,
+ publisher = "Springer",
+ series = "Lecture Notes in Computer Science",
+ number = 94,
+ pages = "211--258",
+}
+
+@Article{OHearn:Reynolds:00,
+ author = "Peter W. O'Hearn and John C. Reynolds",
+ title = "From Algol to Polymorphic Linear Lambda-calculus",
+ journal = "Journal of the ACM",
+ volume = "47",
+ number = "1",
+ pages = "167--223",
+ month = jan,
+ year = "2000",
+}
+
+
+@InProceedings{Abadi:Cardelli:Curien:93,
+ author = "Mart\'{\i}n Abadi and Luca Cardelli and Pierre-Louis Curien",
+ title = "Formal Parametric Polymorphism",
+ booktitle = "Conference Record of the 20th Annual ACM
+ SIGPLAN-SIGACT Symposium on Principles of Programming
+ Languages",
+ pages = "157--170",
+ year = "1993",
+}
+
+@InProceedings{Abadi:Cardelli:Plotkin:94,
+ author = "Gordon D. Plotkin and Mart\'{\i}n Abadi and Luca
+ Cardelli",
+ title = "Subtyping and Parametricity",
+ booktitle = "Proceedings of 9th Annual IEEE Symposium on Logic in Computer
+ Science",
+ pages = "310--319",
+ month = jul,
+ year = "1994",
+ publisher = {IEEE Computer Society Press},
+}
+
+@InProceedings{Abadi:Cardelli:Viswanathan:96,
+ author = "Mart{\'\i}n Abadi and Luca Cardelli and Ramesh
+ Viswanathan",
+ title = "An interpretation of objects and object types",
+ booktitle = "Conference record of the 23rd Symposium on Principles of Programming Languages",
+ year = "1996",
+ pages = "396--409",
+ publisher = {{ACM} Press},
+}
+
+
+
+
+
+
+@InProceedings{Abadi:Leino:97,
+ author = {Mart{\'\i}n Abadi and K.~R.~M.~Leino},
+ title = {A Logic of Object-oriented Programs},
+ booktitle = {Proceedings of Theory and Practice of Software Development},
+ pages = {682--696},
+ year = {1997},
+ editor = {Michel Bidoit and Max Dauchet},
+ volume = {1214},
+ series = {Lecture Notes in Computer Science},
+ publisher = {Springer},
+}
+
+@InProceedings{Abadi:Pierce:Plotkin:89,
+ author = "Mart\'{\i}n Abadi and Benjamin C. Pierce and Gordon D. Plotkin",
+ title = "Faithful Ideal Models for Recursive Polymorphic Types",
+ booktitle = "Proceedings of 4th Annual IEEE Symposium on Logic in Computer Science",
+ pages = "216--225",
+ month = jun,
+ year = "1989",
+ publisher = {IEEE Computer Society Press},
+}
+
+
+@InProceedings{Abadi:Plotkin:90,
+ author = {Mart\'{\i}n Abadi and Gordon D. Plotkin},
+ title = {A PER Model of Polymorphism and Recursive Types},
+ booktitle = {Proceedings of 5th Annual IEEE Symposium on Logic in Computer Science},
+ pages = {355--365},
+ year = {1990},
+ publisher = {IEEE Computer Society Press},
+}
+
+@InProceedings{Abadi:Plotkin:93,
+ author = "Gordon D. Plotkin and Mart\'{\i}n Abadi",
+ title = "A logic for parametric polymorphism",
+ booktitle = "International Conference on Typed Lambda Calculi and
+ Applications",
+ year = "1993",
+ editor = "M. Bezem and J. F. Groote",
+ series = "Lecture Notes in Computer Science",
+ number = "664",
+ pages = "361--375",
+ month = mar,
+}
+
+
+
+@InProceedings{Abramsky:Ghica:Murawski:Ong:Stark:04,
+ author = {Samson Abramsky and Dan Ghica and Andrzej Murawski and
+ Luke Ong and Ian Stark},
+ title = {Nominal Games and Full Abstraction for the
+ Nu-Calculus},
+ booktitle = {Proceedings of the 19th Annual IEEE Symposium on
+ Logic in Computer Science},
+ pages = {150--159},
+ year = 2004,
+ publisher = {IEEE Computer Society Press},
+}
+
+
+
+@InCollection{Abramsky:Jung:94,
+ author = {Samson Abramsky and Achim Jung},
+ booktitle = {Handbook of Logic in Computer Science},
+ title = {Domain Theory},
+ publisher = {Clarendon Press},
+ pages = {1--168},
+ year = 1994,
+ editor = {S. Abramsky and D. M. Gabbay and T. S. E. Maibaum},
+ volume = 3
+}
+
+@InProceedings{Abramsky:McCusker:97,
+ author = {Samson Abramsky and Guy McCusker},
+ title = {Game Semantics},
+ booktitle = {Logic and Computation. Proceedings of the 1997 Marktoberdorf Summer School},
+ year = {1998},
+ editor = {H. Schwichtenberg and U. Berger},
+ publisher = {Springer},
+}
+
+@InProceedings{Abramsky:McCusker:Honda:98,
+ title = "A Fully Abstract Game Semantics for General
+ References",
+ author = "Samson Abramsky and Kohei Honda and Guy {McCusker}",
+ booktitle = "Proceedings 13th Annual IEEE Symposium on Logic
+ in Computer Science",
+ publisher = "IEEE Computer Society Press",
+pages = {334--344},
+ year = "1998",
+}
+
+@inproceedings{Aceto:Huettel:Ingolfsdottir:Kleist:00,
+ author = {Luca Aceto and Hans H{\"u}ttel and Anna Ing{\'o}lfsd{\'o}ttir and Josva Kleist},
+ title = {Relating semantic models for the object calculus},
+ booktitle = {Electronic Notes in Theoretical Computer Science},
+ volume = {7},
+ editor = {C. Palamidessi and J. Parrow},
+ year = {2000}
+}
+
+@InProceedings{Ahmed:Appel:Virga:02,
+ author = {Amal J. Ahmed and Andrew W. Appel and Roberto Virga},
+ title = {A Stratified Semantics of General References Embeddable in Higher-Order Logic},
+ booktitle = {Proceedings of 17th Annual IEEE Symposium Logic in Computer Science},
+ publisher = "IEEE Computer Society Press",
+ pages = {75--86},
+ year = {2002},
+}
+
+
+@Unpublished{Ahmed:Appel:Virga:03,
+ author = {Amal J. Ahmed and Andrew W. Appel and Roberto Virga},
+ title = {An Indexed Model of Impredicative Polymorphism and Mutable References},
+ note = {Princeton University},
+ month = {January},
+ year = {2003},
+}
+
+
+@Article{Amadio:91,
+ author = "R. M. Amadio",
+ title = "Recursion over realizability structures",
+ journal = "Information and Computation",
+ volume = "91",
+ number = "1",
+ pages = "55--86",
+ year = "1991",
+}
+
+@InProceedings{Amadio:Cardelli:91,
+ author = "Roberto M. Amadio and Luca Cardelli",
+ title = "Subtyping Recursive Types",
+ pages = "104--118",
+ booktitle = "Conference Record of the 18th Annual {ACM} Symposium
+ on Principles of Programming Languages",
+ month = jan,
+ year = "1991",
+ note = "Journal version in \cite{Amadio:Cardelli:93}",
+}
+
+
+@Article{Amadio:Cardelli:93,
+ author = "Roberto M. Amadio and Luca Cardelli",
+ title = "Subtyping Recursive Types",
+ journal = "ACM Transactions on Programming Languages and
+ Systems",
+ volume = "15",
+ number = "4",
+ pages = "575--631",
+ year = "1993",
+}
+
+
+@inProceedings{Andersen:Pedersen:Huettel:Kleist:97,
+ author = "Dan S. Andersen and Lars H. Pedersen and Hans H{\"u}ttel and Josva Kleist",
+ title = "Objects, Types and Modal Logics",
+ booktitle = "Proceedings of {FOOL4}",
+ year = "1997",
+ month = nov,
+ url = "citeseer.nj.nec.com/andersen96objects.html",
+}
+
+@inproceedings{mellies-vouillon,
+ author = "Paul-Andr{\'e} Melli{\`e}s and J{\'e}r{\^o}me Vouillon",
+ title = {Recursive polymorphic types and parametricity in an operational framework},
+ booktitle = {LICS},
+ year = "2005",
+}
+
+
+@Article{appel-mcallester,
+ author = {Andrew Appel and David McAllester},
+ title = {An Indexed Model of Recursive Types for Foundational Proof-Carrying Code},
+ journal = {TOPLAS},
+ year = {2001},
+ volume = {23},
+ number = {5},
+ pages = {657--683},
+}
+
+@InProceedings{appel+:vmm,
+ author = {Andrew Appel and Paul-Andr{\'e} Melli{\`e}s and Christopher Richards and J{\'e}r{\^o}me Vouillon},
+ title = {A Very Modal Model of a Modern, Major, General Type System},
+ booktitle = {POPL},
+ year = 2007
+}
+
+@InProceedings{dockins+:mfps08,
+ author = {Robert Dockins and Andrew W. Appel and Aquinas Hobor},
+ title = {Multimodal Separation Logic for Reasoning About Operational Semantics},
+ booktitle = {MFPS},
+ year = {2008},
+}
+
+@Article{Apt:Plotkin:86,
+ title = "Countable Nondeterminism and Random Assignment",
+ author = "Krzysztof R. Apt and Gordon D. Plotkin",
+ area = "Programming Languages and Systems",
+ pages = "724--767",
+ journal = "Journal of the ACM",
+ month = oct,
+ year = "1986",
+ volume = "33",
+ number = "4",
+}
+
+@Article{DiGianantonio:Honsell:Plotkin:95,
+ title = "Uncountable Limits and the lambda Calculus",
+ author = "Pietro {di Gianantonio} and Furio Honsell and Gordon D.
+ Plotkin",
+ journal = "Nordic Journal of Computing",
+ year = 1995,
+ number = 2,
+ volume = 2,
+ pages = "126--145",
+}
+
+@Article{Apt:81,
+ author = "Krzysztof R. Apt",
+ title = "Ten Years of {Hoare}'s Logic: {A} Survey --- Part
+ {I}",
+ journal = "ACM Transactions on Programming Languages and
+ Systems",
+ volume = "3",
+ number = "4",
+ pages = "431--483",
+ month = oct,
+ year = "1981",
+}
+
+@Book{Arnold:Gosling:Holmes:00,
+ author = "Ken Arnold and James Gosling and David Holmes",
+ key = "Arnold \& Gosling",
+ title = "The {Java} Programming Language",
+ publisher = "Addison-Wesley",
+ year = "2000",
+ edition = "Third",
+}
+
+@InProceedings{Banerjee:Naumann:02,
+ author = "Anindya Banerjee and David A. Naumann",
+ title = "Representation independence, confinement and access
+ control",
+ pages = "166--177",
+ month = jan,
+ year = "2002",
+ booktitle = "Proceedings of the 29th ACM SIGPLAN-SIGACT symposium
+ on Principles of Programming Languages",
+ publisher = "IEEE Computer Society Press",
+}
+
+
+@InCollection{Barendregt:92,
+ author = {Henk P. Barendregt},
+ title = {Lambda Calculi with Types},
+ booktitle = {Handbook of Logic in Computer Science},
+ pages = {117--309},
+ publisher = {Oxford University Press},
+ year = 1992,
+ editor = {Samson Abramsky and Dov Gabbay and T.~S.~E. Maibaum},
+ volume = 2,
+ chapter = 2
+}
+
+
+
+
+@InProceedings{ahmed:esop06,
+ author = {Amal Ahmed},
+ title = {Step-Indexed Syntactic Logical Relations for Recursive and Quantified Types},
+ booktitle = {ESOP},
+ year = 2006,
+}
+
+@InProceedings{ahmed+:popl09,
+ author = {Amal Ahmed and Derek Dreyer and Andreas Rossberg},
+ title = {State-Dependent Representation Independence},
+ booktitle = {POPL},
+ year = {2009},
+}
+
+@InProceedings{dreyer+:lics09,
+ author = {Derek Dreyer and Amal Ahmed and Lars Birkedal},
+ title = {Logical Step-Indexed Logical Relations},
+ booktitle = {LICS},
+ year = {2009},
+}
+
+@InProceedings{benton:popl04,
+ author = {Nick Benton},
+ title = {Simple Relational Correctness Proofs for Static Analyses and Program Transformations},
+ booktitle = {POPL},
+ year = {2004},
+}
+
+@InProceedings{benton-leperchey,
+ author = {Nick Benton and Benjamin Leperchey},
+ title = {Relational Reasoning in a Nominal Semantics for Storage},
+ booktitle = {TLCA},
+ year = {2005},
+}
+
+@Article{Birkedal:Harper:99,
+ author = "Lars Birkedal and Robert W. Harper",
+ title = "Constructing interpretations of recursive types in an
+ operational setting",
+ journal = "Information and Computation",
+ year = "1999",
+ volume = "155",
+ pages = "3--63",
+}
+
+@Article{Blass:Gurevich:00,
+ author = "Andreas Blass and Yuri Gurevich",
+ title = "The Underlying Logic of {Hoare} Logic",
+ journal = "Bulletin of the European Association for Theoretical
+ Computer Science",
+ volume = "70",
+ pages = "82--110",
+ month = feb,
+ year = "2000",
+ url = "\url{http://research.microsoft.com/~gurevich/Opera/142.ps}",
+}
+
+@InProceedings{Bodirsky:Gaertner:Oertzen:Schwinghammer:01,
+author = {Manuel Bodirsky and Tobias G\"artner and Timo von Oertzen and Jan Schwinghammer},
+title = {Computing the Density of Regular Languages},
+pages = {23--35},
+month = aug,
+address = {Helsinki},
+booktitle = {Proceedings of the Student Session of the European Summer School in Logic, Language, and Information},
+year = {2001},
+}
+
+@Misc{Bodirsky:Gaertner:Oertzen:Schwinghammer:LongRun,
+ author = {Manuel Bodirsky and Tobias G\"artner and Timo von Oertzen and Jan Schwinghammer},
+ year = {2002},
+ title = {Long-run properties of periodic probabilistic systems},
+ howpublished = {Manuscript},
+}
+
+
+@Misc{Bodirsky:Gaertner:Oertzen:Schwinghammer:Periods,
+ author = {Manuel Bodirsky and Tobias G\"artner and Timo von Oertzen and Jan Schwinghammer},
+ title = {Periodic Sequences of Group Elements},
+ year = {2002},
+ howpublished = {Manuscript},
+}
+
+@InProceedings{Bono:Bugliesi:99,
+ author = {Viviana Bono and Michele Bugliesi},
+ title = {Interpretations of Extensible Objects and Types},
+ booktitle = {Proceedings of the 12th Int. Symposium on Fundamentals of Computing},
+ pages = {112--123},
+ year = {1999},
+ volume = {1684},
+ series = {Lecture Notes in Computer Science},
+ publisher = {Springer},
+}
+
+
+@InProceedings{Bono:Patel:Shmatikov:Mitchell:99,
+ author = "Viviana Bono and Amit J. Patel and Vitaly Shmatikov
+ and John C. Mitchell",
+ title = "A Core Calculus of Classes and Objects",
+ booktitle = "15th Conference on the Mathematical Foundations
+ of Programming Semantics",
+ series = "Electronic Notes in Computer Science",
+ volume = "20",
+ year = "1999",
+ month = apr,
+}
+
+@Article{Boudol:04,
+ author = {G{\'}erard Boudol},
+ title = {The recursive record semantics of objects revisited},
+ journal = {Journal of Functional Programming},
+ year = {2004},
+ volume = {14},
+ number = {3},
+ pages = {263-315},
+ month = may,
+}
+
+@Article{Bracha:Odersky:Stoutamire:Wadler:98,
+ author = "Gilad Bracha and Martin Odersky and David Stoutamire
+ and Philip Wadler",
+ title = "Making the Future Safe for the Past: Adding Genericity
+ to the {Java} Programming Language",
+ journal = "ACM SIG{\-}PLAN Notices",
+ volume = "33",
+ number = "10",
+ pages = "183--200",
+ month = oct,
+ year = "1998",
+}
+
+
+
+@InProceedings{Bracha:Ungar:04,
+ author = {Gilad Bracha and David Ungar},
+ title = {Mirrors: Design Principles for Meta-level Facilities of Object-Oriented Programming Languages},
+ booktitle = {Proceedings of the ACM Conference on Object-Oriented Programming, Systems, Languages and Applications},
+ year = {2004},
+ month = oct,
+ publisher = {ACM Press},
+}
+
+
+@Article{Breazu-Tannen:EtAl:91,
+ author = "Val {Breazu-Tannen} and Thierry Coquand and Gunter
+ Gunter and Andre Scedrov",
+ title = "Inheritance as Implicit Coercion",
+ journal = "Information and Computation",
+ month = jul,
+ year = "1991",
+ number = "1",
+ volume = "93",
+ pages = "172--221",
+}
+
+
+@Book{Bruce:02,
+ author = "Kim B. Bruce",
+ title = "Foundations of Object-Oriented Languages: Types and
+ Semantics",
+ publisher = "MIT Press",
+ year = "2002",
+}
+
+
+
+@Article{Bruce:94,
+ author = "Kim B. Bruce",
+ title = "A Paradigmatic Object-Oriented Programming Language:
+ Design, Static Typing and Semantics",
+ journal = "Journal of Functional Programming",
+ volume = "4",
+ number = "2",
+ month = apr,
+ pages = "127--206",
+ year = "1994",
+}
+
+@article {Bruce:Cardelli:Pierce:99,
+author = "Kim B. Bruce and Luca Cardelli and Benjamin C. Pierce",
+title = "Comparing Object Encodings",
+journal = "Information and Computation",
+year = 1999,
+month = nov,
+volume = 155,
+number = "1/2",
+pages = "108--133",
+}
+
+@Article{Bruce:etal:95,
+ author = "Kim B. Bruce and Luca Cardelli and Giuseppe Castagna
+ and {The Hopkins Objects Group} and Gary T. Leavens and
+ Benjamin Pierce",
+ title = "On Binary Methods",
+ journal = "Theory and Practice of Object Systems",
+ publisher = "John Wiley and Sons, Inc.",
+ year = "1995",
+ pages = "221--242",
+ volume = "1",
+ number = "3",
+}
+
+@Book{Castagna:97,
+ author = "Giuseppe Castagna",
+ title = "Object-Oriented Programming: {A} Unified Foundation",
+ publisher = "Birkhauser",
+ year = 1997,
+ series = "Progress in Theoretical Computer Science",
+}
+
+@Article{Bugliesi:Delzanno:Liquori:Martelli:00,
+ author = "Michele Bugliesi and Giorgio Delzanno and Luigi Liquori and Maurizio Martelli",
+ title = "Object Calculi in Linear Logic",
+ journal = "Journal of Logic and Computation",
+ volume = 10,
+ number = 1,
+ pages = "75 --104",
+ month = feb,
+ year = "2000",
+}
+
+@InProceedings{Calcagno+:lics09,
+ author={Cristiano Calcagno and Peter W. O'Hearn and Hongseok Yang},
+ title={Local Action and Abstract Separation Logic},
+ booktitle={LICS},
+ year={2007},
+}
+
+@InProceedings{Calcagno:Ishtiaq:OHearn:00,
+ author = "Cristiano Calcagno and Samin Ishtiaq and Peter W.
+ O'Hearn",
+ title = "Semantic Analysis of Pointer Aliasing, Allocation and
+ Disposal in {H}oare Logic",
+ booktitle = "Proceedings of 2nd International Conference on Principles and
+ Practice of Declarative Programming",
+ year = "2000",
+ pages = "190--201",
+ editor = "Maurizio Gabbrielli and Frank Pfenning",
+ series = "Lecture Notes in Computer Science",
+publisher = {Springer},
+}
+
+@InProceedings{Canning:Cook:Hill:Olthoff:Mitchell:89,
+ author = "P. Canning and W. Cook and W. Hill and W. Olthoff and
+ J. Mitchell",
+ title = "{F}-bounded polymorphism for object-oriented
+ programming",
+ booktitle = "Proceedings 4th International Conference on Functional Programming Languages and Computer
+ Architecture",
+ year = "1989",
+ publisher = "ACM Press",
+ pages = "273--280",
+}
+
+@InCollection{Cardelli:84,
+ author = "Luca Cardelli",
+ title = "A Semantics of Multiple Inheritance",
+ booktitle = "Semantics of Data Types",
+ editor = "Gilles Kahn and David MacQueen and Gordon Plotkin",
+ series = "Lecture Notes in Computer Science",
+ volume = "173",
+ pages = "51--67",
+ year = "1984",
+ month = jun,
+ publisher = "Springer",
+ abstract-url = "http://www.luca.demon.co.uk/Papers.html#Inheritance",
+ note = "Full version in \cite{Cardelli:88}"
+}
+
+
+
+@Article{Cardelli:88,
+ author = "Luca Cardelli",
+ title = "A Semantics of Multiple Inheritance",
+ journal = "Information and Computation",
+ volume = "76",
+ number = "2/3",
+ month = feb,
+ year = "1988",
+ pages = "138--164",
+}
+
+@Article{Cardelli:Martini:Mitchell:Scedrov:94,
+ author = "Luca Cardelli and Simone Martini and John C. Mitchell
+ and Andre Scedrov",
+ title = "An Extension of {S}ystem {F} with Subtyping",
+ journal = "Information and Computation",
+ volume = "109",
+ number = "1--2",
+ pages = "4--56",
+ year = "1994",
+}
+
+@Article{Cardelli:Wegner:85,
+ author = "Luca Cardelli and Peter Wegner",
+ title = "On Understanding Types, Data Abstraction, and
+ Polymorphism",
+ journal = "ACM Computing Surveys",
+ volume = "17",
+ number = "4",
+ pages = "471--522",
+ month = dec,
+ year = "1985",
+}
+
+@InProceedings{Cardone:89,
+ title = "Relational Semantics for Recursive Types and Bounded
+ Quantification",
+ author = "Felice Cardone",
+ editor = "Giorgio Ausiello and Mariangiola Dezani-Ciancaglini
+ and Simona Ronchi Della Rocca",
+ booktitle = "16th International Colloquium Automata, Languages and Programming",
+ month = jul,
+ year = "1989",
+ series = "Lecture Notes in Computer Science",
+ volume = "372",
+ publisher = "Springer",
+ pages = "164--178",
+}
+
+@Article{Clarke:79,
+ author = "E. M. Clarke",
+ year = "1979",
+ title = "Programming Language Constructs for which it it
+ Impossible to obtain good {Hoare} Axiom Systems",
+ journal = "Journal of the ACM",
+ volume = "26",
+ number = "1",
+ pages = "129--147",
+}
+
+@Article{Cook:78,
+ author = {Stephen A. Cook},
+ title = {Soundness and Completeness of an Axiom System for Program Verification},
+ journal = {{SIAM} Journal on Computing},
+ year = {1978},
+ volume = {7},
+ number = {1},
+ pages = {70--90},
+}
+
+
+@PhdThesis{Cook:89,
+ author = "William R. Cook",
+ title = "A Denotational Semantics of Inheritance",
+ school = "Department of Computer Science, Brown University",
+ type = "Ph.{D}. Thesis",
+ month = may,
+ year = "1989",
+}
+
+
+@Article{Cook:Palsberg:94,
+ author = "William Cook and Jens Palsberg",
+ title = "A Denotational Semantics of Inheritance and its
+ Correctness",
+ journal = "Information and Computation",
+ pages = "329--350",
+ year = "1994",
+month = nov,
+ number = "2",
+ volume = "114",
+}
+
+@article{Coquand:Gunter:Winskel:89,
+ author = "Thierry Coquand and Carl A. Gunter and Glynn Winskel",
+ title = "Domain Theoretic Models of Polymorphism",
+ journal = "Information and Computation",
+ volume = "81",
+ number = "2",
+ pages = "123--167",
+ year = "1989",
+ url = "citeseer.nj.nec.com/coquand89domain.html"
+}
+
+
+@incollection{Cousot:90,
+ author = {Patrick Cousot},
+ title = {Methods and Logics for Proving Programs},
+ pages = {843--993},
+ editor = {Jan {van Leeuwen}},
+ chapter = 15,
+ booktitle = {Formal Models and Semantics},
+ volume = {B},
+ series = {Handbook of Theoretical Computer Science},
+ publisher = {Elsevier},
+ year = 1990,
+}
+
+@TechReport{Crary:99,
+ author = {Karl Crary},
+ title = {Simple, Efficient Object Encoding using Intersection Types},
+ institution = {Carnegie Mellon University},
+ year = {1999},
+ month = jan,
+ number = {CMU-CS-99-100},
+}
+
+
+@InCollection{Curien:Ghelli:94,
+ author = "Pierre-Louis Curien and Giorgio Ghelli",
+ title = "Coherence of Subsumption, Minimum Subtyping and
+ Type-Checking in ${F}_{\leq}$",
+ editor = "Carl A. Gunter and John C. Mitchell",
+ booktitle = "Theoretical Aspects of Object-Oriented Programming:
+ Types, Semantics, and Language Design",
+ series = "Foundations of Computing Series",
+ pages = "247--292",
+ publisher = "MIT Press",
+ year = "1994",
+}
+
+
+@InProceedings{Eifrig:Smith:Trifonov:95,
+ author = "Jonathan Eifrig and Scott Smith and Valery Trifonov",
+ title = "Type Inference for Recursively Constrained Types and
+ its Application to {OOP}",
+ booktitle = "Proceedings of the 1995 Mathematical Foundations of
+ Programming Semantics Conference",
+ series = "Electronic Notes in Theoretical Computer Science",
+ publisher = "Elsevier",
+ volume = "1",
+ year = "1995",
+ fullurl = "http://www.elsevier.nl/locate/entcs/volume1.html",
+}
+
+@Article{Eifrig:Smith:Trifonov:Zwarico:95,
+ author = "Jonathan Eifrig and Scott Smith and Valery Trifonov
+ and Amy Zwarico",
+ title = "An Interpretation of Typed {OOP} in a Language with
+ State",
+ journal = "Lisp and Symbolic Computation",
+ volume = 8,
+ number = 4,
+ pages = "357--397",
+ month = dec,
+ year = 1995,
+}
+
+@Article{Erkok:Launchbury:00,
+ author = "Levent Erk{\"o}k and John Launchbury",
+ title = "Recursive monadic bindings",
+ journal = "ACM SIG{\-}PLAN Notices",
+ volume = "35",
+ number = "9",
+ pages = "174--185",
+ month = sep,
+ year = "2000",
+}
+
+@MastersThesis{Fecher:99,
+ author = {Harald Fecher},
+ title = {Denotational Semantics of Untyped Object-Based Programming Languages},
+ school = {Technische Universit{\"a}t Darmstadt},
+ year = {1999},
+}
+
+@Article{Filinski:94,
+ author = "Andrzej Filinski",
+ title = "Recursion from Iteration",
+ journal = "{LISP} and Symbolic Computation",
+ volume = "7",
+ number = "1",
+ pages = "11--37",
+ month = jan,
+ year = "1994",
+}
+
+@InProceedings{Findler:Felleisen:01,
+ author = "Robert Bruce Findler and Matthias Felleisen",
+ title = "Contract Soundness for Object-Oriented Languages",
+ booktitle = "OOPSLA '01 Conference Proceedings",
+ year = "2001",
+ month = oct,
+ pages = "1--15",
+}
+
+
+@InProceedings{Findler:Felleisen:02,
+ author = {Robert Bruce Findler and Matthias Felleisen},
+ title = {Contracts for Higher-Order Functions},
+ booktitle = {Proceedings of the 2002 International Conference on Functional Programming},
+ OPTpages = {},
+ year = {2002},
+ OPTseries = {},
+ month = oct,
+}
+
+
+
+@Article{felleisen-hieb,
+ author = {Matthias Felleisen and Robert Hieb},
+ title = {The revised report on the syntactic theories of sequential control and state},
+ journal = {TCS},
+ year = {1992},
+ volume = {103},
+ number = {2},
+ pages = {235--271},
+}
+
+@PhdThesis{Fiore:94,
+ author = {Marcelo P. Fiore},
+ title = {Axiomatic Domain Theory in Categories of Partial Maps},
+ school = {University of Edinburgh},
+ year = {1994},
+ note = {LFCS report ECS-LFCS-94-307},
+}
+
+
+@Book{Fiore:96,
+ author = {Marcelo P. Fiore},
+ title = {Axiomatic Domain Theory in Categories of Partial Maps},
+ publisher = {Cambridge University Press},
+ year = 1996,
+ series = {Distinguished Dissertations in Computer Science}
+}
+
+@Article{FioreEtAl:96,
+ author = "Marcelo Fiore and Achim Jung and Eugenio Moggi and
+ Peter O'Hearn and Jon Riecke and Giuseppe Rosolini and
+ Ian Stark",
+ title = "Domains and Denotational Semantics: History,
+ Accomplishments and Open Problems",
+ journal = "Bulletin of the European Association for Theoretical
+ Computer Science",
+ volume = "59",
+ pages = "227--256",
+ month = jun,
+ year = "1996",
+}
+
+@Article{Fisher:Honsell:Mitchell:94,
+ author = "Kathleen Fisher and Furio Honsell and John C.
+ Mitchell",
+ title = "A lambda calculus of objects and method
+ specialization",
+ journal = "Nordic Journal of Computing",
+ year = "1994",
+ volume = "1",
+ pages = "3--37",
+}
+
+
+@Article{Fisher:Mitchell95,
+ title = "The Development of Type Systems for Object-Oriented
+ Languages",
+ author = "Kathleen Fisher and John C. Mitchell",
+ journal = "Theory and Practice of Object Sytems",
+ pages = "189--220",
+ year = "1995",
+ volume = "1",
+ number = "3",
+}
+
+@InProceedings{Fisher:Mitchell:95,
+ author = "Kathleen Fisher and John C. Mitchell",
+ title = "A Delegation-based Object Calculus with Subtyping",
+ booktitle = "Fundamentals of Computation Theory (FCT'95)",
+ series = "Lecture Notes in Computer Science",
+ volume = "965",
+ pages = "42--61",
+ year = "1995",
+publisher = {Springer},
+}
+
+@Article{Fisher:Mitchell:98,
+ author = "Kathleen Fisher and John C. Mitchell",
+ title = "On the Relationship Between Classes, Objects and Data
+ Abstraction",
+ journal = "Theory and Practice of Object Systems",
+ year = "1998",
+ volume = "4",
+ number = "1",
+ pages = "3--25",
+}
+
+@InProceedings{Floyd:67,
+ author = "Robert W. Floyd",
+ title = "Assigning Meanings to Programs",
+ booktitle = "Proceedings of Mathematical Aspects of Computer Science",
+ month = apr,
+ year = "1967",
+ pages = "19--32",
+ editor = "Jacob T. Schwartz",
+ volume = "19",
+ series = "Proceedings of Symposia in Applied Mathematics",
+ publisher = "American Mathematical Society",
+}
+
+
+@InProceedings{Freyd:91,
+ author = "Peter J. Freyd",
+ title = "Algebraically Complete Categories",
+ editor = "A. Carboni and M. C. Pedicchio and G. Rosolini",
+ booktitle = "Proceedings of 1990 Como Category Theory Conference",
+ series = "Lecture Notes in Mathematics",
+ volume = "1488",
+ pages = "95--104",
+ publisher = "Springer",
+ year = "1991",
+}
+
+@Article{Freyd:Rosolini:Mulry:Scott:92,
+ author = "Peter Freyd and Giuseppe Rosolini and Philip Mulry and
+ Dana Scott",
+ title = "Extensional {PERs}",
+ journal = "Information and Computation",
+ volume = "98",
+ number = "2",
+ special = "Selected Papers from 5th Ann.\ IEEE Symp.\ on Logic in
+ Computer Science, LICS'90, Philadelphia, PA, USA, 4--7
+ June 1990",
+ pages = "211--227",
+ year = "1992",
+}
+
+
+@Book{GangOfFourBook,
+ author = "Erich Gamma and Richard Helm and Ralph Johnson and
+ John Vlissides",
+ title = "Design Patterns: Elements of Reusable Object-Oriented
+ Software",
+ publisher = "Addison Wesley",
+ year = "1995",
+}
+
+
+@Article{Gapeyev:Levin:Pierce:00,
+ author = "Vladimir Gapeyev and Michael Y. Levin and Benjamin C.
+ Pierce",
+ title = "Recursive subtyping revealed (functional pearl)",
+ journal = "ACM SIG{\-}PLAN Notices",
+ volume = "35",
+ number = "9",
+ pages = "221--231",
+ month = sep,
+ year = "2000",
+ url = "http://www.acm.org/pubs/citations/proceedings/fp/351240/p221-gapeyev/",
+}
+
+ @InCollection{Abadi:Leino:04,
+ author = {Mart{\'\i}n Abadi and K.~R.~M.~Leino},
+ title = {A Logic of Object-Oriented Programs},
+ booktitle = {Verification: Theory and Practice. Essays Dedicated to Zohar Manna on the Occasion of His 64th Birthday
+ },
+ pages = {11--41},
+ publisher = {Springer},
+series = {Lecture Notes in Computer Science},
+volumne = {2772},
+ year = {2004},
+ editor = {Nachum Dershowitz},
+}
+
+@Book{Girard:Lafont:Taylor:89,
+ author = "Jean-Yves Girard and Yves Lafont and Paul Taylor",
+ title = "Proofs and Types",
+ publisher = "Cambridge University Press",
+ series = "Cambridge Tracts in Theoretical Computer Science",
+ year = "1989",
+ volume = "7",
+}
+
+@Misc{Glimming:05,
+ author = {Johan Glimming},
+ title = {\emph{Dialgebraic Semantics of Typed Object Calculi}},
+ year = 2005,
+ month = {May},
+ howpublished = {Licentiate thesis, Stockholm University}
+}
+
+@inproceedings{Glimming:Ghani:04,
+ author = {Johan Glimming and Neil Ghani},
+ title = {Difunctorial Semantics of Object Calculus},
+ booktitle = {Proceedings {WOOD} '04: Workshop on Object-Oriented Developments},
+ series = {Electronic Notes in Theoretical Computer Science},
+ publisher = {Elsevier},
+ year = 2004,
+ note = {To appear},
+}
+
+@InProceedings{Goerdt:88,
+ title = "Hoare Calculi for Higher-Type Control Structures and
+ Their Completeness in the Sense of~{Cook}",
+ author = "Andreas Goerdt",
+ booktitle = "Mathematical Foundations of Computer Science 1988",
+ editor = "Michael P. Chytil and Ladislav Janiga and V{\'a}clav
+ Koubek",
+ month = sep,
+ year = "1988",
+ series = "Lecture Notes in Computer Science",
+ volume = "324",
+ publisher = "Springer",
+ pages = "329--338",
+}
+
+
+@InCollection{Gordon:98,
+ author = {Andrew~D.~Gordon},
+ title = {Operational equivalences for untyped and polymorphic object calculi},
+ booktitle = {\cite{Gordon:Pitts:98}},
+ pages = {9--54},
+ year = {1998},
+}
+
+
+@inproceedings{Gordon:Hankin:00,
+ author = {Andrew D. Gordon and Paul D. Hankin},
+ title = {A Concurrent Object Calculus: Reduction and Typing},
+ booktitle = {Proceedings {HLCL}'98},
+ series = {Electronic Notes in Theoretical Computer Science},
+ publisher = {Elsevier},
+ volume = {16},
+ issue = {3},
+ editor = {Uwe Nestmann and Benjamin C. Pierce},
+ year = {2000}
+}
+
+@InProceedings{Gordon:Hankin:Lassen:97,
+ author = "Andrew D. Gordon and Paul D. Hankin and S{\o}ren. B. Lassen",
+ title = "Compilation and Equivalence of Imperative Objects",
+ booktitle = "Proceedings of FST+TCS'97",
+ series = "Lecture Notes in Computer Science",
+ pages = {74--87},
+ volume = {1346},
+ month = dec,
+ year = "1997",
+}
+
+
+@book{Gordon:Pitts:98,
+ editor = {Andrew D. Gordon and Andrew M. Pitts},
+ title = {Higher Order Operational Techniques in Semantics},
+ publisher = {Cambridge University Press},
+ series = {Publications of the Newton Institute},
+ year = 1998,
+}
+
+@InProceedings{Gordon:Rees:96,
+ author = {Andrew~D.~Gordon and Gareth~D.~Rees},
+ title = {Bisimilarity for a First-Order Calculus of Objects with Subtyping},
+ booktitle = {Conference Record of the 23rd Symposium on Principles of Programming Languages},
+ pages = {386--395},
+ year = {1996},
+ month = jan,
+}
+
+
+@Book{Gosling:Joy:Steele:Bracha:04,
+ author = {James Gosling and Bill Joy and Guy Steele and Gilad Bracha},
+ title = {The Java Language Specification},
+ publisher = {Addison-Wesley},
+ year = {2004},
+ edition = {Third},
+}
+
+
+
+@InProceedings{Goubault-Larrecq:Lasota:Nowak:02,
+ author = "Jean {Goubault-Larrecq} and Slawomir Lasota and David
+ Nowak",
+ title = "Logical Relations for Monadic Types",
+ booktitle = "Proc.\ 16th Int.\ Workshop Computer Science Logic (CSL
+ 2002)",
+ volume = "2471",
+ pages = "553--568",
+ series = "Lecture Notes in Computer Science",
+ year = "2002",
+ publisher = "Springer",
+}
+
+@InProceedings{Goubault-Larrecq:Lasota:Nowak:Zhang:04,
+ author = "Jean {Goubault-Larrecq} and Slawomir Lasota and David Nowak and
+ Yu Zhang",
+ title = "Complete Lax Logical Relations for Cryptographic
+ Lambda-Calculi",
+ booktitle = "Proc.\ 18th Int.\ Workshop Computer Science Logic (CSL
+ 2004)",
+ volume = "3210",
+ series = "Lecture Notes in Computer Science",
+ pages = "400--414",
+ year = "2004",
+ publisher = "Springer",
+}
+
+
+@InProceedings{Halpern:84,
+ author = "Joseph Y. Halpern",
+ title = "A Good {H}oare Axiom System for an {A}lgol-Like
+ Language",
+ booktitle = "Conference Record of the Eleventh Annual {ACM}
+ Symposium on Principles of Programming Languages",
+ publisher = "ACM Press",
+ month = jan,
+ year = "1984",
+ pages = "262--271",
+}
+
+
+@Article{Hasegawa:94,
+ title = "Categorical data types in parametric polymorphism",
+ author = "Ryu Hasegawa",
+ pages = "71--109",
+ journal = "Mathematical Structures in Computer Science",
+ month = mar,
+ year = "1994",
+ volume = "4",
+ number = "1",
+}
+
+
+@Book{Haskell98,
+editor = {Simon {Peyton Jones}},
+title = {Haskell 98 Language and Libraries. The Revised Report},
+publisher = {Cambridge University Press},
+year = {2003},
+OPTmonth = {April},
+}
+
+@InProceedings{Hensel:Huismann:Jacobs:Tews:98,
+ title = "Reasoning about Classes in Object-Oriented Languages:
+ Logical Models and Tools",
+ author = "Ulrich Hensel and Marieke Huisman and Bart Jacobs and
+ Hendrik Tews",
+ booktitle = "Programming Languages and Systems---{ESOP}'98, 7th
+ European Symposium on Programming",
+ editor = "Chris Hankin",
+ month = mar,
+ year = "1998",
+ series = "Lecture Notes in Computer Science",
+ volume = "1381",
+ pages = "105--121",
+ publisher = {Springer},
+}
+
+@Article{Hoare:69,
+ author = "C. A. R. Hoare",
+ title = "{An Axiomatic Basis of Computer Programming}",
+ journal = "Communications of the ACM",
+ year = "1969",
+ volume = "12",
+ pages = "576--580",
+ publisher = "ACM Press",
+}
+
+@Article{Hofmann:Pierce:94,
+ author = "Martin Hofmann and Benjamin Pierce",
+ title = "A Unifying Type-Theoretic Framework for Objects",
+ journal = "Journal of Functional Programming",
+ volume = "5",
+ number = "4",
+ pages = "593--635",
+ month = oct,
+ year = "1995",
+}
+
+@Article{Hofmann:Pierce:95,
+ author = "Martin Hofmann and Benjamin C. Pierce",
+ title = "A Unifying Type-Theoretic Framework for Objects",
+ journal = "Journal of Functional Programming",
+ month = oct,
+ year = "1995",
+ volume = "5",
+ number = "4",
+ pages = "593--635",
+}
+
+
+@Article{Hofmann:Pierce:96,
+ author = {Martin Hofmann and Benjamin Pierce},
+ title = {Positive Subtyping},
+ journal = {Information and Computation},
+ year = {1996},
+ volume = {126},
+ number = {1},
+ pages = {11--33},
+}
+
+@Misc{Hofmann:Tang:02,
+ author = {Francis Tang and Martin Hofmann},
+ title = {Generation of Verification Conditions for {Abadi} and {Leino}'s Logic of Objects},
+ howpublished = {Presented at 9th International Workshop on Foundations of Object-Oriented Languages},
+ month = jan,
+ year = {2002},
+}
+
+@InProceedings{Berger:Honda:Yoshida:05,
+ author = "Martin Berger and Kohei Honda and Nobuko Yoshida",
+ title = "A Logical Analysis of Aliasing in Imperative
+ Higher-Order Functions",
+ booktitle = "Proceedings of the 10th {ACM} {SIGPLAN} International
+ Conference on Functional Programming ({ICFP} '05)",
+ publisher = "ACM Press",
+ year = "2005",
+ notes = "To appear",
+}
+
+@InProceedings{Honda:Yoshida:Berger:05,
+ author = {Kohei Honda and Nobuko Yoshida and Martin Berger},
+ title = {An Observationally Complete Program Logic for Imperative Higher-Order Functions},
+ booktitle = {{LICS'05}},
+ pages = {270--279},
+ year = 2005,
+}
+
+@Article{Honda:04,
+ author = "Kohei Honda",
+ title = "From process logic to program logic",
+ journal = "ACM SIG{\-}PLAN Notices",
+ volume = "39",
+ number = "9",
+ pages = "163--174",
+ month = sep,
+ year = "2004",
+}
+
+@Article{Honsell:Pravato:Rocca:98,
+ title = "{Structured Operational Semantics} of a fragment of
+ the language {Scheme}",
+ author = "Furio Honsell and Alberto Pravato and Simona Ronchi
+ Della Rocca",
+ pages = "335--365",
+ journal = "Journal of Functional Programming",
+ month = jul,
+ year = "1998",
+ volume = "8",
+ number = "4",
+}
+
+@InProceedings{Igarashi:Pierce:00,
+ author = {Atsushi Igarashi and Benjamin C. Pierce},
+ title = {On inner Classes},
+ booktitle = {Proceedings of the European Conference on Object-Oriented Programming},
+ pages = {129--153},
+ year = {2000},
+ volume = {1850},
+ series = {Lecture Notes in Computer Science},
+ publisher = {Springer},
+}
+
+@Article{Ishtiaq:OHearn:01,
+ author = "Samin S. Ishtiaq and Peter W. O'Hearn",
+ title = "{BI} as an Assertion Language for Mutable Data
+ Structures",
+ journal = "ACM SIG{\-}PLAN Notices",
+ volume = "36",
+ number = "3",
+ pages = "14--26",
+ month = mar,
+ year = "2001",
+}
+
+@inproceedings{Jacobs:00,
+ author = {Bart Jacobs},
+ title = {Subtypes and bounded quantification from a fibred perspective},
+ booktitle = {Electronic Notes in Theoretical Computer Science},
+ volume = {1},
+ editor = {S. Brookes, M. Main, A. Melton and M. Mislove},
+ year = {2000},
+ publisher = {Elsevier},
+}
+
+@InCollection{Jacobs:96,
+ author = "Bart P. F. Jacobs",
+ title = "Objects and classes, coalgebraically",
+ editor = "B. Freitag and C. B. Jones and C. Lengauer and H. J.
+ Schek",
+ booktitle = "Object-Orientation with Parallelism and Persistence",
+ pages = "83--103",
+ publisher = "Kluwer Academic Publishers",
+ year = "1996",
+ url = "http://www.cwi.nl/pub/CWIreports/AP/CS-R9536.ps.Z",
+}
+
+@InProceedings{Jacobs:Poll:01,
+ author = "Bart Jacobs and Erik Poll",
+ title = "A Logic for the {Java} Modeling Language {JML}",
+ series = "Lecture Notes in Computer Science",
+ volume = "2029",
+ pages = "284--299",
+ year = "2001",
+ booktitle = "Fundamental Approaches to Software Engineering
+ (FASE'2001)",
+ publisher = "Springer",
+}
+
+@Article{Jacobs:Poll:03,
+ author = "Bart Jacobs and Erik Poll",
+ title = "Coalgebras and monads in the semantics of {Java}",
+ journal = "Theoretical Computer Science",
+ volume = "291",
+ number = "3",
+ pages = "329--349",
+ year = "2003",
+}
+
+@Article{Jacobs:Rutten:97,
+ author = "Bart Jacobs and Jan Rutten",
+ title = "A Tutorial on (Co)Algebras and (Co)Induction",
+ journal = "Bulletin of the European Association for Theoretical
+ Computer Science",
+ volume = "62",
+ pages = "222--259",
+ month = jun,
+ year = "1997",
+}
+
+@inproceedings{Jeffrey:Rathke:02,
+author = {Alan Jeffrey and Julian Rathke},
+year = {2002},
+title = {A fully abstract may testing semantics for concurrent objects},
+booktitle = {Proceedings $17^{th}$ Annual Symposium on Logic in Computer Science},
+publisher = {IEEE Computer Society Press},
+pages = {101--112}
+}
+
+@inproceedings{Jeffrey:Rathke:99,
+ author = {Alan Jeffrey and Julian Rathke},
+ title = {Towards a theory of bisimulation for local names},
+ booktitle = {Proc. LICS'99, 14th Annual Symposium on Logic in Computer Science},
+ year = {1999},
+ publisher = {IEEE Computer Society Press},
+ pages = {56--66},
+}
+
+@InCollection{Kamin:Reddy:94,
+ author = "Samuel N. Kamin and Uday S. Reddy",
+ title = "Two Semantic Models of Object-Oriented Languages",
+ booktitle = "Theoretical Aspects of Object-Oriented Programming:
+ Types, Semantics, and Language Design",
+ editor = "Carl A. Gunter and John C. Mitchell",
+ publisher = "MIT Press",
+ pages = "464--495",
+ year = "1994",
+}
+
+@Book{Kernighan:Ritchie:88,
+ author = {Brian Kernighan and Dennis Ritchie},
+ title = {The {C} Programming Language},
+ publisher = {Prentice-Hall},
+ year = {1988},
+ edition = {Second},
+}
+
+
+
+@InProceedings{Kleist:Sangiorgi:98,
+ author = "Josva Kleist and Davide Sangiorgi",
+ title = "Imperative Objects and Mobile Processes",
+ pages = "285--303",
+ booktitle = "Programming Concepts and Methods",
+ year = "1998",
+ editor = "David Gries and Willem-Paul {de Roever}",
+}
+
+@article{Kleymann:99,
+ author = "Thomas Kleymann",
+ title = "Hoare Logic and Auxiliary Variables",
+ journal = "Formal Aspects of Computing",
+ volume = "11",
+ number = "5",
+ pages = "541--566",
+ year = "1999",
+month = dec,
+}
+
+@InProceedings{Laeufer:95,
+ author = "L{\"{a}}ufer, K.",
+ title = "A Framework for Higher-Order Functions in {C}++",
+ booktitle = "Proceedings of Conference on Object-Oriented Technologies",
+ year = 1995,
+ address = "Monterey, CA",
+ month = jun,
+ pages = "103--116",
+}
+
+@InProceedings{Laird:02,
+ author = {James Laird},
+ title = {A Categorical Semantics of Higher-Order Store},
+ booktitle = {Proceedings of the 9th Conference on Category Theory and Computer Science, CTCS '02},
+ pages = {1--18},
+ year = {2003},
+ editor = {Rick Blute and Peter Selinger},
+ volume = {69},
+ series = {Electronic notes in Theoretical Computer Science},
+ publisher = {Elsevier},
+}
+
+@Article{Landin:64,
+ author = "Peter J. Landin",
+ title = "The Mechanical Evaluation of Expressions",
+ journal = "Computer Journal",
+ volume = "6",
+ number = "4",
+ month = jan,
+ year = "1964",
+ pages = "308--320",
+}
+
+
+@InProceedings{Leino:98,
+ title = "Recursive Object Types in a Logic of Object-Oriented
+ Programs",
+ author = "K. Rustan M. Leino",
+ booktitle = "7th European Symposium on Programming",
+ editor = "Chris Hankin",
+ month = mar,
+ year = "1998",
+ series = "Lecture Notes in Computer Science",
+publisher = {Springer},
+ volume = "1381",
+ pages = "170--184",
+}
+
+
+@InProceedings{Levy:02,
+ author = "Paul Blain Levy",
+ title = "Possible World Semantics for General Storage in
+ Call-By-Value",
+ booktitle = "CSL: 16th Workshop on Computer Science Logic",
+ series = "Lecture Notes in Computer Science",
+ volume = "2471",
+ editor = "Julian Bradfield",
+ publisher = "Springer",
+ year = "2002",
+}
+
+
+@Book{Levy:04,
+ author = {Paul Blain Levy},
+ title = {Call-By-Push-Value. A Functional/Imperative Synthesis},
+ publisher = {Kluwer},
+ year = {2004},
+ volume = {2},
+ series = {Semantic Structures in Computation},
+}
+
+@Article{Liang:Bracha:98,
+ author = "Sheng Liang and Gilad Bracha",
+ title = "Dynamic Class Loading in the {Java Virtual Machine}",
+ pages = "36--44",
+ booktitle = "Proceedings of the 13th Conference on Object-Oriented
+ Programming, Systems, Languages, and Applications",
+ month = oct,
+ journal = "ACM SIGPLAN Notices",
+ volume = "33",
+number = "10",
+ publisher = "ACM Press",
+ year = "1998",
+}
+
+
+@Article{Liskov:Wing:94,
+ author = "Barbara H. Liskov and Jeannette M. Wing",
+ title = "A Behavioral Notion of Subtyping",
+ journal = "ACM Transactions on Programming Languages and
+ Systems",
+ volume = "16",
+ number = "6",
+ pages = "1811--1841",
+ month = nov,
+ year = "1994",
+}
+
+@PhdThesis{Longley:95,
+ author = "John Longley",
+ title = "Realizability toposes and language semantics",
+ school = "University of Edinburgh",
+ year = "1995",
+}
+
+@Article{Longo:Moggi:91,
+ author = "Giuseppe Longo and Eugenio Moggi",
+ title = "Constructive Natural Deduction and its `$\omega$-set'
+ Interpretation",
+ journal = "Mathematical Structures in Computer Science",
+ pages = "215--254",
+ volume = "1",
+ number = "2",
+ month = jul,
+ year = "1991",
+}
+
+
+@InProceedings{Ma:Reynolds:92,
+ author = "QingMing Ma and John C. Reynolds",
+ title = "Types, Abstraction, and Parametric Polymorphism, Part
+ 2",
+ booktitle = "Proceedings 7th International Conference on Mathematical Foundations of Programming Semantics",
+ editor = "Stephen Brookes and Michael Main and Austin Melton and
+ Michael Mislove and David A. Schmidt",
+ series = "Lecture Notes in Computer Science",
+ volume = "598",
+ publisher = "Springer",
+ year = "1992",
+ pages = "1--40",
+}
+
+@Book{MacLane:97,
+ author = {Saunders {Mac Lane}},
+ title = {Categories for the Working Mathematician},
+ series = {Graduate Texts in Mathematics},
+ volume = {5},
+ publisher = {Springer},
+ year = {1997},
+}
+
+
+@Article{MacQueen:Plotkin:Sethi:86,
+ author = "David B. MacQueen and Gordon D. Plotkin and Ravi
+ Sethi",
+ title = "An Ideal Model for Recursive Polymorphic Types",
+ journal = "Information and Control",
+ month = oct,
+ volume = "71",
+ number = "1--2",
+ year = "1986",
+ pages = "95--130",
+}
+
+@InProceedings{Meyer:Sieber:88,
+ author = "Albert R. Meyer and K. Sieber",
+ title = "Towards Fully Abstract Semantics for Local Variables:
+ Preliminary Report",
+ pages = "191--203",
+ booktitle = "Conference Record of the Fifteenth Annual {ACM}
+ Symposium on Principles of Programming Languages",
+ year = "1988",
+ publisher = "ACM Press",
+ month = jan,
+}
+
+
+@Article{Milner:78,
+ author = "Robin Milner",
+ journal = "Journal of Computer and System Science",
+ pages = "348--375",
+ title = "A Theory of Type Polymorphism in Programming
+ Languages",
+ volume = "17",
+ number = "3",
+ year = "1978",
+}
+
+@InProceedings{Mitchell:90,
+ author = "John C. Mitchell",
+ title = "Toward a Typed Foundation for Method Specialization
+ and Inheritance",
+ booktitle = "Conference Record of the 17th Annual {ACM}
+ Symposium on Principles of Programming
+ Languages",
+publisher = {ACM Press},
+ year = "1990",
+ pages = "109--124",
+ month = jan,
+}
+
+@InCollection{Mitchell:91,
+ author = "John C. Mitchell",
+ title = "On the Equivalence of Data Representations",
+ editor = "V. Lifschitz",
+ booktitle = "Artificial Intelligence and Mathematical Theory of
+ Computation: Papers in Honor of {John McCarthy}",
+ publisher = "Academic Press",
+ pages = "305--330",
+ year = "1991",
+}
+
+@Book{Mitchell:96,
+ author = "John C. Mitchell",
+ title = "Foundations for Programming Languages",
+ publisher = "MIT Press",
+ year = "1996",
+}
+
+@Article{Mitchell:Moggi:91,
+ author = "John C. Mitchell and Eugenio Moggi",
+ title = "{K}ripke-Style Models for Typed Lambda Calculus",
+ journal = "Annals of Pure and Applied Logic",
+ volume = "51",
+ number = "1--2",
+ pages = "99--124",
+ year = "1991",
+}
+
+@Article{Mitchell:Plotkin:88,
+ author = "John C. Mitchell and Gordon D. Plotkin",
+ title = "Abstract Types Have Existential Type",
+ journal = "ACM Transactions on Programming Languages and
+ Systems",
+ volume = "10",
+ number = "3",
+ pages = "470--502",
+ month = jul,
+ year = "1988",
+}
+
+@InProceedings{Mitchell:Scedrov:93,
+ author = "John C. Mitchell and Andre Scedrov",
+ title = "Notes on Sconing and Relators",
+ publisher = "Springer",
+ series = "Lecture Notes in Computer Science",
+ volume = "702",
+ pages = "352--378",
+ year = "1993",
+ booktitle = "Computer Science Logic '92, Selected Papers",
+ editor = {Egon B{\"o}rger and
+ Gerhard J{\"a}ger and
+ Hans Kleine B{\"u}ning and
+ Simone Martini and
+ Michael M. Richter},
+}
+
+
+@InProceedings{Mitchell:Viswanathan:96,
+ title = "Effective Models of Polymorphism, Subtyping and
+ Recursion (Extended Abstract)",
+ author = "John C. Mitchell and Ramesh Viswanathan",
+ editor = "Friedhelm {Meyer auf der Heide} and Burkhard Monien",
+ booktitle = "23rd International Colloquium on Automata, Languages and Programming",
+ month = jul,
+ year = "1996",
+ series = "Lecture Notes in Computer Science",
+ publisher = "Springer",
+ volume = "1099",
+ pages = "170--181",
+}
+
+@Article{Moggi:Sabry:04,
+ author = "Eugenio Moggi and Amr Sabry",
+ title = "An Abstract Monadic Semantics for Value Recursion",
+ journal = "Theoretical Informatics and Applications",
+ volume = "38",
+ number = "4",
+ special = "Selected Papers from 5th Int.\ Wksh.\ on Fixed Points
+ in Comp.\ Sci., FICS 2003, Warsaw, Poland, 12--13 Apr.\
+ 2003",
+ pages = "375--400",
+ year = "2004",
+}
+
+
+@Misc{Niehren:Schwinghammer:Smolka:Futures,
+ author = {Joachim Niehren and Jan Schwinghammer and Gert Smolka},
+ title = {Concurrent Computation in a Lambda Calculus with Futures},
+ year = {2003},
+ howpublished = {Draft},
+}
+
+@inproceedings{Nipkow:Oheimb:02,
+author={David von Oheimb and Tobias Nipkow},
+title={Hoare Logic for {NanoJava}: Auxiliary Variables, Side Effects and
+Virtual Methods Revisited},
+booktitle={Formal Methods Europe (FME 2002)},
+editor={L.-H. Eriksson and P. Lindsay},
+publisher={Springer},
+series={LNCS},
+volume=2391,
+pages={89-105},
+year={2002},
+}
+
+@Article{OHearn:03,
+ author = {Peter W. O'Hearn},
+ title = {On Bunched Typing},
+ journal = {Journal of Functional Programming},
+ year = {2003},
+ pages = {747--796},
+volume = {13},
+ number = "4",
+}
+
+@Article{OHearn:98,
+ author = {Peter W. O'Hearn},
+ title = {Polymorphism, Objects and Abstract Types},
+ journal = {{SIGACT} News},
+ year = {1998},
+ volume = {29},
+ number = {4},
+ pages = {39--50},
+ month = dec,
+}
+
+@Article{OHearn:Pym:99,
+ author = {Peter W. O'Hearn and David J. Pym},
+ title = {The Logic of Bunched Implications},
+ journal = {Bulletin of Symbolic Logic},
+ year = {1999},
+ volume = {5},
+ number = {2},
+ pages = {215--244},
+ month = jun,
+}
+
+@Article{OHearn:Reddy:99,
+ author = {Peter W. O'Hearn and Uday S. Reddy},
+ title = {Objects, interference and the Yoneda embedding},
+ journal = {Theoretical Computer Science},
+ year = {1999},
+ volume = {228},
+ number = {1--2},
+ pages = {253--282},
+}
+
+
+@InProceedings{OHearn:Reynolds:Yang:01,
+ author = {Peter W. O'Hearn and John C. Reynolds and Hongseok Yang},
+ title = {Local Reasoning about Programs that Alter Data Structures},
+ booktitle = {Proceedings Computer Science Logic (CSL'01)},
+ pages = {1--18},
+ year = {2001},
+ editor = {L. Fribourg},
+ volume = {2142},
+ series = {Lecture Notes in Computer Science},
+ publisher = {Springer},
+}
+
+@Article{OHearn:Tennent:95,
+ title = "Parametricity and Local Variables",
+ author = "Peter W. O'Hearn and Robert D. Tennent",
+ pages = "658--709",
+ journal = "Journal of the ACM",
+ month = may,
+ year = "1995",
+ volume = "42",
+ number = "3",
+}
+
+
+@Book{OHearn:Tennent:97,
+ editor = "Peter W. O'Hearn and Robert D. Tennent",
+ title = "{{A}lgol-Like Languages, Vols {I} and {II}}",
+ publisher = "Birkhauser",
+ year = "1997",
+ series = "Progress in Theoretical Computer Science",
+}
+
+@Article{Ohori:Buneman:89,
+ key = "Ohori \& Buneman",
+ author = "Atsushi Ohori and Peter Buneman",
+ title = "Static Type Inference for Parametric Classes",
+ journal = "ACM SIGPLAN Notices",
+ volume = "24",
+ number = "10",
+ month = oct,
+ year = "1989",
+ pages = "445--456",
+editor = "Norman Meyerowitz",
+ note = "OOPSLA '89 Conference Proceedings",
+}
+
+
+@PhdThesis{Oles:82,
+ title = "A Category-theoretic approach to the semantics of
+ programming languages",
+ author = "Frank Joseph Oles",
+ year = "1982",
+ school = "Syracuse University",
+}
+
+@Article{Palsberg:95,
+ title = "Efficient Inference of Object Types",
+ author = "Jens Palsberg",
+ pages = "198--209",
+ journal = "Information and Computation",
+ month = dec,
+ year = "1995",
+ volume = "123",
+ number = "2",
+}
+
+@Book{Paulson:87,
+ author = "Larry C. Paulson",
+ title = "Logic and Computation : Interactive proof with
+ Cambridge {LCF}",
+ series = "Cambridge Tracts in Theoretical Computer Science",
+ volume = "2",
+ year = "1987",
+publisher = "Cambridge University Press",
+}
+
+@TechReport{Phoa:92,
+ author = "Wesley Phoa",
+ title = "An Introduction to Fibrations, Topos Theory, the
+ Effective Topos and Modest Sets",
+ number = "ECS-LFCS-92-208",
+ institution = "Department of Computer Science, University of
+ Edinburgh",
+ year = "1992",
+}
+
+@Book{Pierce:02,
+ author = "Benjamin C. Pierce",
+ title = "Types and Programming Languages",
+ publisher = "The MIT Press",
+ year = "2002",
+}
+
+
+@Book{Pierce:91,
+ author = "Benjamin C. Pierce",
+ title = "Basic Category Theory for Computer Scientists",
+ publisher = "MIT Press",
+ year = "1991",
+}
+
+@Article{Pierce:Turner:94,
+ author = "Benjamin C. Pierce and David N. Turner",
+ title = "Simple Type-Theoretic Foundations for Object-Oriented
+ Programming",
+ journal = "Journal of Functional Programming",
+ volume = "4",
+ number = "2",
+ pages = "207--247",
+ year = "1994",
+}
+
+@Article{Pierik:deBoer:05,
+ author = {Cees Pierik and Frank S. de Boer},
+ title = {A Proof Outline Logic for Object-Oriented Programming},
+ journal = {Theoretical Computer Science},
+ year = {2005},
+ note = {To appear},
+}
+
+@InProceedings{Pitts:87,
+ author = "Andrew M. Pitts",
+ title = "Polymorphism is Set Theoretic, Constructively",
+ booktitle = "Category Theory and Computer Science",
+ editor = "D. H. Pitt and A. Poign\'{e} and David E. Rydeheard",
+ series = "Lecture Notes in Computer Science",
+ publisher = "Springer",
+ volume = "283",
+ year = "1987",
+}
+
+
+@ARTICLE{pitts:relational,
+ AUTHOR={Andrew M. Pitts},
+ TITLE={Relational Properties of Domains},
+ JOURNAL={Information and Computation},
+ VOLUME=127,
+ YEAR=1996,
+ PAGES={66--90},
+}
+
+@InProceedings{Pitts:Stark:93,
+ author = "Andrew M. Pitts and Ian D. B. Stark",
+ title = "Observable Properties of Higher Order Functions That
+ Dynamically Create Local Names, or: What's new?",
+ booktitle = "Proceedings 18th International Symposium on Mathematical Foundations of Computer Science",
+ editor = "Andrzej M. Borzyszkowski and Stefan Sokolowski",
+ series = "Lecture Notes in Computer Science",
+ volume = "711",
+ publisher = "Springer",
+ year = "1993",
+ pages = "122--141",
+}
+
+@InProceedings{pitts-stark:state,
+ author = "Andrew Pitts and Ian Stark",
+ title = "Operational Reasoning for Functions with Local State",
+ booktitle = "HOOTS",
+ year = "1998",
+}
+
+
+
+
+
+@InProceedings{chin+:popl08,
+ author = {Wei-Ngan Chin and Cristina David and Huu Hai Nguyen and Shengchao Qin},
+ title = {Enhancing Modular {OO} Verification with Separation Logic},
+ booktitle = "POPL",
+ year = 2008,
+}
+
+@Unpublished{Plotkin:83,
+ author = {Gordon D. Plotkin},
+ title = {Domain Theory},
+note = "Pisa notes",
+ year = {1983},
+}
+
+@Article{Plotkin:Smyth:82,
+ author = "Michael B. Smyth and Gordon D. Plotkin",
+ title = "The Category-theoretic Solution of Recursive Domain
+ Equations",
+ journal = "SIAM J. Comput.",
+ volume = "11",
+ number = "4",
+ pages = "761--783",
+ year = "1982",
+}
+
+@InProceedings{Poetzsch-Heffter:Mueller:98,
+ author = "Arnd Poetzsch-Heffter and Peter M{\"u}ller",
+ title = "Logical Foundations for Typed Object-Oriented
+ Languages",
+ editor = "David Gries and Willem-Paul {De~Roever}",
+ booktitle = "Proceedings {IFIP} Working Conference on Programming
+ Concepts and Methods",
+ year = "1998",
+ publisher = "Chapman \& Hall",
+}
+
+
+@InProceedings{Poetzsch-Heffter:Mueller:99,
+ key = "Poetzsch-Heffter \& M{\"u}ller",
+ author = "Arnd Poetzsch-Heffter and Peter M{\"u}ller",
+ title = "A Programming Logic for Sequential {J}ava",
+ booktitle = "European Symposium on Programming",
+ editor = "S. D. Swierstra",
+ series = "Lecture Notes in Computer Science",
+ publisher = "Springer",
+ volume = "1576",
+ pages = "162--176",
+ year = "1999",
+}
+
+@Article{Pym:OHearn:Yang:04,
+ author = "David J. Pym and Peter W. O'Hearn and Hongseok
+ Yang",
+ title = "Possible worlds and resources: the semantics of {BI}",
+ journal = "Theoretical Computer Science",
+ volume = "315",
+ number = "1",
+ pages = "257--305",
+ day = "5",
+ month = may,
+ year = "2004",
+}
+
+@Article{Reddy:02,
+ author = {Uday S.~Reddy},
+ title = {Objects and classes in Algol-like languages},
+ journal = {Information and Computation},
+ year = {2002},
+ volume = {172},
+ number = {1},
+ pages = {63--97},
+ month = {January},
+}
+
+@Article{Reddy:96,
+ author = "Uday S. Reddy",
+ title = "Global State Considered Unnecessary: An Introduction
+ to Object-Based Semantics",
+ journal = "{LISP} and Symbolic Computation",
+ volume = "9",
+ number = "1",
+ pages = "7--76",
+ month = feb,
+ year = "1996",
+}
+
+@Misc{Reddy:98,
+ author = {Uday S. Reddy},
+ title = {Objects and Classes in {Algol}-like Languages},
+ year = {1998},
+ note = {Presented at {FOOL} 5 workshop},
+}
+
+
+@Article{Reddy:Yang:04,
+ author = {Uday S. Reddy and Hongseok Yang},
+ title = {Correctness of Data Representations Involving Heap
+ Data Structures},
+ journal = {Science of Computer Programming},
+ year = {2004},
+ volume = {50},
+ number = {1--3},
+ pages = {129--160},
+ month = {March},
+}
+
+
+@Article{Remy:Vouillon:98,
+author = "Didier R{\'e}my and J{\'e}r{\^o}me Vouillon",
+ title = "Objective {ML}:
+ An effective object-oriented extension to {ML}",
+ journal = "Theory And Practice of Object Systems",
+ year = 1998,
+ volume = "4",
+ number = "1",
+ pages = "27--50",
+}
+
+
+@InProceedings{Reus:02,
+ author = {Bernhard Reus},
+ title = {Class-based versus Object-based: A Denotational Comparison},
+ booktitle = {Proceedings of 9th International Conference on Algebraic Methodology And Software
+Technology},
+ series = "Lecture Notes in Computer Science",
+ publisher = "Springer",
+editor = {H{\'}el{\`}ene Kirchner and Christophe Ringeissen},
+ volume = {2422},
+ pages = {473--488},
+ year = {2002},
+}
+
+@INPROCEEDINGS{Reus:03,
+ author = {B.~Reus},
+ title = {Modular Semantics and Logics of Classes},
+ booktitle = "Computer Science Logic",
+ pages = "456--469",
+ editor = "Matthias Baatz and Johann A.~Makowsky",
+ publisher = "Springer",
+ Series = "Lecture Notes in Computer Science",
+ volume = "2803",
+ year = "2003"
+}
+
+
+@Unpublished{Reus:99,
+ author = {Bernhard Reus},
+ title = {Realizability Models for Type Theories},
+ note = {Draft of a Tutorial for the {R}ealizability {W}orkshop'99 in {T}rento},
+ month = nov,
+ year = {2000},
+}
+
+
+
+@TechReport{Reus:Schwinghammer:04,
+ author = {Bernhard Reus and Jan Schwinghammer},
+ title = {Denotational Semantics for {Abadi} and {Leino}'s Logic of Objects},
+ institution = {Informatics, University of Sussex},
+ year = {2004},
+ number = {2004:03},
+}
+
+@InProceedings{Reus:Schwinghammer:05,
+ author = {Bernhard Reus and Jan Schwinghammer},
+ title = {Denotational Semantics for {Abadi} and {Leino}'s Logic of Objects},
+ booktitle = {Proceedings of the European Symposium on Programming},
+ year = {2005},
+pages = {264--279},
+ editor = {Mooly Sagiv},
+ series = {Lecture Notes in Computer Science},
+volume = {3444},
+ publisher = {Springer},
+}
+
+@InProceedings{Reus:Streicher:02,
+ author = {Bernhard Reus and Thomas Streicher},
+ title = {Semantics and Logic of Object Calculi},
+ booktitle = {Proceedings of 17th Annual IEEE Symposium Logic in Computer Science},
+ publisher = {IEEE Computer Society Press},
+ year = {2002},
+ pages = {113--124},
+}
+
+
+@Article{Reus:Streicher:04,
+ author = {Bernhard Reus and Thomas Streicher},
+ title = {Semantics and Logic of Object Calculi},
+ journal = {Theoretical Computer Science},
+ year = {2004},
+ volume = {316},
+ publisher = "Elsevier",
+ pages = {191--213},
+}
+
+@INPROCEEDINGS{Reus:Wirsing:Hennicker:01,
+ Author = "B.~Reus and M.~Wirsing and R.~Hennicker",
+ Title = "{A Hoare-Calculus for Verifying Java Realizations of OCL-Constrained Design Models}",
+ Booktitle = "FASE 2001",
+ Year = 2001,
+Editor = "Heinrich Hussmann",
+ Publisher = "Springer",
+ Volume = 2029,
+ Pages = "300--317",
+ Series = "Lecture Notes in Computer Science",
+}
+
+@incollection{Reynolds:02a,
+author = "Reynolds, John C.",
+title = "What do Types Mean? --- {From} Intrinsic to Extrinsic Semantics",
+booktitle = "Essays on Programming Methodology",
+editor = "Annabelle McIver and Carroll Morgan",
+publisher = "Springer",
+year = "2002",
+}
+
+@InProceedings{Reynolds:02,
+ author = "John C. Reynolds",
+ title = "Separation Logic: {A} Logic for Shared Mutable Data
+ Structures",
+ pages = "55--74",
+ booktitle = "LICS'02",
+ year = "2002"
+}
+
+@InProceedings{hobor+:esop08,
+ author = {Aquinas Hobor and Andrew Appel and Francesco {Zappa Nardelli}},
+ title = {Oracle Semantics for Concurrent Separation Logic},
+ booktitle = {ESOP},
+ year = {2008},
+}
+
+@InProceedings{stovring+:popl07,
+ author = {Kristian St\o{}vring and Soren Lassen},
+ title = {A Complete, Co-Inductive Syntactic Theory of Sequential Control and State},
+ booktitle = {POPL},
+ year = {2007},
+}
+
+@InProceedings{lassen+:lics08,
+ author = {Soren B. Lassen and Paul Blain Levy},
+ title = {Typed Normal Form Bisimulation for Parametric Polymorphism},
+ booktitle = {LICS},
+ year = {2008},
+}
+
+@inproceedings{meyer-sieber-1988,
+ author = "Albert R. Meyer and Kurt Sieber",
+ title = "Towards fully abstract semantics for local variables",
+ booktitle = {POPL},
+ year = 1988,
+}
+
+@InProceedings{pottier:lics08,
+ author = {Fran\c{c}ois Pottier},
+ title = {Hiding local state in direct style: a higher-order anti-frame rule},
+ booktitle = {LICS},
+ year = {2008},
+}
+
+@InProceedings{hobor+:popl10,
+ author = {Aquinas Hobor and Robert Dockins and Andrew Appel},
+ title = {A Theory of Indirection via Approximation},
+ booktitle = {POPL},
+ year = {2010},
+}
+
+@InProceedings{Dockins+:aplas09,
+ author={Robert Dockins and Aquinas Hobor and Andrew W. Appel},
+ title={A Fresh Look at Separation Algebras and Share Accounting},
+ booktitle={APLAS},
+ year={2009},
+}
+
+@InProceedings{Balabonski+:flops14,
+ author={Thibaut Balabonski and Fran\c{c}ois Pottier and Jonathan Protzenko},
+ title={Type Soundness and Race Freedom for {M}ezzo},
+ booktitle={FLOPS},
+ year={2014},
+}
+
+@Article{Pottier:jfp13,
+ author={Fran\c{c}ois Pottier},
+ title={Syntactic soundness proof of a type-and-capability system with hidden state},
+ journal={JFP},
+ volume={23},
+ number={1},
+ pages={38--144},
+ year={2013},
+}
+
+@Unpublished{pottier:generalized,
+ author = {Fran\c{c}ois Pottier},
+ title = {Generalizing the higher-order frame and anti-frame rules},
+ note = {Unpublished},
+ year = {2009},
+ mon = jul,
+}
+
+@inproceedings{pilkiewicz+:monotonic,
+ author = {Alexandre Pilkiewicz and Fran\c{c}ois Pottier},
+ title = {The Essence of Monotonic State},
+ booktitle = {TLDI},
+ year = 2011,
+}
+
+@InProceedings{schwinghammer+:antiframe,
+ author = {Jan Schwinghammer and Hongseok Yang and Lars Birkedal and Fran\c{c}ois Pottier and Bernhard Reus},
+ title = {A Semantic Foundation for Hidden State},
+ booktitle = {FOSSACS},
+ year = 2010,
+}
+
+@InProceedings{chargueraud+:icfp08,
+ author = {Arthur Chargu\'eraud and Fran\c{c}ois Pottier},
+ title = {Functional translation of a calculus of capabilities},
+ booktitle = {ICFP},
+ year = {2008},
+}
+
+@InProceedings{benton+:tldi09,
+ author = {Nick Benton and Nicolas Tabareau},
+ title = {Compiling functional types to relational specifications for low level imperative code},
+ booktitle = {TLDI},
+ year = {2009},
+}
+
+@InProceedings{benton+:icfp09,
+ author = {Nick Benton and Chung-Kil Hur},
+ title = {Biorthogonality, Step-Indexing and Compiler Correctness},
+ booktitle = {ICFP},
+ year = 2009}
+
+
+@InProceedings{benton-tabareau-tldi2009,
+ author = {Nick Benton and Nicolas Tabareau},
+ title = {Compiling Functional Types to Relational Specifications for Low Level Imperative Code},
+ booktitle = {TLDI},
+ year = {2009},
+}
+
+@article{DBLP:journals/iandc/AbramskyJM00,
+ author = {Samson Abramsky and
+ Radha Jagadeesan and
+ Pasquale Malacaria},
+ title = {Full Abstraction for PCF},
+ journal = {Inf. Comput.},
+ volume = {163},
+ number = {2},
+ year = {2000},
+ pages = {409-470},
+ bibsource = {DBLP, http://dblp.uni-trier.de}
+}
+
+@article{DBLP:journals/iandc/HylandO00,
+ author = {J. M. E. Hyland and
+ C.-H. Luke Ong},
+ title = {On Full Abstraction for PCF: I, II, and III},
+ journal = {Inf. Comput.},
+ volume = {163},
+ number = {2},
+ year = {2000},
+ pages = {285-408},
+ bibsource = {DBLP, http://dblp.uni-trier.de}
+}
+
+
+@Unpublished{koutavas-lassen,
+ author = {V. Koutavas and S. Lassen},
+ title = {Fun with Fully Abstract Operational Game Semantics for General References},
+ note = {Unpublished},
+ month = feb,
+ year = 2008
+}
+
+
+
+@InProceedings{murawski+:lics11,
+ author = {Andrzej S. Murawski and Nikos Tzevelekos},
+ title = {Game semantics for good general references},
+ booktitle = {LICS},
+ year = {2011},
+}
+
+@inproceedings{laird:icalp07,
+ author = {James Laird},
+ title = {A Fully Abstract Trace Semantics for General References},
+ booktitle = {ICALP},
+ year = {2007}
+}
+
+@inproceedings{DBLP:conf/fossacs/Laird04,
+ author = {James Laird},
+ title = {A Game Semantics of Local Names and Good Variables},
+ booktitle = {Foundations of Software Science and Computation Structures,
+ 7th International Conference, FOSSACS 2004, Held as Part
+ of the Joint European Conferences on Theory and Practice
+ of Software, ETAPS 2004, Barcelona, Spain, March 29 - April
+ 2, 2004, Proceedings},
+ year = {2004},
+ publisher = {Springer},
+ series = {Lecture Notes in Computer Science},
+ volume = {2987},
+ pages = {289-303},
+ ee = {http://springerlink.metapress.com/openurl.asp?genre=article{\&}issn=0302-9743{\&}volume=2987{\&}spage=289},
+ bibsource = {DBLP, http://dblp.uni-trier.de}
+}
+
+
+@inproceedings{lassen+:csl07,
+ author = {Soren B. Lassen and
+ Paul Blain Levy},
+ title = {Typed Normal Form Bisimulation},
+ booktitle = {CSL},
+ year = {2007}
+}
+
+
+
+@inproceedings{DBLP:conf/fossacs/MurawskiT09,
+ author = {Andrzej S. Murawski and
+ Nikos Tzevelekos},
+ title = {Full Abstraction for Reduced ML},
+ booktitle = {FOSSACS},
+ year = {2009}
+}
+
+
+@article{DBLP:journals/tcs/MurawskiW08,
+ author = {Andrzej S. Murawski and
+ Igor Walukiewicz},
+ title = {Third-order {Idealized Algol} with iteration is decidable},
+ journal = {TCS},
+ volume = {390},
+ number = {2--3},
+ year = {2008},
+ pages = {214--229}
+}
+
+@inproceedings{DBLP:conf/icalp/GhicaM00,
+ author = {Dan R. Ghica and
+ Guy McCusker},
+ title = {Reasoning about {Idealized Algol} Using Regular Languages},
+ booktitle = {ICALP},
+ year = {2000}
+}
+
+@inproceedings{DBLP:conf/galop/Murawski05,
+ author = {Andrzej S. Murawski},
+ title = {Functions with local state: from regularity to undecidability},
+ booktitle = {GALOP},
+ year = {2005}
+}
+
+@inproceedings{DBLP:conf/icalp/MurawskiOW05,
+ author = {Andrzej S. Murawski and
+ C.-H. Luke Ong and
+ Igor Walukiewicz},
+ title = {{Idealized Algol} with Ground Recursion, and DPDA Equivalence},
+ booktitle = {ICALP 2005},
+ year = 2005
+}
+
+@article{murawski-rml-badvars,
+ author = {Andrzej S. Murawski},
+ title = {Functions with local state: regularity and undecidability},
+ journal = {TCS},
+ volume = {338},
+ number = {1--3},
+ year = {2005},
+ pages = {315--349}
+}
+
+@inproceedings{DBLP:conf/lics/McCusker96,
+ author = {Guy McCusker},
+ title = {Games and Full Abstraction for FPC},
+ booktitle = {LICS},
+ year = {1996},
+ pages = {174-183},
+ bibsource = {DBLP, http://dblp.uni-trier.de}
+}
+
+@inproceedings{DBLP:conf/fossacs/AbramskyJ03,
+ author = {Samson Abramsky and
+ Radha Jagadeesan},
+ title = {A Game Semantics for Generic Polymorphism},
+ booktitle = {Foundations of Software Science and Computational Structures,
+ 6th International Conference, FOSSACS 2003 Held as Part
+ of the Joint European Conference on Theory and Practice
+ of Software, ETAPS 2003, Warsaw, Poland, April 7-11, 2003,
+ Proceedings},
+ publisher = {Springer},
+ series = {Lecture Notes in Computer Science},
+ volume = {2620},
+ year = {2003},
+ pages = {1-22},
+ ee = {http://link.springer.de/link/service/series/0558/bibs/2620/26200001.htm},
+ bibsource = {DBLP, http://dblp.uni-trier.de}
+}
+
+@inproceedings{DBLP:conf/lics/LongoMS93,
+ author = {Giuseppe Longo and
+ Kathleen Milsted and
+ Sergei Soloviev},
+ title = {The Genericity Theorem and the Notion of Parametricity in
+ the Polymorphic lambda-calculus (Extended Abstract)},
+ booktitle = {LICS},
+ year = {1993}
+}
+
+@inproceedings{DBLP:conf/lics/AbramskyHM98,
+ author = {Samson Abramsky and
+ Kohei Honda and
+ Guy McCusker},
+ title = {A Fully Abstract Game Semantics for General References},
+ booktitle = {LICS},
+ year = {1998},
+}
+
+@inproceedings{abramsky-mccusker-lecturenotes,
+ author = {Samson Abramsky and
+ Guy McCusker},
+ title = {Game Semantics},
+ booktitle = {Proceedings of the 1997 Marktoberdorf Summer School},
+ year = {1998}
+}
+
+@inproceedings{DBLP:conf/lics/Hughes97,
+ author = {Dominic J. D. Hughes},
+ title = {Games and Definability for System F},
+ booktitle = {LICS},
+ year = {1997}
+}
+
+@Unpublished{laird:icalpsubmission,
+ author = {James Laird},
+ title = {Game Semantics for Call-by-Value Polymorphism},
+ note = {Manuscript},
+ month = {March},
+ year = 2010
+}
+
+
+
+@article{DBLP:journals/entcs/AbramskyM96,
+ author = {Samson Abramsky and
+ Guy McCusker},
+ title = {Linearity, Sharing and State: a fully abstract game semantics
+ for {Idealized Algol} with active expressions},
+ journal = {Electr. Notes Theor. Comput. Sci.},
+ volume = {3},
+ year = {1996}
+}
+
+@InProceedings{ohearn-reddy-95,
+ author = {Peter O'Hearn and Uday Reddy},
+ title = {Objects, Interference, and the {Y}oneda Embedding},
+ booktitle = {MFPS},
+ year = 1995}
+
+
+@InProceedings{pitts:96,
+ author = {Andrew M. Pitts},
+ title = {Reasoning about Local Variables with Operationally-Based Logical Relations},
+ booktitle = {LICS},
+ year = 1996}
+
+
+
+@InProceedings{sumii:csl09,
+ author = {Eijiro Sumii},
+ title = {A Complete Characterization of Observational Equivalence in Polymorphic $\lambda$-Calculus with General References},
+ booktitle = {CSL},
+ year = 2009}
+
+@inproceedings{sangiorgi+:lics07,
+ title = {Environmental Bisimulations for Higher-Order Languages},
+ author = {Davide Sangiorgi and Naoki Kobayashi and Eijiro Sumii},
+ booktitle = {LICS},
+ year = 2007,
+}
+
+@inproceedings{bohr-birkedal-2006,
+ author = "Nina Bohr and Lars Birkedal",
+ title = {Relational reasoning for recursive types and references},
+ booktitle = {APLAS},
+ year = 2006,
+}
+@PhdThesis{bohr:thesis,
+ author = {Nina Bohr},
+ title = {Advances in Reasoning Principles for Contextual Equivalence and Termination},
+ school = {IT University of Copenhagen},
+ year = {2007},
+}
+@article{sumii-pierce-jacm,
+ author = {Eijiro Sumii and Benjamin Pierce},
+ title = {A Bisimulation for Type Abstraction and Recursion},
+ journal = {Journal of the ACM},
+ volume = 54,
+ number = 5,
+ year = 2007,
+ pages = {1--43},
+}
+
+@inproceedings{koutavas-wand-2006,
+ author = {Vasileios Koutavas and Mitchell Wand},
+ title = {Small Bisimulations for Reasoning About Higher-Order Imperative Programs},
+ booktitle = {POPL},
+ year = {2006},
+}
+
+
+@PhDthesis{ahmed:thesis,
+ title = {Semantics of Types for Mutable State},
+ author = "Amal Ahmed",
+ school = "Princeton University",
+ year = 2004
+}
+
+@Article{johann+:impact,
+ author = {Patricia Johann and Janis Voigtl\"ander},
+ title = {The Impact of \emph{seq} on Free Theorems-Based Program Transformations},
+ journal = {Fundamenta Informaticae},
+ year = {2006},
+ volume = {69},
+ number = {1--2},
+ pages = {63--102},
+}
+
+@InProceedings{johann+:lics10,
+ author = {Patricia Johann and Alex Simpson and Janis Voigtl\"ander},
+ title = {A Generic Operational Metatheory for Algebraic Effects},
+ booktitle = {LICS},
+ year = {2010},
+}
+
+@InProceedings{laird:lics97,
+ author = {James Laird},
+ title = {Full Abstraction for Functional Languages with Control},
+ booktitle = {LICS},
+ year = {1997},
+}
+
+@Article{krivine:realize,
+ author = {Jean-Louis Krivine},
+ title = {Classical logic, storage operators and second-order lambda-calculus},
+ journal = {Annals of Pure and Applied Logic},
+ year = {1994},
+ volume = {68},
+ pages = {53--78},
+}
+
+@InProceedings{friedman-haynes,
+ author = {Daniel Friedman and Christopher Haynes},
+ title = {Constraining control},
+ booktitle = {POPL},
+ year = {1985},
+}
+
+@InProceedings{dreyer+:popl10,
+ author = {Derek Dreyer and Georg Neis and Andreas Rossberg and Lars Birkedal},
+ title = {A Relational Modal Logic for Higher-Order Stateful {ADTs}},
+ booktitle = {POPL},
+ year = {2010},
+}
+
+@Article{mason-talcott,
+ author = {Ian Mason and Carolyn Talcott},
+ title = {Equivalence in functional languages with effects},
+ journal = {JFP},
+ year = {1991},
+ volume = {1},
+ number = {3},
+ pages = {287--327},
+}
+
+@InProceedings{thielecke:esop00,
+ author = {Hayo Thielecke},
+ title = {On Exceptions versus Continuations in the Presence of State},
+ booktitle = {ESOP},
+ year = {2000},
+}
+
+
+@Article{johann:shortcut,
+ author = {Patricia Johann},
+ title = {Short Cut Fusion is Correct},
+ journal = {JFP},
+ year = {2003},
+ volume = {13},
+ number = {4},
+ pages = {797--814},
+}
+
+@InProceedings{neis+:icfp09,
+ author = {Georg Neis and Derek Dreyer and Andreas Rossberg},
+ title = {Non-Parametric Parametricity},
+ booktitle = {ICFP},
+ year = {2009},
+}
+
+@Article{neis+:jfp11,
+ author = {Georg Neis and Derek Dreyer and Andreas Rossberg},
+ title = {Non-Parametric Parametricity},
+ journal = {JFP},
+ year = {2011},
+ volume = {21},
+ number = {4\&5},
+ pages = {497--562},
+}
+
+@Article{dreyer+:lmcs11,
+ author = {Derek Dreyer and Amal Ahmed and Lars Birkedal},
+ title = {Logical Step-Indexed Logical Relations},
+ journal = {LMCS},
+ year = {2011},
+ volume = {7},
+ number = {2:16},
+ pages = {1--37},
+ month = jun,
+}
+
+@InProceedings{lassen:lics05,
+ author = {Soren Lassen},
+ title = {Eager Normal Form Bisimulation},
+ booktitle = {LICS},
+ year = {2005},
+}
+
+@inproceedings{reynolds-1983,
+ author = "John C. Reynolds",
+ title = "Types, abstraction and parametric polymorphism",
+ booktitle = "Information Processing",
+ year = 1983,
+}
+
+@Article{pierce-sangiorgi,
+ author = {Benjamin C. Pierce and Davide Sangiorgi},
+ title = {Behavioral Equivalence in the Polymorphic Pi-Calculus},
+ journal = {Journal of the ACM},
+ year = {2000},
+ volume = {47},
+ number = {3},
+ pages = {531--586},
+}
+
+@InProceedings{gotsman+:aplas07,
+ author = {Alexey Gotsman and Josh Berdine and Byron Cook and Noam Rinetzky and Mooly Sagiv},
+ title = {Local Reasoning About Storable Locks and Threads},
+ booktitle = {APLAS},
+ year = {2007},
+}
+
+@InProceedings{buisse+:mfps11,
+ author = {Alexandre Buisse and Lars Birkedal and Kristian St\o{}vring},
+ title = {A Step-Indexed {Kripke} Model of Separation Logic for Storable Locks},
+ booktitle = {MFPS},
+ year = {2011},
+}
+
+@Article{sangiorgi:lazy-lambda,
+ author = {Davide Sangiorgi},
+ title = {The Lazy Lambda Calculus in a Concurrency Scenario},
+ journal = {Information and Computation},
+ year = {1994},
+ volume = {111},
+ number = {1},
+ pages = {120--153},
+}
+
+@inproceedings{wadler:free-theorems,
+ author = "Philip Wadler",
+ title = "Theorems for free!",
+ booktitle = {FPCA},
+ year = 1989,
+}
+
+@InProceedings{birkedal+:lics11,
+ author = {Lars Birkedal and Rasmus Ejlers M\o{}gelberg and Jan Schwinghammer and Kristian St\o{}vring},
+ title = {First steps in synthetic guarded domain theory: step-indexing in the topos of trees},
+ booktitle = {LICS},
+ year = {2011},
+
+
+}
+
+@InProceedings{ahmed+:icfp11,
+ author = {Amal Ahmed and Matthias Blume},
+ title = {An Equivalence-Preserving {CPS} Translation via Multi-Language Semantics},
+ booktitle = {ICFP},
+ year = 2011,
+}
+
+
+@Article{uustalu+:njc99,
+ author = {Tarmo Uustalu and Varmo Vene},
+ title = {Mendler-style Inductive Types, Categorically},
+ journal = {Nordic Journal of Computing},
+ year = {1999},
+ volume = {6},
+ number = {3},
+ pages = {343--361},
+}
+
+
+@Article{mendler:pal91,
+ author = {Nax P. Mendler},
+ title = {Inductive Types and Type Constraints in the Second-Order Lambda-Calculus},
+ journal = {Annals of Pure and Applied Logic},
+ year = {1991},
+ volume = {51},
+ number = {1--2},
+ pages = {159--172},
+}
+
+
+@InProceedings{koutavas+:mfps11,
+ author = {Vasileios Koutavas and Paul Blain Levy and Eijiro Sumii},
+ title = {From Applicative to Environmental Bisimulation},
+ booktitle = {MFPS},
+ year = 2011,
+}
+
+
+@InCollection{abramsky:applicative,
+ author = {Samson Abramsky},
+ title = {The Lazy Lambda Calculus},
+ booktitle = {Research Topics in Functional Programming},
+ pages = {65--117},
+ editor = {D. A. Turner},
+ year = 1990,
+}
+
+
+@InProceedings{vafeiadis:mfps11,
+ author = {Viktor Vafeiadis},
+ title = {Concurrent separation logic and operational semantics},
+ booktitle = {MFPS},
+ year = 2011,
+}
+
+
+
+@InProceedings{hur+:popl12,
+ author = {Chung-Kil Hur and Derek Dreyer and Georg Neis and Viktor Vafeiadis},
+ title = {The Marriage of Bisimulations and {Kripke} Logical Relations},
+ booktitle = {POPL},
+ year = {2012},
+}
+
+
+@InProceedings{le+:pldi14,
+ author = {Vu Le and Mehrdad Afshari and Zhengdong Su},
+ title = {Compiler Validation via Equivalence Modulo Inputs},
+ booktitle = {PLDI},
+ year = {2014},
+}
+
+
+@Article{leroy:compcert,
+ author = {Xavier Leroy},
+ title = {A formally verified compiler back-end},
+ journal = {Journal of Automated Reasoning},
+ year = {2009},
+ volume = {43},
+ number = {4},
+ pages = {363--446},
+}
+
+
+@InProceedings{perconti+:esop14,
+ author = {James T. Perconti and Amal Ahmed},
+ title = {Verifying an Open Compiler Using Multi-Language Semantics},
+ booktitle = {ESOP},
+ year = {2014},
+}
+
+
+@InProceedings{matthews+:popl07,
+ author = {Jacob Matthews and Robert Bruce Findler},
+ title = {Operational Semantics for Multi-Language Programs},
+ booktitle = {POPL},
+ year = {2007},
+}
+
+
+@InProceedings{beringer+:esop14,
+ author = {Lennart Beringer and Gordon Stewart and Robert Dockins and Andrew W. Appel},
+ title = {Verified Compilation for Shared-Memory {C}},
+ booktitle = {ESOP},
+ year = {2014},
+}
+
+@inproceedings{caresl,
+ title={Unifying refinement and {Hoare}-style reasoning in a logic for higher-order concurrency},
+ author={Aaron Turon and Derek Dreyer and Lars Birkedal},
+ booktitle={ICFP},
+ year={2013},
+}
+@InProceedings{fcsl,
+ author = {Aleksandar Nanevski and Ruy Ley-Wild and Ilya Sergey and Germ\'an Andr\'es Delbianco},
+ title = {Communicating State Transition Systems for Fine-Grained Concurrent Resources},
+ booktitle = {ESOP},
+ year = {2014},
+}
+@InProceedings{tada,
+ author = {Pedro {da Rocha Pinto} and Thomas Dinsdale-Young and Philippa Gardner},
+ title = {{TaDA}: A Logic for Time and Data Abstraction},
+ booktitle = {ECOOP},
+ year = {2014},
+}
+@InProceedings{icap,
+ author = {Kasper Svendsen and Lars Birkedal},
+ title = {Impredicative Concurrent Abstract Predicates},
+ booktitle = {ESOP},
+ year = {2014},
+}
+
+@InProceedings{krishnaswami+:icfp12,
+ author = {Neelakantan R. Krishnaswami and Aaron Turon and Derek Dreyer and Deepak Garg},
+ title = {Superficially substructural types},
+ booktitle = {ICFP},
+ year = {2012},
+}
+@inproceedings{cap,
+ title={Concurrent abstract predicates},
+ author={Dinsdale-Young, T. and Dodds, M. and Gardner, P. and Parkinson, M.
+ and Vafeiadis, V.},
+ booktitle={ECOOP},
+ year={2010},
+}
+@inproceedings{scsl,
+author = {Ley-Wild, Ruy and Nanevski, Aleksandar},
+booktitle = {POPL},
+title = {Subjective Auxiliary State for Coarse-Grained Concurrency},
+year = {2013}
+}
+
+@InProceedings{views,
+ author = {Thomas Dinsdale-Young and Lars Birkedal and Philippa Gardner and Matthew J. Parkinson and Hongseok Yang},
+ title = {Views: Compositional reasoning for concurrent programs},
+ booktitle = {POPL},
+ year = {2013},
+}
+
+@article{rg,
+ author = {Jones, C. B.},
+ title = {Tentative steps toward a development method for interfering programs},
+ journal = {TOPLAS},
+ volume = {5},
+ number = {4},
+ year = {1983},
+ pages = {596--619},
+ publisher = {ACM},
+ }
+
+@inproceedings{lrg,
+ author = {Feng, Xinyu},
+ title = {Local rely-guarantee reasoning},
+ booktitle = {POPL},
+ year = {2009}
+ }
+
+@inproceedings{rgsep,
+ title={A marriage of rely/guarantee and separation logic},
+ author={Vafeiadis, V. and Parkinson, M.},
+ booktitle={CONCUR},
+ year={2007},
+}
+
+@InProceedings{Parkinson+:popl07,
+ author={Matthew J. Parkinson and Richard Bornat and Peter W. O'Hearn},
+ title={Modular verification of a non-blocking stack},
+ booktitle={POPL},
+ year={2007},
+}
+
+@article{ohearn:csl,
+ title={Resources, concurrency, and local reasoning},
+ author={O'Hearn, P.W.},
+ journal={TCS},
+ volume={375},
+ number={1},
+ pages={271--307},
+ year={2007},
+}
+
+@InProceedings{Elmas+:tacas10,
+ author={Tayfun Elmas and Shaz Qadeer and Ali Sezgin and Omer Subasi and Serdar Tasiran},
+ title={Simplifying Linearizability Proofs with Reduction and Abstraction},
+ booktitle={TACAS},
+ year={2010},
+}
+
+@InProceedings{Elmas+:popl09,
+ author={Tayfun Elmas and Shaz Qadeer and Serdar Tasiran},
+ title={A calculus of atomic actions},
+ booktitle={POPL},
+ year={2009},
+}
+
+@article{linearizability,
+ author = {Herlihy, Maurice P. and Wing, Jeannette M.},
+ title = {Linearizability: a correctness condition for concurrent objects},
+ journal = {TOPLAS},
+ volume = {12},
+ number = {3},
+ year = {1990},
+ pages = {463--492},
+ publisher = {ACM},
+ }
+
+@inproceedings{blaming,
+ title = {Blaming the client: On data refinement in the presence of pointers},
+ author = {Filipovi\'{c}, Ivana and O’Hearn, Peter and Torp-Smith, Noah and Yang, Hongseok},
+ year = 2009,
+ booktitle = {FACS},
+}
+
+@InProceedings{jacobs-piessens,
+ author = {Bart Jacobs and Frank Piessens},
+ title = {Expressive modular fine-grained concurrency specification},
+ booktitle = {POPL},
+ year = 2011,
+}
+
+@Misc{Jacobs:personalcommunication2014,
+ author = {Bart Jacobs},
+ title = {Personal communication},
+ year = {2014},
+}
+
+@InProceedings{turon+:popl13,
+ author = {Aaron Turon and Jacob Thamsborg and Amal Ahmed and Lars Birkedal and Derek Dreyer},
+ title = {Logical relations for fine-grained concurrency},
+ booktitle = {POPL},
+ year = {2013},
+}
+
+@InProceedings{elimination-stack,
+ author = {D. Hendler and N. Shavit and L. Yerushalmi},
+ title = {A Scalable Lock-Free Stack Algorithm},
+ booktitle = {SPAA},
+ year = 2004
+}
+
+@Article{lamport:sc,
+ author={Leslie Lamport},
+ title={How to Make a Multiprocessor Computer That Correctly Executes Multiprocess Programs},
+ journal={IEEE Trans.\ Comput.},
+ year={1979},
+ volume={28},
+ number={9},
+ pages={690--691},
+}
+
+@InProceedings{sagl,
+ author = {Xinyu Feng and Rodrigo Ferreira and Zhong Shao},
+ title = {On the relationship between concurrent separation logic and assume-guarantee reasoning},
+ booktitle = {ESOP},
+ year = {2007},
+}
+
+
+@Article{owicki-gries:ghost-state,
+ author = {Susan Owicki and David Gries},
+ title = {Verifying Properties of Parallel Programs: An Axiomatic Approach},
+ journal = {CACM},
+ year = {1976},
+ volume = {19},
+ number = {5},
+ pages = {279--285},
+}
+
+@InProceedings{cohen+:imr,
+ author = {Cohen, Ernie and Alkassar, Eyad and Boyarinov, Vladimir and Dahlweid, Markus and Degenbaev, Ulan and Hillebrand, Mark and Langenstein, Bruno and Leinenbach, Dirk and Moskal, Micha\l and Obua, Steven and Paul, Wolfgang and Pentchev, Hristo and Petrova, Elena and Santen, Thomas and Schirmer, Norbert and Schmaltz, Sabine and Schulte, Wolfram and Shadrin, Andrey and Tobies, Stephan and Tsyban, Alexandra and Tverdyshev, Sergey},
+ title = {Invariants, Modularity, and Rights},
+ booktitle = {PSI},
+ year = {2009},
+}
+
+@Article{ashcroft:invariants,
+ author = {Edward A. Ashcroft},
+ title = {Proving assertions about parallel programs},
+ journal = {J. Comput. Syst. Sci.},
+ year = {1975},
+ volume = {10},
+ number = {1},
+ pages = {110--135},
+}
+
+@PhdThesis{vafeiadis-thesis,
+ author = {Viktor Vafeiadis},
+ title = {Modular fine-grained concurrency verification},
+ school = {University of Cambridge},
+ year = {2007},
+}
+
+@article{abadi+:speculation,
+ author = {Mart{\'{\i}}n Abadi and
+ Leslie Lamport},
+ title = {The Existence of Refinement Mappings},
+ journal = {TCS},
+ year = {1991},
+ volume = {82},
+ number = {2},
+ pages = {253--284},
+ url = {http://dx.doi.org/10.1016/0304-3975(91)90224-P},
+ doi = {10.1016/0304-3975(91)90224-P},
+ timestamp = {Wed, 29 Oct 2014 20:04:49 +0100},
+ biburl = {http://dblp.uni-trier.de/rec/bib/journals/tcs/AbadiL91},
+ bibsource = {dblp computer science bibliography, http://dblp.org}
+}
+
+@inproceedings{hocap,
+ author = {Kasper Svendsen and
+ Lars Birkedal and
+ Matthew J. Parkinson},
+ title = {Modular Reasoning about Separation of Concurrent Data Structures},
+ booktitle = {{ESOP}},
+ pages = {169--188},
+ year = {2013},
+ timestamp = {Mon, 18 Feb 2013 15:03:29 +0100},
+ biburl = {http://dblp.uni-trier.de/rec/bib/conf/esop/SvendsenBP13},
+ bibsource = {dblp computer science bibliography, http://dblp.org}
+}
+
+@report{catlogic,
+ author = {Lars Birkedal and Ale\v{s} Bizjak},
+ title = {A Taste of Categorical Logic --- Tutorial Notes},
+ month = oct,
+ year = {2014},
+ note = {Available at \url{http://users-cs.au.dk/birke/modures/tutorial/categorical-logic-tutorial-notes.pdf}}
+}
+
diff --git a/docs/constructions.tex b/docs/constructions.tex
new file mode 100644
index 0000000000000000000000000000000000000000..90aa83e42730cf95200010db9c576553a6b9de1e
--- /dev/null
+++ b/docs/constructions.tex
@@ -0,0 +1,386 @@
+% !TEX root = ./appendix.tex
+
+\section{Monoid constructions}
+
+We will use the notation $\mcarp{M} \eqdef |M| \setminus \{\mzero_M\}$ for the carrier of monoid $M$ without zero. When we define a carrier, a zero element is always implicitly added (we do not explicitly give it), and all cases of multiplication that are not defined (including those involving a zero element) go to that element.
+
+To disambiguate which monoid an element is part of, we use the notation $a : M$ to denote an $a$ s.t.\ $a \in |M|$.
+
+When defining a monoid, we will show some \emph{frame-preserving updates} $\melt \mupd \meltsB$ that it supports.
+Remember that
+\[
+ \melt \mupd \meltsB \eqdef \always\All \melt_f. \melt \sep \melt_f \Ra \Exists \meltB \in \meltsB. \meltB \sep \melt_f.
+\]
+The rule \ruleref{FpUpd} (and, later, \ruleref{GhostUpd}) allows us to use such updates in Hoare proofs.
+The following principles generally hold for frame-preserving updates.
+\begin{mathpar}
+ \infer{
+ \melt \mupd \meltsB
+ }{
+ \melt \mupd \meltsB \cup \meltsB'
+ }
+ \and
+ \infer{
+ \melt \mupd \meltsB
+ }{
+ \melt \mtimes \melt_f \mupd \{ \meltB \mtimes \melt_f \mid \meltB \in \meltsB \}
+ }
+\end{mathpar}
+
+Some of our constructions require or preserve \emph{cancellativity}:
+\[
+ \text{$\monoid$ cancellative} \eqdef
+ \All \melt_f, \melt, \meltB \in \mcar{\monoid}. \melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero \Ra \melt = \meltB
+\]
+
+
+\subsection{Exclusive monoid}
+
+Given a set $X$, we define a monoid such that at most one $x \in X$ can be owned.
+Let $\exm{X}$ be the monoid with carrier $X \uplus \{ \munit \}$ and multiplication
+\[
+\melt \cdot \meltB \;\eqdef\;
+\begin{cases}
+ \melt & \mbox{if } \meltB = \munit \\
+ \meltB & \mbox{if } \melt = \munit
+\end{cases}
+\]
+
+The frame-preserving update
+\begin{mathpar}
+\inferH{ExUpd}
+ {x \in X}
+ {x \mupd \melt}
+\end{mathpar}
+is easily shown, as the only possible frame for $x$ is $\munit$.
+
+Exclusive monoids are cancellative.
+\begin{proof}[Proof of cancellativity]
+If $\melt_f = \munit$, then the statement is trivial.
+If $\melt_f \neq \munit$, then we must have $\melt = \meltB = \munit$, as otherwise one of the two products would be $\mzero$.
+\end{proof}
+
+\subsection{Agreement monoid}
+
+Given a set $X$, we define a monoid such that everybody agrees on which $x \in X$ has been chosen.
+Let $\agm{X}$ be the monoid with carrier $X \uplus \{ \munit \}$ and multiplication
+\[
+\melt \cdot \meltB \;\eqdef\;
+\begin{cases}
+\melt & \mbox{if } \meltB = \munit \lor \melt = \meltB \\
+\meltB & \mbox{if } \melt = \munit
+\end{cases}
+\]
+
+Agreement monoids are cancellative.
+\begin{proof}[Proof of cancellativity]
+ If $\melt_f = \munit$, then the statement is trivial.
+ If $\melt_f \neq \munit$, then if $\melt = \munit$, we must have $\meltB = \munit$ and we are done.
+ Similar so for $\meltB = \munit$.
+ So let $\melt \neq \munit \neq \meltB$ and $\melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero$.
+ It follows immediately that $\melt = \melt_f = \meltB$.
+\end{proof}
+
+\subsection{Finite Powerset Monoid}
+
+Given an infinite set $X$, we define a monoid $\textmon{PowFin}$ with carrier $\mathcal{P}^{\textrm{fin}}(X)$ as follows:
+\[
+\melt \cdot \meltB \;\eqdef\; \melt \cup \meltB \quad \mbox{if } \melt \cap \meltB = \emptyset
+\]
+
+We obtain:
+\begin{mathpar}
+ \inferH{PowFinUpd}{}
+ {\emptyset \mupd \{ \{x\} \mid x \in X \}}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{PowFinUpd}]
+ Assume some frame $\melt_f \sep \emptyset$. Since $\melt_f$ is finite and $X$ is infinite, there exists an $x \notin \melt_f$.
+ Pick that for the result.
+\end{proof}
+
+The powerset monoids is cancellative.
+\begin{proof}[Proof of cancellativity]
+ Let $\melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero$.
+ So we have $\melt_f \sep \melt$ and $\melt_f \sep \meltB$, and we have to show $\melt = \meltB$.
+ Assume $x \in \melt$. Hence $x \in \melt_f \mtimes \melt$ and thus $x \in \melt_f \mtimes \meltB$.
+ By disjointness, $x \notin \melt_f$ and hence $x \in meltB$.
+ The other direction works the same way.
+\end{proof}
+
+\subsection{Product monoid}
+\label{sec:prodm}
+
+Given a family $(M_i)_{i \in I}$ of monoids ($I$ countable), we construct a product monoid.
+Let $\prod_{i \in I} M_i$ be the monoid with carrier $\prod_{i \in I} \mcarp{M_i}$ and point-wise multiplication, non-zero when \emph{all} individual multiplications are non-zero.
+For $f \in \prod_{i \in I} \mcarp{M_i}$, we write $f[i \mapsto a]$ for the disjoint union $f \uplus [i \mapsto a]$.
+
+Frame-preserving updates on the $M_i$ lift to the product:
+\begin{mathpar}
+ \inferH{ProdUpd}
+ {a \mupd_{M_i} B}
+ {f[i \mapsto a] \mupd \{ f[i \mapsto b] \mid b \in B\}}
+\end{mathpar}
+\begin{proof}[Proof of \ruleref{ProdUpd}]
+Assume some frame $g$ and let $c \eqdef g(i)$.
+Since $f[i \mapsto a] \sep g$, we get $f \sep g$ and $a \sep_{M_i} c$.
+Thus there exists $b \in B$ such that $b \sep_{M_i} c$.
+It suffices to show $f[i \mapsto b] \sep g$.
+Since multiplication is defined pointwise, this is the case if all components are compatible.
+For $i$, we know this from $b \sep_{M_i} c$.
+For all the other components, from $f \sep g$.
+\end{proof}
+
+If every $M_i$ is cancellative, then so is $\prod_{i \in I} M_i$.
+\begin{proof}[Proof of cancellativity]
+Let $\melt, \meltB, \melt_f \in \prod_{i \in I} \mcarp{M_i}$, and assume $\melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero$.
+By the definition of multiplication, this means that for all $i \in I$ we have $\melt_f(i) \mtimes \melt(i) = \melt_f(i) \mtimes \meltB(i) \neq \mzero_{M_i}$.
+As all base monoids are cancellative, we obtain $\forall i \in I.\; \melt(i) = \meltB(i)$ from which we immediately get $\melt = \meltB$.
+\end{proof}
+
+\subsection{Fractional monoid}
+\label{sec:fracm}
+
+Given a monoid $M$, we define a monoid representing fractional ownership of some piece $\melt \in M$.
+The idea is to preserve all the frame-preserving update that $M$ could have, while additionally being able to do \emph{any} update if we own the full state (as determined by the fraction being $1$).
+Let $\fracm{M}$ be the monoid with carrier $(((0, 1] \cap \mathbb{Q}) \times M) \uplus \{\munit\}$ and multiplication
+\begin{align*}
+ (q, a) \mtimes (q', a') &\eqdef (q + q', a \mtimes a') \qquad \mbox{if $q+q'\le 1$} \\
+ (q, a) \mtimes \munit &\eqdef (q,a) \\
+ \munit \mtimes (q,a) &\eqdef (q,a).
+\end{align*}
+
+We get the following frame-preserving update.
+\begin{mathpar}
+ \inferH{FracUpdFull}
+ {a, b \in M}
+ {(1, a) \mupd (1, b)}
+ \and\inferH{FracUpdLocal}
+ {a \mupd_M B}
+ {(q, a) \mupd \{q\} \times B}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{FracUpdFull}]
+Assume some $f \sep (1, a)$. This can only be $f = \munit$, so showing $f \sep (1, b)$ is trivial.
+\end{proof}
+
+\begin{proof}[Proof of \ruleref{FracUpdLocal}]
+ Assume some $f \sep (q, a)$. If $f = \munit$, then $f \sep (q, b)$ is trivial for any $b \in B$. Just pick the one we obtain by choosing $\munit_M$ as the frame for $a$.
+
+ In the interesting case, we have $f = (q_f, a_f)$.
+ Obtain $b$ such that $b \in B \land b \sep a_f$.
+ Then $(q, b) \sep f$, and we are done.
+\end{proof}
+
+$\fracm{M}$ is cancellative if $M$ is cancellative.
+\begin{proof}[Proof of cancellativitiy]
+If $\melt_f = \munit$, we are trivially done.
+So let $\melt_f = (q_f, \melt_f')$.
+If $\melt = \munit$, then $\meltB = \munit$ as otherwise the fractions could not match up.
+Again, we are trivially done.
+Similar so for $\meltB = \munit$.
+So let $\melt = (q_a, \melt')$ and $\meltB = (q_b, \meltB')$.
+We have $(q_f + q_a, \melt_f' \mtimes \melt') = (q_f + q_b, \melt_f' \mtimes \meltB')$.
+We have to show $q_a = q_b$ and $\melt' = \meltB'$.
+The first is trivial, the second follows from cancellativitiy of $M$.
+\end{proof}
+
+\subsection{Finite partial function monoid}
+\label{sec:fpfunm}
+
+Given a countable set $X$ and a monoid $M$, we construct a monoid representing finite partial functions from $X$ to (non-unit, non-zero elements of) $M$.
+Let $\fpfunm{X}{M}$ be the product monoid $\prod_{x \in X} M$, as defined in \secref{sec:prodm} but restricting the carrier to functions $f$ where the set $\dom(f) \eqdef \{ x \mid f(x) \neq \munit_M \}$ is finite.
+This is well-defined as the set of these $f$ contains the unit and is closed under multiplication.
+(We identify finite partial functions from $X$ to $\mcarp{M}\setminus\{\munit_M\}$ and total functions from $X$ to $\mcarp{M}$ with finite $\munit_M$-support.)
+
+We use two frame-preserving updates:
+\begin{mathpar}
+ \inferH{FpFunAlloc}
+ {a \in \mcarp{M}}
+ {f \mupd \{ f[x \mapsto a] \mid x \notin \dom(f) \}}
+ \and
+ \inferH{FpFunUpd}
+ {a \mupd_M B}
+ {f[i \mapsto a] \mupd \{ f[i \mapsto b] \mid b \in B\}}
+\end{mathpar}
+Rule \ruleref{FpFunUpd} simply restates \ruleref{ProdUpd}.
+
+\begin{proof}[Proof of \ruleref{FpFunAlloc}]
+ Assume some $g \sep f$. Since $\dom(f \mtimes g)$ is finite, there will be some undefined element $x \notin \dom(f \mtimes g)$. Let $f' \eqdef f[x \mapsto a]$. This is compatible with $g$, so we are done.
+\end{proof}
+
+We write $[x \mapsto a]$ for the function mapping $x$ to $a$ and everything else in $X$ to $\munit$.
+
+%\subsection{Disposable monoid}
+%
+%Given a monoid $M$, we construct a monoid where, having full ownership of an element $\melt$ of $M$, one can throw it away, transitioning to a dead element.
+%Let \dispm{M} be the monoid with carrier $\mcarp{M} \uplus \{ \disposed \}$ and multiplication
+%% The previous unit must remain the unit of the new monoid, as is is always duplicable and hence we could not transition to \disposed if it were not composable with \disposed
+%\begin{align*}
+% \melt \mtimes \meltB &\eqdef \melt \mtimes_M \meltB & \IF \melt \sep[M] \meltB \\
+% \disposed \mtimes \disposed &\eqdef \disposed \\
+% \munit_M \mtimes \disposed &\eqdef \disposed \mtimes \munit_M \eqdef \disposed
+%\end{align*}
+%The unit is the same as in $M$.
+%
+%The frame-preserving updates are
+%\begin{mathpar}
+% \inferH{DispUpd}
+% {a \in \mcarp{M} \setminus \{\munit_M\} \and a \mupd_M B}
+% {a \mupd B}
+% \and
+% \inferH{Dispose}
+% {a \in \mcarp{M} \setminus \{\munit_M\} \and \All b \in \mcarp{M}. a \sep b \Ra b = \munit_M}
+% {a \mupd \disposed}
+%\end{mathpar}
+%
+%\begin{proof}[Proof of \ruleref{DispUpd}]
+%Assume a frame $f$. If $f = \disposed$, then $a = \munit_M$, which is a contradiction.
+%Thus $f \in \mcarp{M}$ and we can use $a \mupd_M B$.
+%\end{proof}
+%
+%\begin{proof}[Proof of \ruleref{Dispose}]
+%The second premiss says that $a$ has no non-trivial frame in $M$. To show the update, assume a frame $f$ in $\dispm{M}$. Like above, we get $f \in \mcarp{M}$, and thus $f = \munit_M$. But $\disposed \sep \munit_M$ is trivial, so we are done.
+%\end{proof}
+
+\subsection{Authoritative monoid}\label{sec:auth}
+
+Given a monoid $M$, we construct a monoid modeling someone owning an \emph{authoritative} element $x$ of $M$, and others potentially owning fragments $\melt \le_M x$ of $x$.
+(If $M$ is an exclusive monoid, the construction is very similar to a half-ownership monoid with two asymmetric halves.)
+Let $\auth{M}$ be the monoid with carrier
+\[
+ \SET{ (x, \melt) }{ x \in \mcarp{\exm{\mcarp{M}}} \land \melt \in \mcarp{M} \land (x = \munit_{\exm{\mcarp{M}}} \lor \melt \leq_M x) }
+\]
+and multiplication
+\[
+(x, \melt) \mtimes (y, \meltB) \eqdef
+ (x \mtimes y, \melt \mtimes \meltB) \quad \mbox{if } x \sep y \land \melt \sep \meltB \land (x \mtimes y = \munit_{\exm{\mcarp{M}}} \lor \melt \mtimes \meltB \leq_M x \mtimes y)
+\]
+Note that $(\munit_{\exm{\mcarp{M}}}, \munit_M)$ is the unit and asserts no ownership whatsoever, but $(\munit_{M}, \munit_M)$ asserts that the authoritative element is $\munit_M$.
+
+Let $x, \melt \in \mcarp M$.
+We write $\authfull x$ for full ownership $(x, \munit_M):\auth{M}$ and $\authfrag \melt$ for fragmental ownership $(\munit_{\exm{\mcarp{M}}}, \melt)$ and $\authfull x , \authfrag \melt$ for combined ownership $(x, \melt)$.
+If $x$ or $a$ is $\mzero_{M}$, then the sugar denotes $\mzero_{\auth{M}}$.
+
+\ralf{This needs syncing with the Coq development.}
+The frame-preserving update involves a rather unwieldy side-condition:
+\begin{mathpar}
+ \inferH{AuthUpd}{
+ \All\melt_f\in\mcar{\monoid}. \melt\sep\meltB \land \melt\mtimes\melt_f \le \meltB\mtimes\melt_f \Ra \melt'\mtimes\melt_f \le \melt'\mtimes\meltB \and
+ \melt' \sep \meltB
+ }{
+ \authfull \melt \mtimes \meltB, \authfrag \melt \mupd \authfull \melt' \mtimes \meltB, \authfrag \melt'
+ }
+\end{mathpar}
+We therefore derive two special cases.
+
+\paragraph{Local frame-preserving updates.}
+
+\newcommand\authupd{f}%
+Following~\cite{scsl}, we say that $\authupd: \mcar{M} \ra \mcar{M}$ is \emph{local} if
+\[
+ \All a, b \in \mcar{M}. a \sep b \land \authupd(a) \neq \mzero \Ra \authupd(a \mtimes b) = \authupd(a) \mtimes b
+\]
+Then,
+\begin{mathpar}
+ \inferH{AuthUpdLocal}
+ {\text{$\authupd$ local} \and \authupd(\melt)\sep\meltB}
+ {\authfull \melt \mtimes \meltB, \authfrag \melt \mupd \authfull \authupd(\melt) \mtimes \meltB, \authfrag \authupd(\melt)}
+\end{mathpar}
+
+\paragraph{Frame-preserving updates on cancellative monoids.}
+
+Frame-preserving updates are also possible if we assume $M$ cancellative:
+\begin{mathpar}
+ \inferH{AuthUpdCancel}
+ {\text{$M$ cancellative} \and \melt'\sep\meltB}
+ {\authfull \melt \mtimes \meltB, \authfrag \melt \mupd \authfull \melt' \mtimes \meltB, \authfrag \melt'}
+\end{mathpar}
+
+\subsection{Fractional heap monoid}
+\label{sec:fheapm}
+
+By combining the fractional, finite partial function, and authoritative monoids, we construct two flavors of heaps with fractional permissions and mention their important frame-preserving updates.
+Hereinafter, we assume the set $\textdom{Val}$ of values is countable.
+
+Given a set $Y$, define $\FHeap(Y) \eqdef \fpfunm{\textdom{Val}}{\fracm{Y}}$ representing a fractional heap with codomain $Y$.
+From \S\S\ref{sec:fracm} and~\ref{sec:fpfunm} we obtain the following frame-preserving updates as well as the fact that $\FHeap(Y)$ is cancellative.
+\begin{mathpar}
+ \axiomH{FHeapUpd}{h[x \mapsto (1, y)] \mupd h[x \mapsto (1, y')]} \and
+ \axiomH{FHeapAlloc}{h \mupd \{\, h[x \mapsto (1, y)] \mid x \in \textdom{Val} \,\}}
+\end{mathpar}
+We will write $qh$ with $h : \textsort{Val} \fpfn Y$ for the function in $\FHeap(Y)$ mapping every $x \in \dom(h)$ to $(q, h(x))$, and everything else to $\munit$.
+
+Define $\AFHeap(Y) \eqdef \auth{\FHeap(Y)}$ representing an authoritative fractional heap with codomain $Y$.
+We easily obtain the following frame-preserving updates.
+\begin{mathpar}
+ \axiomH{AFHeapUpd}{
+ (\authfull h[x \mapsto (1, y)], \authfrag [x \mapsto (1, y)]) \mupd (\authfull h[x \mapsto (1, y')], \authfrag [x \mapsto (1, y')])
+ }
+ \and
+ \inferH{AFHeapAdd}{
+ x \notin \dom(h)
+ }{
+ \authfull h \mupd (\authfull h[x \mapsto (q, y)], \authfrag [x \mapsto (q, y)])
+ }
+ \and
+ \axiomH{AFHeapRemove}{
+ (\authfull h[x \mapsto (q, y)], \authfrag [x \mapsto (q, y)]) \mupd \authfull h
+ }
+\end{mathpar}
+
+\subsection{STS with tokens monoid}
+\label{sec:stsmon}
+
+\ralf{This needs syncing with the Coq development.}
+
+Given a state-transition system~(STS) $(\STSS, \ra)$, a set of tokens $\STSS$, and a labeling $\STSL: \STSS \ra \mathcal{P}(\STST)$ of \emph{protocol-owned} tokens for each state, we construct a monoid modeling an authoritative current state and permitting transitions given a \emph{bound} on the current state and a set of \emph{locally-owned} tokens.
+
+The construction follows the idea of STSs as described in CaReSL \cite{caresl}.
+We first lift the transition relation to $\STSS \times \mathcal{P}(\STST)$ (implementing a \emph{law of token conservation}) and define upwards closure:
+\begin{align*}
+ (s, T) \ra (s', T') \eqdef&\, s \ra s' \land \STSL(s) \uplus T = \STSL(s') \uplus T' \\
+ \textsf{frame}(s, T) \eqdef&\, (s, \STST \setminus (\STSL(s) \uplus T)) \\
+ \upclose(S, T) \eqdef&\, \SET{ s' \in \STSS}{\exists s \in S.\; \textsf{frame}(s, T) \ststrans \textsf{frame}(s', T) }
+\end{align*}
+
+\noindent
+We have
+\begin{quote}
+ If $(s, T) \ra (s', T')$\\
+ and $T_f \sep (T \uplus \STSL(s))$,\\
+ then $\textsf{frame}(s, T_f) \ra \textsf{frame}(s', T_f)$.
+\end{quote}
+\begin{proof}
+This follows directly by framing the tokens in $\STST \setminus (T_f \uplus T \uplus \STSL(s))$ around the given transition, which yields $(s, \STST \setminus (T_f \uplus \STSL{T}(s))) \ra (s', T' \uplus (\STST \setminus (T_f \uplus T \uplus \STSL{T}(s))))$.
+This is exactly what we have to show, since we know $\STSL(s) \uplus T = \STSL(s') \uplus T'$.
+\end{proof}
+
+Let $\STSMon{\STSS}$ be the monoid with carrier
+\[
+ \SET{ (s, S, T) \in \exm{\STSS} \times \mathcal{P}(\STSS) \times \mathcal{P}(\STST) }{ \begin{aligned} &(s = \munit \lor s \in S) \land \upclose(S, T) = S \land{} \\& S \neq \emptyset \land \All s \in S. \STSL(s) \sep T \end{aligned} }
+\]
+and multiplication
+\[
+ (s, S, T) \mtimes (s', S', T') \eqdef (s'' \eqdef s \mtimes_{\exm{\STSS}} s', S'' \eqdef S \cap S', T'' \eqdef T \cup T') \quad \text{if }\begin{aligned}[t] &(s = \munit \lor s' = \munit) \land T \sep T' \land{} \\& S'' \neq \emptyset \land (s'' \neq \munit \Ra s'' \in S'') \end{aligned}
+\]
+
+Some sugar makes it more convenient to assert being at least in a certain state and owning some tokens: $(s, T) : \STSMon{\STSS} \eqdef (\munit, \upclose(\{s\}, T), T) : \STSMon{\STSS}$, and
+$s : \STSMon{\STSS} \eqdef (s, \emptyset) : \STSMon{\STSS}$.
+
+We will need the following frame-preserving update.
+\begin{mathpar}
+ \inferH{StsStep}{(s, T) \ststrans (s', T')}
+ {(s, S, T) \mupd (s', \upclose(\{s'\}, T'), T')}
+\end{mathpar}
+\begin{proof}[Proof of \ruleref{StsStep}]
+Assume some upwards-closed $S_f, T_f$ (the frame cannot be authoritative) s.t.\ $s \in S_f$ and $T_f \sep (T \uplus \STSL(s))$. We have to show that this frame combines with our final monoid element, which is the case if $s' \in S_f$ and $T_f \sep T'$.
+By upward-closedness, it suffices to show $\textsf{frame}(s, T_f) \ststrans \textsf{frame}(s', T_f)$.
+This follows by induction on the path $(s, T) \ststrans (s', T')$, and using the lemma proven above for each step.
+\end{proof}
+
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "iris"
+%%% End:
diff --git a/docs/derived.tex b/docs/derived.tex
new file mode 100644
index 0000000000000000000000000000000000000000..857f881c7a34a7113552d421b0ab6b87b6d1dcea
--- /dev/null
+++ b/docs/derived.tex
@@ -0,0 +1,192 @@
+\section{Derived constructions}
+
+In this section we describe some constructions that we will use throughout the rest of the appendix.
+
+\subsection{Global monoid}
+
+Hereinafter we assume the global monoid (served up as a parameter to Iris) is obtained from a family of monoids $(M_i)_{i \in I}$ by first applying the construction for finite partial functions to each~(\Sref{sec:fpfunm}), and then applying the product construction~(\Sref{sec:prodm}):
+\[ M \eqdef \prod_{i \in I} \fpfunm{\textdom{GhName}}{M_i} \]
+We don't care so much about what concretely $\textdom{GhName}$ is, as long as it is countable and infinite.
+We write $\ownGhost{\gname}{\melt : M_i}$ (or just $\ownGhost{\gname}{\melt}$ if $M_i$ is clear from the context) for $\ownGGhost{[i \mapsto [\gname \mapsto \melt]]}$ when $\melt \in \mcarp {M_i}$, and for $\FALSE$ when $\melt = \mzero_{M_i}$.
+In other words, $\ownGhost{\gname}{\melt : M_i}$ asserts that in the current state of monoid $M_i$, the name $\gname$ is allocated and has at least value $\melt$.
+
+From~\ruleref{FpUpd} and the multiplications and frame-preserving updates in~\Sref{sec:prodm} and~\Sref{sec:fpfunm}, we have the following derived rules.
+\begin{mathpar}
+ \axiomH{NewGhost}{
+ \TRUE \vs \Exists\gname. \ownGhost\gname{\melt : M_i}
+ }
+ \and
+ \inferH{GhostUpd}
+ {\melt \mupd_{M_i} B}
+ {\ownGhost\gname{\melt : M_i} \vs \Exists \meltB\in B. \ownGhost\gname{\meltB : M_i}}
+ \and
+ \axiomH{GhostEq}
+ {\ownGhost\gname{\melt : M_i} * \ownGhost\gname{\meltB : M_i} \Lra \ownGhost\gname{\melt\mtimes\meltB : M_i}}
+
+ \axiomH{GhostUnit}
+ {\TRUE \Ra \ownGhost{\gname}{\munit : M_i}}
+
+ \axiomH{GhostZero}
+ {\ownGhost\gname{\mzero : M_i} \Ra \FALSE}
+
+ \axiomH{GhostTimeless}
+ {\timeless{\ownGhost\gname{\melt : M_i}}}
+\end{mathpar}
+
+\subsection{STSs with interpretation}\label{sec:stsinterp}
+
+Building on \Sref{sec:stsmon}, after constructing the monoid $\STSMon{\STSS}$ for a particular STS, we can use an invariant to tie an interpretation, $\pred : \STSS \to \Prop$, to the STS's current state, recovering CaReSL-style reasoning~\cite{caresl}.
+
+An STS invariant asserts authoritative ownership of an STS's current state and that state's interpretation:
+\begin{align*}
+ \STSInv(\STSS, \pred, \gname) \eqdef{}& \Exists s \in \STSS. \ownGhost{\gname}{(s, \STSS, \emptyset):\STSMon{\STSS}} * \pred(s) \\
+ \STS(\STSS, \pred, \gname, \iname) \eqdef{}& \knowInv{\iname}{\STSInv(\STSS, \pred, \gname)}
+\end{align*}
+
+We can specialize \ruleref{NewInv}, \ruleref{InvOpen}, and \ruleref{InvClose} to STS invariants:
+\begin{mathpar}
+ \inferH{NewSts}
+ {\infinite(\mask)}
+ {\later\pred(s) \vs[\mask] \Exists \iname \in \mask, \gname. \STS(\STSS, \pred, \gname, \iname) * \ownGhost{\gname}{(s, \STST \setminus \STSL(s)) : \STSMon{\STSS}}}
+ \and
+ \axiomH{StsOpen}
+ { \STS(\STSS, \pred, \gname, \iname) \vdash \ownGhost{\gname}{(s_0, T) : \STSMon{\STSS}} \vsE[\{\iname\}][\emptyset] \Exists s\in \upclose(\{s_0\}, T). \later\pred(s) * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T):\STSMon{\STSS}}}
+ \and
+ \axiomH{StsClose}
+ { \STS(\STSS, \pred, \gname, \iname), (s, T) \ststrans (s', T') \proves \later\pred(s') * \ownGhost{\gname}{(s, S, T):\STSMon{\STSS}} \vs[\emptyset][\{\iname\}] \ownGhost{\gname}{(s', T') : \STSMon{\STSS}} }
+\end{mathpar}
+\begin{proof}
+\ruleref{NewSts} uses \ruleref{NewGhost} to allocate $\ownGhost{\gname}{(s, \upclose(s, T), T) : \STSMon{\STSS}}$ where $T \eqdef \STST \setminus \STSL(s)$, and \ruleref{NewInv}.
+
+\ruleref{StsOpen} just uses \ruleref{InvOpen} and \ruleref{InvClose} on $\iname$, and the monoid equality $(s, \upclose(\{s_0\}, T), T) = (s, \STSS, \emptyset) \mtimes (\munit, \upclose(\{s_0\}, T), T)$.
+
+\ruleref{StsClose} applies \ruleref{StsStep} and \ruleref{InvClose}.
+\end{proof}
+
+Using these view shifts, we can prove STS variants of the invariant rules \ruleref{Inv} and \ruleref{VSInv}~(compare the former to CaReSL's island update rule~\cite{caresl}):
+\begin{mathpar}
+ \inferH{Sts}
+ {\All s \in \upclose(\{s_0\}, T). \hoare{\later\pred(s) * P}{\expr}{\Ret \val. \Exists s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * Q}[\mask]
+ \and \physatomic{\expr}}
+ { \STS(\STSS, \pred, \gname, \iname) \vdash \hoare{\ownGhost{\gname}{(s_0, T):\STSMon{\STSS}} * P}{\expr}{\Ret \val. \Exists s', T'. \ownGhost{\gname}{(s', T'):\STSMon{\STSS}} * Q}[\mask \uplus \{\iname\}]}
+ \and
+ \inferH{VSSts}
+ {\forall s \in \upclose(\{s_0\}, T).\; \later\pred(s) * P \vs[\mask_1][\mask_2] \exists s', T'.\; (s, T) \ststrans (s', T') * \later\pred(s') * Q}
+ { \STS(\STSS, \pred, \gname, \iname) \vdash \ownGhost{\gname}{(s_0, T):\STSMon{\STSS}} * P \vs[\mask_1 \uplus \{\iname\}][\mask_2 \uplus \{\iname\}] \Exists s', T'. \ownGhost{\gname}{(s', T'):\STSMon{\STSS}} * Q}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{Sts}]\label{pf:sts}
+ We have to show
+ \[\hoare{\ownGhost{\gname}{(s_0, T):\STSMon{\STSS}} * P}{\expr}{\Ret \val. \Exists s', T'. \ownGhost{\gname}{(s', T'):\STSMon{\STSS}} * Q}[\mask \uplus \{\iname\}]\]
+ where $\val$, $s'$, $T'$ are free in $Q$.
+
+ First, by \ruleref{ACsq} with \ruleref{StsOpen} and \ruleref{StsClose} (after moving $(s, T) \ststrans (s', T')$ into the view shift using \ruleref{VSBoxOut}), it suffices to show
+ \[\hoareV{\Exists s\in \upclose(\{s_0\}, T). \later\pred(s) * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)} * P}{\expr}{\Ret \val. \Exists s, T, S, s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * \ownGhost{\gname}{(s, S, T):\STSMon{\STSS}} * Q(\val, s', T')}[\mask]\]
+
+ Now, use \ruleref{Exist} to move the $s$ from the precondition into the context and use \ruleref{Csq} to (i)~fix the $s$ and $T$ in the postcondition to be the same as in the precondition, and (ii)~fix $S \eqdef \upclose(\{s_0\}, T)$.
+ It remains to show:
+ \[\hoareV{s\in \upclose(\{s_0\}, T) * \later\pred(s) * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)} * P}{\expr}{\Ret \val. \Exists s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)} * Q(\val, s', T')}[\mask]\]
+
+ Finally, use \ruleref{BoxOut} to move $s\in \upclose(\{s_0\}, T)$ into the context, and \ruleref{Frame} on $\ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)}$:
+ \[s\in \upclose(\{s_0\}, T) \vdash \hoare{\later\pred(s) * P}{\expr}{\Ret \val. \Exists s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * Q(\val, s', T')}[\mask]\]
+
+ This holds by our premise.
+\end{proof}
+
+% \begin{proof}[Proof of \ruleref{VSSts}]
+% This is similar to above, so we only give the proof in short notation:
+
+% \hproof{%
+% Context: $\knowInv\iname{\STSInv(\STSS, \pred, \gname)}$ \\
+% \pline[\mask_1 \uplus \{\iname\}]{
+% \ownGhost\gname{(s_0, T)} * P
+% } \\
+% \pline[\mask_1]{%
+% \Exists s. \later\pred(s) * \ownGhost\gname{(s, S, T)} * P
+% } \qquad by \ruleref{StsOpen} \\
+% Context: $s \in S \eqdef \upclose(\{s_0\}, T)$ \\
+% \pline[\mask_2]{%
+% \Exists s', T'. \later\pred(s') * Q(s', T') * \ownGhost\gname{(s, S, T)}
+% } \qquad by premiss \\
+% Context: $(s, T) \ststrans (s', T')$ \\
+% \pline[\mask_2 \uplus \{\iname\}]{
+% \ownGhost\gname{(s', T')} * Q(s', T')
+% } \qquad by \ruleref{StsClose}
+% }
+% \end{proof}
+
+\subsection{Authoritative monoids with interpretation}\label{sec:authinterp}
+
+Building on \Sref{sec:auth}, after constructing the monoid $\auth{M}$ for a cancellative monoid $M$, we can tie an interpretation, $\pred : \mcarp{M} \to \Prop$, to the authoritative element of $M$, recovering reasoning that is close to the sharing rule in~\cite{krishnaswami+:icfp12}.
+
+Let $\pred_\bot$ be the extension of $\pred$ to $\mcar{M}$ with $\pred_\bot(\mzero) = \FALSE$.
+Now define
+\begin{align*}
+ \AuthInv(M, \pred, \gname) \eqdef{}& \exists \melt \in \mcar{M}.\; \ownGhost{\gname}{\authfull \melt:\auth{M}} * \pred_\bot(\melt) \\
+ \Auth(M, \pred, \gname, \iname) \eqdef{}& M~\textlog{cancellative} \land \knowInv{\iname}{\AuthInv(M, \pred, \gname)}
+\end{align*}
+
+The frame-preserving updates for $\auth{M}$ gives rise to the following view shifts:
+\begin{mathpar}
+ \inferH{NewAuth}
+ {\infinite(\mask) \and M~\textlog{cancellative}}
+ {\later\pred_\bot(a) \vs[\mask] \exists \iname \in \mask, \gname.\; \Auth(M, \pred, \gname, \iname) * \ownGhost{\gname}{\authfrag a : \auth{M}}}
+ \and
+ \axiomH{AuthOpen}
+ {\Auth(M, \pred, \gname, \iname) \vdash \ownGhost{\gname}{\authfrag \melt : \auth{M}} \vsE[\{\iname\}][\emptyset] \exists \melt_f.\; \later\pred_\bot(\melt \mtimes \melt_f) * \ownGhost{\gname}{\authfull \melt \mtimes \melt_f, \authfrag a:\auth{M}}}
+ \and
+ \axiomH{AuthClose}
+ {\Auth(M, \pred, \gname, \iname) \vdash \later\pred_\bot(\meltB \mtimes \melt_f) * \ownGhost{\gname}{\authfull a \mtimes \melt_f, \authfrag a:\auth{M}} \vs[\emptyset][\{\iname\}] \ownGhost{\gname}{\authfrag \meltB : \auth{M}} }
+\end{mathpar}
+
+These view shifts in turn can be used to prove variants of the invariant rules:
+\begin{mathpar}
+ \inferH{Auth}
+ {\forall \melt_f.\; \hoare{\later\pred_\bot(a \mtimes \melt_f) * P}{\expr}{\Ret\val. \exists \meltB.\; \later\pred_\bot(\meltB\mtimes \melt_f) * Q}[\mask]
+ \and \physatomic{\expr}}
+ {\Auth(M, \pred, \gname, \iname) \vdash \hoare{\ownGhost{\gname}{\authfrag a:\auth{M}} * P}{\expr}{\Ret\val. \exists \meltB.\; \ownGhost{\gname}{\authfrag \meltB:\auth{M}} * Q}[\mask \uplus \{\iname\}]}
+ \and
+ \inferH{VSAuth}
+ {\forall \melt_f.\; \later\pred_\bot(a \mtimes \melt_f) * P \vs[\mask_1][\mask_2] \exists \meltB.\; \later\pred_\bot(\meltB \mtimes \melt_f) * Q(\meltB)}
+ {\Auth(M, \pred, \gname, \iname) \vdash
+ \ownGhost{\gname}{\authfrag a:\auth{M}} * P \vs[\mask_1 \uplus \{\iname\}][\mask_2 \uplus \{\iname\}]
+ \exists \meltB.\; \ownGhost{\gname}{\authfrag \meltB:\auth{M}} * Q(\meltB)}
+\end{mathpar}
+
+
+\subsection{Ghost heap}
+\label{sec:ghostheap}%
+
+We define a simple ghost heap with fractional permissions.
+Some modules require a few ghost names per module instance to properly manage ghost state, but would like to expose to clients a single logical name (avoiding clutter).
+In such cases we use these ghost heaps.
+
+We seek to implement the following interface:
+\newcommand{\GRefspecmaps}{\textsf{GMapsTo}}%
+\begin{align*}
+ \exists& {\fgmapsto[]} : \textsort{Val} \times \mathbb{Q}_{>} \times \textsort{Val} \ra \textsort{Prop}.\;\\
+ & \All x, q, v. x \fgmapsto[q] v \Ra x \fgmapsto[q] v \land q \in (0, 1] \\
+ &\forall x, q_1, q_2, v, w.\; x \fgmapsto[q_1] v * x \fgmapsto[q_2] w \Leftrightarrow x \fgmapsto[q_1 + q_2] v * v = w\\
+ & \forall v.\; \TRUE \vs[\emptyset] \exists x.\; x \fgmapsto[1] v \\
+ & \forall x, v, w.\; x \fgmapsto[1] v \vs[\emptyset] x \fgmapsto[1] w
+\end{align*}
+We write $x \fgmapsto v$ for $\exists q.\; x \fgmapsto[q] v$ and $x \gmapsto v$ for $x \fgmapsto[1] v$.
+Note that $x \fgmapsto v$ is duplicable but cannot be boxed (as it depends on resources); \ie we have $x \fgmapsto v \Lra x \fgmapsto v * x \fgmapsto v$ but not $x \fgmapsto v \Ra \always x \fgmapsto v$.
+
+To implement this interface, allocate an instance $\gname_G$ of $\FHeap(\textdom{Val})$ and define
+\[
+ x \fgmapsto[q] v \eqdef
+ \begin{cases}
+ \ownGhost{\gname_G}{x \mapsto (q, v)} & \text{if $q \in (0, 1]$} \\
+ \FALSE & \text{otherwise}
+ \end{cases}
+\]
+The view shifts in the specification follow immediately from \ruleref{GhostUpd} and the frame-preserving updates in~\Sref{sec:fheapm}.
+The first implication is immediate from the definition.
+The second implication follows by case distinction on $q_1 + q_2 \in (0, 1]$.
+
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "iris"
+%%% End:
diff --git a/docs/encodings.tex b/docs/encodings.tex
new file mode 100644
index 0000000000000000000000000000000000000000..06b00d3193eed5131f110ad8b00943e872a91a8a
--- /dev/null
+++ b/docs/encodings.tex
@@ -0,0 +1,568 @@
+% !TEX root = ./appendix.tex
+
+\section{Monoid constructions}
+
+We will use the notation $\mcarp{M} \eqdef |M| \setminus \{\mzero_M\}$ for the carrier of monoid $M$ without zero. When we define a carrier, a zero element is always implicitly added (we do not explicitly give it), and all cases of multiplication that are not defined (including those involving a zero element) go to that element.
+
+To disambiguate which monoid an element is part of, we use the notation $a : M$ to denote an $a$ s.t.\ $a \in |M|$.
+
+When defining a monoid, we will show some \emph{frame-preserving updates} $\melt \mupd \meltsB$ that it supports.
+Remember that
+\[
+ \melt \mupd \meltsB \eqdef \always\All \melt_f. \melt \sep \melt_f \Ra \Exists \meltB \in \meltsB. \meltB \sep \melt_f.
+\]
+The rule \ruleref{FpUpd} (and, later, \ruleref{GhostUpd}) allows us to use such updates in Hoare proofs.
+The following principles generally hold for frame-preserving updates.
+\begin{mathpar}
+ \infer{
+ \melt \mupd \meltsB
+ }{
+ \melt \mupd \meltsB \cup \meltsB'
+ }
+ \and
+ \infer{
+ \melt \mupd \meltsB
+ }{
+ \melt \mtimes \melt_f \mupd \{ \meltB \mtimes \melt_f \mid \meltB \in \meltsB \}
+ }
+\end{mathpar}
+
+Some of our constructions require or preserve \emph{cancellativity}:
+\[
+ \text{$\monoid$ cancellative} \eqdef
+ \All \melt_f, \melt, \meltB \in \mcar{\monoid}. \melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero \Ra \melt = \meltB
+\]
+
+
+\subsection{Exclusive monoid}
+
+Given a set $X$, we define a monoid such that at most one $x \in X$ can be owned.
+Let $\exm{X}$ be the monoid with carrier $X \uplus \{ \munit \}$ and multiplication
+\[
+\melt \cdot \meltB \;\eqdef\;
+\begin{cases}
+ \melt & \mbox{if } \meltB = \munit \\
+ \meltB & \mbox{if } \melt = \munit
+\end{cases}
+\]
+
+The frame-preserving update
+\begin{mathpar}
+\inferH{ExUpd}
+ {x \in X}
+ {x \mupd \melt}
+\end{mathpar}
+is easily shown, as the only possible frame for $x$ is $\munit$.
+
+Exclusive monoids are cancellative.
+\begin{proof}[Proof of cancellativity]
+If $\melt_f = \munit$, then the statement is trivial.
+If $\melt_f \neq \munit$, then we must have $\melt = \meltB = \munit$, as otherwise one of the two products would be $\mzero$.
+\end{proof}
+
+\subsection{Agreement monoid}
+
+Given a set $X$, we define a monoid such that everybody agrees on which $x \in X$ has been chosen.
+Let $\agm{X}$ be the monoid with carrier $X \uplus \{ \munit \}$ and multiplication
+\[
+\melt \cdot \meltB \;\eqdef\;
+\begin{cases}
+\melt & \mbox{if } \meltB = \munit \lor \melt = \meltB \\
+\meltB & \mbox{if } \melt = \munit
+\end{cases}
+\]
+
+Agreement monoids are cancellative.
+\begin{proof}[Proof of cancellativity]
+ If $\melt_f = \munit$, then the statement is trivial.
+ If $\melt_f \neq \munit$, then if $\melt = \munit$, we must have $\meltB = \munit$ and we are done.
+ Similar so for $\meltB = \munit$.
+ So let $\melt \neq \munit \neq \meltB$ and $\melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero$.
+ It follows immediately that $\melt = \melt_f = \meltB$.
+\end{proof}
+
+\subsection{Finite Powerset Monoid}
+
+Given an infinite set $X$, we define a monoid $\textmon{PowFin}$ with carrier $\mathcal{P}^{\textrm{fin}}(X)$ as follows:
+\[
+\melt \cdot \meltB \;\eqdef\; \melt \cup \meltB \quad \mbox{if } \melt \cap \meltB = \emptyset
+\]
+
+We obtain:
+\begin{mathpar}
+ \inferH{PowFinUpd}{}
+ {\emptyset \mupd \{ \{x\} \mid x \in X \}}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{PowFinUpd}]
+ Assume some frame $\melt_f \sep \emptyset$. Since $\melt_f$ is finite and $X$ is infinite, there exists an $x \notin \melt_f$.
+ Pick that for the result.
+\end{proof}
+
+The powerset monoids is cancellative.
+\begin{proof}[Proof of cancellativity]
+ Let $\melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero$.
+ So we have $\melt_f \sep \melt$ and $\melt_f \sep \meltB$, and we have to show $\melt = \meltB$.
+ Assume $x \in \melt$. Hence $x \in \melt_f \mtimes \melt$ and thus $x \in \melt_f \mtimes \meltB$.
+ By disjointness, $x \notin \melt_f$ and hence $x \in meltB$.
+ The other direction works the same way.
+\end{proof}
+
+\subsection{Product monoid}
+\label{sec:prodm}
+
+Given a family $(M_i)_{i \in I}$ of monoids ($I$ countable), we construct a product monoid.
+Let $\prod_{i \in I} M_i$ be the monoid with carrier $\prod_{i \in I} \mcarp{M_i}$ and point-wise multiplication, non-zero when \emph{all} individual multiplications are non-zero.
+For $f \in \prod_{i \in I} \mcarp{M_i}$, we write $f[i \mapsto a]$ for the disjoint union $f \uplus [i \mapsto a]$.
+
+Frame-preserving updates on the $M_i$ lift to the product:
+\begin{mathpar}
+ \inferH{ProdUpd}
+ {a \mupd_{M_i} B}
+ {f[i \mapsto a] \mupd \{ f[i \mapsto b] \mid b \in B\}}
+\end{mathpar}
+\begin{proof}[Proof of \ruleref{ProdUpd}]
+Assume some frame $g$ and let $c \eqdef g(i)$.
+Since $f[i \mapsto a] \sep g$, we get $f \sep g$ and $a \sep_{M_i} c$.
+Thus there exists $b \in B$ such that $b \sep_{M_i} c$.
+It suffices to show $f[i \mapsto b] \sep g$.
+Since multiplication is defined pointwise, this is the case if all components are compatible.
+For $i$, we know this from $b \sep_{M_i} c$.
+For all the other components, from $f \sep g$.
+\end{proof}
+
+If every $M_i$ is cancellative, then so is $\prod_{i \in I} M_i$.
+\begin{proof}[Proof of cancellativity]
+Let $\melt, \meltB, \melt_f \in \prod_{i \in I} \mcarp{M_i}$, and assume $\melt_f \mtimes \melt = \melt_f \mtimes \meltB \neq \mzero$.
+By the definition of multiplication, this means that for all $i \in I$ we have $\melt_f(i) \mtimes \melt(i) = \melt_f(i) \mtimes \meltB(i) \neq \mzero_{M_i}$.
+As all base monoids are cancellative, we obtain $\forall i \in I.\; \melt(i) = \meltB(i)$ from which we immediately get $\melt = \meltB$.
+\end{proof}
+
+\subsection{Fractional monoid}
+\label{sec:fracm}
+
+Given a monoid $M$, we define a monoid representing fractional ownership of some piece $\melt \in M$.
+The idea is to preserve all the frame-preserving update that $M$ could have, while additionally being able to do \emph{any} update if we own the full state (as determined by the fraction being $1$).
+Let $\fracm{M}$ be the monoid with carrier $(((0, 1] \cap \mathbb{Q}) \times M) \uplus \{\munit\}$ and multiplication
+\begin{align*}
+ (q, a) \mtimes (q', a') &\eqdef (q + q', a \mtimes a') \qquad \mbox{if $q+q'\le 1$} \\
+ (q, a) \mtimes \munit &\eqdef (q,a) \\
+ \munit \mtimes (q,a) &\eqdef (q,a).
+\end{align*}
+
+We get the following frame-preserving update.
+\begin{mathpar}
+ \inferH{FracUpdFull}
+ {a, b \in M}
+ {(1, a) \mupd (1, b)}
+ \and\inferH{FracUpdLocal}
+ {a \mupd_M B}
+ {(q, a) \mupd \{q\} \times B}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{FracUpdFull}]
+Assume some $f \sep (1, a)$. This can only be $f = \munit$, so showing $f \sep (1, b)$ is trivial.
+\end{proof}
+
+\begin{proof}[Proof of \ruleref{FracUpdLocal}]
+ Assume some $f \sep (q, a)$. If $f = \munit$, then $f \sep (q, b)$ is trivial for any $b \in B$. Just pick the one we obtain by choosing $\munit_M$ as the frame for $a$.
+
+ In the interesting case, we have $f = (q_f, a_f)$.
+ Obtain $b$ such that $b \in B \land b \sep a_f$.
+ Then $(q, b) \sep f$, and we are done.
+\end{proof}
+
+$\fracm{M}$ is cancellative if $M$ is cancellative.
+\begin{proof}[Proof of cancellativitiy]
+If $\melt_f = \munit$, we are trivially done.
+So let $\melt_f = (q_f, \melt_f')$.
+If $\melt = \munit$, then $\meltB = \munit$ as otherwise the fractions could not match up.
+Again, we are trivially done.
+Similar so for $\meltB = \munit$.
+So let $\melt = (q_a, \melt')$ and $\meltB = (q_b, \meltB')$.
+We have $(q_f + q_a, \melt_f' \mtimes \melt') = (q_f + q_b, \melt_f' \mtimes \meltB')$.
+We have to show $q_a = q_b$ and $\melt' = \meltB'$.
+The first is trivial, the second follows from cancellativitiy of $M$.
+\end{proof}
+
+\subsection{Finite partial function monoid}
+\label{sec:fpfunm}
+
+Given a countable set $X$ and a monoid $M$, we construct a monoid representing finite partial functions from $X$ to (non-unit, non-zero elements of) $M$.
+Let $\fpfunm{X}{M}$ be the product monoid $\prod_{x \in X} M$, as defined in \secref{sec:prodm} but restricting the carrier to functions $f$ where the set $\dom(f) \eqdef \{ x \mid f(x) \neq \munit_M \}$ is finite.
+This is well-defined as the set of these $f$ contains the unit and is closed under multiplication.
+(We identify finite partial functions from $X$ to $\mcarp{M}\setminus\{\munit_M\}$ and total functions from $X$ to $\mcarp{M}$ with finite $\munit_M$-support.)
+
+We use two frame-preserving updates:
+\begin{mathpar}
+ \inferH{FpFunAlloc}
+ {a \in \mcarp{M}}
+ {f \mupd \{ f[x \mapsto a] \mid x \notin \dom(f) \}}
+ \and
+ \inferH{FpFunUpd}
+ {a \mupd_M B}
+ {f[i \mapsto a] \mupd \{ f[i \mapsto b] \mid b \in B\}}
+\end{mathpar}
+Rule \ruleref{FpFunUpd} simply restates \ruleref{ProdUpd}.
+
+\begin{proof}[Proof of \ruleref{FpFunAlloc}]
+ Assume some $g \sep f$. Since $\dom(f \mtimes g)$ is finite, there will be some undefined element $x \notin \dom(f \mtimes g)$. Let $f' \eqdef f[x \mapsto a]$. This is compatible with $g$, so we are done.
+\end{proof}
+
+We write $[x \mapsto a]$ for the function mapping $x$ to $a$ and everything else in $X$ to $\munit$.
+
+%\subsection{Disposable monoid}
+%
+%Given a monoid $M$, we construct a monoid where, having full ownership of an element $\melt$ of $M$, one can throw it away, transitioning to a dead element.
+%Let \dispm{M} be the monoid with carrier $\mcarp{M} \uplus \{ \disposed \}$ and multiplication
+%% The previous unit must remain the unit of the new monoid, as is is always duplicable and hence we could not transition to \disposed if it were not composable with \disposed
+%\begin{align*}
+% \melt \mtimes \meltB &\eqdef \melt \mtimes_M \meltB & \IF \melt \sep[M] \meltB \\
+% \disposed \mtimes \disposed &\eqdef \disposed \\
+% \munit_M \mtimes \disposed &\eqdef \disposed \mtimes \munit_M \eqdef \disposed
+%\end{align*}
+%The unit is the same as in $M$.
+%
+%The frame-preserving updates are
+%\begin{mathpar}
+% \inferH{DispUpd}
+% {a \in \mcarp{M} \setminus \{\munit_M\} \and a \mupd_M B}
+% {a \mupd B}
+% \and
+% \inferH{Dispose}
+% {a \in \mcarp{M} \setminus \{\munit_M\} \and \All b \in \mcarp{M}. a \sep b \Ra b = \munit_M}
+% {a \mupd \disposed}
+%\end{mathpar}
+%
+%\begin{proof}[Proof of \ruleref{DispUpd}]
+%Assume a frame $f$. If $f = \disposed$, then $a = \munit_M$, which is a contradiction.
+%Thus $f \in \mcarp{M}$ and we can use $a \mupd_M B$.
+%\end{proof}
+%
+%\begin{proof}[Proof of \ruleref{Dispose}]
+%The second premiss says that $a$ has no non-trivial frame in $M$. To show the update, assume a frame $f$ in $\dispm{M}$. Like above, we get $f \in \mcarp{M}$, and thus $f = \munit_M$. But $\disposed \sep \munit_M$ is trivial, so we are done.
+%\end{proof}
+
+\subsection{Authoritative monoid}\label{sec:auth}
+
+Given a monoid $M$, we construct a monoid modeling someone owning an \emph{authoritative} element $x$ of $M$, and others potentially owning fragments $\melt \le_M x$ of $x$.
+(If $M$ is an exclusive monoid, the construction is very similar to a half-ownership monoid with two asymmetric halves.)
+Let $\auth{M}$ be the monoid with carrier
+\[
+ \SET{ (x, \melt) }{ x \in \mcarp{\exm{\mcarp{M}}} \land \melt \in \mcarp{M} \land (x = \munit_{\exm{\mcarp{M}}} \lor \melt \leq_M x) }
+\]
+and multiplication
+\[
+(x, \melt) \mtimes (y, \meltB) \eqdef
+ (x \mtimes y, \melt \mtimes \meltB) \quad \mbox{if } x \sep y \land \melt \sep \meltB \land (x \mtimes y = \munit_{\exm{\mcarp{M}}} \lor \melt \mtimes \meltB \leq_M x \mtimes y)
+\]
+Note that $(\munit_{\exm{\mcarp{M}}}, \munit_M)$ is the unit and asserts no ownership whatsoever, but $(\munit_{M}, \munit_M)$ asserts that the authoritative element is $\munit_M$.
+
+Let $x, \melt \in \mcarp M$.
+We write $\authfull x$ for full ownership $(x, \munit_M):\auth{M}$ and $\authfrag \melt$ for fragmental ownership $(\munit_{\exm{\mcarp{M}}}, \melt)$ and $\authfull x , \authfrag \melt$ for combined ownership $(x, \melt)$.
+If $x$ or $a$ is $\mzero_{M}$, then the sugar denotes $\mzero_{\auth{M}}$.
+
+\ralf{This needs syncing with the Coq development.}
+The frame-preserving update involves a rather unwieldy side-condition:
+\begin{mathpar}
+ \inferH{AuthUpd}{
+ \All\melt_f\in\mcar{\monoid}. \melt\sep\meltB \land \melt\mtimes\melt_f \le \meltB\mtimes\melt_f \Ra \melt'\mtimes\melt_f \le \melt'\mtimes\meltB \and
+ \melt' \sep \meltB
+ }{
+ \authfull \melt \mtimes \meltB, \authfrag \melt \mupd \authfull \melt' \mtimes \meltB, \authfrag \melt'
+ }
+\end{mathpar}
+We therefore derive two special cases.
+
+\paragraph{Local frame-preserving updates.}
+
+\newcommand\authupd{f}%
+Following~\cite{scsl}, we say that $\authupd: \mcar{M} \ra \mcar{M}$ is \emph{local} if
+\[
+ \All a, b \in \mcar{M}. a \sep b \land \authupd(a) \neq \mzero \Ra \authupd(a \mtimes b) = \authupd(a) \mtimes b
+\]
+Then,
+\begin{mathpar}
+ \inferH{AuthUpdLocal}
+ {\text{$\authupd$ local} \and \authupd(\melt)\sep\meltB}
+ {\authfull \melt \mtimes \meltB, \authfrag \melt \mupd \authfull \authupd(\melt) \mtimes \meltB, \authfrag \authupd(\melt)}
+\end{mathpar}
+
+\paragraph{Frame-preserving updates on cancellative monoids.}
+
+Frame-preserving updates are also possible if we assume $M$ cancellative:
+\begin{mathpar}
+ \inferH{AuthUpdCancel}
+ {\text{$M$ cancellative} \and \melt'\sep\meltB}
+ {\authfull \melt \mtimes \meltB, \authfrag \melt \mupd \authfull \melt' \mtimes \meltB, \authfrag \melt'}
+\end{mathpar}
+
+\subsection{Fractional heap monoid}
+\label{sec:fheapm}
+
+By combining the fractional, finite partial function, and authoritative monoids, we construct two flavors of heaps with fractional permissions and mention their important frame-preserving updates.
+Hereinafter, we assume the set $\textdom{Val}$ of values is countable.
+
+Given a set $Y$, define $\FHeap(Y) \eqdef \fpfunm{\textdom{Val}}{\fracm{Y}}$ representing a fractional heap with codomain $Y$.
+From \S\S\ref{sec:fracm} and~\ref{sec:fpfunm} we obtain the following frame-preserving updates as well as the fact that $\FHeap(Y)$ is cancellative.
+\begin{mathpar}
+ \axiomH{FHeapUpd}{h[x \mapsto (1, y)] \mupd h[x \mapsto (1, y')]} \and
+ \axiomH{FHeapAlloc}{h \mupd \{\, h[x \mapsto (1, y)] \mid x \in \textdom{Val} \,\}}
+\end{mathpar}
+We will write $qh$ with $h : \textsort{Val} \fpfn Y$ for the function in $\FHeap(Y)$ mapping every $x \in \dom(h)$ to $(q, h(x))$, and everything else to $\munit$.
+
+Define $\AFHeap(Y) \eqdef \auth{\FHeap(Y)}$ representing an authoritative fractional heap with codomain $Y$.
+We easily obtain the following frame-preserving updates.
+\begin{mathpar}
+ \axiomH{AFHeapUpd}{
+ (\authfull h[x \mapsto (1, y)], \authfrag [x \mapsto (1, y)]) \mupd (\authfull h[x \mapsto (1, y')], \authfrag [x \mapsto (1, y')])
+ }
+ \and
+ \inferH{AFHeapAdd}{
+ x \notin \dom(h)
+ }{
+ \authfull h \mupd (\authfull h[x \mapsto (q, y)], \authfrag [x \mapsto (q, y)])
+ }
+ \and
+ \axiomH{AFHeapRemove}{
+ (\authfull h[x \mapsto (q, y)], \authfrag [x \mapsto (q, y)]) \mupd \authfull h
+ }
+\end{mathpar}
+
+\subsection{STS with tokens monoid}
+\label{sec:stsmon}
+
+\ralf{This needs syncing with the Coq development.}
+
+Given a state-transition system~(STS) $(\STSS, \ra)$, a set of tokens $\STSS$, and a labeling $\STSL: \STSS \ra \mathcal{P}(\STST)$ of \emph{protocol-owned} tokens for each state, we construct a monoid modeling an authoritative current state and permitting transitions given a \emph{bound} on the current state and a set of \emph{locally-owned} tokens.
+
+The construction follows the idea of STSs as described in CaReSL \cite{caresl}.
+We first lift the transition relation to $\STSS \times \mathcal{P}(\STST)$ (implementing a \emph{law of token conservation}) and define upwards closure:
+\begin{align*}
+ (s, T) \ra (s', T') \eqdef&\, s \ra s' \land \STSL(s) \uplus T = \STSL(s') \uplus T' \\
+ \textsf{frame}(s, T) \eqdef&\, (s, \STST \setminus (\STSL(s) \uplus T)) \\
+ \upclose(S, T) \eqdef&\, \SET{ s' \in \STSS}{\exists s \in S.\; \textsf{frame}(s, T) \ststrans \textsf{frame}(s', T) }
+\end{align*}
+
+\noindent
+We have
+\begin{quote}
+ If $(s, T) \ra (s', T')$\\
+ and $T_f \sep (T \uplus \STSL(s))$,\\
+ then $\textsf{frame}(s, T_f) \ra \textsf{frame}(s', T_f)$.
+\end{quote}
+\begin{proof}
+This follows directly by framing the tokens in $\STST \setminus (T_f \uplus T \uplus \STSL(s))$ around the given transition, which yields $(s, \STST \setminus (T_f \uplus \STSL{T}(s))) \ra (s', T' \uplus (\STST \setminus (T_f \uplus T \uplus \STSL{T}(s))))$.
+This is exactly what we have to show, since we know $\STSL(s) \uplus T = \STSL(s') \uplus T'$.
+\end{proof}
+
+Let $\STSMon{\STSS}$ be the monoid with carrier
+\[
+ \SET{ (s, S, T) \in \exm{\STSS} \times \mathcal{P}(\STSS) \times \mathcal{P}(\STST) }{ \begin{aligned} &(s = \munit \lor s \in S) \land \upclose(S, T) = S \land{} \\& S \neq \emptyset \land \All s \in S. \STSL(s) \sep T \end{aligned} }
+\]
+and multiplication
+\[
+ (s, S, T) \mtimes (s', S', T') \eqdef (s'' \eqdef s \mtimes_{\exm{\STSS}} s', S'' \eqdef S \cap S', T'' \eqdef T \cup T') \quad \text{if }\begin{aligned}[t] &(s = \munit \lor s' = \munit) \land T \sep T' \land{} \\& S'' \neq \emptyset \land (s'' \neq \munit \Ra s'' \in S'') \end{aligned}
+\]
+
+Some sugar makes it more convenient to assert being at least in a certain state and owning some tokens: $(s, T) : \STSMon{\STSS} \eqdef (\munit, \upclose(\{s\}, T), T) : \STSMon{\STSS}$, and
+$s : \STSMon{\STSS} \eqdef (s, \emptyset) : \STSMon{\STSS}$.
+
+We will need the following frame-preserving update.
+\begin{mathpar}
+ \inferH{StsStep}{(s, T) \ststrans (s', T')}
+ {(s, S, T) \mupd (s', \upclose(\{s'\}, T'), T')}
+\end{mathpar}
+\begin{proof}[Proof of \ruleref{StsStep}]
+Assume some upwards-closed $S_f, T_f$ (the frame cannot be authoritative) s.t.\ $s \in S_f$ and $T_f \sep (T \uplus \STSL(s))$. We have to show that this frame combines with our final monoid element, which is the case if $s' \in S_f$ and $T_f \sep T'$.
+By upward-closedness, it suffices to show $\textsf{frame}(s, T_f) \ststrans \textsf{frame}(s', T_f)$.
+This follows by induction on the path $(s, T) \ststrans (s', T')$, and using the lemma proven above for each step.
+\end{proof}
+
+\section{Derived constructions}
+
+In this section we describe some constructions that we will use throughout the rest of the appendix.
+
+\subsection{Global monoid}
+
+Hereinafter we assume the global monoid (served up as a parameter to Iris) is obtained from a family of monoids $(M_i)_{i \in I}$ by first applying the construction for finite partial functions to each~(\Sref{sec:fpfunm}), and then applying the product construction~(\Sref{sec:prodm}):
+\[ M \eqdef \prod_{i \in I} \fpfunm{\textdom{GhName}}{M_i} \]
+We don't care so much about what concretely $\textdom{GhName}$ is, as long as it is countable and infinite.
+We write $\ownGhost{\gname}{\melt : M_i}$ (or just $\ownGhost{\gname}{\melt}$ if $M_i$ is clear from the context) for $\ownGGhost{[i \mapsto [\gname \mapsto \melt]]}$ when $\melt \in \mcarp {M_i}$, and for $\FALSE$ when $\melt = \mzero_{M_i}$.
+In other words, $\ownGhost{\gname}{\melt : M_i}$ asserts that in the current state of monoid $M_i$, the name $\gname$ is allocated and has at least value $\melt$.
+
+From~\ruleref{FpUpd} and the multiplications and frame-preserving updates in~\Sref{sec:prodm} and~\Sref{sec:fpfunm}, we have the following derived rules.
+\begin{mathpar}
+ \axiomH{NewGhost}{
+ \TRUE \vs \Exists\gname. \ownGhost\gname{\melt : M_i}
+ }
+ \and
+ \inferH{GhostUpd}
+ {\melt \mupd_{M_i} B}
+ {\ownGhost\gname{\melt : M_i} \vs \Exists \meltB\in B. \ownGhost\gname{\meltB : M_i}}
+ \and
+ \axiomH{GhostEq}
+ {\ownGhost\gname{\melt : M_i} * \ownGhost\gname{\meltB : M_i} \Lra \ownGhost\gname{\melt\mtimes\meltB : M_i}}
+
+ \axiomH{GhostUnit}
+ {\TRUE \Ra \ownGhost{\gname}{\munit : M_i}}
+
+ \axiomH{GhostZero}
+ {\ownGhost\gname{\mzero : M_i} \Ra \FALSE}
+
+ \axiomH{GhostTimeless}
+ {\timeless{\ownGhost\gname{\melt : M_i}}}
+\end{mathpar}
+
+\subsection{STSs with interpretation}\label{sec:stsinterp}
+
+Building on \Sref{sec:stsmon}, after constructing the monoid $\STSMon{\STSS}$ for a particular STS, we can use an invariant to tie an interpretation, $\pred : \STSS \to \Prop$, to the STS's current state, recovering CaReSL-style reasoning~\cite{caresl}.
+
+An STS invariant asserts authoritative ownership of an STS's current state and that state's interpretation:
+\begin{align*}
+ \STSInv(\STSS, \pred, \gname) \eqdef{}& \Exists s \in \STSS. \ownGhost{\gname}{(s, \STSS, \emptyset):\STSMon{\STSS}} * \pred(s) \\
+ \STS(\STSS, \pred, \gname, \iname) \eqdef{}& \knowInv{\iname}{\STSInv(\STSS, \pred, \gname)}
+\end{align*}
+
+We can specialize \ruleref{NewInv}, \ruleref{InvOpen}, and \ruleref{InvClose} to STS invariants:
+\begin{mathpar}
+ \inferH{NewSts}
+ {\infinite(\mask)}
+ {\later\pred(s) \vs[\mask] \Exists \iname \in \mask, \gname. \STS(\STSS, \pred, \gname, \iname) * \ownGhost{\gname}{(s, \STST \setminus \STSL(s)) : \STSMon{\STSS}}}
+ \and
+ \axiomH{StsOpen}
+ { \STS(\STSS, \pred, \gname, \iname) \vdash \ownGhost{\gname}{(s_0, T) : \STSMon{\STSS}} \vsE[\{\iname\}][\emptyset] \Exists s\in \upclose(\{s_0\}, T). \later\pred(s) * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T):\STSMon{\STSS}}}
+ \and
+ \axiomH{StsClose}
+ { \STS(\STSS, \pred, \gname, \iname), (s, T) \ststrans (s', T') \proves \later\pred(s') * \ownGhost{\gname}{(s, S, T):\STSMon{\STSS}} \vs[\emptyset][\{\iname\}] \ownGhost{\gname}{(s', T') : \STSMon{\STSS}} }
+\end{mathpar}
+\begin{proof}
+\ruleref{NewSts} uses \ruleref{NewGhost} to allocate $\ownGhost{\gname}{(s, \upclose(s, T), T) : \STSMon{\STSS}}$ where $T \eqdef \STST \setminus \STSL(s)$, and \ruleref{NewInv}.
+
+\ruleref{StsOpen} just uses \ruleref{InvOpen} and \ruleref{InvClose} on $\iname$, and the monoid equality $(s, \upclose(\{s_0\}, T), T) = (s, \STSS, \emptyset) \mtimes (\munit, \upclose(\{s_0\}, T), T)$.
+
+\ruleref{StsClose} applies \ruleref{StsStep} and \ruleref{InvClose}.
+\end{proof}
+
+Using these view shifts, we can prove STS variants of the invariant rules \ruleref{Inv} and \ruleref{VSInv}~(compare the former to CaReSL's island update rule~\cite{caresl}):
+\begin{mathpar}
+ \inferH{Sts}
+ {\All s \in \upclose(\{s_0\}, T). \hoare{\later\pred(s) * P}{\expr}{\Ret \val. \Exists s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * Q}[\mask]
+ \and \physatomic{\expr}}
+ { \STS(\STSS, \pred, \gname, \iname) \vdash \hoare{\ownGhost{\gname}{(s_0, T):\STSMon{\STSS}} * P}{\expr}{\Ret \val. \Exists s', T'. \ownGhost{\gname}{(s', T'):\STSMon{\STSS}} * Q}[\mask \uplus \{\iname\}]}
+ \and
+ \inferH{VSSts}
+ {\forall s \in \upclose(\{s_0\}, T).\; \later\pred(s) * P \vs[\mask_1][\mask_2] \exists s', T'.\; (s, T) \ststrans (s', T') * \later\pred(s') * Q}
+ { \STS(\STSS, \pred, \gname, \iname) \vdash \ownGhost{\gname}{(s_0, T):\STSMon{\STSS}} * P \vs[\mask_1 \uplus \{\iname\}][\mask_2 \uplus \{\iname\}] \Exists s', T'. \ownGhost{\gname}{(s', T'):\STSMon{\STSS}} * Q}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{Sts}]\label{pf:sts}
+ We have to show
+ \[\hoare{\ownGhost{\gname}{(s_0, T):\STSMon{\STSS}} * P}{\expr}{\Ret \val. \Exists s', T'. \ownGhost{\gname}{(s', T'):\STSMon{\STSS}} * Q}[\mask \uplus \{\iname\}]\]
+ where $\val$, $s'$, $T'$ are free in $Q$.
+
+ First, by \ruleref{ACsq} with \ruleref{StsOpen} and \ruleref{StsClose} (after moving $(s, T) \ststrans (s', T')$ into the view shift using \ruleref{VSBoxOut}), it suffices to show
+ \[\hoareV{\Exists s\in \upclose(\{s_0\}, T). \later\pred(s) * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)} * P}{\expr}{\Ret \val. \Exists s, T, S, s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * \ownGhost{\gname}{(s, S, T):\STSMon{\STSS}} * Q(\val, s', T')}[\mask]\]
+
+ Now, use \ruleref{Exist} to move the $s$ from the precondition into the context and use \ruleref{Csq} to (i)~fix the $s$ and $T$ in the postcondition to be the same as in the precondition, and (ii)~fix $S \eqdef \upclose(\{s_0\}, T)$.
+ It remains to show:
+ \[\hoareV{s\in \upclose(\{s_0\}, T) * \later\pred(s) * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)} * P}{\expr}{\Ret \val. \Exists s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * \ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)} * Q(\val, s', T')}[\mask]\]
+
+ Finally, use \ruleref{BoxOut} to move $s\in \upclose(\{s_0\}, T)$ into the context, and \ruleref{Frame} on $\ownGhost{\gname}{(s, \upclose(\{s_0\}, T), T)}$:
+ \[s\in \upclose(\{s_0\}, T) \vdash \hoare{\later\pred(s) * P}{\expr}{\Ret \val. \Exists s', T'. (s, T) \ststrans (s', T') * \later\pred(s') * Q(\val, s', T')}[\mask]\]
+
+ This holds by our premise.
+\end{proof}
+
+\begin{proof}[Proof of \ruleref{VSSts}]
+This is similar to above, so we only give the proof in short notation:
+
+\hproof{%
+ Context: $\knowInv\iname{\STSInv(\STSS, \pred, \gname)}$ \\
+ \pline[\mask_1 \uplus \{\iname\}]{
+ \ownGhost\gname{(s_0, T)} * P
+ } \\
+ \pline[\mask_1]{%
+ \Exists s. \later\pred(s) * \ownGhost\gname{(s, S, T)} * P
+ } \qquad by \ruleref{StsOpen} \\
+ Context: $s \in S \eqdef \upclose(\{s_0\}, T)$ \\
+ \pline[\mask_2]{%
+ \Exists s', T'. \later\pred(s') * Q(s', T') * \ownGhost\gname{(s, S, T)}
+ } \qquad by premiss \\
+ Context: $(s, T) \ststrans (s', T')$ \\
+ \pline[\mask_2 \uplus \{\iname\}]{
+ \ownGhost\gname{(s', T')} * Q(s', T')
+ } \qquad by \ruleref{StsClose}
+}
+\end{proof}
+
+\subsection{Authoritative monoids with interpretation}\label{sec:authinterp}
+
+Building on \Sref{sec:auth}, after constructing the monoid $\auth{M}$ for a cancellative monoid $M$, we can tie an interpretation, $\pred : \mcarp{M} \to \Prop$, to the authoritative element of $M$, recovering reasoning that is close to the sharing rule in~\cite{krishnaswami+:icfp12}.
+
+Let $\pred_\bot$ be the extension of $\pred$ to $\mcar{M}$ with $\pred_\bot(\mzero) = \FALSE$.
+Now define
+\begin{align*}
+ \AuthInv(M, \pred, \gname) \eqdef{}& \exists \melt \in \mcar{M}.\; \ownGhost{\gname}{\authfull \melt:\auth{M}} * \pred_\bot(\melt) \\
+ \Auth(M, \pred, \gname, \iname) \eqdef{}& M~\textlog{cancellative} \land \knowInv{\iname}{\AuthInv(M, \pred, \gname)}
+\end{align*}
+
+The frame-preserving updates for $\auth{M}$ gives rise to the following view shifts:
+\begin{mathpar}
+ \inferH{NewAuth}
+ {\infinite(\mask) \and M~\textlog{cancellative}}
+ {\later\pred_\bot(a) \vs[\mask] \exists \iname \in \mask, \gname.\; \Auth(M, \pred, \gname, \iname) * \ownGhost{\gname}{\authfrag a : \auth{M}}}
+ \and
+ \axiomH{AuthOpen}
+ {\Auth(M, \pred, \gname, \iname) \vdash \ownGhost{\gname}{\authfrag \melt : \auth{M}} \vsE[\{\iname\}][\emptyset] \exists \melt_f.\; \later\pred_\bot(\melt \mtimes \melt_f) * \ownGhost{\gname}{\authfull \melt \mtimes \melt_f, \authfrag a:\auth{M}}}
+ \and
+ \axiomH{AuthClose}
+ {\Auth(M, \pred, \gname, \iname) \vdash \later\pred_\bot(\meltB \mtimes \melt_f) * \ownGhost{\gname}{\authfull a \mtimes \melt_f, \authfrag a:\auth{M}} \vs[\emptyset][\{\iname\}] \ownGhost{\gname}{\authfrag \meltB : \auth{M}} }
+\end{mathpar}
+
+These view shifts in turn can be used to prove variants of the invariant rules:
+\begin{mathpar}
+ \inferH{Auth}
+ {\forall \melt_f.\; \hoare{\later\pred_\bot(a \mtimes \melt_f) * P}{\expr}{\Ret\val. \exists \meltB.\; \later\pred_\bot(\meltB\mtimes \melt_f) * Q}[\mask]
+ \and \physatomic{\expr}}
+ {\Auth(M, \pred, \gname, \iname) \vdash \hoare{\ownGhost{\gname}{\authfrag a:\auth{M}} * P}{\expr}{\Ret\val. \exists \meltB.\; \ownGhost{\gname}{\authfrag \meltB:\auth{M}} * Q}[\mask \uplus \{\iname\}]}
+ \and
+ \inferH{VSAuth}
+ {\forall \melt_f.\; \later\pred_\bot(a \mtimes \melt_f) * P \vs[\mask_1][\mask_2] \exists \meltB.\; \later\pred_\bot(\meltB \mtimes \melt_f) * Q(\meltB)}
+ {\Auth(M, \pred, \gname, \iname) \vdash
+ \ownGhost{\gname}{\authfrag a:\auth{M}} * P \vs[\mask_1 \uplus \{\iname\}][\mask_2 \uplus \{\iname\}]
+ \exists \meltB.\; \ownGhost{\gname}{\authfrag \meltB:\auth{M}} * Q(\meltB)}
+\end{mathpar}
+
+
+\subsection{Ghost heap}
+\label{sec:ghostheap}%
+
+We define a simple ghost heap with fractional permissions.
+Some modules require a few ghost names per module instance to properly manage ghost state, but would like to expose to clients a single logical name (avoiding clutter).
+In such cases (\eg \Sref{sec:mcas}), we use these ghost heaps.
+
+We seek to implement the following interface:
+\newcommand{\GRefspecmaps}{\textsf{GMapsTo}}%
+\begin{align*}
+ \exists& {\fgmapsto[]} : \textsort{Val} \times \mathbb{Q}_{>} \times \textsort{Val} \ra \textsort{Prop}.\;\\
+ & \All x, q, v. x \fgmapsto[q] v \Ra x \fgmapsto[q] v \land q \in (0, 1] \\
+ &\forall x, q_1, q_2, v, w.\; x \fgmapsto[q_1] v * x \fgmapsto[q_2] w \Leftrightarrow x \fgmapsto[q_1 + q_2] v * v = w\\
+ & \forall v.\; \TRUE \vs[\emptyset] \exists x.\; x \fgmapsto[1] v \\
+ & \forall x, v, w.\; x \fgmapsto[1] v \vs[\emptyset] x \fgmapsto[1] w
+\end{align*}
+We write $x \fgmapsto v$ for $\exists q.\; x \fgmapsto[q] v$ and $x \gmapsto v$ for $x \fgmapsto[1] v$.
+Note that $x \fgmapsto v$ is duplicable but cannot be boxed (as it depends on resources); \ie we have $x \fgmapsto v \Lra x \fgmapsto v * x \fgmapsto v$ but not $x \fgmapsto v \Ra \always x \fgmapsto v$.
+
+To implement this interface, allocate an instance $\gname_G$ of $\FHeap(\textdom{Val})$ and define
+\[
+ x \fgmapsto[q] v \eqdef
+ \begin{cases}
+ \ownGhost{\gname_G}{x \mapsto (q, v)} & \text{if $q \in (0, 1]$} \\
+ \FALSE & \text{otherwise}
+ \end{cases}
+\]
+The view shifts in the specification follow immediately from \ruleref{GhostUpd} and the frame-preserving updates in~\Sref{sec:fheapm}.
+The first implication is immediate from the definition.
+The second implication follows by case distinction on $q_1 + q_2 \in (0, 1]$.
+
diff --git a/docs/iris.tex b/docs/iris.tex
new file mode 100644
index 0000000000000000000000000000000000000000..b0bd1b4bb4625d537246cf244c73e22e34861ac0
--- /dev/null
+++ b/docs/iris.tex
@@ -0,0 +1,54 @@
+\documentclass[10pt]{article}
+\usepackage{lmodern}
+\usepackage[T1]{fontenc}
+\usepackage[utf8]{inputenc}
+
+\newif\ifslow\slowfalse %\slowtrue
+\ifslow
+ \usepackage[english]{babel}
+ \usepackage[babel=true]{microtype}
+\fi
+\usepackage[top=1in, bottom=1in, left=1.25in, right=1.25in]{geometry}
+
+\usepackage[backend=biber]{biblatex}
+\bibliography{bib}
+
+\input{setup}
+
+\begin{document}
+
+\title{\bfseries The Iris Documentation}
+
+%FIXME any better way to do this?
+\author{%
+ Ralf Jung \\ MPI-SWS \& Saarland University \\ jung@mpi-sws.org \and
+ David Swasey \\ MPI-SWS \\ swasey@mpi-sws.org \andcr
+ Filip Sieczkowski \\ Aarhus University \\ filips@cs.au.dk \and
+ Kasper Svendsen \\ Aarhus University \\ ksvendsen@cs.au.dk \and
+ Aaron Turon \\ Mozilla Research \\ aturon@mozilla.com \andcr
+ Lars Birkedal \\ Aarhus University \\ birkedal@cs.au.dk \and
+ Derek Dreyer \\ MPI-SWS \\ dreyer@mpi-sws.org}
+
+\def\andcr{\end{tabular}\\\begin{tabular}[t]{c}}% see \@maketitle in article.cls and \and in latex.ltx
+\maketitle
+\let\andcr\relax%
+
+\thispagestyle{empty}
+
+%\clearpage
+\tableofcontents
+
+\clearpage\begingroup
+\input{algebra}
+\endgroup\clearpage\begingroup
+\input{constructions}
+\endgroup\clearpage\begingroup
+\input{logic}
+\endgroup\clearpage\begingroup
+\input{model}
+\endgroup\clearpage\begingroup
+\input{derived}
+\endgroup\clearpage\begingroup
+\printbibliography
+
+\end{document}
diff --git a/docs/listproc.sty b/docs/listproc.sty
new file mode 100644
index 0000000000000000000000000000000000000000..1e3b167e8ae6779580cbc4454ec1a49435f23639
--- /dev/null
+++ b/docs/listproc.sty
@@ -0,0 +1,349 @@
+%%
+%% This is file `listproc.sty',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% listproc.dtx (with options: `package')
+%%
+%% Copyright (C) 2011 by Jesse A. Tov
+%%
+%% This file may be distributed and/or modified under the conditions of the
+%% LaTeX Project Public License, either version 1.2 of this license or (at
+%% your option) any later version. The latest version of this license is
+%% in:
+%%
+%% http://www.latex-project.org/lppl.txt
+%%
+%% and version 1.2 or later is part of all distributions of LaTeX
+%% version 1999/12/01 or later.
+%%
+\NeedsTeXFormat{LaTeX2e}[1999/12/01]
+\ProvidesPackage{listproc}[2011/03/26 v0.1 (list processing)]
+\newcommand\newlist{\@lstp@def{}\newcommand}
+\newcommand\renewlist{\@lstp@def{}\renewcommand}
+\newcommand\deflist{\@lstp@def{}\def}
+\newcommand\gdeflist{\@lstp@def\global\def}
+\newcommand\@lstp@def[4]{%
+ #2#3{}%
+ \@for\lstp@def@temp:=#4\do{%
+ \eSnocTo\lstp@def@temp#3%
+ }%
+ #1\let#3#3%
+ \let\lstp@def@temp\@undefined
+}
+\newtoks\lstp@ta
+\newtoks\lstp@tb
+\newcommand\ConsTo{\@lstp@ConsTo\relax\def}
+\newcommand\gConsTo{\@lstp@ConsTo\global\def}
+\newcommand\eConsTo{\@lstp@ConsTo\relax\edef}
+\newcommand\xConsTo{\@lstp@ConsTo\global\edef}
+\newcommand\@lstp@ConsTo[4]{%
+ \long#2\lstp@temp{#3}%
+ \lstp@ta=\expandafter{\expandafter\listitem\expandafter{\lstp@temp}}%
+ \lstp@tb=\expandafter{#4}%
+ #1\edef#4{\the\lstp@ta\the\lstp@tb}%
+}
+\newcommand\SnocTo{\@lstp@SnocTo\relax\def}
+\newcommand\gSnocTo{\@lstp@SnocTo\global\def}
+\newcommand\eSnocTo{\@lstp@SnocTo\relax\edef}
+\newcommand\xSnocTo{\@lstp@SnocTo\global\edef}
+\newcommand\@lstp@SnocTo[4]{%
+ \long#2\lstp@temp{#3}%
+ \lstp@ta=\expandafter{\expandafter\listitem\expandafter{\lstp@temp}}%
+ \lstp@tb=\expandafter{#4}%
+ #1\edef#4{\the\lstp@tb\the\lstp@ta}%
+}
+\newcommand\AppendTo{\@lstp@AppendTo\relax}
+\newcommand\gAppendTo{\@lstp@AppendTo\global}
+\newcommand\@lstp@AppendTo[3]{%
+ \lstp@ta=\expandafter{#2}%
+ \lstp@tb=\expandafter{#3}%
+ #1\edef#3{\the\lstp@ta\the\lstp@tb}%
+}
+\long\def\@LopOff\listitem#1#2\@LopOff#3#4{%
+ #3{#1}%
+ #4{#2}%
+}
+\newcommand\@lstp@LopTo[4]{\expandafter\@LopOff#3\@LopOff{#1\def#4}{#2\def#3}}
+\newcommand\@lstp@RestTo[3]{\expandafter\@LopOff#2\@LopOff{\@gobble}{#1\def#3}}
+\newcommand\LopTo{\@lstp@LopTo\relax\relax}
+\newcommand\gLopTo{\@lstp@LopTo\global\global}
+\newcommand\glLopTo{\@lstp@LopTo\global\relax}
+\newcommand\lgLopTo{\@lstp@LopTo\relax\global}
+\newcommand\FirstTo{\@lstp@LopTo\relax\@gobblethree}
+\newcommand\gFirstTo{\@lstp@LopTo\global\@gobblethree}
+\newcommand\RestTo{\@lstp@RestTo\relax}
+\newcommand\gRestTo{\@lstp@RestTo\global}
+\newcommand*\IfList[1]{%
+ {%
+ \expandafter\@IfList#1\@IfList
+ }%
+}
+\def\@IfList#1#2\@IfList{%
+ \ifx\listitem#1\relax
+ \aftergroup\@firstoftwo
+ \else
+ \aftergroup\@secondoftwo
+ \fi
+}
+\def\@forList#1:=#2\do#3{%
+ \long\def\lstp@for@listitem##1{%
+ \long\def#1{##1}%
+ #3%
+ \let\listitem\lstp@for@listitem%
+ }%
+ \let\listitem\lstp@for@listitem%
+ #2%
+ \let\listitem\@undefined%
+}
+\newcommand\SetToListLength[2]{%
+ \lstp@length{#2}{\value{#1}}%
+}
+\newcommand\lstp@length[2]{%
+ #2=0 %
+ \long\def\listitem##1{\advance#2 by1 }%
+ #1\let\listitem\@undefined%
+}
+\newcommand\MapListTo{\@lstp@MapListTo\relax}
+\newcommand\gMapListTo{\@lstp@MapListTo\global}
+\newcommand\MapAndAppendTo{\@lstp@MapAndAppendTo\relax}
+\newcommand\gMapAndAppendTo{\@lstp@MapAndAppendTo\global}
+\newcommand\@lstp@MapListTo[4]{%
+ \let\lstp@map@temp#3%
+ #1\let#4\empty%
+ \@lstp@MapAndAppendTo{#1}{#2}\lstp@map@temp#4%
+ \let\lstp@map@temp\@undefined%
+}
+\newcommand\@lstp@MapAndAppendTo[4]{%
+ \long\def\listitem##1{\@lstp@SnocTo{#1}\def{#2}{#4}}%
+ #3%
+ \let\listitem\@undefined%
+}
+\newcommand\lstp@insert[3]{%
+ \edef\lstp@insert@temp@a{#2{#1}}%
+ \let\lstp@insert@temp@i#3%
+ \let#3\empty
+ \long\def\lstp@insert@listitem##1{%
+ \edef\lstp@insert@temp@b{#2{##1}}%
+ \ifnum\lstp@insert@temp@a<\lstp@insert@temp@b
+ \SnocTo{#1}{#3}%
+ \let\listitem\lstp@insert@listitem@done
+ \else
+ \let\listitem\lstp@insert@listitem
+ \fi
+ \SnocTo{##1}{#3}%
+ }%
+ \long\def\lstp@insert@listitem@done##1{\SnocTo{##1}{#3}}%
+ \let\listitem\lstp@insert@listitem
+ \lstp@insert@temp@i%
+ \ifx\listitem\lstp@insert@listitem%
+ \SnocTo{#1}{#3}%
+ \fi%
+ \let\lstp@insert@temp@i\@undefined%
+ \let\listitem\@undefined%
+}
+\providecommand\@apply@group[2]{#1#2}
+\newcommand\SortList[2][\@apply@group{}]{%
+ \let\lstp@sort@temp@i#2%
+ \let#2\empty
+ \long\def\lstp@sort@listitem##1{%
+ \lstp@insert{##1}{#1}{#2}%
+ \let\listitem\lstp@sort@listitem
+ }%
+ \let\listitem\lstp@sort@listitem
+ \lstp@sort@temp@i
+ \let\lstp@sort@temp@i\@undefined
+ \let\listitem\@undefined
+}
+\newcounter{lstp@ifsucc}
+\newcommand\lstp@ifsucc[2]{%
+ \setcounter{lstp@ifsucc}{#1}%
+ \addtocounter{lstp@ifsucc}{1}%
+ \ifnum#2=\value{lstp@ifsucc}%
+ \let\@lstp@ifsucc@kont\@firstoftwo
+ \else
+ \let\@lstp@ifsucc@kont\@secondoftwo
+ \fi
+ \@lstp@ifsucc@kont
+}
+\newcommand\CompressList[2][\@apply@group{}]{%
+ \let\lstp@compress@temp@i#2%
+ \let#2\empty
+ \def\lstp@compress@add@single{%
+ \expandafter\SnocTo\expandafter
+ {\expandafter\@single\expandafter{\lstp@compress@temp@a}}{#2}%
+ }%
+ \def\lstp@compress@add@range{%
+ \expandafter\expandafter\expandafter\SnocTo
+ \expandafter\expandafter\expandafter{%
+ \expandafter\expandafter\expandafter\@range
+ \expandafter\expandafter\expandafter{%
+ \expandafter\lstp@compress@temp@a\expandafter}%
+ \expandafter{\lstp@compress@temp@b}}#2%
+ }%
+ \long\def\lstp@compress@listitem@start##1{%
+ \def\lstp@compress@temp@a{##1}%
+ \edef\lstp@compress@temp@a@key{#1{##1}}%
+ \let\listitem\lstp@compress@listitem@single
+ }%
+ \long\def\lstp@compress@listitem@single##1{%
+ \def\lstp@compress@temp@b{##1}%
+ \edef\lstp@compress@temp@b@key{#1{##1}}%
+ \ifnum\lstp@compress@temp@a@key=\lstp@compress@temp@b@key
+ \let\listitem\lstp@compress@listitem@single
+ \else
+ \lstp@ifsucc{\lstp@compress@temp@a@key}{\lstp@compress@temp@b@key}
+ {\let\listitem\lstp@compress@listitem@range}
+ {\lstp@compress@add@single
+ \let\lstp@compress@temp@a\lstp@compress@temp@b
+ \let\lstp@compress@temp@a@key\lstp@compress@temp@b@key
+ \let\listitem\lstp@compress@listitem@single}%
+ \fi
+ }%
+ \long\def\lstp@compress@listitem@range##1{%
+ \def\lstp@compress@temp@c{##1}%
+ \edef\lstp@compress@temp@c@key{#1{##1}}%
+ \ifnum\lstp@compress@temp@b@key=\lstp@compress@temp@c@key
+ \let\listitem\lstp@compress@listitem@range
+ \else
+ \lstp@ifsucc{\lstp@compress@temp@b@key}{\lstp@compress@temp@c@key}
+ {%
+ \let\lstp@compress@temp@b\lstp@compress@temp@c
+ \let\lstp@compress@temp@b@key\lstp@compress@temp@c@key
+ \let\listitem\lstp@compress@listitem@range
+ }
+ {%
+ \lstp@compress@add@range
+ \let\lstp@compress@temp@a\lstp@compress@temp@c
+ \let\lstp@compress@temp@a@key\lstp@compress@temp@c@key
+ \let\listitem\lstp@compress@listitem@single
+ }%
+ \fi
+ }%
+ \let\listitem\lstp@compress@listitem@start
+ \lstp@compress@temp@i
+ \ifx\listitem\lstp@compress@listitem@single
+ \lstp@compress@add@single
+ \else
+ \ifx\listitem\lstp@compress@listitem@range
+ \lstp@compress@add@range
+ \fi
+ \fi
+ \let\lstp@compress@temp@a\@undefined
+ \let\lstp@compress@temp@b\@undefined
+ \let\lstp@compress@temp@c\@undefined
+ \let\lstp@compress@temp@a@key\@undefined
+ \let\lstp@compress@temp@b@key\@undefined
+ \let\lstp@compress@temp@c@key\@undefined
+ \let\lstp@compress@temp@i\@undefined
+ \let\listitem\@undefined
+}
+\newcommand\FormatListSepTwo{ and }
+\newcommand\FormatListSepMore{, }
+\newcommand\FormatListSepLast{, and }
+\newcounter{lstp@FormatList@length}
+\newcounter{lstp@FormatList@posn}
+\newcommand\FormatList[4]{{%
+ \deflist\lstp@FormatList@list{#4}%
+ \SetToListLength{lstp@FormatList@length}\lstp@FormatList@list%
+ \setcounter{lstp@FormatList@posn}{0}%
+ \ifnum\value{lstp@FormatList@length}=1%
+ #1%
+ \else%
+ #2%
+ \fi%
+ \def\listitem##1{%
+ \addtocounter{lstp@FormatList@posn}{1}%
+ \ifnum1<\value{lstp@FormatList@posn}%
+ \ifnum2=\value{lstp@FormatList@length}%
+ \FormatListSepTwo
+ \else
+ \ifnum\value{lstp@FormatList@length}=\value{lstp@FormatList@posn}%
+ \FormatListSepLast
+ \else
+ \FormatListSepMore
+ \fi
+ \fi
+ \fi
+ #3{##1}%
+ }%
+ \lstp@FormatList@list
+}}
+\newcommand\ListExpr[1]{\@lstp@ListExpr{#1}\relax}
+\newcommand\ListExprTo[2]{\@lstp@ListExpr{#1}{\def#2}}
+\newcommand\gListExprTo[2]{\@lstp@ListExpr{#1}{\gdef#2}}
+\newcommand\@lstp@defbinop[2]{%
+ \newcommand#1[2]{%
+ \Eval{##1}\let\@lstp@tmp\@lstp@acc
+ {\Eval{##2}}%
+ #2\@lstp@tmp\@lstp@acc
+ }%
+}
+\newcommand\@lstp@defunop[2]{%
+ \newcommand#1[1]{%
+ \Eval{##1}%
+ #2\@lstp@acc\@lstp@acc
+ }%
+}
+\newcommand\@lstp@definplaceunopopt[3][]{%
+ \newcommand#2[2][#1]{%
+ \Eval{##2}%
+ #3[##1]\@lstp@acc
+ \global\let\@lstp@acc\@lstp@acc
+ }%
+}
+\newcommand\@lstp@ListExpr[2]{%
+ {%
+ \gdef\@lstp@acc{}%
+ \def\Eval##1{%
+ \IfList{##1}{%
+ \global\let\@lstp@acc##1%
+ }{%
+ \@lstp@ifListOp##1\@lstp@ifListOp{%
+ ##1%
+ }{%
+ \xdef\@lstp@acc{##1}%
+ }%
+ }%
+ }%
+ \def\Q##1{\gdef\@lstp@acc{##1}}%
+ \def\Nil{\global\let\@lstp@acc\empty}%
+ \def\List##1{\gdeflist\@lstp@acc{##1}}%
+ \@lstp@defbinop\Cons\xConsTo
+ \@lstp@defbinop\Snoc\xSnocTo
+ \@lstp@defunop\First\gFirstTo
+ \@lstp@defunop\Rest\gRestTo
+ \@lstp@defbinop\Append\gAppendTo
+ \@lstp@definplaceunopopt[\@apply@group{}]\Sort\SortList
+ \@lstp@definplaceunopopt[\@apply@group{}]\Compress\CompressList
+ \newcommand\Map[2]{%
+ \Eval{##2}%
+ \gMapListTo{##1}\@lstp@acc\@lstp@acc
+ }%
+ \Eval{#1}%
+ }%
+ \def\@lstp@finish##1{#2{##1}}%
+ \expandafter\@lstp@finish\expandafter{\@lstp@acc}%
+}
+\def\@lstp@ifListOp#1#2\@lstp@ifListOp{%
+ \@lstp@ifInToks#1{
+ \Q\Nil\List\Cons\Snoc\Append
+ \First\Rest\Sort\Compress\Map
+ }
+}
+\newcommand\@lstp@ifInToks[2]{%
+ {%
+ \def\@tester##1#1##2\@tester{%
+ \ifx\@notfound##2\relax
+ \aftergroup\@secondoftwo
+ \else
+ \aftergroup\@firstoftwo
+ \fi
+ }%
+ \@tester#2\@lstp@ifInToks#1\@notfound\@tester
+ }%
+}
+\endinput
+%%
+%% End of file `listproc.sty'.
diff --git a/docs/locallabel.sty b/docs/locallabel.sty
new file mode 100644
index 0000000000000000000000000000000000000000..6c28e92e6364e8dda324b978030a45598b5942c4
--- /dev/null
+++ b/docs/locallabel.sty
@@ -0,0 +1,118 @@
+% Locallabel
+%
+% Copyright (C) 2001, 2002, 2003 Didier Rémy
+%
+% Author : Didier Remy
+% Version : 1.1.1
+% Bug Reports : to author
+% Web Site : http://pauillac.inria.fr/~remy/latex/
+%
+% Locallabel is free software; you can redistribute it and/or modify
+% it under the terms of the GNU General Public License as published by
+% the Free Software Foundation; either version 2, or (at your option)
+% any later version.
+%
+% Locallabel is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU General Public License for more details
+% (http://pauillac.inria.fr/~remy/license/GPL).
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% File locallabel.sty (LaTeX macros)
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%
+
+%% Identification
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{locallabel}
+ [2001/23/02 v0.92 Locallabel]
+
+%% Preliminary declarations
+
+%% Options
+
+%% More declarations
+
+%% We use two counters: The global counter is incremented at each reset.
+%% Its value is the ``group'' of a local.
+%% The local counter is the last numeric value of a bound label in the
+%% current group. The value of a label #1 is globally set to
+%% \csname llb@\the\c@llb@global-#1\endcsname
+%% The global command \csname llb@\the\c@llb@global-#1*\endcsname is
+%% use to ensure that a label is only bound once. Usually a label is
+%% bound and declared at the same time with \llabel. It may also be bound in
+%% advance, with \lbind, for instance so as to control the numbering.
+%% Then, another \llabel must be used to declare it in the text.
+%% If no \lbind has been used before, the \llabel calls \lbind implicitlt.
+
+\newcounter{llb@global}
+\newcounter{llb@local}
+
+\newcommand \llb@find [1]
+ {\expandafter \ifx \csname llb@\the\c@llb@global-#1\endcsname \relax
+ \message {*** Local label #1 undefined in this context}%
+ \edef \llb@current {#1??}%
+ \else
+ \edef \llb@current {\csname llb@\the\c@llb@global-#1\endcsname}%
+ \fi}
+
+\newcommand \llb@make [1]
+ {\expandafter \ifx \csname llb@\the\c@llb@global-#1\endcsname \relax
+ \stepcounter{llb@local}\relax \expandafter
+ \xdef \csname llb@\the\c@llb@global-#1\endcsname {\the\c@llb@local}%
+ \edef \llb@current {\the\c@llb@local}%
+ \else
+ \expandafter \ifx \csname llb@\the\c@llb@global-#1*\endcsname \relax
+ \message {*** Local label #1 already defined in this countext!}%
+ \edef \llb@current {\csname llb@\the\c@llb@global-#1\endcsname ??}%
+ \else
+ \expandafter \global \expandafter \let
+ \csname llb@\the\c@llb@global-#1*\endcsname \relax
+ \edef \llb@current {\csname llb@\the\c@llb@global-#1\endcsname}
+ \fi
+ \fi
+}
+
+%%% Redefine those macros to change typsetting
+
+\newcommand \thelocallabel {\the \c@llb@local}
+
+\newcommand \LlabelTypeset [1] {(\textrm {\bfseries #1})}
+\newcommand \LrefTypeset [1] {(\textrm {#1)}}
+\newcommand \glabel [1]{\LlabelTypeset{\softtarget {#1}{#1}}}
+\newcommand \gref [1]{\LrefTypeset{\softlink {#1}{#1}}}
+
+%%% To reset all local labels---which just increment a global prefix.
+\newcommand \locallabelreset[1][0]%
+ {\stepcounter {llb@global}\setcounter {llb@local}{#1}}
+
+%%% Make a new local label, typeset it, and bind to the given name
+\def \llb@relax {\relax}
+\newcommand {\llabel}[2][\relax]%
+ {\llb@make{#2}%
+ \def \@test {#1}\ifx \@test\llb@relax\else
+ \edef \@currentlabel {\the\c@llb@local}%
+ \def \@test {#1}\ifx \@test\empty \def \@test{#2}\fi
+ \label{\@test}%
+ \fi%
+ \LlabelTypeset {\softtarget{llb@\the\c@llb@global-#2}{\llb@current}}}
+
+%%% Retreive the local label of given name and type set it.
+\newcommand \lref [1]
+ {\llb@find {#1}%
+ \LrefTypeset {\softlink {llb@\the\c@llb@global-#1}{\llb@current}}}
+
+%%% Make a new local label and bind it to the given name but do not typeset
+%%% it. Typesetting may then be done with \llabel non locally. Useful to
+%%% control the order of numberring.
+\newcommand \lbind [1]
+ {\llb@make {#1}%
+ \expandafter \global \expandafter
+ \let \csname llb@\the\c@llb@global-#1*\endcsname \empty}
+
+\AtBeginDocument {%
+ \@ifundefined{softlink}{\let \softlink \@secondoftwo}{}%
+ \@ifundefined{softtarget}{\let \softtarget \@secondoftwo}{}%
+}
diff --git a/docs/logic.tex b/docs/logic.tex
new file mode 100644
index 0000000000000000000000000000000000000000..e991d07a85c27d8235f2c894511244b671b4ae05
--- /dev/null
+++ b/docs/logic.tex
@@ -0,0 +1,796 @@
+
+\section{Parameters to the logic}
+
+\begin{itemize}
+% \item A set \textdom{Exp} of \emph{expressions} (metavariable $\expr$) with a
+% subset \textdom{Val} of values ($\val$). We assume that if $\expr$ is an
+% expression then so is $\fork{\expr}$. We moreover assume a value
+% \textsf{fRet} (giving the intended return value of a fork), and we assume that
+% \begin{align*}
+% \fork{\expr} &\notin \textdom{Val} \\
+% \fork{\expr_1} = \fork{\expr_2} &\implies \expr_1 = \expr_2
+% \end{align*}
+\item A set $\textdom{Ectx}$ of \emph{evaluation contexts} ($\ectx$) that includes the empty context $[\; ]$,
+ a plugging operation $\ectx[\expr]$ that produces an expression, and context composition $\circ$
+ satisfying the following axioms:
+ \begin{align*}
+ [\; ][ \expr ] &= \expr \\
+ \ectx_1[\ectx_2[\expr]] &= (\ectx_1 \circ \ectx_2) [\expr] \\
+ \ectx_1[\expr] = \ectx_2[\expr] &\implies \ectx_1 = \ectx_2 \\
+ \ectx[\expr_1] = \ectx[\expr_2] &\implies \expr_1 = \expr_2 \\
+ \ectx_1 \circ \ectx_2 = [\; ] &\implies \ectx_1 = \ectx_2 = [\; ] \\
+ \ectx[\expr] \in \textdom{Val} &\implies \ectx = [\;] \\
+% \ectx[\expr] = \fork{\expr'} &\implies \ectx = [\;]
+ \end{align*}
+
+\item A set \textdom{State} of shared machine states (\eg heaps), metavariable $\state$.
+\item An \emph{atomic stepping relation} \[
+ (- \step -) \subseteq (\textdom{State} \times \textdom{Exp}) \times (\textdom{State} \times \textdom{Exp})
+\]
+and notions of an expression to be \emph{reducible} or \emph{stuck}, such that
+\begin{align*}
+ \textlog{reducible}(\expr) &\iff \Exists \state, \expr_2, \state_2. \cfg{\state}{\expr} \step \cfg{\state_2}{\expr_2} \\
+% \textlog{stuck}(\expr) &\iff \All \ectx, \expr'. \expr = \ectx[\expr'] \implies
+ \lnot \textlog{reducible}(\expr')
+\end{align*}
+and the following hold
+% \begin{align*}
+% &\textlog{stuck}(\fork{\expr})& \\
+% &\textlog{stuck}(\val)&\\
+% &\ectx[\expr] = \ectx'[\expr'] \implies \textlog{reducible}(\expr') \implies
+% \expr \notin \textdom{Val} \implies \Exists \ectx''. \ectx' = \ectx \circ \ectx'' &\mbox{(step-by-value)} \\
+% &\ectx[\expr] = \ectx'[\fork{\expr'}] \implies
+% \expr \notin \textdom{Val} \implies \Exists \ectx''. \ectx' = \ectx \circ \ectx'' &\mbox{(fork-by-value)} \\
+% \end{align*}
+
+\item A predicate \textlog{atomic} on expressions satisfying
+ \begin{align*}
+ &\textlog{atomic}(\expr) \implies \textlog{reducible}(\expr) &\\
+ &\textlog{atomic}(\expr) \implies \cfg{\state}{\expr} \step \cfg{\state_2}{\expr_2} \implies \expr_2 \in \textdom{Val} &\mbox{(atomic-step)}
+ \end{align*}
+
+
+\item A commutative monoid with zero, $M$.
+That is, a set $\mcar{M}$ with two distinguished elements $\mzero$ (zero, undefined) and $\munit$ (one, unit) and an operation $\mtimes$ (times, combine) such that
+\begin{align*}
+ \melt \mtimes \meltB &= \meltB \mtimes \melt \\
+ \munit \mtimes \melt &= \melt \\
+ (\melt \mtimes \meltB) \mtimes \meltC &= \melt \mtimes (\meltB \mtimes \meltC) \\
+ \mzero \mtimes \melt &= \mzero \\
+ \mzero &\neq \munit
+\end{align*}
+Let $\mcarp{M} \eqdef |\monoid| \setminus \{\mzero\}$.
+
+\item Arbitrary additional types and terms.
+\end{itemize}
+
+\section{The concurrent language}
+
+\paragraph{Machine syntax}
+\[
+ \tpool \in \textdom{ThreadPool} \eqdef \mathbb{N} \fpfn \textdom{Exp}
+\]
+
+\judgment{Machine reduction} {\cfg{\state}{\tpool} \step
+ \cfg{\state'}{\tpool'}}
+\begin{mathpar}
+\infer
+ {\cfg{\state}{\expr} \step \cfg{\state'}{\expr'}}
+ {\cfg{\state}{\tpool [i \mapsto \ectx[\expr]]} \step
+ \cfg{\state'}{\tpool [i \mapsto \ectx[\expr']]}}
+% \and
+% \infer
+% {}
+% {\cfg{\state}{\tpool [i \mapsto \ectx[\fork{\expr}]]} \step
+% \cfg{\state}{\tpool [i \mapsto \ectx[\textsf{fRet}]] [j \mapsto \expr]}}
+\end{mathpar}
+
+\section{Syntax}
+
+\subsection{Grammar}\label{sec:grammar}
+
+\paragraph{Signatures.}
+We use a signature to account syntactically for the logic's parameters.
+A \emph{signature} $\Sig = (\SigType, \SigFn)$ comprises a set
+\[
+ \SigType \supseteq \{ \textsort{Val}, \textsort{Exp}, \textsort{Ectx}, \textsort{State}, \textsort{Monoid}, \textsort{InvName}, \textsort{InvMask}, \Prop \}
+\]
+of base types (or base \emph{sorts}) and a set $\SigFn$ of typed function symbols.
+This means that each function symbol has an associated \emph{arity} comprising a natural number $n$ and an ordered list of $n+1$ base types.
+We write
+\[
+ \sigfn : \type_1, \dots, \type_n \to \type_{n+1} \in \SigFn
+\]
+to express that $\sigfn$ is a function symbol with the indicated arity.
+\dave{Say something not-too-shabby about adequacy: We don't spell out what it means.}
+
+\paragraph{Syntax.}
+Iris syntax is built up from a signature $\Sig$ and a countably infinite set $\textdom{Var}$ of variables (ranged over by metavariables $x$, $y$, $z$):
+
+\begin{align*}
+ \term, \prop, \pred ::={}&
+ x \mid
+ \sigfn(\term_1, \dots, \term_n) \mid
+ \unitval \mid
+ (\term, \term) \mid
+ \pi_i\; \term \mid
+ \Lam x.\term \mid
+ \term\;\term \mid
+ \mzero \mid
+ \munit \mid
+ \term \mtimes \term \mid
+\\&
+ \FALSE \mid
+ \TRUE \mid
+ \term =_\sort \term \mid
+ \prop \Ra \prop \mid
+ \prop \land \prop \mid
+ \prop \lor \prop \mid
+ \prop * \prop \mid
+ \prop \wand \prop \mid
+\\&
+ \MU \var. \pred \mid
+ \Exists \var:\sort. \prop \mid
+ \All \var:\sort. \prop \mid
+\\&
+ \knowInv{\term}{\prop} \mid
+ \ownGGhost{\term} \mid
+ \ownPhys{\term} \mid
+ \always\prop \mid
+ {\later\prop} \mid
+ \pvsA{\prop}{\term}{\term} \mid
+ \dynA{\term}{\pred}{\term} \mid
+ \timeless{\prop}
+\\[0.4em]
+ \sort ::={}&
+ \type \mid
+ \unitsort \mid
+ \sort \times \sort \mid
+ \sort \to \sort
+\end{align*}
+Recursive predicates must be \emph{guarded}: in $\MU \var. \pred$, the variable $\var$ can only appear under the later $\later$ modality.
+
+\paragraph{Metavariable conventions.}
+We introduce additional metavariables ranging over terms and generally let the choice of metavariable indicate the term's sort:
+\[
+\begin{array}{r|l}
+ \text{metavariable} & \text{sort} \\\hline
+ \term, \termB & \text{arbitrary} \\
+ \val, \valB & \textsort{Val} \\
+ \expr & \textsort{Exp} \\
+ \ectx & \textsort{Ectx} \\
+ \state & \textsort{State} \\
+\end{array}
+\qquad\qquad
+\begin{array}{r|l}
+ \text{metavariable} & \text{sort} \\\hline
+ \iname & \textsort{InvName} \\
+ \mask & \textsort{InvMask} \\
+ \melt, \meltB & \textsort{Monoid} \\
+ \prop, \propB, \propC & \Prop \\
+ \pred, \predB, \predC & \sort\to\Prop \text{ (when $\sort$ is clear from context)} \\
+\end{array}
+\]
+
+\paragraph{Variable conventions.}
+We often abuse notation, using the preceding \emph{term} meta-variables to range over (bound) \emph{variables}.
+We omit type annotations in binders, when the type is clear from context.
+
+
+\subsection{Types}\label{sec:types}
+
+Iris terms are simply-typed.
+The judgment $\vctx \proves_\Sig \wtt{\term}{\sort}$ expresses that, in signature $\Sig$ and variable context $\vctx$, the term $\term$ has sort $\sort$.
+In giving the rules for this judgment, we omit the signature (which does not change).
+
+A variable context, $\vctx = x_1:\sort_1, \dots, x_n:\sort_n$, declares a list of variables and their sorts.
+In writing $\vctx, x:\sort$, we presuppose that $x$ is not already declared in $\vctx$.
+
+\judgment{Well-typed terms}{\vctx \proves_\Sig \wtt{\term}{\sort}}
+\begin{mathparpagebreakable}
+%%% variables and function symbols
+ \axiom{x : \sort \proves \wtt{x}{\sort}}
+\and
+ \infer{\vctx \proves \wtt{\term}{\sort}}
+ {\vctx, x:\sort' \proves \wtt{\term}{\sort}}
+\and
+ \infer{\vctx, x:\sort', y:\sort' \proves \wtt{\term}{\sort}}
+ {\vctx, x:\sort' \proves \wtt{\term[x/y]}{\sort}}
+\and
+ \infer{\vctx_1, x:\sort', y:\sort'', \vctx_2 \proves \wtt{\term}{\sort}}
+ {\vctx_1, x:\sort'', y:\sort', \vctx_2 \proves \wtt{\term[y/x,x/y]}{\sort}}
+\and
+ \infer{
+ \vctx \proves \wtt{\term_1}{\type_1} \and
+ \cdots \and
+ \vctx \proves \wtt{\term_n}{\type_n} \and
+ \sigfn : \type_1, \dots, \type_n \to \type_{n+1} \in \SigFn
+ }{
+ \vctx \proves \wtt {\sigfn(\term_1, \dots, \term_n)} {\type_{n+1}}
+ }
+%%% products
+\and
+ \axiom{\vctx \proves \wtt{\unitval}{\unitsort}}
+\and
+ \infer{\vctx \proves \wtt{\term}{\sort_1} \and \vctx \proves \wtt{\termB}{\sort_2}}
+ {\vctx \proves \wtt{(\term,\termB)}{\sort_1 \times \sort_2}}
+\and
+ \infer{\vctx \proves \wtt{\term}{\sort_1 \times \sort_2} \and i \in \{1, 2\}}
+ {\vctx \proves \wtt{\pi_i\,\term}{\sort_i}}
+%%% functions
+\and
+ \infer{\vctx, x:\sort \proves \wtt{\term}{\sort'}}
+ {\vctx \proves \wtt{\Lam x. \term}{\sort \to \sort'}}
+\and
+ \infer
+ {\vctx \proves \wtt{\term}{\sort \to \sort'} \and \wtt{\termB}{\sort}}
+ {\vctx \proves \wtt{\term\;\termB}{\sort'}}
+%%% monoids
+\and
+ \axiom{\vctx \proves \wtt{\mzero}{\textsort{Monoid}}}
+\and
+ \axiom{\vctx \proves \wtt{\munit}{\textsort{Monoid}}}
+\and
+ \infer{\vctx \proves \wtt{\melt}{\textsort{Monoid}} \and \vctx \proves \wtt{\meltB}{\textsort{Monoid}}}
+ {\vctx \proves \wtt{\melt \mtimes \meltB}{\textsort{Monoid}}}
+%%% props and predicates
+\\
+ \axiom{\vctx \proves \wtt{\FALSE}{\Prop}}
+\and
+ \axiom{\vctx \proves \wtt{\TRUE}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\term}{\sort} \and \vctx \proves \wtt{\termB}{\sort}}
+ {\vctx \proves \wtt{\term =_\sort \termB}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop} \and \vctx \proves \wtt{\propB}{\Prop}}
+ {\vctx \proves \wtt{\prop \Ra \propB}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop} \and \vctx \proves \wtt{\propB}{\Prop}}
+ {\vctx \proves \wtt{\prop \land \propB}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop} \and \vctx \proves \wtt{\propB}{\Prop}}
+ {\vctx \proves \wtt{\prop \lor \propB}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop} \and \vctx \proves \wtt{\propB}{\Prop}}
+ {\vctx \proves \wtt{\prop * \propB}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop} \and \vctx \proves \wtt{\propB}{\Prop}}
+ {\vctx \proves \wtt{\prop \wand \propB}{\Prop}}
+\and
+ \infer{
+ \vctx, \var:\sort\to\Prop \proves \wtt{\pred}{\sort\to\Prop} \and
+ \text{$\var$ is guarded in $\pred$}
+ }{
+ \vctx \proves \wtt{\MU \var. \pred}{\sort\to\Prop}
+ }
+\and
+ \infer{\vctx, x:\sort \proves \wtt{\prop}{\Prop}}
+ {\vctx \proves \wtt{\Exists x:\sort. \prop}{\Prop}}
+\and
+ \infer{\vctx, x:\sort \proves \wtt{\prop}{\Prop}}
+ {\vctx \proves \wtt{\All x:\sort. \prop}{\Prop}}
+\and
+ \infer{
+ \vctx \proves \wtt{\prop}{\Prop} \and
+ \vctx \proves \wtt{\iname}{\textsort{InvName}}
+ }{
+ \vctx \proves \wtt{\knowInv{\iname}{\prop}}{\Prop}
+ }
+\and
+ \infer{\vctx \proves \wtt{\melt}{\textsort{Monoid}}}
+ {\vctx \proves \wtt{\ownGGhost{\melt}}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\state}{\textsort{State}}}
+ {\vctx \proves \wtt{\ownPhys{\state}}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop}}
+ {\vctx \proves \wtt{\always\prop}{\Prop}}
+\and
+ \infer{\vctx \proves \wtt{\prop}{\Prop}}
+ {\vctx \proves \wtt{\later\prop}{\Prop}}
+\and
+ \infer{
+ \vctx \proves \wtt{\prop}{\Prop} \and
+ \vctx \proves \wtt{\mask}{\textsort{InvMask}} \and
+ \vctx \proves \wtt{\mask'}{\textsort{InvMask}}
+ }{
+ \vctx \proves \wtt{\pvsA{\prop}{\mask}{\mask'}}{\Prop}
+ }
+\and
+ \infer{
+ \vctx \proves \wtt{\expr}{\textsort{Exp}} \and
+ \vctx \proves \wtt{\pred}{\textsort{Val} \to \Prop} \and
+ \vctx \proves \wtt{\mask}{\textsort{InvMask}}
+ }{
+ \vctx \proves \wtt{\dynA{\expr}{\pred}{\mask}}{\Prop}
+ }
+\and
+ \infer{
+ \vctx \proves \wtt{\prop}{\Prop}
+ }{
+ \vctx \proves \wtt{\timeless{\prop}}{\Prop}
+ }
+\end{mathparpagebreakable}
+
+
+\section{Base logic}
+
+The judgment $\vctx \mid \pfctx \proves \prop$ says that with free variables $\vctx$, proposition $\prop$ holds whenever all assumptions $\pfctx$ hold.
+We implicitly assume that an arbitrary variable context, $\vctx$, is added to every constituent of the rules.
+Axioms $\prop \Ra \propB$ stand for judgments $\vctx \mid \cdot \proves \prop \Ra \propB$ with no assumptions.
+(Bi-implications are analogous.)
+
+% \subsubsection{Judgments}
+%
+% Proof rules implicitly assume well-sortedness.
+
+% e\subsection{Laws of intuitionistic higher-order logic with guarded recursion over a simply-typed lambda calculus}\label{sec:HOL}
+
+This is entirely standard.
+
+Soundness follows from the theorem that ${\cal U}(\any, \textdom{Prop})
+: {\cal U}^{\textrm{op}} \to \textrm{Poset}$ is a hyperdoctrine.
+
+\begin{mathpar}
+\inferH{Asm}
+ {\prop \in \pfctx}
+ {\pfctx \proves \prop}
+\and
+\inferH{Eq}
+ {\pfctx \proves \prop(\term) \\ \pfctx \proves \term = \term'}
+ {\pfctx \proves \prop(\term')}
+\and
+\infer[$\wedge$I]
+ {\pfctx \proves \prop \\ \pfctx \proves \propB}
+ {\pfctx \proves \prop \wedge \propB}
+\and
+\infer[$\wedge$EL]
+ {\pfctx \proves \prop \wedge \propB}
+ {\pfctx \proves \prop}
+\and
+\infer[$\wedge$ER]
+ {\pfctx \proves \prop \wedge \propB}
+ {\pfctx \proves \propB}
+\and
+\infer[$\vee$E]
+ {\pfctx \proves \prop \vee \propB \\
+ \pfctx, \prop \proves \propC \\
+ \pfctx, \propB \proves \propC}
+ {\pfctx \proves \propC}
+\and
+\infer[$\vee$IL]
+ {\pfctx \proves \prop }
+ {\pfctx \proves \prop \vee \propB}
+\and
+\infer[$\vee$IR]
+ {\pfctx \proves \propB}
+ {\pfctx \proves \prop \vee \propB}
+\and
+\infer[$\Ra$I]
+ {\pfctx, \prop \proves \propB}
+ {\pfctx \proves \prop \Ra \propB}
+\and
+\infer[$\Ra$E]
+ {\pfctx \proves \prop \Ra \propB \\ \pfctx \proves \prop}
+ {\pfctx \proves \propB}
+\and
+\infer[$\forall_1$I]
+ {\pfctx, x : \sort \proves \prop}
+ {\pfctx \proves \forall x: \sort.\; \prop}
+\and
+\infer[$\forall_1$E]
+ {\pfctx \proves \forall X \in \sort.\; \prop \\
+ \pfctx \proves \term: \sort}
+ {\pfctx \proves \prop[\term/X]}
+\and
+\infer[$\exists_1$E]
+ {\pfctx \proves \exists X\in \sort.\; \prop \\
+ \pfctx, X : \sort, \prop \proves \propB}
+ {\pfctx \proves \propB}
+\and
+\infer[$\exists_1$I]
+ {\pfctx \proves \prop[\term/X] \\
+ \pfctx \proves \term: \sort}
+ {\pfctx \proves \exists X: \sort. \prop}
+\and
+\infer[$\forall_2$I]
+ {\pfctx, \var: \Pred(\sort) \proves \prop}
+ {\pfctx \proves \forall \var\in \Pred(\sort).\; \prop}
+\and
+\infer[$\forall_2$E]
+ {\pfctx \proves \forall \var. \prop \\
+ \pfctx \proves \propB: \Prop}
+ {\pfctx \proves \prop[\propB/\var]}
+\and
+\infer[$\exists_2$E]
+ {\pfctx \proves \exists \var \in \Pred(\sort).\prop \\
+ \pfctx, \var : \Pred(\sort), \prop \proves \propB}
+ {\pfctx \proves \propB}
+\and
+\infer[$\exists_2$I]
+ {\pfctx \proves \prop[\propB/\var] \\
+ \pfctx \proves \propB: \Prop}
+ {\pfctx \proves \exists \var. \prop}
+\and
+\inferB[Elem]
+ {\pfctx \proves \term \in (X \in \sort). \prop}
+ {\pfctx \proves \prop[\term/X]}
+\and
+\inferB[Elem-$\mu$]
+ {\pfctx \proves \term \in (\mu\var \in \Pred(\sort). \pred)}
+ {\pfctx \proves \term \in \pred[\mu\var \in \Pred(\sort). \pred/\var]}
+\end{mathpar}
+
+\subsection{Axioms from the logic of (affine) bunched implications}
+\begin{mathpar}
+\begin{array}{rMcMl}
+ \prop * \propB &\Lra& \propB * \prop \\
+ (\prop * \propB) * \propC &\Lra& \prop * (\propB * \propC) \\
+ \prop * \propB &\Ra& \prop
+\end{array}
+\and
+\begin{array}{rMcMl}
+ (\prop \vee \propB) * \propC &\Lra&
+ (\prop * \propC) \vee (\propB * \propC) \\
+ (\prop \wedge \propB) * \propC &\Ra&
+ (\prop * \propC) \wedge (\propB * \propC) \\
+ (\Exists x. \prop) * \propB &\Lra& \Exists x. (\prop * \propB) \\
+ (\All x. \prop) * \propB &\Ra& \All x. (\prop * \propB)
+\end{array}
+\and
+\infer
+ {\pfctx, \prop_1 \proves \propB_1 \and
+ \pfctx, \prop_2 \proves \propB_2}
+ {\pfctx, \prop_1 * \prop_2 \proves \propB_1 * \propB_2}
+\and
+\infer
+ {\pfctx, \prop * \propB \proves \propC}
+ {\pfctx, \prop \proves \propB \wand \propC}
+\and
+\infer
+ {\pfctx, \prop \proves \propB \wand \propC}
+ {\pfctx, \prop * \propB \proves \propC}
+\end{mathpar}
+
+\subsection{Laws for ghosts and physical resources}
+
+\begin{mathpar}
+\begin{array}{rMcMl}
+\ownGGhost{\melt} * \ownGGhost{\meltB} &\Lra& \ownGGhost{\melt \mtimes \meltB} \\
+\TRUE &\Ra& \ownGGhost{\munit}\\
+\ownGGhost{\mzero} &\Ra& \FALSE\\
+\multicolumn{3}{c}{\timeless{\ownGGhost{\melt}}}
+\end{array}
+\and
+\begin{array}{c}
+\ownPhys{\state} * \ownPhys{\state'} \Ra \FALSE \\
+\timeless{\ownPhys{\state}}
+\end{array}
+\end{mathpar}
+
+\subsection{Laws for the later modality}\label{sec:later}
+
+\begin{mathpar}
+\inferH{Mono}
+ {\pfctx \proves \prop}
+ {\pfctx \proves \later{\prop}}
+\and
+\inferhref{L{\"o}b}{Loeb}
+ {\pfctx, \later{\prop} \proves \prop}
+ {\pfctx \proves \prop}
+\and
+\begin{array}[b]{rMcMl}
+ \later{\always{\prop}} &\Lra& \always{\later{\prop}} \\
+ \later{(\prop \wedge \propB)} &\Lra& \later{\prop} \wedge \later{\propB} \\
+ \later{(\prop \vee \propB)} &\Lra& \later{\prop} \vee \later{\propB} \\
+\end{array}
+\and
+\begin{array}[b]{rMcMl}
+ \later{\All x.\prop} &\Lra& \All x. \later\prop \\
+ \later{\Exists x.\prop} &\Lra& \Exists x. \later\prop \\
+ \later{(\prop * \propB)} &\Lra& \later\prop * \later\propB
+\end{array}
+\end{mathpar}
+
+\subsection{Laws for the always modality}\label{sec:always}
+
+\begin{mathpar}
+\axiomH{Necessity}
+ {\always{\prop} \Ra \prop}
+\and
+\inferhref{$\always$I}{AlwaysIntro}
+ {\always{\pfctx} \proves \prop}
+ {\always{\pfctx} \proves \always{\prop}}
+\and
+\begin{array}[b]{rMcMl}
+ \always(\term =_\sort \termB) &\Lra& \term=_\sort \termB \\
+ \always{\prop} * \propB &\Lra& \always{\prop} \land \propB \\
+ \always{(\prop \Ra \propB)} &\Ra& \always{\prop} \Ra \always{\propB} \\
+\end{array}
+\and
+\begin{array}[b]{rMcMl}
+ \always{(\prop \land \propB)} &\Lra& \always{\prop} \land \always{\propB} \\
+ \always{(\prop \lor \propB)} &\Lra& \always{\prop} \lor \always{\propB} \\
+ \always{\All x. \prop} &\Lra& \All x. \always{\prop} \\
+ \always{\Exists x. \prop} &\Lra& \Exists x. \always{\prop} \\
+\end{array}
+\end{mathpar}
+Note that $\always$ binds more tightly than $*$, $\land$, $\lor$, and $\Ra$.
+
+\section{Program logic}\label{sec:proglog}
+
+Hoare triples and view shifts are syntactic sugar for weakest (liberal) preconditions and primitive view shifts, respectively:
+\[
+\hoare{\prop}{\expr}{\Ret\val.\propB}[\mask] \eqdef \always{(\prop \Ra \dynA{\expr}{\lambda\Ret\val.\propB}{\mask})}
+\qquad\qquad
+\begin{aligned}
+\prop \vs[\mask_1][\mask_2] \propB &\eqdef \always{(\prop \Ra \pvsA{\propB}{\mask_1}{\mask_2})} \\
+\prop \vsE[\mask_1][\mask_2] \propB &\eqdef \prop \vs[\mask_1][\mask_2] \propB \land \propB \vs[\mask2][\mask_1] \prop
+\end{aligned}
+\]
+We write just one mask for a view shift when $\mask_1 = \mask_2$.
+The convention for omitted masks is generous:
+An omitted $\mask$ is $\top$ for Hoare triples and $\emptyset$ for view shifts.
+
+% PDS: We're repeating ourselves. We gave Γ conventions and we're about to give Θ conventions. Also, the scope of "Below" is unclear.
+% Below, we implicitly assume the same context for all judgements which don't have an explicit context at \emph{all} pre-conditions \emph{and} the conclusion.
+
+Henceforward, we implicitly assume a proof context, $\pfctx$, is added to every constituent of the rules.
+Generally, this is an arbitrary proof context.
+We write $\provesalways$ to denote judgments that can only be extended with a boxed proof context.
+
+\ralf{Give the actual base rules from the Coq development instead}
+
+\subsection{Hoare triples}
+\begin{mathpar}
+\inferH{Ret}
+ {}
+ {\hoare{\TRUE}{\valB}{\Ret\val. \val = \valB}[\mask]}
+\and
+\inferH{Bind}
+ {\hoare{\prop}{\expr}{\Ret\val. \propB}[\mask] \\
+ \All \val. \hoare{\propB}{K[\val]}{\Ret\valB.\propC}[\mask]}
+ {\hoare{\prop}{K[\expr]}{\Ret\valB.\propC}[\mask]}
+\and
+\inferH{Csq}
+ {\prop \vs \prop' \\
+ \hoare{\prop'}{\expr}{\Ret\val.\propB'}[\mask] \\
+ \All \val. \propB' \vs \propB}
+ {\hoare{\prop}{\expr}{\Ret\val.\propB}[\mask]}
+\and
+\inferH{Frame}
+ {\hoare{\prop}{\expr}{\Ret\val. \propB}[\mask]}
+ {\hoare{\prop * \propC}{\expr}{\Ret\val. \propB * \propC}[\mask \uplus \mask']}
+\and
+\inferH{AFrame}
+ {\hoare{\prop}{\expr}{\Ret\val. \propB}[\mask] \and \text{$\expr$ not a value}
+ }
+ {\hoare{\prop * \later\propC}{\expr}{\Ret\val. \propB * \propC}[\mask \uplus \mask']}
+% \and
+% \inferH{Fork}
+% {\hoare{\prop}{\expr}{\Ret\any. \TRUE}[\top]}
+% {\hoare{\later\prop * \later\propB}{\fork{\expr}}{\Ret\val. \val = \textsf{fRet} \land \propB}[\mask]}
+\and
+\inferH{ACsq}
+ {\prop \vs[\mask \uplus \mask'][\mask] \prop' \\
+ \hoare{\prop'}{\expr}{\Ret\val.\propB'}[\mask] \\
+ \All\val. \propB' \vs[\mask][\mask \uplus \mask'] \propB \\
+ \physatomic{\expr}
+ }
+ {\hoare{\prop}{\expr}{\Ret\val.\propB}[\mask \uplus \mask']}
+\end{mathpar}
+
+\subsection{View shifts}
+
+\begin{mathpar}
+\inferH{NewInv}
+ {\infinite(\mask)}
+ {\later{\prop} \vs[\mask] \exists \iname\in\mask.\; \knowInv{\iname}{\prop}}
+\and
+\inferH{FpUpd}
+ {\melt \mupd \meltsB}
+ {\ownGGhost{\melt} \vs \exists \meltB \in \meltsB.\; \ownGGhost{\meltB}}
+\and
+\inferH{VSTrans}
+ {\prop \vs[\mask_1][\mask_2] \propB \and \propB \vs[\mask_2][\mask_3] \propC \and \mask_2 \subseteq \mask_1 \cup \mask_3}
+ {\prop \vs[\mask_1][\mask_3] \propC}
+\and
+\inferH{VSImp}
+ {\always{(\prop \Ra \propB)}}
+ {\prop \vs[\emptyset] \propB}
+\and
+\inferH{VSFrame}
+ {\prop \vs[\mask_1][\mask_2] \propB}
+ {\prop * \propC \vs[\mask_1 \uplus \mask'][\mask_2 \uplus \mask'] \propB * \propC}
+\and
+\inferH{VSTimeless}
+ {\timeless{\prop}}
+ {\later \prop \vs \prop}
+\and
+\axiomH{InvOpen}
+ {\knowInv{\iname}{\prop} \proves \TRUE \vs[\{ \iname \} ][\emptyset] \later \prop}
+\and
+\axiomH{InvClose}
+ {\knowInv{\iname}{\prop} \proves \later \prop \vs[\emptyset][\{ \iname \} ] \TRUE }
+\end{mathpar}
+
+\vspace{5pt}
+Note that $\timeless{\prop}$ means that $\prop$ does not depend on the step index.
+Furthermore, $$\melt \mupd \meltsB \eqdef \always{\All \melt_f. \melt \sep \melt_f \Ra \Exists \meltB \in \meltsB. \meltB \sep \melt_f}$$
+
+\subsection{Derived rules}
+
+\paragraph{Derived structural rules.}
+The following are easily derived by unfolding the sugar for Hoare triples and view shifts.
+\begin{mathpar}
+\inferHB{Disj}
+ {\hoare{\prop}{\expr}{\Ret\val.\propC}[\mask] \and \hoare{\propB}{\expr}{\Ret\val.\propC}[\mask]}
+ {\hoare{\prop \lor \propB}{\expr}{\Ret\val.\propC}[\mask]}
+\and
+\inferHB{VSDisj}
+ {\prop \vs[\mask_1][\mask_2] \propC \and \propB \vs[\mask_1][\mask_2] \propC}
+ {\prop \lor \propB \vs[\mask_1][\mask_2] \propC}
+\and
+\inferHB{Exist}
+ {\All \var. \hoare{\prop}{\expr}{\Ret\val.\propB}[\mask]}
+ {\hoare{\Exists \var. \prop}{\expr}{\Ret\val.\propB}[\mask]}
+\and
+\inferHB{VSExist}
+ {\All \var. (\prop \vs[\mask_1][\mask_2] \propB)}
+ {(\Exists \var. \prop) \vs[\mask_1][\mask_2] \propB}
+\and
+\inferHB{BoxOut}
+ {\always\propB \provesalways \hoare{\prop}{\expr}{\Ret\val.\propC}[\mask]}
+ {\hoare{\prop \land \always{\propB}}{\expr}{\Ret\val.\propC}[\mask]}
+\and
+\inferHB{VSBoxOut}
+ {\always\propB \provesalways \prop \vs[\mask_1][\mask_2] \propC}
+ {\prop \land \always{\propB} \vs[\mask_1][\mask_2] \propC}
+ \and
+\inferH{False}
+ {}
+ {\hoare{\FALSE}{\expr}{\Ret \val. \prop}[\mask]}
+\and
+\inferH{VSFalse}
+ {}
+ {\FALSE \vs[\mask_1][\mask_2] \prop }
+\end{mathpar}
+The proofs all follow the same pattern, so we only show two of them in detail.
+\begin{proof}[Proof of \ruleref{Exist}]
+ After unfolding the syntactic sugar for Hoare triples and removing the boxes from premise and conclusion, our goal becomes
+ \[
+ (\Exists \var. \prop(\var)) \Ra \dynA{\expr}{\Lam\val. \propB}{\mask}
+ \]
+ (remember that $\var$ is free in $\prop$) and the premise reads
+ \[
+ \All \var. \prop(\var) \Ra \dynA{\expr}{\Lam\val. \propB}{\mask}.
+ \]
+ Let $\var$ be given and assume $\prop(\var)$.
+ To show $\dynA{\expr}{\Lam\val. \propB}{\mask}$, apply the premise to $\var$ and $\prop(\var)$.
+
+ For the other direction, assume
+ \[
+ \hoare{\Exists \var. \prop(\var)}{\expr}{\Ret\val. \propB}[\mask]
+ \]
+ and let $\var$ be given.
+ We have to show $\hoare{\prop(\var)}{\expr}{\Ret\val. \propB}[\mask]$.
+ This trivially follows from \ruleref{Csq} with $\prop(\var) \Ra \Exists \var. \prop(\var)$.
+\end{proof}
+
+\begin{proof}[Proof of \ruleref{BoxOut}]
+ After unfolding the syntactic sugar for Hoare triples, our goal becomes
+ \begin{equation}\label{eq:boxin:goal}
+ \always\pfctx \proves \always\bigl(\prop\land\always \propB \Ra \dynA{\expr}{\Lam\val. \propC}{\mask}\bigr)
+ \end{equation}
+ while our premise reads
+ \begin{equation}\label{eq:boxin:as}
+ \always\pfctx, \always\propB \proves \always(\prop \Ra \dynA{\expr}{\Lam\val. \propC}{\mask})
+ \end{equation}
+ By the introduction rules for $\always$ and implication, it suffices to show
+ \[ (\always\pfctx), \prop,\always \propB \proves \dynA{\expr}{\Lam\val. \propC}{\mask} \]
+ By modus ponens and \ruleref{Necessity}, it suffices to show~\eqref{eq:boxin:as}, which is exactly our assumption.
+
+ For the other direction, assume~\eqref{eq:boxin:goal}. We have to show~\eqref{eq:boxin:as}. By \ruleref{AlwaysIntro} and implication introduction, it suffices to show
+ \[ (\always\pfctx), \prop,\always \propB \proves \dynA{\expr}{\Lam\val. \propC}{\mask} \]
+ which easily follows from~\eqref{eq:boxin:goal}.
+\end{proof}
+
+\paragraph{Derived rules for invariants.}
+Invariants can be opened around atomic expressions and view shifts.
+
+\begin{mathpar}
+\inferH{Inv}
+ {\hoare{\later{\propC} * \prop }
+ {\expr}
+ {\Ret\val. \later{\propC} * \propB }[\mask]
+ \and \physatomic{\expr}
+ }
+ {\knowInv{\iname}{\propC} \proves \hoare{\prop}
+ {\expr}
+ {\Ret\val. \propB}[\mask \uplus \{ \iname \}]
+ }
+\and
+\inferH{VSInv}
+ {\later{\prop} * \propB \vs[\mask_1][\mask_2] \later{\prop} * \propC}
+ {\knowInv{\iname}{\prop} \proves \propB \vs[\mask_1 \uplus \{ \iname \}][\mask_2 \uplus \{ \iname \}] \propC}
+\end{mathpar}
+
+\begin{proof}[Proof of \ruleref{Inv}]
+ Use \ruleref{ACsq} with $\mask_1 \eqdef \mask \cup \{\iname\}$, $\mask_2 \eqdef \mask$.
+ The view shifts are obtained by \ruleref{InvOpen} and \ruleref{InvClose} with framing of $\mask$ and $\prop$ or $\propB$, respectively.
+\end{proof}
+
+\begin{proof}[Proof of \ruleref{VSInv}]
+Analogous to the proof of \ruleref{Inv}, using \ruleref{VSTrans} instead of \ruleref{ACsq}.
+\end{proof}
+
+\subsubsection{Unsound rules}
+
+Some rule suggestions (or rather, wishes) keep coming up, which are unsound. We collect them here.
+\begin{mathpar}
+ \infer
+ {P \vs Q}
+ {\later P \vs \later Q}
+ \and
+ \infer
+ {\later(P \vs Q)}
+ {\later P \vs \later Q}
+\end{mathpar}
+
+Of course, the second rule implies the first, so let's focus on that.
+Since implications work under $\later$, from $\later P$ we can get $\later \pvs{Q}$.
+If we now try to prove $\pvs{\later Q}$, we will be unable to establish world satisfaction in the new world:
+We have no choice but to use $\later \pvs{Q}$ at one step index below what we are operating on (because we have it under a $\later$).
+We can easily get world satisfaction for that lower step-index (by downwards-closedness of step-indexed predicates).
+We can, however, not make much use of the world satisfaction that we get out, becaase it is one step-index too low.
+
+\subsection{Adequacy}
+
+The adequacy statement reads as follows:
+\begin{align*}
+ &\All \mask, \expr, \val, \pred, i, \state, \state', \tpool'.
+ \\&( \proves \hoare{\ownPhys\state}{\expr}{x.\; \pred(x)}[\mask]) \implies
+ \\&\cfg{\state}{[i \mapsto \expr]} \step^\ast
+ \cfg{\state'}{[i \mapsto \val] \uplus \tpool'} \implies
+ \\&\pred(\val)
+\end{align*}
+where $\pred$ can mention neither resources nor invariants.
+
+\subsection{Axiom lifting}\label{sec:lifting}
+
+The following lemmas help in proving axioms for a particular language.
+The first applies to expressions with side-effects, and the second to side-effect-free expressions.
+\dave{Update the others, and the example, wrt the new treatment of $\predB$.}
+\begin{align*}
+ &\All \expr, \state, \pred, \prop, \propB, \mask. \\
+ &\textlog{reducible}(e) \implies \\
+ &(\All \expr', \state'. \cfg{\state}{\expr} \step \cfg{\state'}{\expr'} \implies \pred(\expr', \state')) \implies \\
+ &{} \proves \bigl( (\All \expr', \state'. \pred (\expr', \state') \Ra \hoare{\prop}{\expr'}{\Ret\val. \propB}[\mask]) \Ra \hoare{ \later \prop * \ownPhys{\state} }{\expr}{\Ret\val. \propB}[\mask] \bigr) \\
+ \quad\\
+ &\All \expr, \pred, \prop, \propB, \mask. \\
+ &\textlog{reducible}(e) \implies \\
+ &(\All \state, \expr_2, \state_2. \cfg{\state}{\expr} \step \cfg{\state_2}{\expr_2} \implies \state_2 = \state \land \pred(\expr_2)) \implies \\
+ &{} \proves \bigl( (\All \expr'. \pred(\expr') \Ra \hoare{\prop}{\expr'}{\Ret\val. \propB}[\mask]) \Ra \hoare{\later\prop}{\expr}{\Ret\val. \propB}[\mask] \bigr)
+\end{align*}
+Note that $\pred$ is a meta-logic predicate---it does not depend on any world or resources being owned.
+
+The following specializations cover all cases of a heap-manipulating lambda calculus like $F_{\mu!}$.
+\begin{align*}
+ &\All \expr, \expr', \prop, \propB, \mask. \\
+ &\textlog{reducible}(e) \implies \\
+ &(\All \state, \expr_2, \state_2. \cfg{\state}{\expr} \step \cfg{\state_2}{\expr_2} \implies \state_2 = \state \land \expr_2 = \expr') \implies \\
+ &{} \proves (\hoare{\prop}{\expr'}{\Ret\val. \propB}[\mask] \Ra \hoare{\later\prop}{\expr}{\Ret\val. \propB}[\mask] ) \\
+ \quad \\
+ &\All \expr, \state, \pred, \mask. \\
+ &\textlog{atomic}(e) \implies \\
+ &\bigl(\All \expr_2, \state_2. \cfg{\state}{\expr} \step \cfg{\state_2}{\expr_2} \implies \pred(\expr_2, \state_2)\bigr) \implies \\
+ &{} \proves (\hoare{ \ownPhys{\state} }{\expr}{\Ret\val. \Exists\state'. \ownPhys{\state'} \land \pred(\val, \state') }[\mask] )
+\end{align*}
+The first is restricted to deterministic pure reductions, like $\beta$-reduction.
+The second is suited to proving triples for (possibly non-deterministic) atomic expressions; for example, with $\expr \eqdef \;!\ell$ (dereferencing $\ell$) and $\state \eqdef h \mtimes \ell \mapsto \valB$ and $\pred(\val, \state') \eqdef \state' = (h \mtimes \ell \mapsto \valB) \land \val = \valB$, one obtains the axiom $\All h, \ell, \valB. \hoare{\ownPhys{h \mtimes \ell \mapsto \valB}}{!\ell}{\Ret\val. \val = \valB \land \ownPhys{h \mtimes \ell \mapsto \valB} }$.
+%Axioms for CAS-like operations can be obtained by first deriving rules for the two possible cases, and then using the disjunction rule.
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "iris"
+%%% End:
diff --git a/docs/mathpartir.sty b/docs/mathpartir.sty
new file mode 100644
index 0000000000000000000000000000000000000000..a39595a5977867ce837c5c37f143c70cbbedc254
--- /dev/null
+++ b/docs/mathpartir.sty
@@ -0,0 +1,446 @@
+% Mathpartir --- Math Paragraph for Typesetting Inference Rules
+%
+% Copyright (C) 2001, 2002, 2003, 2004, 2005 Didier Rémy
+%
+% Author : Didier Remy
+% Version : 1.2.0
+% Bug Reports : to author
+% Web Site : http://pauillac.inria.fr/~remy/latex/
+%
+% Mathpartir is free software; you can redistribute it and/or modify
+% it under the terms of the GNU General Public License as published by
+% the Free Software Foundation; either version 2, or (at your option)
+% any later version.
+%
+% Mathpartir is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU General Public License for more details
+% (http://pauillac.inria.fr/~remy/license/GPL).
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% File mathpartir.sty (LaTeX macros)
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{mathpartir}
+ [2005/12/20 version 1.2.0 Math Paragraph for Typesetting Inference Rules]
+
+%%
+
+%% Identification
+%% Preliminary declarations
+
+\RequirePackage {keyval}
+
+%% Options
+%% More declarations
+
+%% PART I: Typesetting maths in paragraphe mode
+
+%% \newdimen \mpr@tmpdim
+%% Dimens are a precious ressource. Uses seems to be local.
+\let \mpr@tmpdim \@tempdima
+
+% To ensure hevea \hva compatibility, \hva should expands to nothing
+% in mathpar or in inferrule
+\let \mpr@hva \empty
+
+%% normal paragraph parametters, should rather be taken dynamically
+\def \mpr@savepar {%
+ \edef \MathparNormalpar
+ {\noexpand \lineskiplimit \the\lineskiplimit
+ \noexpand \lineskip \the\lineskip}%
+ }
+
+\def \mpr@rulelineskip {\lineskiplimit=0.3em\lineskip=0.2em plus 0.1em}
+\def \mpr@lesslineskip {\lineskiplimit=0.6em\lineskip=0.5em plus 0.2em}
+\def \mpr@lineskip {\lineskiplimit=1.2em\lineskip=1.2em plus 0.2em}
+\let \MathparLineskip \mpr@lineskip
+\def \mpr@paroptions {\MathparLineskip}
+\let \mpr@prebindings \relax
+
+\newskip \mpr@andskip \mpr@andskip 2em plus 0.5fil minus 0.5em
+
+\def \mpr@goodbreakand
+ {\hskip -\mpr@andskip \penalty -1000\hskip \mpr@andskip}
+\def \mpr@and {\hskip \mpr@andskip}
+\def \mpr@andcr {\penalty 50\mpr@and}
+\def \mpr@cr {\penalty -10000\mpr@and}
+\def \mpr@eqno #1{\mpr@andcr #1\hskip 0em plus -1fil \penalty 10}
+
+\def \mpr@bindings {%
+ \let \and \mpr@andcr
+ \let \par \mpr@andcr
+ \let \\\mpr@cr
+ \let \eqno \mpr@eqno
+ \let \hva \mpr@hva
+ }
+\let \MathparBindings \mpr@bindings
+
+% \@ifundefined {ignorespacesafterend}
+% {\def \ignorespacesafterend {\aftergroup \ignorespaces}
+
+\newenvironment{mathpar}[1][]
+ {$$\mpr@savepar \parskip 0em \hsize \linewidth \centering
+ \vbox \bgroup \mpr@prebindings \mpr@paroptions #1\ifmmode $\else
+ \noindent $\displaystyle\fi
+ \MathparBindings}
+ {\unskip \ifmmode $\fi\egroup $$\ignorespacesafterend}
+
+\newenvironment{mathparpagebreakable}[1][]
+ {\begingroup
+ \par
+ \mpr@savepar \parskip 0em \hsize \linewidth \centering
+ \mpr@prebindings \mpr@paroptions #1%
+ \vskip \abovedisplayskip \vskip -\lineskip%
+ \ifmmode \else $\displaystyle\fi
+ \MathparBindings
+ }
+ {\unskip
+ \ifmmode $\fi \par\endgroup
+ \vskip \belowdisplayskip
+ \noindent
+ \ignorespacesafterend}
+
+% \def \math@mathpar #1{\setbox0 \hbox {$\displaystyle #1$}\ifnum
+% \wd0 < \hsize $$\box0$$\else \bmathpar #1\emathpar \fi}
+
+%%% HOV BOXES
+
+\def \mathvbox@ #1{\hbox \bgroup \mpr@normallineskip
+ \vbox \bgroup \tabskip 0em \let \\ \cr
+ \halign \bgroup \hfil $##$\hfil\cr #1\crcr \egroup \egroup
+ \egroup}
+
+\def \mathhvbox@ #1{\setbox0 \hbox {\let \\\qquad $#1$}\ifnum \wd0 < \hsize
+ \box0\else \mathvbox {#1}\fi}
+
+
+%% Part II -- operations on lists
+
+\newtoks \mpr@lista
+\newtoks \mpr@listb
+
+\long \def\mpr@cons #1\mpr@to#2{\mpr@lista {\\{#1}}\mpr@listb \expandafter
+{#2}\edef #2{\the \mpr@lista \the \mpr@listb}}
+
+\long \def\mpr@snoc #1\mpr@to#2{\mpr@lista {\\{#1}}\mpr@listb \expandafter
+{#2}\edef #2{\the \mpr@listb\the\mpr@lista}}
+
+\long \def \mpr@concat#1=#2\mpr@to#3{\mpr@lista \expandafter {#2}\mpr@listb
+\expandafter {#3}\edef #1{\the \mpr@listb\the\mpr@lista}}
+
+\def \mpr@head #1\mpr@to #2{\expandafter \mpr@head@ #1\mpr@head@ #1#2}
+\long \def \mpr@head@ #1#2\mpr@head@ #3#4{\def #4{#1}\def#3{#2}}
+
+\def \mpr@flatten #1\mpr@to #2{\expandafter \mpr@flatten@ #1\mpr@flatten@ #1#2}
+\long \def \mpr@flatten@ \\#1\\#2\mpr@flatten@ #3#4{\def #4{#1}\def #3{\\#2}}
+
+\def \mpr@makelist #1\mpr@to #2{\def \mpr@all {#1}%
+ \mpr@lista {\\}\mpr@listb \expandafter {\mpr@all}\edef \mpr@all {\the
+ \mpr@lista \the \mpr@listb \the \mpr@lista}\let #2\empty
+ \def \mpr@stripof ##1##2\mpr@stripend{\def \mpr@stripped{##2}}\loop
+ \mpr@flatten \mpr@all \mpr@to \mpr@one
+ \expandafter \mpr@snoc \mpr@one \mpr@to #2\expandafter \mpr@stripof
+ \mpr@all \mpr@stripend
+ \ifx \mpr@stripped \empty \let \mpr@isempty 0\else \let \mpr@isempty 1\fi
+ \ifx 1\mpr@isempty
+ \repeat
+}
+
+\def \mpr@rev #1\mpr@to #2{\let \mpr@tmp \empty
+ \def \\##1{\mpr@cons ##1\mpr@to \mpr@tmp}#1\let #2\mpr@tmp}
+
+%% Part III -- Type inference rules
+
+\newif \if@premisse
+\newbox \mpr@hlist
+\newbox \mpr@vlist
+\newif \ifmpr@center \mpr@centertrue
+\def \mpr@htovlist {%
+ \setbox \mpr@hlist
+ \hbox {\strut
+ \ifmpr@center \hskip -0.5\wd\mpr@hlist\fi
+ \unhbox \mpr@hlist}%
+ \setbox \mpr@vlist
+ \vbox {\if@premisse \box \mpr@hlist \unvbox \mpr@vlist
+ \else \unvbox \mpr@vlist \box \mpr@hlist
+ \fi}%
+}
+% OLD version
+% \def \mpr@htovlist {%
+% \setbox \mpr@hlist
+% \hbox {\strut \hskip -0.5\wd\mpr@hlist \unhbox \mpr@hlist}%
+% \setbox \mpr@vlist
+% \vbox {\if@premisse \box \mpr@hlist \unvbox \mpr@vlist
+% \else \unvbox \mpr@vlist \box \mpr@hlist
+% \fi}%
+% }
+
+\def \mpr@item #1{$\displaystyle #1$}
+\def \mpr@sep{2em}
+\def \mpr@blank { }
+\def \mpr@hovbox #1#2{\hbox
+ \bgroup
+ \ifx #1T\@premissetrue
+ \else \ifx #1B\@premissefalse
+ \else
+ \PackageError{mathpartir}
+ {Premisse orientation should either be T or B}
+ {Fatal error in Package}%
+ \fi \fi
+ \def \@test {#2}\ifx \@test \mpr@blank\else
+ \setbox \mpr@hlist \hbox {}%
+ \setbox \mpr@vlist \vbox {}%
+ \if@premisse \let \snoc \mpr@cons \else \let \snoc \mpr@snoc \fi
+ \let \@hvlist \empty \let \@rev \empty
+ \mpr@tmpdim 0em
+ \expandafter \mpr@makelist #2\mpr@to \mpr@flat
+ \if@premisse \mpr@rev \mpr@flat \mpr@to \@rev \else \let \@rev \mpr@flat \fi
+ \def \\##1{%
+ \def \@test {##1}\ifx \@test \empty
+ \mpr@htovlist
+ \mpr@tmpdim 0em %%% last bug fix not extensively checked
+ \else
+ \setbox0 \hbox{\mpr@item {##1}}\relax
+ \advance \mpr@tmpdim by \wd0
+ %\mpr@tmpdim 1.02\mpr@tmpdim
+ \ifnum \mpr@tmpdim < \hsize
+ \ifnum \wd\mpr@hlist > 0
+ \if@premisse
+ \setbox \mpr@hlist
+ \hbox {\unhbox0 \hskip \mpr@sep \unhbox \mpr@hlist}%
+ \else
+ \setbox \mpr@hlist
+ \hbox {\unhbox \mpr@hlist \hskip \mpr@sep \unhbox0}%
+ \fi
+ \else
+ \setbox \mpr@hlist \hbox {\unhbox0}%
+ \fi
+ \else
+ \ifnum \wd \mpr@hlist > 0
+ \mpr@htovlist
+ \mpr@tmpdim \wd0
+ \fi
+ \setbox \mpr@hlist \hbox {\unhbox0}%
+ \fi
+ \advance \mpr@tmpdim by \mpr@sep
+ \fi
+ }%
+ \@rev
+ \mpr@htovlist
+ \ifmpr@center \hskip \wd\mpr@vlist\fi \box \mpr@vlist
+ \fi
+ \egroup
+}
+
+%%% INFERENCE RULES
+
+\@ifundefined{@@over}{%
+ \let\@@over\over % fallback if amsmath is not loaded
+ \let\@@overwithdelims\overwithdelims
+ \let\@@atop\atop \let\@@atopwithdelims\atopwithdelims
+ \let\@@above\above \let\@@abovewithdelims\abovewithdelims
+ }{}
+
+%% The default
+
+\def \mpr@@fraction #1#2{\hbox {\advance \hsize by -0.5em
+ $\displaystyle {#1\mpr@over #2}$}}
+\def \mpr@@nofraction #1#2{\hbox {\advance \hsize by -0.5em
+ $\displaystyle {#1\@@atop #2}$}}
+
+\let \mpr@fraction \mpr@@fraction
+
+%% A generic solution to arrow
+
+\def \mpr@make@fraction #1#2#3#4#5{\hbox {%
+ \def \mpr@tail{#1}%
+ \def \mpr@body{#2}%
+ \def \mpr@head{#3}%
+ \setbox1=\hbox{$#4$}\setbox2=\hbox{$#5$}%
+ \setbox3=\hbox{$\mkern -3mu\mpr@body\mkern -3mu$}%
+ \setbox3=\hbox{$\mkern -3mu \mpr@body\mkern -3mu$}%
+ \dimen0=\dp1\advance\dimen0 by \ht3\relax\dp1\dimen0\relax
+ \dimen0=\ht2\advance\dimen0 by \dp3\relax\ht2\dimen0\relax
+ \setbox0=\hbox {$\box1 \@@atop \box2$}%
+ \dimen0=\wd0\box0
+ \box0 \hskip -\dimen0\relax
+ \hbox to \dimen0 {$%
+ \mathrel{\mpr@tail}\joinrel
+ \xleaders\hbox{\copy3}\hfil\joinrel\mathrel{\mpr@head}%
+ $}}}
+
+%% Old stuff should be removed in next version
+\def \mpr@@nothing #1#2
+ {$\lower 0.01pt \mpr@@nofraction {#1}{#2}$}
+\def \mpr@@reduce #1#2{\hbox
+ {$\lower 0.01pt \mpr@@fraction {#1}{#2}\mkern -15mu\rightarrow$}}
+\def \mpr@@rewrite #1#2#3{\hbox
+ {$\lower 0.01pt \mpr@@fraction {#2}{#3}\mkern -8mu#1$}}
+\def \mpr@infercenter #1{\vcenter {\mpr@hovbox{T}{#1}}}
+
+\def \mpr@empty {}
+\def \mpr@inferrule
+ {\bgroup
+ \ifnum \linewidth<\hsize \hsize \linewidth\fi
+ \mpr@rulelineskip
+ \let \and \qquad
+ \let \hva \mpr@hva
+ \let \@rulename \mpr@empty
+ \let \@rule@options \mpr@empty
+ \let \mpr@over \@@over
+ \mpr@inferrule@}
+\newcommand {\mpr@inferrule@}[3][]
+ {\everymath={\displaystyle}%
+ \def \@test {#2}\ifx \empty \@test
+ \setbox0 \hbox {$\vcenter {\mpr@hovbox{B}{#3}}$}%
+ \else
+ \def \@test {#3}\ifx \empty \@test
+ \setbox0 \hbox {$\vcenter {\mpr@hovbox{T}{#2}}$}%
+ \else
+ \setbox0 \mpr@fraction {\mpr@hovbox{T}{#2}}{\mpr@hovbox{B}{#3}}%
+ \fi \fi
+ \def \@test {#1}\ifx \@test\empty \box0
+ \else \vbox
+%%% Suggestion de Francois pour les etiquettes longues
+%%% {\hbox to \wd0 {\RefTirName {#1}\hfil}\box0}\fi
+ {\hbox {\RefTirName {#1}}\box0}\fi
+ \egroup}
+
+\def \mpr@vdotfil #1{\vbox to #1{\leaders \hbox{$\cdot$} \vfil}}
+
+% They are two forms
+% \inferrule [label]{[premisses}{conclusions}
+% or
+% \inferrule* [options]{[premisses}{conclusions}
+%
+% Premisses and conclusions are lists of elements separated by \\
+% Each \\ produces a break, attempting horizontal breaks if possible,
+% and vertical breaks if needed.
+%
+% An empty element obtained by \\\\ produces a vertical break in all cases.
+%
+% The former rule is aligned on the fraction bar.
+% The optional label appears on top of the rule
+% The second form to be used in a derivation tree is aligned on the last
+% line of its conclusion
+%
+% The second form can be parameterized, using the key=val interface. The
+% folloiwng keys are recognized:
+%
+% width set the width of the rule to val
+% narrower set the width of the rule to val\hsize
+% before execute val at the beginning/left
+% lab put a label [Val] on top of the rule
+% lskip add negative skip on the right
+% left put a left label [Val]
+% Left put a left label [Val], ignoring its width
+% right put a right label [Val]
+% Right put a right label [Val], ignoring its width
+% leftskip skip negative space on the left-hand side
+% rightskip skip negative space on the right-hand side
+% vdots lift the rule by val and fill vertical space with dots
+% after execute val at the end/right
+%
+% Note that most options must come in this order to avoid strange
+% typesetting (in particular leftskip must preceed left and Left and
+% rightskip must follow Right or right; vdots must come last
+% or be only followed by rightskip.
+%
+
+%% Keys that make sence in all kinds of rules
+\def \mprset #1{\setkeys{mprset}{#1}}
+\define@key {mprset}{andskip}[]{\mpr@andskip=#1}
+\define@key {mprset}{lineskip}[]{\lineskip=#1}
+\define@key {mprset}{flushleft}[]{\mpr@centerfalse}
+\define@key {mprset}{center}[]{\mpr@centertrue}
+\define@key {mprset}{rewrite}[]{\let \mpr@fraction \mpr@@rewrite}
+\define@key {mprset}{atop}[]{\let \mpr@fraction \mpr@@nofraction}
+\define@key {mprset}{myfraction}[]{\let \mpr@fraction #1}
+\define@key {mprset}{fraction}[]{\def \mpr@fraction {\mpr@make@fraction #1}}
+\define@key {mprset}{sep}{\def\mpr@sep{#1}}
+
+\newbox \mpr@right
+\define@key {mpr}{flushleft}[]{\mpr@centerfalse}
+\define@key {mpr}{center}[]{\mpr@centertrue}
+\define@key {mpr}{rewrite}[]{\let \mpr@fraction \mpr@@rewrite}
+\define@key {mpr}{myfraction}[]{\let \mpr@fraction #1}
+\define@key {mpr}{fraction}[]{\def \mpr@fraction {\mpr@make@fraction #1}}
+\define@key {mpr}{left}{\setbox0 \hbox {$\TirName {#1}\;$}\relax
+ \advance \hsize by -\wd0\box0}
+\define@key {mpr}{width}{\hsize #1}
+\define@key {mpr}{sep}{\def\mpr@sep{#1}}
+\define@key {mpr}{before}{#1}
+\define@key {mpr}{lab}{\let \RefTirName \TirName \def \mpr@rulename {#1}}
+\define@key {mpr}{Lab}{\let \RefTirName \TirName \def \mpr@rulename {#1}}
+\define@key {mpr}{narrower}{\hsize #1\hsize}
+\define@key {mpr}{leftskip}{\hskip -#1}
+\define@key {mpr}{reduce}[]{\let \mpr@fraction \mpr@@reduce}
+\define@key {mpr}{rightskip}
+ {\setbox \mpr@right \hbox {\unhbox \mpr@right \hskip -#1}}
+\define@key {mpr}{LEFT}{\setbox0 \hbox {$#1$}\relax
+ \advance \hsize by -\wd0\box0}
+\define@key {mpr}{left}{\setbox0 \hbox {$\TirName {#1}\;$}\relax
+ \advance \hsize by -\wd0\box0}
+\define@key {mpr}{Left}{\llap{$\TirName {#1}\;$}}
+\define@key {mpr}{right}
+ {\setbox0 \hbox {$\;\TirName {#1}$}\relax \advance \hsize by -\wd0
+ \setbox \mpr@right \hbox {\unhbox \mpr@right \unhbox0}}
+\define@key {mpr}{RIGHT}
+ {\setbox0 \hbox {$#1$}\relax \advance \hsize by -\wd0
+ \setbox \mpr@right \hbox {\unhbox \mpr@right \unhbox0}}
+\define@key {mpr}{Right}
+ {\setbox \mpr@right \hbox {\unhbox \mpr@right \rlap {$\;\TirName {#1}$}}}
+\define@key {mpr}{vdots}{\def \mpr@vdots {\@@atop \mpr@vdotfil{#1}}}
+\define@key {mpr}{after}{\edef \mpr@after {\mpr@after #1}}
+
+\newcommand \mpr@inferstar@ [3][]{\setbox0
+ \hbox {\let \mpr@rulename \mpr@empty \let \mpr@vdots \relax
+ \setbox \mpr@right \hbox{}%
+ $\setkeys{mpr}{#1}%
+ \ifx \mpr@rulename \mpr@empty \mpr@inferrule {#2}{#3}\else
+ \mpr@inferrule [{\mpr@rulename}]{#2}{#3}\fi
+ \box \mpr@right \mpr@vdots$}
+ \setbox1 \hbox {\strut}
+ \@tempdima \dp0 \advance \@tempdima by -\dp1
+ \raise \@tempdima \box0}
+
+\def \mpr@infer {\@ifnextchar *{\mpr@inferstar}{\mpr@inferrule}}
+\newcommand \mpr@err@skipargs[3][]{}
+\def \mpr@inferstar*{\ifmmode
+ \let \@do \mpr@inferstar@
+ \else
+ \let \@do \mpr@err@skipargs
+ \PackageError {mathpartir}
+ {\string\inferrule* can only be used in math mode}{}%
+ \fi \@do}
+
+
+%%% Exports
+
+% Envirnonment mathpar
+
+\let \inferrule \mpr@infer
+
+% make a short name \infer is not already defined
+\@ifundefined {infer}{\let \infer \mpr@infer}{}
+
+\def \TirNameStyle #1{\small \textsc{#1}}
+\def \tir@name #1{\hbox {\small \TirNameStyle{#1}}}
+\let \TirName \tir@name
+\let \DefTirName \TirName
+\let \RefTirName \TirName
+
+%%% Other Exports
+
+% \let \listcons \mpr@cons
+% \let \listsnoc \mpr@snoc
+% \let \listhead \mpr@head
+% \let \listmake \mpr@makelist
+
+
+
+
+\endinput
diff --git a/docs/model.tex b/docs/model.tex
new file mode 100644
index 0000000000000000000000000000000000000000..c3d8fd1685931cfc48d82576ab3df1521f2ed9e6
--- /dev/null
+++ b/docs/model.tex
@@ -0,0 +1,527 @@
+\section{Model and semantics}
+
+The semantics closely follows the ideas laid out in~\cite{catlogic}.
+We just repeat some of the most important definitions here.
+
+An \emph{ordered family of equivalence relations} (o.f.e.\@) is a pair
+$(X,(\nequiv{n})_{n\in\mathbb{N}})$, with $X$ a set, and each $\nequiv{n}$
+an equivalence relation over $X$ satisfying
+\begin{itemize}
+ \item $\All x,x'. x \nequiv{0} x',$
+ \item $\All x,x',n. x \nequiv{n+1} x' \implies x \nequiv{n} x',$
+ \item $\All x,x'. (\All n. x\nequiv{n} x') \implies x = x'.$
+\end{itemize}
+\a
+Let $(X,(\nequivset{n}{X})_{n\in\mathbb{N}})$ and
+$(Y,(\nequivset{n}{Y})_{n\in\mathbb{N}})$ be o.f.e.'s. A function $f:
+X\to Y$ is \emph{non-expansive} if, for all $x$, $x'$ and $n$,
+\[
+x \nequivset{n}{X} x' \implies
+fx \nequivset{n}{Y} f x'.
+\]
+Let $(X,(\nequiv{n})_{n\in\mathbb{N}})$ be an o.f.e.
+A sequence $(x_i)_{i\in\mathbb{N}}$ of elements in $X$ is a
+\emph{chain} (aka \emph{Cauchy sequence}) if
+\[
+\All k. \Exists n. \All i,j\geq n. x_i \nequiv{k} x_j.
+\]
+A \emph{limit} of a chain $(x_i)_{i\in\mathbb{N}}$ is an element
+$x\in X$ such that
+\[
+\All n. \Exists k. \All i\geq k. x_i \nequiv{n} x.
+\]
+An o.f.e.\ $(X,(\nequiv{n})_{n\in\mathbb{N}})$ is \emph{complete}
+if all chains have a limit.
+A complete o.f.e.\ is called a c.o.f.e.\ (pronounced ``coffee'').
+When the family of equivalence relations is clear from context we
+simply
+write $X$ for a c.o.f.e.\ $(X,(\nequiv{n})_{n\in\mathbb{N}})$.
+
+
+Let $\cal U$ be the category of c.o.f.e.'s and nonexpansive maps.
+
+Products and function spaces are defined as follows.
+For c.o.f.e.'s $(X,(\nequivset{n}{X})_{n\in\mathbb{N}})$ and
+$(Y,(\nequivset{n}{Y})_{n\in\mathbb{N}})$, their product
+is
+$(X\times Y, (\nequiv{n})_{n\in\mathbb{N}}),$
+where
+\[
+(x,y) \nequiv{n} (x',y') \iff
+x \nequiv{n} x' \land
+y \nequiv{n} y'.
+\]
+The function space is
+\[
+(\{\, f : X\to Y \mid f \text{ is non-expansive}\,\}, (\nequiv{n})_{n\in\mathbb{N}}),
+\]
+where
+\[
+f \nequiv{n} g \iff
+\All x. f(x) \nequiv{n} g(x).
+\]
+
+For a c.o.f.e.\ $(X,(\nequiv{n}_{n\in\mathbb{N}}))$,
+$\latert (X,(\nequiv{n}_{n\in\mathbb{N}}))$ is the c.o.f.e.\@
+$(X,(\nequivB{n}_{n\in\mathbb{N}}))$, where
+\[
+x \nequivB{n} x' \iff \begin{cases}
+\top &\IF n=0 \\
+x \nequiv{n-1} x' &\IF n>0
+\end{cases}
+\]
+
+(Sidenote: $\latert$ extends to a functor on $\cal U$ by the identity
+action on morphisms).
+
+
+\subsection{Semantic structures: propositions}
+\ralf{This needs to be synced with the Coq development again.}
+
+\[
+\begin{array}[t]{rcl}
+% \protStatus &::=& \enabled \ALT \disabled \\[0.4em]
+\textdom{Res} &\eqdef&
+\{\, \rs = (\pres, \ghostRes) \mid
+\pres \in \textdom{State} \uplus \{\munit\} \land \ghostRes \in \mcarp{\monoid} \,\} \\[0.5em]
+(\pres, \ghostRes) \rtimes
+(\pres', \ghostRes') &\eqdef&
+\begin{cases}
+(\pres, \ghostRes \mtimes \ghostRes') & \mbox{if $\pres' = \munit$ and $\ghostRes \mtimes \ghostRes' \neq \mzero$} \\
+(\pres', \ghostRes \mtimes \ghostRes') & \mbox{if $\pres = \munit$ and $\ghostRes \mtimes \ghostRes' \neq \mzero$}
+\end{cases}
+\\[0.5em]
+%
+\rs \leq \rs' & \eqdef &
+\Exists \rs''. \rs' = \rs \rtimes \rs''\\[1em]
+%
+\UPred(\textdom{Res}) &\eqdef&
+\{\, p \subseteq \mathbb{N} \times \textdom{Res} \mid
+\All (k,\rs) \in p.
+\All j\leq k.
+\All \rs' \geq \rs.
+(j,\rs')\in p \,\}\\[0.5em]
+\restr{p}{k} &\eqdef&
+\{\, (j, \rs) \in p \mid j < k \,\}\\[0.5em]
+p \nequiv{n} q & \eqdef & \restr{p}{n} = \restr{q}{n}\\[1em]
+%
+\textdom{PreProp} & \cong &
+\latert\big( \textdom{World} \monra \UPred(\textdom{Res})
+\big)\\[0.5em]
+%
+\textdom{World} & \eqdef &
+\mathbb{N} \fpfn \textdom{PreProp}\\[0.5em]
+%
+w \nequiv{n} w' & \eqdef &
+n = 0 \lor
+\bigl(\dom(w) = \dom(w') \land \All i\in\dom(w). w(i) \nequiv{n} w'(i)\bigr)
+\\[0.5em]
+%
+w \leq w' & \eqdef &
+\dom(w) \subseteq \dom(w') \land \All i \in \dom(w). w(i) = w'(i)
+\\[0.5em]
+%
+\textdom{Prop} & \eqdef & \textdom{World} \monra \UPred(\textdom{Res})
+\end{array}
+\]
+
+For $p,q\in\UPred(\textdom{Res})$ with $p \nequiv{n} q$ defined
+as above, $\UPred(\textdom{Res})$ is a
+c.o.f.e.
+
+$\textdom{Prop}$ is a c.o.f.e., which exists by America and Rutten's theorem~\cite{America-Rutten:JCSS89}.
+We do not need to consider how the object is constructed.
+We only need the isomorphism, given by maps
+\begin{align*}
+ \wIso &: \latert \bigl(World \monra \UPred(\textdom{Res})\bigr) \to \textdom{PreProp} \\
+ \wIso^{-1} &: \textdom{PreProp} \to \latert \bigl(World \monra \UPred(\textdom{Res})\bigr)
+\end{align*}
+which are inverses to each other.
+Note: this is an isomorphism in $\cal U$, i.e., $\wIso$ and
+$\wIso^{-1}$ are both non-expansive.
+
+$\textdom{World}$ is a c.o.f.e.\ with the family of equivalence
+relations defined as shown above.
+
+\subsection{Semantic structures: types and environments}
+
+For a set $X$, write $\Delta X$ for the discrete c.o.f.e.\ with $x \nequiv{n}
+x'$ iff $n = 0$ or $x = x'$
+\[
+\begin{array}[t]{@{}l@{\ }c@{\ }l@{}}
+\Sem{\textsort{Unit}} &\eqdef& \Delta \{ \star \} \\
+\Sem{\textsort{InvName}} &\eqdef& \Delta \mathbb{N} \\
+\Sem{\textsort{InvMask}} &\eqdef& \Delta \pset{\mathbb{N}} \\
+\Sem{\textsort{Monoid}} &\eqdef& \Delta |\monoid|
+\end{array}
+\qquad\qquad
+\begin{array}[t]{@{}l@{\ }c@{\ }l@{}}
+\Sem{\textsort{Val}} &\eqdef& \Delta \textdom{Val} \\
+\Sem{\textsort{Exp}} &\eqdef& \Delta \textdom{Exp} \\
+\Sem{\textsort{Ectx}} &\eqdef& \Delta \textdom{Ectx} \\
+\Sem{\textsort{State}} &\eqdef& \Delta \textdom{State} \\
+\end{array}
+\qquad\qquad
+\begin{array}[t]{@{}l@{\ }c@{\ }l@{}}
+\Sem{\sort \times \sort'} &\eqdef& \Sem{\sort} \times \Sem{\sort} \\
+\Sem{\sort \to \sort'} &\eqdef& \Sem{\sort} \to \Sem{\sort} \\
+\Sem{\Prop} &\eqdef& \textdom{Prop} \\
+\end{array}
+\]
+
+The balance of our signature $\Sig$ is interpreted as follows.
+For each base type $\type$ not covered by the preceding table, we pick an object $X_\type$ in $\cal U$ and define
+\[
+\Sem{\type} \eqdef X_\type
+\]
+For each function symbol $\sigfn : \type_1, \dots, \type_n \to \type_{n+1} \in \SigFn$, we pick an arrow $\Sem{\sigfn} : \Sem{\type_1} \times \dots \times \Sem{\type_n} \to \Sem{\type_{n+1}}$ in $\cal U$.
+
+An environment $\vctx$ is interpreted as the set of
+maps $\rho$, with $\dom(\rho) = \dom(\vctx)$ and
+$\rho(x)\in\Sem{\vctx(x)}$,
+and
+$\rho\nequiv{n} \rho' \iff n=0 \lor \bigl(\dom(\rho)=\dom(\rho') \land
+\All x\in\dom(\rho). \rho(x) \nequiv{n} \rho'(x)\bigr)$.
+
+\ralf{Re-check all the following definitions with the Coq development.}
+%\typedsection{Validity}{valid : \pset{\textdom{Prop}} \in Sets}
+%
+%\begin{align*}
+%valid(p) &\iff \All n \in \mathbb{N}. \All \rs \in \textdom{Res}. \All W \in \textdom{World}. (n, \rs) \in p(W)
+%\end{align*}
+
+\typedsection{Later modality}{\later : \textdom{Prop} \to \textdom{Prop} \in {\cal U}}
+
+\begin{align*}
+ \later p &\eqdef \Lam W. \{\, (n + 1, r) \mid (n, r) \in p(W) \,\} \cup \{\, (0, r) \mid r \in \textdom{Res} \,\}
+\end{align*}
+\begin{lem}
+ $\later{}$ is well-defined: $\later {p}$ is a valid proposition (this amounts to showing non-expansiveness), and $\later{}$ itself is a \emph{contractive} map.
+\end{lem}
+
+\typedsection{Always modality}{\always{} : \textdom{Prop} \to \textdom{Prop} \in {\cal U}}
+
+\begin{align*}
+ \always{p} \eqdef \Lam W. \{\, (n, r) \mid (n, \munit) \in p(W) \,\}
+\end{align*}
+\begin{lem}
+ $\always{}$ is well-defined: $\always{p}$ is a valid proposition (this amounts to showing non-expansiveness), and $\always{}$ itself is a non-expansive map.
+\end{lem}
+
+% PDS: p \Rightarrow q not defined.
+%\begin{lem}\label{lem:always-impl-valid}
+%\begin{align*}
+%&\forall p, q \in \textdom{Prop}.~\\
+%&\qquad
+% (\forall n \in \mathbb{N}.~\forall \rs \in \textdom{Res}.~\forall W \in \textdom{World}.~(n, \rs) \in p(W) \Rightarrow (n, \rs) \in q(W)) \Leftrightarrow~valid(\always{(p \Rightarrow q)})
+%\end{align*}
+%\end{lem}
+
+\typedsection{Invariant definition}{inv : \Delta(\mathbb{N}) \times \textdom{Prop} \to \textdom{Prop} \in {\cal U}}
+\begin{align*}
+ \mathit{inv}(\iota, p) &\eqdef \Lam W. \{\, (n, r) \mid \iota\in\dom(W) \land W(\iota) \nequiv{n+1}_{\textdom{PreProp}} \wIso(p) \,\}
+\end{align*}
+\begin{lem}
+ $\mathit{inv}$ is well-defined: $\mathit{inv}(\iota, p)$ is a valid proposition (this amounts to showing non-expansiveness), and $\mathit{inv}$ itself is a non-expansive map.
+\end{lem}
+
+\typedsection{World satisfaction}{\fullSat{-}{-}{-}{-} :
+ \textdom{State} \times
+ \pset{\mathbb{N}} \times
+ \textdom{Res} \times
+ \textdom{World} \to \psetdown{\mathbb{N}} \in {\cal U}}
+\ralf{Make this Dave-compatible: Explicitly compose all the things in $s$}
+\begin{align*}
+ \fullSat{\state}{\mask}{\rs}{W} &=
+ \begin{aligned}[t]
+ \{\, n + 1 \in \mathbb{N} \mid &\Exists \rsB:\mathbb{N} \fpfn \textdom{Res}. (\rs \rtimes \rsB).\pres = \state \land{}\\
+ &\quad \All \iota \in \dom(W). \iota \in \dom(W) \leftrightarrow \iota \in \dom(\rsB) \land {}\\
+ &\quad\quad \iota \in \mask \ra (n, \rsB(\iota)) \in \wIso^{-1}(W(\iota))(W) \,\} \cup \{ 0 \}
+ \end{aligned}
+\end{align*}
+\begin{lem}\label{lem:fullsat-nonexpansive}
+ $\fullSat{-}{-}{-}{-}$ is well-defined: It maps into $\psetdown{\mathbb{N}}$. (There is no need for it to be a non-expansive map, it doesn't itself live in $\cal U$.)
+\end{lem}
+
+\begin{lem}\label{lem:fullsat-weaken-mask}
+ \begin{align*}
+ \MoveEqLeft
+ \All \state \in \Delta(\textdom{State}).
+ \All \mask_1, \mask_2 \in \Delta(\pset{\mathbb{N}}).
+ \All \rs, \rsB \in \Delta(\textdom{Res}).
+ \All W \in \textdom{World}. \\&
+ \mask_1 \subseteq \mask_2 \implies (\fullSat{\state}{\mask_2}{\rs}{W}) \subseteq (\fullSat{\state}{\mask_1}{\rs}{W})
+ \end{align*}
+\end{lem}
+
+\begin{lem}\label{lem:nequal_ext_world}
+ \begin{align*}
+ &
+ \All n \in \mathbb{N}.
+ \All W_1, W_1', W_2 \in \textdom{World}.
+ W_1 \nequiv{n} W_2 \land W_1 \leq W_1' \implies \Exists W_2' \in \textdom{World}. W_1' \nequiv{n} W_2' \land W_2 \leq W_2'
+ \end{align*}
+\end{lem}
+
+\typedsection{Timeless}{\textit{timeless} : \textdom{Prop} \to \textdom{Prop}}
+
+\begin{align*}
+ \textit{timeless}(p) \eqdef
+ \begin{aligned}[t]
+ \Lam W.
+ \{\, (n, r) &\mid \All W' \geq W. \All k \leq n. \All r' \in \textdom{Res}. \\
+ &\qquad
+ k > 0 \land (k - 1, r') \in p(W') \implies (k, r') \in p(W') \,\}
+ \end{aligned}
+\end{align*}
+
+\begin{lem}
+ \textit{timeless} is well-defined: \textit{timeless}(p) is a valid proposition, and \textit{timeless} itself is a non-expansive map.
+\end{lem}
+
+% PDS: \Ra undefined.
+%\begin{lem}
+%\begin{align*}
+%&
+% \All p \in \textdom{Prop}.
+% \All \mask \in \pset{\mathbb{N}}.
+%valid(\textit{timeless}(p) \Ra (\later p \vs[\mask][\mask] p))
+%\end{align*}
+%\end{lem}
+
+\typedsection{View-shift}{\mathit{vs} : \Delta(\pset{\mathbb{N}}) \times \Delta(\pset{\mathbb{N}}) \times \textdom{Prop} \to \textdom{Prop} \in {\cal U}}
+\begin{align*}
+ \mathit{vs}_{\mask_1}^{\mask_2}(q) &= \Lam W.
+ \begin{aligned}[t]
+ \{\, (n, \rs) &\mid \All W_F \geq W. \All \rs_F, \mask_F, \state. \All k \leq n.\\
+ &\qquad
+ k \in (\fullSat{\state}{\mask_1 \cup \mask_F}{\rs \rtimes \rs_F}{W_F}) \land k > 0 \land \mask_F \sep (\mask_1 \cup \mask_2) \implies{} \\
+ &\qquad
+ \Exists W' \geq W_F. \Exists \rs'. k \in (\fullSat{\state}{\mask_2 \cup \mask_F}{\rs' \rtimes \rs_F}{W'}) \land (k, \rs') \in q(W')
+ \,\}
+ \end{aligned}
+\end{align*}
+\begin{lem}
+ $\mathit{vs}$ is well-defined: $\mathit{vs}_{\mask_1}^{\mask_2}(q)$ is a valid proposition, and $\mathit{vs}$ is a non-expansive map.
+\end{lem}
+
+
+%\begin{lem}\label{lem:prim_view_shift_trans}
+%\begin{align*}
+%\MoveEqLeft
+% \All \mask_1, \mask_2, \mask_3 \in \Delta(\pset{\mathbb{N}}).
+% \All p, q \in \textdom{Prop}. \All W \in \textdom{World}.
+% \All n \in \mathbb{N}.\\
+%&
+% \mask_2 \subseteq \mask_1 \cup \mask_3 \land
+% \bigl(\All W' \geq W. \All r \in \textdom{Res}. \All k \leq n. (k, r) \in p(W') \implies (k, r) \in vs_{\mask_2}^{\mask_3}(q)(W')\bigr) \\
+%&\qquad
+% {}\implies \All r \in \textdom{Res}. (n, r) \in vs_{\mask_1}^{\mask_2}(p)(W) \implies (n, r) \in vs_{\mask_1}^{\mask_3}(q)(W)
+%\end{align*}
+%\end{lem}
+
+% PDS: E_1 ==>> E_2 undefined.
+%\begin{lem}
+%\begin{align*}
+%&
+% \forall \mask_1, \mask_2, \mask_3 \in \Delta(\pset{\mathbb{N}}).~
+% \forall p_1, p_2, p_3 \in \textdom{Prop}.~\\
+%&\qquad
+% \mask_2 \subseteq \mask_1 \cup \mask_3 \Rightarrow
+% valid(((p_1 \vs[\mask_1][\mask_2] p_2) \land (p_2 \vs[\mask_2][\mask_3] p_3)) \Rightarrow (p_1 \vs[\mask_1][\mask_3] p_3))
+%\end{align*}
+%\end{lem}
+
+%\begin{lem}
+%\begin{align*}
+%\MoveEqLeft
+% \All \iota \in \mathbb{N}.
+% \All p \in \textdom{Prop}.
+% \All W \in \textdom{World}.
+% \All \rs \in \textdom{Res}.
+% \All n \in \mathbb{N}. \\
+%&
+% (n, \rs) \in inv(\iota, p)(W) \implies (n, \rs) \in vs_{\{ \iota \}}^{\emptyset}(\later p)(W)
+%\end{align*}
+%\end{lem}
+
+% PDS: * undefined.
+%\begin{lem}
+%\begin{align*}
+%&
+% \forall \iota \in \mathbb{N}.~
+% \forall p \in \textdom{Prop}.~
+% \forall W \in \textdom{World}.~
+% \forall \rs \in \textdom{Res}.~
+% \forall n \in \mathbb{N}.~\\
+%&\qquad
+% (n, \rs) \in (inv(\iota, p) * \later p)(W) \Rightarrow (n, \rs) \in vs^{\{ \iota \}}_{\emptyset}(\top)(W)
+%\end{align*}
+%\end{lem}
+
+% \begin{lem}
+% \begin{align*}
+% &
+% \forall \mask_1, \mask_2 \in \Delta(\pset{\mathbb{N}}).~
+% valid(\bot \vs[\mask_1][\mask_2] \bot)
+% \end{align*}
+% \end{lem}
+
+% PDS: E_1 ==>> E_2 undefined.
+%\begin{lem}
+%\begin{align*}
+%&
+% \forall p, q \in \textdom{Prop}.~
+% \forall \mask \in \pset{\mathbb{N}}.~
+%valid(\always{(p \Rightarrow q)} \Rightarrow (p \vs[\mask][\mask] q))
+%\end{align*}
+%\end{lem}
+
+% PDS: E # E' and E_1 ==>> E_2 undefined.
+%\begin{lem}
+%\begin{align*}
+%&
+% \forall p_1, p_2, p_3 \in \textdom{Prop}.~
+% \forall \mask_1, \mask_2, \mask \in \pset{\mathbb{N}}.~
+%valid(\mask \sep \mask_1 \Ra \mask \sep \mask_2 \Ra (p_1 \vs[\mask_1][\mask_2] p_2) \Rightarrow (p_1 * p_3 \vs[\mask_1 \cup \mask][\mask_2 \cup \mask] p_2 * p_3))
+%\end{align*}
+%\end{lem}
+
+\typedsection{Weakest precondition}{\mathit{wp} : \Delta(\pset{\mathbb{N}}) \times \Delta(\textdom{Exp}) \times (\Delta(\textdom{Val}) \to \textdom{Prop}) \to \textdom{Prop} \in {\cal U}}
+
+% \begin{align*}
+% \mathit{wp}_\mask(\expr, q) &\eqdef \Lam W.
+% \begin{aligned}[t]
+% \{\, (n, \rs) &\mid \All W_F \geq W; k \leq n; \rs_F; \state; \mask_F \sep \mask. k > 0 \land k \in (\fullSat{\state}{\mask \cup \mask_F}{\rs \rtimes \rs_F}{W_F}) \implies{}\\
+% &\qquad
+% (\expr \in \textdom{Val} \implies \Exists W' \geq W_F. \Exists \rs'. \\
+% &\qquad\qquad
+% k \in (\fullSat{\state}{\mask \cup \mask_F}{\rs' \rtimes \rs_F}{W'}) \land (k, \rs') \in q(\expr)(W'))~\land \\
+% &\qquad
+% (\All\ectx,\expr_0,\expr'_0,\state'. \expr = \ectx[\expr_0] \land \cfg{\state}{\expr_0} \step \cfg{\state'}{\expr'_0} \implies \Exists W' \geq W_F. \Exists \rs'. \\
+% &\qquad\qquad
+% k - 1 \in (\fullSat{\state'}{\mask \cup \mask_F}{\rs' \rtimes \rs_F}{W'}) \land (k-1, \rs') \in wp_\mask(\ectx[\expr_0'], q)(W'))~\land \\
+% &\qquad
+% (\All\ectx,\expr'. \expr = \ectx[\fork{\expr'}] \implies \Exists W' \geq W_F. \Exists \rs', \rs_1', \rs_2'. \\
+% &\qquad\qquad
+% k - 1 \in (\fullSat{\state}{\mask \cup \mask_F}{\rs' \rtimes \rs_F}{W'}) \land \rs' = \rs_1' \rtimes \rs_2'~\land \\
+% &\qquad\qquad
+% (k-1, \rs_1') \in \mathit{wp}_\mask(\ectx[\textsf{fRet}], q)(W') \land
+% (k-1, \rs_2') \in \mathit{wp}_\top(\expr', \Lam\any. \top)(W'))
+% \,\}
+% \end{aligned}
+% \end{align*}
+\begin{lem}
+ $\mathit{wp}$ is well-defined: $\mathit{wp}_{\mask}(\expr, q)$ is a valid proposition, and $\mathit{wp}$ is a non-expansive map. Besides, the dependency on the recursive occurrence is contractive, so $\mathit{wp}$ has a fixed-point.
+\end{lem}
+
+\begin{lem}
+ $\mathit{wp}$ on values and non-mask-changing $\mathit{vs}$ agree:
+ \[ \mathit{wp}_\mask(\val, q) = \mathit{vs}_{\mask}^{\mask}(q \: \val) \]
+\end{lem}
+
+\typedsection{Interpretation of terms}{\Sem{\vctx \proves \term : \sort} : \Sem{\vctx} \to \Sem{\sort} \in {\cal U}}
+
+%A term $\vctx \proves \term : \sort$ is interpreted as a non-expansive map from $\Sem{\vctx}$ to $\Sem{\sort}$.
+
+\begin{align*}
+ \Sem{\vctx \proves x : \sort}_\gamma &= \gamma(x) \\
+ \Sem{\vctx \proves \sigfn(\term_1, \dots, \term_n) : \type_{n+1}}_\gamma &= \Sem{\sigfn}(\Sem{\vctx \proves \term_1 : \type_1}_\gamma, \dots, \Sem{\vctx \proves \term_n : \type_n}_\gamma) \ \WHEN \sigfn : \type_1, \dots, \type_n \to \type_{n+1} \in \SigFn \\
+ \Sem{\vctx \proves \Lam x. \term : \sort \to \sort'}_\gamma &=
+ \Lam v : \Sem{\sort}. \Sem{\vctx, x : \sort \proves \term : \sort'}_{\gamma[x \mapsto v]} \\
+ \Sem{\vctx \proves \term~\termB : \sort'}_\gamma &=
+ \Sem{\vctx \proves \term : \sort \to \sort'}_\gamma(\Sem{\vctx \proves \termB : \sort}_\gamma) \\
+ \Sem{\vctx \proves \unitval : \unitsort}_\gamma &= \star \\
+ \Sem{\vctx \proves (\term_1, \term_2) : \sort_1 \times \sort_2}_\gamma &= (\Sem{\vctx \proves \term_1 : \sort_1}_\gamma, \Sem{\vctx \proves \term_2 : \sort_2}_\gamma) \\
+ \Sem{\vctx \proves \pi_i~\term : \sort_1}_\gamma &= \pi_i(\Sem{\vctx \proves \term : \sort_1 \times \sort_2}_\gamma)
+\end{align*}
+%
+\begin{align*}
+ \Sem{\vctx \proves \mzero : \textsort{Monoid}}_\gamma &= \mzero \\
+ \Sem{\vctx \proves \munit : \textsort{Monoid}}_\gamma &= \munit \\
+ \Sem{\vctx \proves \melt \mtimes \meltB : \textsort{Monoid}}_\gamma &=
+ \Sem{\vctx \proves \melt : \textsort{Monoid}}_\gamma \mtimes \Sem{\vctx \proves \meltB : \textsort{Monoid}}_\gamma
+\end{align*}
+%
+\begin{align*}
+ \Sem{\vctx \proves t =_\sort u : \Prop}_\gamma &=
+ \Lam W. \{\, (n, r) \mid \Sem{\vctx \proves t : \sort}_\gamma \nequiv{n+1} \Sem{\vctx \proves u : \sort}_\gamma \,\} \\
+ \Sem{\vctx \proves \FALSE : \Prop}_\gamma &= \Lam W. \emptyset \\
+ \Sem{\vctx \proves \TRUE : \Prop}_\gamma &= \Lam W. \mathbb{N} \times \textdom{Res} \\
+ \Sem{\vctx \proves P \land Q : \Prop}_\gamma &=
+ \Lam W. \Sem{\vctx \proves P : \Prop}_\gamma(W) \cap \Sem{\vctx \proves Q : \Prop}_\gamma(W) \\
+ \Sem{\vctx \proves P \lor Q : \Prop}_\gamma &=
+ \Lam W. \Sem{\vctx \proves P : \Prop}_\gamma(W) \cup \Sem{\vctx \proves Q : \Prop}_\gamma(W) \\
+ \Sem{\vctx \proves P \Ra Q : \Prop}_\gamma &=
+ \Lam W. \begin{aligned}[t]
+ \{\, (n, r) &\mid \All n' \leq n. \All W' \geq W. \All r' \geq r. \\
+ &\qquad
+ (n', r') \in \Sem{\vctx \proves P : \Prop}_\gamma(W')~ \\
+ &\qquad
+ \implies (n', r') \in \Sem{\vctx \proves Q : \Prop}_\gamma(W') \,\}
+ \end{aligned} \\
+ \Sem{\vctx \proves \All x : \sort. P : \Prop}_\gamma &=
+ \Lam W. \{\, (n, r) \mid \All v \in \Sem{\sort}. (n, r) \in \Sem{\vctx, x : \sort \proves P : \Prop}_{\gamma[x \mapsto v]}(W) \,\} \\
+ \Sem{\vctx \proves \Exists x : \sort. P : \Prop}_\gamma &=
+ \Lam W. \{\, (n, r) \mid \Exists v \in \Sem{\sort}. (n, r) \in \Sem{\vctx, x : \sort \proves P : \Prop}_{\gamma[x \mapsto v]}(W) \,\}
+\end{align*}
+%
+\begin{align*}
+ \Sem{\vctx \proves \always{\prop} : \Prop}_\gamma &= \always{\Sem{\vctx \proves \prop : \Prop}_\gamma} \\
+ \Sem{\vctx \proves \later{\prop} : \Prop}_\gamma &= \later \Sem{\vctx \proves \prop : \Prop}_\gamma\\
+ \Sem{\vctx \proves \MU x. \pred : \sort \to \Prop}_\gamma &=
+ \mathit{fix}(\Lam v : \Sem{\sort \to \Prop}. \Sem{\vctx, x : \sort \to \Prop \proves \pred : \sort \to \Prop}_{\gamma[x \mapsto v]}) \\
+ \Sem{\vctx \proves \prop * \propB : \Prop}_\gamma &=
+ \begin{aligned}[t]
+ \Lam W. \{\, (n, r) &\mid \Exists r_1, r_2. r = r_1 \bullet r_2 \land{} \\
+ &\qquad
+ (n, r_1) \in \Sem{\vctx \proves \prop : \Prop}_\gamma \land{} \\
+ &\qquad
+ (n, r_2) \in \Sem{\vctx \proves \propB : \Prop}_\gamma \,\}
+ \end{aligned} \\
+ \Sem{\vctx \proves \prop \wand \propB : \Prop}_\gamma &=
+ \begin{aligned}[t]
+ \Lam W. \{\, (n, r) &\mid \All n' \leq n. \All W' \geq W. \All r'. \\
+ &\qquad
+ (n', r') \in \Sem{\vctx \proves \prop : \Prop}_\gamma(W') \land r \sep r' \\
+ &\qquad
+ \implies (n', r \bullet r') \in \Sem{\vctx \proves \propB : \Prop}_\gamma(W')
+ \}
+ \end{aligned} \\
+ \Sem{\vctx \proves \knowInv{\iname}{\prop} : \Prop}_\gamma &=
+ inv(\Sem{\vctx \proves \iname : \textsort{InvName}}_\gamma, \Sem{\vctx \proves \prop : \Prop}_\gamma) \\
+ \Sem{\vctx \proves \ownGGhost{\melt} : \Prop}_\gamma &=
+ \Lam W. \{\, (n, \rs) \mid \rs.\ghostRes \geq \Sem{\vctx \proves \melt : \textsort{Monoid}}_\gamma \,\} \\
+ \Sem{\vctx \proves \ownPhys{\state} : \Prop}_\gamma &=
+ \Lam W. \{\, (n, \rs) \mid \rs.\pres = \Sem{\vctx \proves \state : \textsort{State}}_\gamma \,\}
+\end{align*}
+%
+\begin{align*}
+ \Sem{\vctx \proves \pvsA{\prop}{\mask_1}{\mask_2} : \Prop}_\gamma &=
+ \textdom{vs}^{\Sem{\vctx \proves \mask_2 : \textsort{InvMask}}_\gamma}_{\Sem{\vctx \proves \mask_1 : \textsort{InvMask}}_\gamma}(\Sem{\vctx \proves \prop : \Prop}_\gamma) \\
+ \Sem{\vctx \proves \dynA{\expr}{\pred}{\mask} : \Prop}_\gamma &=
+ \textdom{wp}_{\Sem{\vctx \proves \mask : \textsort{InvMask}}_\gamma}(\Sem{\vctx \proves \expr : \textsort{Exp}}_\gamma, \Sem{\vctx \proves \pred : \textsort{Val} \to \Prop}_\gamma) \\
+ \Sem{\vctx \proves \wtt{\timeless{\prop}}{\Prop}}_\gamma &=
+ \textdom{timeless}(\Sem{\vctx \proves \prop : \Prop}_\gamma)
+\end{align*}
+
+\typedsection{Interpretation of entailment}{\Sem{\vctx \mid \pfctx \proves \prop} : 2 \in \mathit{Sets}}
+
+\[
+\Sem{\vctx \mid \pfctx \proves \propB} \eqdef
+\begin{aligned}[t]
+\MoveEqLeft
+\forall n \in \mathbb{N}.\;
+\forall W \in \textdom{World}.\;
+\forall \rs \in \textdom{Res}.\;
+\forall \gamma \in \Sem{\vctx},\;
+\\&
+\bigl(\All \propB \in \pfctx. (n, \rs) \in \Sem{\vctx \proves \propB : \Prop}_\gamma(W)\bigr)
+\implies (n, \rs) \in \Sem{\vctx \proves \prop : \Prop}_\gamma(W)
+\end{aligned}
+\]
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "iris"
+%%% End:
diff --git a/docs/pftools.sty b/docs/pftools.sty
new file mode 100644
index 0000000000000000000000000000000000000000..c8de881221ba4732421e990f7ed569ea7b6c4a6d
--- /dev/null
+++ b/docs/pftools.sty
@@ -0,0 +1,131 @@
+\NeedsTeXFormat{LaTeX2e}[1999/12/01]
+\ProvidesPackage{pftools}
+
+\RequirePackage{locallabel}
+\RequirePackage{Tabbing} % Avoid the standard tabbing environment. Its \< conflicts with the semantic package.
+\RequirePackage{xparse}
+\RequirePackage{xcolor}
+\RequirePackage{locallabel}
+
+%% Biimplication inference rules
+% \biimp above below
+% The double lines obtained by the simpler
+% "\mprset{fraction={===}}" overlap the conclusion (e.g., the
+% mask E_M in an atomic triple).
+\newcommand*{\biimp}[2]{%
+ \hbox{%
+ \ooalign{%
+ $\genfrac{}{}{1.6pt}1{#1}{#2}$\cr%
+ $\color{white}\genfrac{}{}{0.8pt}1{\phantom{#1}}{\phantom{#2}}$%
+ }%
+ }%
+}
+\newcommand{\BIIMP}{\mprset{myfraction=\biimp}}
+
+
+%% inferH is infer with hyperlinked names.
+% \savelabel lab text: Arrange for \ref{lab} to print text and to link to the current spot.
+\newcommand*{\savelabel}[2]{%
+ % Think @currentlabel : text ref.
+ \edef\@currentlabel{#2}% Save text
+ \phantomsection% Correct hyper reference link
+ \label{#1}% Print text and store name↦text.
+}
+% \textlabel label text: Print and label text.
+\newcommand*{\textlabel}[2]{{#2}\savelabel{#1}{#2}}
+% \rulenamestyle visible
+\newcommand*{\rulenamestyle}[1]{{\TirNameStyle{#1}}} % From mathpartir.sty.
+% \ruleref [discharged] lab
+\def\optionaldischarge#1{%
+ \if\relax\detokenize{#1}\relax\else\ensuremath{^{#1}}\fi}
+\newcommand*{\ruleref}[2][]{\textmd{\rulenamestyle{\ref{#2}}}\optionaldischarge{#1}}
+\newcommand*{\fakeruleref}[2][]{\rulenamestyle{#2}\optionaldischarge{#1}}
+% \rulename label
+\newcommand*{\rulename}[1]{\rulenamestyle{\textlabel{#1}{#1}}}
+% \inferhref name lab premise conclusion
+\newcommand*{\inferhref}[4]{%
+ \inferrule*[lab=\textlabel{#2}{#1}]{#3}{#4}%
+}
+% \infernH name premise conclusion, if name a valid label.
+\newcommand*{\inferH}[3]{\inferhref{#1}{#1}{#2}{#3}}
+\newcommand*{\axiom}[1]{\infer{}{#1}}
+\newcommand*{\axiomhref}[3]{\inferhref{#1}{#2}{}{#3}}
+\newcommand*{\axiomH}[2]{\inferH{#1}{}{#2}}
+\newcommand*{\inferhrefB}[4]{{\BIIMP\inferhref{#1}{#2}{#3}{#4}}}
+\newcommand*{\inferB}[3][]{{\BIIMP\infer[#1]{#2}{#3}}}
+\newcommand*{\inferHB}[3]{{\BIIMP\inferH{#1}{#2}{#3}}}
+\newcommand*{\taghref}[2]{\label{#2}\tag{\rulenamestyle{#1}}}
+\newcommand*{\tagH}[1]{\taghref{#1}{#1}}
+
+% The sanity checks in \lbind and \llabel
+% don't work properly in amsmath environments
+% which perhaps lay out their contents more
+% than once. Use \lbind in such cases.
+% Sigh.
+
+\newcommand*{\tagL}[1]{\lbind{#1}\tag*{\llabel{#1}}}
+
+\newcommand*\ind[1][\quad]{#1\TAB=\TAB+}
+\newcommand*\unind{\TAB-}
+
+\newcommand\IND[1][\quad]{\\*\ind[#1]}
+\newcommand\UNIND{\unind \\}
+
+% Attribution: http://tex.stackexchange.com/questions/119473/tabbing-and-line-wrapping
+\newlength\pf@width
+\newcommand*{\CMT}[1]{%
+ \setlength\pf@width{\linewidth}%
+ \addtolength\pf@width{\@totalleftmargin}%
+ \addtolength\pf@width{-\dimen\@curtab}%
+ \parbox[t]{\pf@width}{\nobelowdisplayskip{#1}\ifhmode\strut\fi}}
+
+\colorlet{rescolor}{rgb:red,0;green,30;blue,55}
+\colorlet{ctxcolor}{black}
+\colorlet{codecolor}{rgb:red,76;green,177;blue,36}
+
+\newcommand*\res[1]{{\color{rescolor}\ensuremath{#1}}}
+%When \left\{ … \right\} looks ugly, remember Dave says you want \bracket.
+\NewDocumentCommand{\RES}{s m O{}}{%
+ $\displaystyle{{\left\{\res{%
+ \IfBooleanTF{#1}{\begin{inbox}[l]#2\end{inbox}}{#2}%
+ }\right\}}_{#3}}$}
+
+\NewDocumentCommand{\ARES}{m O{}}{%
+ ${\displaystyle{\bracket\langle\rangle{\color{rescolor}{#1}}}_{#2}}$}
+
+\newcommand*{\CODE}[1]{%
+ ${\displaystyle{\color{codecolor}#1}}$}
+
+\newcommand*{\VARS}[1]{%
+ Vars: ${\color{ctxcolor}\displaystyle{#1}}$}
+\newcommand*{\CTX}[1]{%
+ Context: ${\color{ctxcolor}\displaystyle{#1}}$}
+
+\newcommand*{\GOAL}[1]{%
+ Goal: ${\displaystyle{#1}}$}
+\newcommand*{\SUFF}[1]{%
+ Suff: ${\displaystyle{#1}}$}
+
+\newcommand*{\PFHAVE}[1]{%
+ Have: ${\displaystyle{#1}}$}
+
+\let\pf@origqedhere\qedhere
+\def\pf@setup{%
+ % A version of \qedhere that accounts for tabbing.
+ \def\qedhere{\TAB`\pf@origqedhere}%
+}
+
+\newcommand*{\TAGL}[1]{\TAB`\llabel{#1}}
+
+% The starred version lacks leading and trailing vertical space.
+\newenvironment{proofoutline*}
+{\partopsep=\z@skip \topsep=\z@skip% avoid initial space
+ \parskip\z@skip% avoid trailing space
+ \pf@setup\par\begingroup\Tabbing\ignorespaces}
+{\endTabbing\endgroup\unskip\ignorespacesafterend}
+
+\newenvironment{proofoutline}
+{\pf@setup\par\begingroup\Tabbing\ignorespaces}
+{\endTabbing\endgroup\ignorespacesafterend}
+
+\endinput
diff --git a/docs/setup.tex b/docs/setup.tex
new file mode 100644
index 0000000000000000000000000000000000000000..e16fbecf978f4044a1befd701ea3ebf903e1d9fa
--- /dev/null
+++ b/docs/setup.tex
@@ -0,0 +1,466 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% PACKAGES
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\usepackage{mathtools}
+%\usepackage{amsmath}
+\usepackage{amsfonts}
+\usepackage{amsthm}
+\usepackage{amssymb}
+\usepackage{stmaryrd}
+
+\usepackage{mathpartir}
+
+\usepackage{array}
+\usepackage{tabu}
+
+\usepackage{dashbox}
+
+\usepackage{pftools}
+
+\usepackage{xcolor} % for print version
+
+\usepackage{graphicx}
+\usepackage{tikz}
+\usepackage{scalerel}
+
+\usepackage{rotating}
+\usepackage{xparse}
+\usepackage{xstring}
+\usepackage{semantic}
+\usepackage{csquotes}
+
+\usepackage{hyperref}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% SETUP
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\SetSymbolFont{stmry}{bold}{U}{stmry}{m}{n} % this fixes warnings when \boldsymbol is used with stmaryrd included
+
+\extrarowheight=\jot % else, arrays are scrunched compared to, say, aligned
+\newcolumntype{.}{@{}}
+% Array {rMcMl} modifies array {rcl}, putting mathrel-style spacing
+% around the centered column. (We used this, for example, in laying
+% out some of Iris' axioms. Generally, aligned is simpler but aligned
+% does not work in mathpar because \\ inherits mathpar's 2em vskip.)
+% The capital M stands for THICKMuskip. The smaller medmuskip would be
+% right for mathbin-style spacing.
+\newcolumntype{M}{@{\mskip\thickmuskip}}
+
+\definecolor{StringRed}{rgb}{.637,0.082,0.082}
+\definecolor{CommentGreen}{rgb}{0.0,0.55,0.3}
+\definecolor{KeywordBlue}{rgb}{0.0,0.3,0.55}
+\definecolor{LinkColor}{rgb}{0.55,0.0,0.3}
+\definecolor{CiteColor}{rgb}{0.55,0.0,0.3}
+\definecolor{HighlightColor}{rgb}{0.0,0.0,0.0}
+
+\usetikzlibrary{shapes}
+%\usetikzlibrary{snakes}
+\usetikzlibrary{arrows}
+\usetikzlibrary{calc}
+\usetikzlibrary{arrows.meta}
+\tikzstyle{state}=[circle, draw, minimum size=1.2cm, align=center]
+\tikzstyle{trans}=[arrows={->[scale=1.4]}]
+
+\tikzstyle{layer}=[rounded corners=2pt, thin, align=center, draw, minimum width=4.2cm,minimum height=0.8cm]
+
+\definecolor{grey}{rgb}{0.5,0.5,0.5}
+\definecolor{red}{rgb}{1,0,0}
+
+\hypersetup{%
+ linktocpage=true, pdfstartview=FitV,
+ breaklinks=true, pageanchor=true, pdfpagemode=UseOutlines,
+ plainpages=false, bookmarksnumbered, bookmarksopen=true, bookmarksopenlevel=3,
+ hypertexnames=true, pdfhighlight=/O,
+ colorlinks=true,linkcolor=LinkColor,citecolor=CiteColor,
+ urlcolor=LinkColor
+}
+
+
+%\theoremstyle{definition}
+%\newtheorem{prop}{Prop}
+\newtheorem{defn}{Definition}
+\newtheorem{cor}{Corollary}
+\newtheorem{conj}{Conj}
+\newtheorem{lem}{Lemma}
+\newtheorem{thm}{Theorem}
+
+\newtheorem{exercise}{Exercise}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% GENERIC MACROS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\newcommand*{\Sref}[1]{\hyperref[#1]{\S\ref*{#1}}}
+\newcommand*{\secref}[1]{\hyperref[#1]{Section~\ref*{#1}}}
+\newcommand*{\lemref}[1]{\hyperref[#1]{Lemma~\ref*{#1}}}
+\newcommand{\corref}[1]{\hyperref[#1]{Cor.~\ref*{#1}}}
+\newcommand*{\defref}[1]{\hyperref[#1]{Definition~\ref*{#1}}}
+\newcommand*{\egref}[1]{\hyperref[#1]{Example~\ref*{#1}}}
+\newcommand*{\appendixref}[1]{\hyperref[#1]{Appendix~\ref*{#1}}}
+\newcommand*{\figref}[1]{\hyperref[#1]{Figure~\ref*{#1}}}
+\newcommand*{\tabref}[1]{\hyperref[#1]{Table~\ref*{#1}}}
+
+\newcommand{\changes}{{\bf\color{red}{Changes}}}
+\newcommand{\TODO}{\vskip 4pt {\color{red}\bf TODO}}
+
+
+\newcommand{\ie}{\emph{i.e.,} }
+\newcommand{\eg}{\emph{e.g.,} }
+\newcommand{\etal}{\emph{et~al.}}
+\newcommand{\wrt}{w.r.t.~}
+
+\newcommand{\aaron}[1]{{\color{red}\textbf{AT: #1}}}
+\newcommand{\derek}[1]{{\color{red}\textbf{DD: #1}}}
+\newcommand{\lars}[1]{{\color{red}\textbf{LB: #1}}}
+\newcommand{\kasper}[1]{{\color{red}\textbf{KS: #1}}}
+\newcommand{\ralf}[1]{{\color{red}\textbf{RJ: #1}}}
+\newcommand{\dave}[1]{{\color{red}\textbf{PDS: #1}}}
+\newcommand{\hush}[1]{}
+\newcommand{\relaxguys}{%
+ \let\aaron\hush%
+ \let\derek\hush%
+ \let\lars\hush%
+ \let\kasper\hush%
+ \let\ralf\hush%
+ \let\dave\hush%
+}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% MATH SYMBOLS & NOTATION & IDENTIFIERS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+% superscript to the left
+\def\presuper#1#2%
+ {\mathop{}%
+ \mathopen{\vphantom{#2}}^{#1}%
+ \kern-\scriptspace%
+ #2}
+
+\DeclareMathOperator*{\Sep}{\scalerel*{\ast}{\sum}}
+\newcommand{\bigast}{\Sep}
+
+\newcommand*{\sep}[1][]{\mathrel{\#_{#1}}} % bad name; it's a different "sep"
+
+\newcommand{\ALT}{\ |\ }
+
+
+\newcommand{\upclose}{\mathord{\uparrow}}
+
+\def\All #1.{\forall #1.\;}%
+\def\Exists #1.{\exists #1.\;}%
+\def\Ret #1.{#1.\;}%
+
+\newcommand{\any}{{\rule[-.2ex]{1ex}{.4pt}}}%
+\newcommand{\unitval}{()}%
+
+\newcommand{\judgment}[2]{\paragraph{#1}\hspace{\stretch{1}}\fbox{$#2$}}
+
+\newcommand{\pfn}{\rightharpoonup}
+\newcommand{\fpfn}{\stackrel{\textrm{fin}}{\rightharpoonup}}
+\newcommand{\ra}{\rightarrow}
+\newcommand{\Ra}{\Rightarrow}
+\newcommand{\Lra}{\Leftrightarrow}
+\newcommand{\monra}{\stackrel{\textrm{mon}}{\rightarrow}}
+
+\newcommand{\eqdef}{\triangleq}
+
+\newcommand{\restr}[2]{\lfloor #1 \rfloor_{#2}}
+\newcommand{\pset}[1]{\wp(#1)} % Powerset
+\newcommand{\psetdown}[1]{\wp^\downarrow(#1)}
+
+\newcommand{\dom}{\textrm{dom}}
+%\newcommand{\rng}{\textrm{rng}}
+%\newcommand{\cod}{\textrm{cod}}
+
+
+\newcommand{\IF}{\mathrel{\text{if}}}
+\newcommand{\WHEN}{\textrm{when }}
+
+
+
+\newcommand{\SET}[2]{
+\left\{%
+#1%
+\;\middle|\;%
+#2%
+\right\}
+}
+\newcommand{\SETB}[1]{
+\left\{%
+#1%
+\right\}
+}
+\newcommand{\SETC}[2]{#1 & #2}
+
+\newenvironment{inbox}[1][]{
+ \begin{array}[#1]{@{}l@{}}
+}{
+ \end{array}
+}
+
+\newcommand{\tabubox}[2][]{%
+ \begin{tabu}{@{#1}X[1,l,m]@{}}%
+ #2 %
+ \end{tabu}%
+}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% CMRA (RESOURCE ALGEBRA) SYMBOLS & NOTATION & IDENTIFIERS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\newcommand{\textmon}[1]{\textsc{#1}}
+
+\newcommand{\monoid}{M}
+
+\newcommand{\melt}{a}
+\newcommand{\meltB}{b}
+\newcommand{\meltC}{c}
+\newcommand{\melts}{A}
+\newcommand{\meltsB}{B}
+
+\newcommand{\mcar}[1]{|#1|}
+\newcommand{\mcarp}[1]{\mcar{#1}^{+}}
+\newcommand{\mzero}{\bot}
+\newcommand{\munit}{\mathord{\varepsilon}}
+\newcommand{\mtimes}{\mathbin{\cdot}}
+
+\newcommand{\mupd}{\rightsquigarrow}
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% MODEL-SPECIFIC SYMBOLS & NOTATION & IDENTIFIERS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\newcommand{\textdom}[1]{\textit{#1}}
+
+\newcommand{\wIso}{\xi}
+
+\newcommand{\rs}{r}
+\newcommand{\rsB}{s}
+
+\newcommand{\pres}{\pi}
+\newcommand{\wld}{w}
+\newcommand{\ghostRes}{g}
+
+%% Various pieces of syntax
+\newcommand{\fullSat}[4]{#1 \models_{#2} #3; #4}
+
+\newcommand{\wtt}[2]{#1 : #2} % well-typed term
+
+\newcommand{\nequiv}[1]{\ensuremath{\mathrel{\stackrel{#1}{=}}}}
+\newcommand{\notnequiv}[1]{\ensuremath{\mathrel{\stackrel{#1}{\neq}}}}
+\newcommand{\nequivset}[2]{\ensuremath{\mathrel{\stackrel{#1}{=}_{#2}}}}
+\newcommand{\nequivB}[1]{\ensuremath{\mathrel{\stackrel{#1}{\equiv}}}}
+\newcommand{\latert}{\mathord{\blacktriangleright}}
+
+\newcommand{\Sem}[1]{\llbracket #1 \rrbracket}
+
+\newcommand{\sembox}[1]{\hfill \normalfont \mbox{\fbox{\(#1\)}}}
+\newcommand{\typedsection}[2]{\subsubsection*{\rm\em #1 \sembox{#2}}}
+
+
+%% Some commonly used identifiers
+\newcommand{\UPred}{\textdom{UPred}}
+\newcommand{\SPred}{\textdom{SPred}}
+
+\newcommand{\PropDom}{\textdom{Prop}}
+\newcommand{\PredDom}{\textdom{Pred}}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% LOGIC SYMBOLS & NOTATION & IDENTIFIERS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\newcommand{\textlog}[1]{\textsf{#1}}
+\newcommand{\textsort}[1]{\textlog{#1}}
+
+\newcommand{\Sig}{\mathcal{S}}
+\newcommand{\SigType}{\mathcal{T}}
+\newcommand{\SigFn}{\mathcal{F}}
+\newcommand{\sigfn}{F}
+
+\newcommand{\type}{\tau}
+
+\newcommand{\var}{x}
+\newcommand{\varB}{y}
+\newcommand{\varC}{z}
+
+\newcommand{\term}{t}
+\newcommand{\termB}{u}
+\newcommand{\termVal}{V}
+
+\newcommand{\sort}{\Sigma}
+
+\newcommand{\vctx}{\Gamma}
+\newcommand{\pfctx}{\Theta}
+
+\newcommand{\prop}{P}
+\newcommand{\propB}{Q}
+\newcommand{\propC}{R}
+
+\newcommand{\pred}{\varphi}
+\newcommand{\predB}{\psi}
+\newcommand{\predC}{\zeta}
+
+\newcommand{\gname}{\gamma}
+\newcommand{\iname}{\iota}
+\newcommand{\inameB}{\iota'}
+
+\newcommand{\mask}{\mathcal{E}}
+
+%% various pieces of Syntax
+\newcommand{\unitsort}{1}% \unit is bold.
+
+\def\MU #1.{\mu #1.\;}%
+\def\Lam #1.{\lambda #1.\;}%
+
+\newcommand{\proves}{\vdash}
+\newcommand{\provesalways}{\vdash_{\!\!\boxempty}}
+
+\newcommand{\wand}{\;{{\mbox{---}}\!\!{*}}\;}
+
+\newcommand{\fmapsto}[1][-]{\stackrel{#1}{\mapsto}}
+\newcommand{\gmapsto}{\hookrightarrow}%
+\newcommand{\fgmapsto}[1][-]{\stackrel{#1}{\gmapsto}}%
+
+\newcommand{\dyn}[2]{\textlog{wp}({#1}, {#2})}
+\newcommand{\adyn}[2]{{#1}\;\llparenthesis{#2}\rrparenthesis}
+\newcommand{\dynpred}[2]{\textdom{wp}({#1}, {#2})}
+\newcommand{\dynA}[3]{\textlog{wp}_{#3}({#1}, {#2})}
+\newcommand{\pvs}[1]{\textlog{vs}({#1})}
+\newcommand{\pvsA}[3]{\textlog{vs}_{#2}^{#3}({#1})}
+
+\newcommand{\later}{\mathord{\triangleright}}
+\newcommand{\always}{\Box{}}
+
+%% Invariants and Ghost ownership
+% PDS: Was 0pt inner, 2pt outer.
+% \boxedassert [tikzoptions] contents [name]
+\tikzstyle{boxedassert_border} = [sharp corners,line width=0.2pt]
+\NewDocumentCommand \boxedassert {O{} m o}{%
+ \tikz[baseline=(m.base)]{
+ % \node[rectangle, draw,inner sep=0.8pt,anchor=base,#1] (m) {${#2}\mathstrut$};
+ \node[rectangle,inner sep=0.8pt,outer sep=0.2pt,anchor=base] (m) {${#2}\mathstrut$};
+ \draw[#1,boxedassert_border] ($(m.south west) + (0,0.65pt)$) rectangle ($(m.north east) + (0, 0.7pt)$);
+ }\IfNoValueF{#3}{^{\,#3}}%
+}
+\newcommand*{\knowInv}[2]{\boxedassert{#2}[#1]}
+\newcommand*{\ownGhost}[2]{\boxedassert[densely dashed]{#2}[#1]}
+\newcommand*{\ownGGhost}[1]{\boxedassert[densely dashed]{#1}}
+
+\newcommand{\ownPhys}[1]{\lfloor#1\rfloor}
+
+%% View Shifts
+\NewDocumentCommand \vsGen {O{} m O{}}%
+ {\mathrel{%
+ \ifthenelse{\equal{#3}{}}{%
+ % Just one mask, or none
+ {#2}_{#1}%
+ }{%
+ % Two masks
+ \presuper{#1}{#2}^{#3}
+ }%
+ }}%
+\NewDocumentCommand \vs {O{} O{}} {\vsGen[#1]{\Rrightarrow}[#2]}
+\NewDocumentCommand \vsL {O{} O{}} {\vsGen[#1]{\Lleftarrow}[#2]}
+\NewDocumentCommand \vsE {O{} O{}} %
+ {\vsGen[#1]{\Lleftarrow\!\!\!\Rrightarrow}[#2]}
+
+%% Hoare Triples
+\newcommand*{\hoaresizebox}[1]{%
+ \hbox{$\mathsurround=0pt{#1}\mathstrut$}}
+\newcommand*{\hoarescalebox}[2]{%
+ \hbox{\scalerel*[1ex]{#1}{#2}}}
+\newcommand{\triple}[5]{%
+ \setbox0=\hoaresizebox{{#3}{#5}}%
+ \setbox1=\hoarescalebox{#1}{\copy0}%
+ \setbox2=\hoarescalebox{#2}{\copy0}%
+ \copy1{#3}\copy2%
+ \;{#4}\;%
+ \copy1{#5}\copy2}
+\NewDocumentCommand \hoare {m m m O{}}{
+ \triple\{\}{#1}{#2}{#3}%
+ _{#4}%
+}
+
+\newcommand{\bracket}[4][]{%
+ \setbox0=\hbox{$\mathsurround=0pt{#1}{#4}\mathstrut$}%
+ \scalerel*[1ex]{#2}{\copy0}%
+ {#4}%
+ \scalerel*[1ex]{#3}{\copy0}}
+% \curlybracket[other] x
+\newcommand{\curlybracket}[2][]{\bracket[{#1}]\{\}{#2}}
+\newcommand{\anglebracket}[2][]{\bracket[{#1}]\langle\rangle{#2}}
+% \hoareV[t] pre c post [mask]
+\NewDocumentCommand \hoareV {O{c} m m m O{}}{
+ {\begin{aligned}[#1]
+ &\curlybracket{#2} \\
+ &\quad{#3} \\
+ &{\curlybracket{#4}}_{#5}
+ \end{aligned}}%
+}
+% \hoareHV[t] pre c post [mask]
+\NewDocumentCommand \hoareHV {O{c} m m m O{}}{
+ {\begin{aligned}[#1]
+ &\curlybracket{#2} \; {#3} \\
+ &{\curlybracket{#4}}_{#5}
+ \end{aligned}}%
+}
+
+
+%% Some commonly used identifiers
+\newcommand{\timeless}[1]{\textlog{timeless}(#1)}
+\newcommand{\physatomic}[1]{\textlog{$#1$ phys.\ atomic}}
+\newcommand{\infinite}{\textlog{infinite}}
+
+\newcommand{\Prop}{\textlog{Prop}}
+\newcommand{\Pred}{\textlog{Pred}}
+
+\newcommand{\TRUE}{\textlog{True}}
+\newcommand{\FALSE}{\textlog{False}}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% LANGUAGE SYNTAX AND SEMANTICS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\newcommand{\expr}{e}
+\newcommand{\val}{v}
+\newcommand{\valB}{w}
+\newcommand{\state}{\sigma}
+\newcommand{\step}{\ra}
+
+\newcommand{\ectx}{K}
+\newcommand{\tpool}{T}
+
+\newcommand{\cfg}[2]{{#1};{#2}}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% DERIVED CONSTRUCTIONS
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%% Commonly used identifiers
+\newcommand{\FHeap}{\textsc{FHeap}}
+\newcommand{\AFHeap}{\textsc{AFHeap}}
+
+\newcommand{\auth}[1]{\ensuremath{\textsc{Auth}(#1)}}
+\newcommand{\authfull}{\mathord{\bullet}\,}
+\newcommand{\authfrag}{\mathord{\circ}\,}
+
+\newcommand{\fpfunm}[2]{\ensuremath{\textsc{FpFun}(#1, #2)}}
+\newcommand{\fracm}[1]{\ensuremath{\textsc{Frac}(#1)}}
+\newcommand{\exm}[1]{\ensuremath{\textsc{Ex}(#1)}}
+\newcommand{\agm}[1]{\ensuremath{\textsc{Ag}(#1)}}
+
+
+\newcommand{\STSMon}[1]{\textsc{Sts}_{#1}}
+\newcommand{\STSInv}{\textsf{STSInv}}
+\newcommand{\STS}{\textsf{STS}}
+\newcommand{\STSS}{\mathcal{S}} % states
+\newcommand{\STST}{\mathcal{T}} % tokens
+\newcommand{\STSL}{\mathcal{L}} % labels
+\newcommand{\ststrans}{\ra^{*}}% the relation relevant to the STS rules
+
+\newcommand{\AuthInv}{\textsf{AuthInv}}
+\newcommand{\Auth}{\textsf{Auth}}
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "iris"
+%%% End:
diff --git a/ectx_lang.v b/ectx_lang.v
deleted file mode 100644
index 8ed1bab7d7fcee2e8f4a92474b7e7453d7635e9e..0000000000000000000000000000000000000000
--- a/ectx_lang.v
+++ /dev/null
@@ -1,208 +0,0 @@
-Require Import Arith Ssreflect.ssreflect Ssreflect.ssrfun.
-Require Import world_prop world_prop_recdom core_lang lang iris_core iris_plog iris_ht_rules iris_vs_rules iris_derived_rules.
-Require Import ModuRes.RA ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.RAConstr ModuRes.CMRA.
-
-Set Bullet Behavior "Strict Subproofs".
-
-(** This file defines an interface for languages with evaluation contexts, and shows that they have a Bind rule. *)
-Module Type ECTX_LANG.
-
- (******************************************************************)
- (** ** Syntax, machine state, and atomic reductions **)
- (******************************************************************)
-
- (** Expressions and values **)
- Parameter expr : Type.
-
- Parameter is_value : expr -> Prop.
- Definition value : Type := {e: expr | is_value e}.
- Parameter is_value_dec : forall e, is_value e + ~is_value e.
-
- (** Evaluation contexts **)
- Parameter ectx : Type.
- Parameter empty_ctx : ectx.
- Parameter comp_ctx : ectx -> ectx -> ectx.
- Parameter fill : ectx -> expr -> expr.
-
- Axiom fill_empty : forall e, fill empty_ctx e = e.
- Axiom fill_comp : forall K1 K2 e, fill K1 (fill K2 e) = fill (comp_ctx K1 K2) e.
- Axiom fill_inj_r : forall K e1 e2, fill K e1 = fill K e2 -> e1 = e2.
- Axiom fill_value : forall K e, is_value (fill K e) -> is_value e.
-
- (** Shared machine state (e.g., the heap) **)
- Parameter state : Type.
-
- (** Primitive (single thread) machine configurations **)
- Definition prim_cfg : Type := (expr * state)%type.
-
- (** The primitive atomic stepping relation **)
- Parameter prim_step : prim_cfg -> prim_cfg -> option expr -> Prop.
-
- (** Some derived notions. **)
- Definition reducible e: Prop :=
- exists sigma cfg' ef, prim_step (e, sigma) cfg' ef.
-
- Definition stuck (e : expr) : Prop :=
- forall K e',
- e = fill K e' ->
- ~reducible e'.
-
- (** Atomic expressions **)
- Parameter atomic : expr -> Prop.
-
- (** Things ought to make sense. *)
- Axiom values_stuck :
- forall e, is_value e -> stuck e.
-
- (* When something does a step, and another decomposition of the same
- expression has a non-value e in the hole, then K is a left
- sub-context of K' - in other words, e also contains the reducible
- expression *)
- Axiom step_by_value :
- forall K K' e e',
- fill K e = fill K' e' ->
- reducible e' ->
- ~ is_value e ->
- exists K'', K' = comp_ctx K K''.
-
- Axiom atomic_not_value :
- forall e, atomic e -> ~is_value e.
-
- Axiom atomic_step: forall e σ e' σ' ef,
- atomic e ->
- prim_step (e, σ) (e', σ') ef ->
- is_value e'.
-
- (* Atomics must not contain evaluation positions. *)
- Axiom atomic_fill: forall e K,
- atomic (fill K e) ->
- ~ is_value e ->
- K = empty_ctx.
-End ECTX_LANG.
-
-Module EctxCoreLang (E: ECTX_LANG) <: CORE_LANG.
-
- Definition expr := E.expr.
- Definition is_value := E.is_value.
- Definition value := E.value.
- Definition is_value_dec := E.is_value_dec.
-
- Definition state := E.state.
- Definition prim_cfg := E.prim_cfg.
-
- (** Base reduction **)
- Definition prim_step (c1 c2: prim_cfg) (ef: option expr) :=
- match c1, c2 with
- | (e1, σ1), (e2, σ2) => exists K e1' e2', e1 = E.fill K e1' /\ e2 = E.fill K e2' /\
- E.prim_step (e1', σ1) (e2', σ2) ef
- end.
-
- Definition reducible e: Prop :=
- exists sigma cfg' ef, prim_step (e, sigma) cfg' ef.
-
-
- Definition is_ctx (ctx : expr -> expr) : Prop :=
- (forall e, is_value (ctx e) -> is_value e) /\
- (forall e1 σ1 e2 σ2 ef, prim_step (e1, σ1) (e2, σ2) ef -> prim_step (ctx e1, σ1) (ctx e2, σ2) ef) /\
- (forall e1 σ1 e2 σ2 ef, ~is_value e1 -> prim_step (ctx e1, σ1) (e2, σ2) ef ->
- exists e2', e2 = ctx e2' /\ prim_step (e1, σ1) (e2', σ2) ef).
-
- Lemma reducible_eq e: reducible e <-> exists K e', e = E.fill K e' /\ E.reducible e'.
- Proof.
- split.
- - intros (σ & c2 & ef & Hstep). destruct c2 as [e2 σ2].
- destruct Hstep as (K & e' & e2' & Heq1 & Heq2 & Hstep).
- exists K e'. split; first assumption. exists σ (e2', σ2) ef.
- assumption.
- - intros (K & e' & Heq & Hred). destruct Hred as (σ & c2 & ef & Hred). destruct c2 as [e2 σ2].
- exists σ (E.fill K e2, σ2) ef. exists K e' e2. split; last split; assumption || reflexivity.
- Qed.
-
- Lemma values_stuck :
- forall e, is_value e -> ~reducible e.
- Proof.
- intros. intros HRed. apply reducible_eq in HRed. destruct HRed as (K & e' & Heq & HRed).
- eapply E.values_stuck; eassumption.
- Qed.
-
- (** Atomic **)
- Definition atomic := E.atomic.
-
- Lemma atomic_not_value :
- forall e, atomic e -> ~is_value e.
- Proof.
- exact E.atomic_not_value.
- Qed.
-
- Lemma atomic_step: forall e σ e' σ' ef,
- atomic e ->
- prim_step (e, σ) (e', σ') ef ->
- is_value e'.
- Proof.
- intros ? ? ? ? ? Hatomic (K & e1' & e2' & Heq1 & Heq2 & Hstep).
- move:(E.atomic_fill e1' K). subst. case/(_ _ _)/Wrap.
- - assumption.
- - intros Hval. eapply E.values_stuck; [eassumption|erewrite E.fill_empty;reflexivity|].
- do 3 eexists. eassumption.
- - intros Heq. subst.
- eapply E.atomic_step; first eassumption.
- erewrite !E.fill_empty. eassumption.
- Qed.
-
-End EctxCoreLang.
-
-Module Type ECTX_RES (RL : VIRA_T) (E : ECTX_LANG) <: CMRA_EXT_T.
- Module C := EctxCoreLang E.
- Include IRIS_RES RL C.
-End ECTX_RES.
-
-Module EctxRes (RL : VIRA_T) (E : ECTX_LANG) <: ECTX_RES RL E.
- Include ECTX_RES RL E.
-End EctxRes.
-
-Module ECTX_IRIS (RL : VIRA_T) (E : ECTX_LANG) (R: ECTX_RES RL E) (WP: WORLD_PROP R).
-
- Module Lang := EctxCoreLang E.
- Module Res := IrisRes RL Lang.
- Module World := WorldProp Res.
- Module Import Core := IrisCore RL Lang Res World.
- Module Import Plog := IrisPlog RL Lang Res World Core.
- Module Import HTRules := IrisHTRules RL Lang Res World Core Plog.
- Module Import VSRules := IrisVSRules RL Lang Res World Core Plog.
- Module Import DerivedRules := IrisDerivedRules RL Lang Res World Core Plog VSRules HTRules.
-
- Local Open Scope ra_scope.
- Local Open Scope de_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
-
- (** We can hae bind with evaluation contexts **)
- Lemma fill_is_ctx K: is_ctx (E.fill K).
- Proof.
- split; last split.
- - intros ? Hval. eapply E.fill_value. eassumption.
- - intros ? ? ? ? ? (K' & e1' & e2' & Heq1 & Heq2 & Hstep).
- exists (E.comp_ctx K K') e1' e2'. rewrite -!E.fill_comp Heq1 Heq2.
- split; last split; reflexivity || assumption.
- - intros ? ? ? ? ? Hnval (K' & e1' & e2' & Heq1 & Heq2 & Hstep).
- destruct (E.step_by_value _ _ _ _ Heq1) as [K'' HeqK].
- + do 3 eexists. eassumption.
- + assumption.
- + subst e2 K'. rewrite -E.fill_comp in Heq1. apply E.fill_inj_r in Heq1. subst e1.
- exists (E.fill K'' e2'). split; first by rewrite -E.fill_comp.
- do 3 eexists. split; last split; eassumption || reflexivity.
- Qed.
-
- Lemma wpBind φ K e safe m :
- wp safe m e (HTRules.plug_bind (E.fill K) safe m φ) ⊑ wp safe m (E.fill K e) φ.
- Proof.
- apply wpBind. apply fill_is_ctx.
- Qed.
-
- Lemma htBind K P Q R e safe m :
- ht safe m P e Q ∧ all (plug_bind (E.fill K) safe m Q R) ⊑ ht safe m P (E.fill K e) R.
- Proof.
- apply htBind. apply fill_is_ctx.
- Qed.
-
-End ECTX_IRIS.
diff --git a/heap_lang/heap_lang.v b/heap_lang/heap_lang.v
new file mode 100644
index 0000000000000000000000000000000000000000..1511b05a59c78ba1b66c7d9c91a5057fc2c12cfa
--- /dev/null
+++ b/heap_lang/heap_lang.v
@@ -0,0 +1,322 @@
+Require Export Autosubst.Autosubst.
+Require Export program_logic.language.
+Require Import prelude.gmap.
+
+Module heap_lang.
+(** Expressions and vals. *)
+Definition loc := positive. (* Really, any countable type. *)
+
+Inductive expr :=
+ (* Base lambda calculus *)
+ | Var (x : var)
+ | Rec (e : {bind 2 of expr}) (* These are recursive lambdas.
+ The *inner* binder is the recursive call! *)
+ | App (e1 e2 : expr)
+ (* Natural numbers *)
+ | LitNat (n : nat)
+ | Plus (e1 e2 : expr)
+ | Le (e1 e2 : expr)
+ (* Unit *)
+ | LitUnit
+ (* Products *)
+ | Pair (e1 e2 : expr)
+ | Fst (e : expr)
+ | Snd (e : expr)
+ (* Sums *)
+ | InjL (e : expr)
+ | InjR (e : expr)
+ | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
+ (* Concurrency *)
+ | Fork (e : expr)
+ (* Heap *)
+ | Loc (l : loc)
+ | Alloc (e : expr)
+ | Load (e : expr)
+ | Store (e1 : expr) (e2 : expr)
+ | Cas (e0 : expr) (e1 : expr) (e2 : expr).
+
+Instance Ids_expr : Ids expr. derive. Defined.
+Instance Rename_expr : Rename expr. derive. Defined.
+Instance Subst_expr : Subst expr. derive. Defined.
+Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.
+
+(* This sugar is used by primitive reduction riles (<=, CAS) and hence
+defined here. *)
+Notation LitTrue := (InjL LitUnit).
+Notation LitFalse := (InjR LitUnit).
+
+Inductive val :=
+ | RecV (e : {bind 2 of expr}) (* These are recursive lambdas.
+ The *inner* binder is the recursive call! *)
+ | LitNatV (n : nat)
+ | LitUnitV
+ | PairV (v1 v2 : val)
+ | InjLV (v : val)
+ | InjRV (v : val)
+ | LocV (l : loc).
+
+Definition LitTrueV := InjLV LitUnitV.
+Definition LitFalseV := InjRV LitUnitV.
+
+Fixpoint of_val (v : val) : expr :=
+ match v with
+ | RecV e => Rec e
+ | LitNatV n => LitNat n
+ | LitUnitV => LitUnit
+ | PairV v1 v2 => Pair (of_val v1) (of_val v2)
+ | InjLV v => InjL (of_val v)
+ | InjRV v => InjR (of_val v)
+ | LocV l => Loc l
+ end.
+Fixpoint to_val (e : expr) : option val :=
+ match e with
+ | Rec e => Some (RecV e)
+ | LitNat n => Some (LitNatV n)
+ | LitUnit => Some LitUnitV
+ | 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
+ | Loc l => Some (LocV l)
+ | _ => None
+ end.
+
+(** The state: heaps of vals. *)
+Definition state := gmap loc val.
+
+(** Evaluation contexts *)
+Inductive ectx_item :=
+ | AppLCtx (e2 : expr)
+ | AppRCtx (v1 : val)
+ | PlusLCtx (e2 : expr)
+ | PlusRCtx (v1 : val)
+ | LeLCtx (e2 : expr)
+ | LeRCtx (v1 : val)
+ | PairLCtx (e2 : expr)
+ | PairRCtx (v1 : val)
+ | FstCtx
+ | SndCtx
+ | InjLCtx
+ | InjRCtx
+ | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
+ | AllocCtx
+ | LoadCtx
+ | StoreLCtx (e2 : expr)
+ | StoreRCtx (v1 : val)
+ | CasLCtx (e1 : expr) (e2 : expr)
+ | CasMCtx (v0 : val) (e2 : expr)
+ | CasRCtx (v0 : val) (v1 : val).
+
+Notation ectx := (list ectx_item).
+
+Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
+ match Ki with
+ | AppLCtx e2 => App e e2
+ | AppRCtx v1 => App (of_val v1) e
+ | PlusLCtx e2 => Plus e e2
+ | PlusRCtx v1 => Plus (of_val v1) e
+ | LeLCtx e2 => Le e e2
+ | LeRCtx v1 => Le (of_val v1) e
+ | 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.
+Definition fill (K : ectx) (e : expr) : expr := fold_right fill_item e K.
+
+(** The stepping relation *)
+Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop :=
+ | BetaS e1 e2 v2 σ :
+ to_val e2 = Some v2 →
+ head_step (App (Rec e1) e2) σ e1.[(Rec e1),e2/] σ None
+ | PlusS n1 n2 σ:
+ head_step (Plus (LitNat n1) (LitNat n2)) σ (LitNat (n1 + n2)) σ None
+ | LeTrueS n1 n2 σ :
+ n1 ≤ n2 →
+ head_step (Le (LitNat n1) (LitNat n2)) σ LitTrue σ None
+ | LeFalseS n1 n2 σ :
+ n1 > n2 →
+ head_step (Le (LitNat n1) (LitNat n2)) σ LitFalse σ 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) σ e1.[e0/] σ None
+ | CaseRS e0 v0 e1 e2 σ :
+ to_val e0 = Some v0 →
+ head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ None
+ | ForkS e σ:
+ head_step (Fork e) σ LitUnit σ (Some e)
+ | AllocS e v σ l :
+ to_val e = Some v → σ !! l = None →
+ head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) None
+ | LoadS l v σ :
+ σ !! l = Some v →
+ head_step (Load (Loc l)) σ (of_val v) σ None
+ | StoreS l e v σ :
+ to_val e = Some v → is_Some (σ !! l) →
+ head_step (Store (Loc l) e) σ 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 (Loc l) e1 e2) σ LitFalse σ None
+ | CasSucS l e1 v1 e2 v2 σ :
+ to_val e1 = Some v1 → to_val e2 = Some v2 →
+ σ !! l = Some v1 →
+ head_step (Cas (Loc l) e1 e2) σ LitTrue (<[l:=v2]>σ) None.
+
+(** Atomic expressions *)
+Definition atomic (e: expr) :=
+ match e with
+ | Alloc e => is_Some (to_val e)
+ | Load e => is_Some (to_val e)
+ | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
+ | Cas e0 e1 e2 => is_Some (to_val e0) ∧ is_Some (to_val e1) ∧ is_Some (to_val e2)
+ | _ => False
+ end.
+
+(** Close reduction under evaluation contexts.
+We could potentially make this a generic construction. *)
+Inductive prim_step
+ (e1 : expr) (σ1 : state) (e2 : expr) (σ2: state) (ef: option expr) : Prop :=
+ Ectx_step K e1' e2' :
+ e1 = fill K e1' → e2 = fill K e2' →
+ head_step e1' σ1 e2' σ2 ef → prim_step e1 σ1 e2 σ2 ef.
+
+(** Basic properties about the language *)
+Lemma to_of_val v : to_val (of_val v) = Some v.
+Proof. by induction v; simplify_option_equality. Qed.
+
+Lemma of_to_val e v : to_val e = Some v → of_val v = e.
+Proof.
+ revert v; induction e; intros; simplify_option_equality; auto with f_equal.
+Qed.
+
+Instance: Injective (=) (=) of_val.
+Proof. by intros ?? Hv; apply (injective Some); rewrite -!to_of_val Hv. Qed.
+
+Instance fill_item_inj Ki : Injective (=) (=) (fill_item Ki).
+Proof. destruct Ki; intros ???; simplify_equality'; auto with f_equal. Qed.
+
+Instance ectx_fill_inj K : Injective (=) (=) (fill K).
+Proof. red; induction K as [|Ki K IH]; naive_solver. Qed.
+
+Lemma fill_app K1 K2 e : fill (K1 ++ K2) e = fill K1 (fill K2 e).
+Proof. revert e; induction K1; simpl; auto with f_equal. Qed.
+
+Lemma fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e).
+Proof.
+ intros [v' Hv']; revert v' Hv'.
+ induction K as [|[]]; intros; simplify_option_equality; eauto.
+Qed.
+
+Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None.
+Proof. rewrite !eq_None_not_Some; eauto using fill_val. Qed.
+
+Lemma values_head_stuck e1 σ1 e2 σ2 ef :
+ head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
+Proof. destruct 1; naive_solver. Qed.
+
+Lemma values_stuck e1 σ1 e2 σ2 ef : prim_step e1 σ1 e2 σ2 ef → to_val e1 = None.
+Proof. intros [??? -> -> ?]; eauto using fill_not_val, values_head_stuck. Qed.
+
+Lemma atomic_not_val e : atomic e → to_val e = None.
+Proof. destruct e; naive_solver. Qed.
+
+Lemma atomic_fill K e : atomic (fill K e) → to_val e = None → K = [].
+Proof.
+ rewrite eq_None_not_Some.
+ destruct K as [|[]]; naive_solver eauto using fill_val.
+Qed.
+
+Lemma atomic_head_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; naive_solver. Qed.
+
+Lemma atomic_step e1 σ1 e2 σ2 ef :
+ atomic e1 → prim_step e1 σ1 e2 σ2 ef → is_Some (to_val e2).
+Proof.
+ intros Hatomic [K e1' e2' -> -> Hstep].
+ assert (K = []) as -> by eauto 10 using atomic_fill, values_head_stuck.
+ naive_solver eauto using atomic_head_step.
+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_equality; 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_equality';
+ try match goal with
+ | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
+ end; auto.
+Qed.
+
+(* When something does a step, and another decomposition of the same expression
+has a non-val [e] in the hole, then [K] is a left sub-context of [K'] - in
+other words, [e] also contains the reducible expression *)
+Lemma step_by_val K K' e1 e1' σ1 e2 σ2 ef :
+ fill K e1 = fill K' e1' → to_val e1 = None → head_step e1' σ1 e2 σ2 ef →
+ K `prefix_of` K'.
+Proof.
+ intros Hfill Hred Hnval; revert K' Hfill.
+ induction K as [|Ki K IH]; simpl; intros K' Hfill; auto using prefix_of_nil.
+ destruct K' as [|Ki' K']; simplify_equality'.
+ { exfalso; apply (eq_None_not_Some (to_val (fill K e1)));
+ eauto using fill_not_val, head_ctx_step_val. }
+ cut (Ki = Ki'); [naive_solver eauto using prefix_of_cons|].
+ eauto using fill_item_no_val_inj, values_head_stuck, fill_not_val.
+Qed.
+
+Lemma alloc_fresh e v σ :
+ let l := fresh (dom _ σ) in
+ to_val e = Some v → head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) None.
+Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.
+
+End heap_lang.
+
+(** Language *)
+Program Canonical Structure heap_lang : language := {|
+ expr := heap_lang.expr; val := heap_lang.val; state := heap_lang.state;
+ of_val := heap_lang.of_val; to_val := heap_lang.to_val;
+ atomic := heap_lang.atomic; prim_step := heap_lang.prim_step;
+|}.
+Solve Obligations with eauto using heap_lang.to_of_val, heap_lang.of_to_val,
+ heap_lang.values_stuck, heap_lang.atomic_not_val, heap_lang.atomic_step.
+
+Global Instance heap_lang_ctx K : LanguageCtx heap_lang (heap_lang.fill K).
+Proof.
+ split.
+ * eauto using heap_lang.fill_not_val.
+ * intros ????? [K' e1' e2' Heq1 Heq2 Hstep].
+ by exists (K ++ K') e1' e2'; rewrite ?heap_lang.fill_app ?Heq1 ?Heq2.
+ * intros e1 σ1 e2 σ2 ? Hnval [K'' e1'' e2'' Heq1 -> Hstep].
+ destruct (heap_lang.step_by_val
+ K K'' e1 e1'' σ1 e2'' σ2 ef) as [K' ->]; eauto.
+ rewrite heap_lang.fill_app in Heq1; apply (injective _) in Heq1.
+ exists (heap_lang.fill K' e2''); rewrite heap_lang.fill_app; split; auto.
+ econstructor; eauto.
+Qed.
+
+Global Instance heap_lang_ctx_item Ki :
+ LanguageCtx heap_lang (heap_lang.fill_item Ki).
+Proof.
+ change (LanguageCtx heap_lang (heap_lang.fill [Ki])).
+ by apply _.
+Qed.
diff --git a/heap_lang/heap_lang_tactics.v b/heap_lang/heap_lang_tactics.v
new file mode 100644
index 0000000000000000000000000000000000000000..b94d96a9874822ec7fad7e6ba170587a48b06313
--- /dev/null
+++ b/heap_lang/heap_lang_tactics.v
@@ -0,0 +1,89 @@
+Require Export heap_lang.heap_lang.
+Require Import prelude.fin_maps.
+Import heap_lang.
+
+(** The tactic [inv_step] performs inversion on hypotheses of the shape
+[prim_step] and [head_step]. For hypotheses of the shape [prim_step] it will
+decompose the evaluation context. 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_step :=
+ repeat match goal with
+ | _ => progress simplify_map_equality' (* 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 : prim_step _ _ _ _ _ |- _ => destruct H; subst
+ | H : _ = fill ?K ?e |- _ =>
+ destruct K as [|[]];
+ simpl in H; first [subst e|discriminate H|injection' H]
+ (* ensure that we make progress for each subgoal *)
+ | H : head_step ?e _ _ _ _, Hv : of_val ?v = fill ?K ?e |- _ =>
+ apply values_head_stuck, (fill_not_val K) in H;
+ by rewrite -Hv to_of_val in H (* maybe use a helper lemma here? *)
+ | 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_expr e tac :=
+ let rec go K e :=
+ match e with
+ | _ => tac (reverse K) e
+ | App ?e1 ?e2 =>
+ lazymatch e1 with
+ | of_val ?v1 => go (AppRCtx v1 :: K) e2 | _ => go (AppLCtx e2 :: K) e1
+ end
+ | Plus ?e1 ?e2 =>
+ lazymatch e1 with
+ | of_val ?v1 => go (PlusRCtx v1 :: K) e2 | _ => go (PlusLCtx e2 :: K) e1
+ end
+ | Le ?e1 ?e2 =>
+ lazymatch e1 with
+ | of_val ?v1 => go (LeRCtx v1 :: K) e2 | _ => go (LeLCtx e2 :: K) e1
+ end
+ | Pair ?e1 ?e2 =>
+ lazymatch e1 with
+ | of_val ?v1 => go (PairRCtx v1 :: K) e2 | _ => go (PairLCtx e2 :: K) e1
+ end
+ | 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 => go (StoreLCtx e2 :: K) e1 || go (StoreRCtx e1 :: K) e2
+ | Cas ?e0 ?e1 ?e2 =>
+ lazymatch e0 with
+ | of_val ?v0 =>
+ lazymatch e1 with
+ | of_val ?v1 => go (CasRCtx v0 v1 :: K) e2
+ | _ => go (CasMCtx v0 e2 :: K) e1
+ end
+ | _ => go (CasLCtx e1 e2 :: K) e0
+ end
+ end in go (@nil ectx_item) e.
+
+(** The tactic [do_step tac] solves goals of the shape [reducible], [prim_step]
+and [head_step] by performing a reduction step and uses [tac] to solve any
+side-conditions generated by individual steps. In case of goals of the shape
+[reducible] and [prim_step], it will try to decompose to expression on the LHS
+into an evaluation context and head-redex. *)
+Ltac do_step tac :=
+ try match goal with |- language.reducible _ _ => eexists _, _, _ end;
+ simpl;
+ match goal with
+ | |- prim_step ?e1 ?σ1 ?e2 ?σ2 ?ef =>
+ reshape_expr e1 ltac:(fun K e1' =>
+ eapply Ectx_step with K e1' _; [reflexivity|reflexivity|];
+ first [apply alloc_fresh|econstructor];
+ rewrite ?to_of_val; tac; fail)
+ | |- head_step ?e1 ?σ1 ?e2 ?σ2 ?ef =>
+ first [apply alloc_fresh|econstructor];
+ rewrite ?to_of_val; tac; fail
+ end.
diff --git a/heap_lang/lifting.v b/heap_lang/lifting.v
new file mode 100644
index 0000000000000000000000000000000000000000..62df239ee2a0f44e9e213bd746e9907073165bd7
--- /dev/null
+++ b/heap_lang/lifting.v
@@ -0,0 +1,164 @@
+Require Import prelude.gmap program_logic.lifting.
+Require Export program_logic.weakestpre heap_lang.heap_lang_tactics.
+Import uPred.
+Import heap_lang.
+Local Hint Extern 0 (language.reducible _ _) => do_step ltac:(eauto 2).
+
+Section lifting.
+Context {Σ : iFunctor}.
+Implicit Types P : iProp heap_lang Σ.
+Implicit Types Q : val → iProp heap_lang Σ.
+Implicit Types K : ectx.
+
+(** Bind. *)
+Lemma wp_bind {E e} K Q :
+ wp E e (λ v, wp E (fill K (of_val v)) Q) ⊑ wp E (fill K e) Q.
+Proof. apply weakestpre.wp_bind. Qed.
+
+Lemma wp_bindi {E e} Ki Q :
+ wp E e (λ v, wp E (fill_item Ki (of_val v)) Q) ⊑ wp E (fill_item Ki e) Q.
+Proof. apply weakestpre.wp_bind. Qed.
+
+(** Base axioms for core primitives of the language: Stateful reductions. *)
+Lemma wp_alloc_pst E σ e v Q :
+ to_val e = Some v →
+ (ownP σ ★ ▷ (∀ l, ■(σ !! l = None) ∧ ownP (<[l:=v]>σ) -★ Q (LocV l)))
+ ⊑ wp E (Alloc e) Q.
+Proof.
+ (* TODO RJ: This works around ssreflect bug #22. *)
+ intros. set (φ v' σ' ef := ∃ l, ef = @None expr ∧ v' = LocV l ∧ σ' = <[l:=v]>σ ∧ σ !! l = None).
+ rewrite -(wp_lift_atomic_step (Alloc e) φ σ) // /φ;
+ last by intros; inv_step; eauto 8.
+ apply sep_mono, later_mono; first done.
+ apply forall_intro=>e2; apply forall_intro=>σ2; apply forall_intro=>ef.
+ apply wand_intro_l.
+ rewrite always_and_sep_l' -associative -always_and_sep_l'.
+ apply const_elim_l=>-[l [-> [-> [-> ?]]]].
+ by rewrite (forall_elim l) right_id const_equiv // left_id wand_elim_r.
+Qed.
+
+Lemma wp_load_pst E σ l v Q :
+ σ !! l = Some v →
+ (ownP σ ★ ▷ (ownP σ -★ Q v)) ⊑ wp E (Load (Loc l)) Q.
+Proof.
+ intros; rewrite -(wp_lift_atomic_det_step σ v σ None) ?right_id //;
+ last (by intros; inv_step; eauto).
+Qed.
+
+Lemma wp_store_pst E σ l e v v' Q :
+ to_val e = Some v → σ !! l = Some v' →
+ (ownP σ ★ ▷ (ownP (<[l:=v]>σ) -★ Q LitUnitV)) ⊑ wp E (Store (Loc l) e) Q.
+Proof.
+ intros.
+ rewrite -(wp_lift_atomic_det_step σ LitUnitV (<[l:=v]>σ) None) ?right_id //;
+ last by intros; inv_step; eauto.
+Qed.
+
+Lemma wp_cas_fail_pst E σ l e1 v1 e2 v2 v' Q :
+ to_val e1 = Some v1 → to_val e2 = Some v2 → σ !! l = Some v' → v' ≠v1 →
+ (ownP σ ★ ▷ (ownP σ -★ Q LitFalseV)) ⊑ wp E (Cas (Loc l) e1 e2) Q.
+Proof.
+ intros; rewrite -(wp_lift_atomic_det_step σ LitFalseV σ None) ?right_id //;
+ last by intros; inv_step; eauto.
+Qed.
+
+Lemma wp_cas_suc_pst E σ l e1 v1 e2 v2 Q :
+ to_val e1 = Some v1 → to_val e2 = Some v2 → σ !! l = Some v1 →
+ (ownP σ ★ ▷ (ownP (<[l:=v2]>σ) -★ Q LitTrueV)) ⊑ wp E (Cas (Loc l) e1 e2) Q.
+Proof.
+ intros.
+ rewrite -(wp_lift_atomic_det_step σ LitTrueV (<[l:=v2]>σ) None) ?right_id //;
+ last by intros; inv_step; eauto.
+Qed.
+
+(** Base axioms for core primitives of the language: Stateless reductions *)
+Lemma wp_fork E e :
+ ▷ wp (Σ:=Σ) coPset_all e (λ _, True) ⊑ wp E (Fork e) (λ v, ■(v = LitUnitV)).
+Proof.
+ rewrite -(wp_lift_pure_det_step (Fork e) LitUnit (Some e)) //=;
+ last by intros; inv_step; eauto.
+ apply later_mono, sep_intro_True_l; last done.
+ by rewrite -(wp_value' _ _ LitUnit) //; apply const_intro.
+Qed.
+
+Lemma wp_rec E ef e v Q :
+ to_val e = Some v →
+ ▷ wp E ef.[Rec ef, e /] Q ⊑ wp E (App (Rec ef) e) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (App _ _) ef.[Rec ef, e /] None)
+ ?right_id //=;
+ last by intros; inv_step; eauto.
+Qed.
+
+Lemma wp_plus E n1 n2 Q :
+ ▷ Q (LitNatV (n1 + n2)) ⊑ wp E (Plus (LitNat n1) (LitNat n2)) Q.
+Proof.
+ rewrite -(wp_lift_pure_det_step (Plus _ _) (LitNat (n1 + n2)) None) ?right_id //;
+ last by intros; inv_step; eauto.
+ by rewrite -wp_value'.
+Qed.
+
+Lemma wp_le_true E n1 n2 Q :
+ n1 ≤ n2 →
+ ▷ Q LitTrueV ⊑ wp E (Le (LitNat n1) (LitNat n2)) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (Le _ _) LitTrue None) ?right_id //;
+ last by intros; inv_step; eauto with omega.
+ by rewrite -wp_value'.
+Qed.
+
+Lemma wp_le_false E n1 n2 Q :
+ n1 > n2 →
+ ▷ Q LitFalseV ⊑ wp E (Le (LitNat n1) (LitNat n2)) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (Le _ _) LitFalse None) ?right_id //;
+ last by intros; inv_step; eauto with omega.
+ by rewrite -wp_value'.
+Qed.
+
+Lemma wp_fst E e1 v1 e2 v2 Q :
+ to_val e1 = Some v1 → to_val e2 = Some v2 →
+ ▷Q v1 ⊑ wp E (Fst (Pair e1 e2)) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (Fst _) e1 None) ?right_id //;
+ last by intros; inv_step; eauto.
+ by rewrite -wp_value'.
+Qed.
+
+Lemma wp_snd E e1 v1 e2 v2 Q :
+ to_val e1 = Some v1 → to_val e2 = Some v2 →
+ ▷ Q v2 ⊑ wp E (Snd (Pair e1 e2)) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (Snd _) e2 None) ?right_id //;
+ last by intros; inv_step; eauto.
+ by rewrite -wp_value'.
+Qed.
+
+Lemma wp_case_inl E e0 v0 e1 e2 Q :
+ to_val e0 = Some v0 →
+ ▷ wp E e1.[e0/] Q ⊑ wp E (Case (InjL e0) e1 e2) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (Case _ _ _) e1.[e0/] None) ?right_id //;
+ last by intros; inv_step; eauto.
+Qed.
+
+Lemma wp_case_inr E e0 v0 e1 e2 Q :
+ to_val e0 = Some v0 →
+ ▷ wp E e2.[e0/] Q ⊑ wp E (Case (InjR e0) e1 e2) Q.
+Proof.
+ intros; rewrite -(wp_lift_pure_det_step (Case _ _ _) e2.[e0/] None) ?right_id //;
+ last by intros; inv_step; eauto.
+Qed.
+
+(** Some derived stateless axioms *)
+Lemma wp_le E n1 n2 P Q :
+ (n1 ≤ n2 → P ⊑ ▷ Q LitTrueV) →
+ (n1 > n2 → P ⊑ ▷ Q LitFalseV) →
+ P ⊑ wp E (Le (LitNat n1) (LitNat n2)) Q.
+Proof.
+ intros; destruct (decide (n1 ≤ n2)).
+ * rewrite -wp_le_true; auto.
+ * rewrite -wp_le_false; auto with omega.
+Qed.
+
+End lifting.
diff --git a/heap_lang/sugar.v b/heap_lang/sugar.v
new file mode 100644
index 0000000000000000000000000000000000000000..36b1ab9ddbc423d0151d2f14c7659a9724f54e2e
--- /dev/null
+++ b/heap_lang/sugar.v
@@ -0,0 +1,65 @@
+Require Export heap_lang.heap_lang heap_lang.lifting.
+Import uPred.
+Import heap_lang.
+
+(** Define some syntactic sugar. LitTrue and LitFalse are defined in heap_lang.v. *)
+Definition Lam (e : {bind expr}) := Rec e.[ren(+1)].
+Definition Let (e1 : expr) (e2: {bind expr}) := App (Lam e2) e1.
+Definition Seq (e1 e2 : expr) := Let e1 e2.[ren(+1)].
+Definition If (e0 e1 e2 : expr) := Case e0 e1.[ren(+1)] e2.[ren(+1)].
+Definition Lt e1 e2 := Le (Plus e1 $ LitNat 1) e2.
+Definition Eq e1 e2 :=
+ Let e1 (Let e2.[ren(+1)]
+ (If (Le (Var 0) (Var 1)) (Le (Var 1) (Var 0)) LitFalse)).
+
+Definition LamV (e : {bind expr}) := RecV e.[ren(+1)].
+
+Definition LetCtx (e2 : {bind expr}) := AppRCtx (LamV e2).
+Definition SeqCtx (e2 : expr) := LetCtx (e2.[ren(+1)]).
+
+Section suger.
+Context {Σ : iFunctor}.
+Implicit Types P : iProp heap_lang Σ.
+Implicit Types Q : val → iProp heap_lang Σ.
+
+(** Proof rules for the sugar *)
+Lemma wp_lam E ef e v Q :
+ to_val e = Some v → ▷ wp E ef.[e/] Q ⊑ wp E (App (Lam ef) e) Q.
+Proof.
+ intros Hv. rewrite -wp_rec; last eassumption.
+ (* RJ: This pulls in functional extensionality. If that bothers us, we have
+ to talk to the Autosubst guys. *)
+ by asimpl.
+Qed.
+Lemma wp_let E e1 e2 Q :
+ wp E e1 (λ v, ▷wp E (e2.[of_val v/]) Q) ⊑ wp E (Let e1 e2) Q.
+Proof.
+ rewrite -(wp_bind [LetCtx e2]). apply wp_mono=>v.
+ by rewrite -wp_lam //= to_of_val.
+Qed.
+Lemma wp_if_true E e1 e2 Q : ▷ wp E e1 Q ⊑ wp E (If LitTrue e1 e2) Q.
+Proof. rewrite -wp_case_inl //. by asimpl. Qed.
+Lemma wp_if_false E e1 e2 Q : ▷ wp E e2 Q ⊑ wp E (If LitFalse e1 e2) Q.
+Proof. rewrite -wp_case_inr //. by asimpl. Qed.
+Lemma wp_lt E n1 n2 P Q :
+ (n1 < n2 → P ⊑ ▷ Q LitTrueV) →
+ (n1 ≥ n2 → P ⊑ ▷ Q LitFalseV) →
+ P ⊑ wp E (Lt (LitNat n1) (LitNat n2)) Q.
+Proof.
+ intros; rewrite -(wp_bind [LeLCtx _]) -wp_plus -later_intro /=.
+ auto using wp_le with lia.
+Qed.
+Lemma wp_eq E n1 n2 P Q :
+ (n1 = n2 → P ⊑ ▷ Q LitTrueV) →
+ (n1 ≠n2 → P ⊑ ▷ Q LitFalseV) →
+ P ⊑ wp E (Eq (LitNat n1) (LitNat n2)) Q.
+Proof.
+ intros HPeq HPne.
+ rewrite -wp_let -wp_value' // -later_intro; asimpl.
+ rewrite -wp_rec //; asimpl.
+ rewrite -(wp_bind [CaseCtx _ _]) -later_intro; asimpl.
+ apply wp_le; intros; asimpl.
+ * rewrite -wp_case_inl // -!later_intro. apply wp_le; auto with lia.
+ * rewrite -wp_case_inr // -later_intro -wp_value' //; auto with lia.
+Qed.
+End suger.
diff --git a/heap_lang/tests.v b/heap_lang/tests.v
new file mode 100644
index 0000000000000000000000000000000000000000..4ca0d01e22cc10f4c7ac51f07d13b924467cfb11
--- /dev/null
+++ b/heap_lang/tests.v
@@ -0,0 +1,118 @@
+(** This file is essentially a bunch of testcases. *)
+Require Import logic.upred.
+Require Import heap_lang.lifting heap_lang.sugar.
+Import heap_lang.
+Import uPred.
+
+Module LangTests.
+ Definition add := Plus (LitNat 21) (LitNat 21).
+ Goal ∀ σ, prim_step add σ (LitNat 42) σ None.
+ Proof. intros; do_step done. Qed.
+ Definition rec := Rec (App (Var 0) (Var 1)). (* fix f x => f x *)
+ Definition rec_app := App rec (LitNat 0).
+ Goal ∀ σ, prim_step rec_app σ rec_app σ None.
+ Proof. intros; do_step done. Qed.
+ Definition lam := Lam (Plus (Var 0) (LitNat 21)).
+ Goal ∀ σ, prim_step (App lam (LitNat 21)) σ add σ None.
+ Proof. intros; do_step done. Qed.
+End LangTests.
+
+Module LiftingTests.
+ Context {Σ : iFunctor}.
+ Implicit Types P : iProp heap_lang Σ.
+ Implicit Types Q : val → iProp heap_lang Σ.
+
+ (* TODO RJ: Some syntactic sugar for language expressions would be nice. *)
+ Definition e3 := Load (Var 0).
+ Definition e2 := Seq (Store (Var 0) (Plus (Load $ Var 0) (LitNat 1))) e3.
+ Definition e := Let (Alloc (LitNat 1)) e2.
+ Goal ∀ σ E, (ownP σ : iProp heap_lang Σ) ⊑ (wp E e (λ v, ■(v = LitNatV 2))).
+ Proof.
+ move=> σ E. rewrite /e.
+ rewrite -wp_let. rewrite -wp_alloc_pst; last done.
+ apply sep_intro_True_r; first done.
+ rewrite -later_intro. apply forall_intro=>l.
+ apply wand_intro_l. rewrite right_id. apply const_elim_l; move=>_.
+ rewrite -later_intro. asimpl.
+ rewrite -(wp_bindi (SeqCtx (Load (Loc _)))).
+ rewrite -(wp_bindi (StoreRCtx (LocV _))).
+ rewrite -(wp_bindi (PlusLCtx _)).
+ rewrite -wp_load_pst; first (apply sep_intro_True_r; first done); last first.
+ { by rewrite lookup_insert. } (* RJ TODO: figure out why apply and eapply fail. *)
+ rewrite -later_intro. apply wand_intro_l. rewrite right_id.
+ rewrite -wp_plus -later_intro.
+ rewrite -wp_store_pst; first (apply sep_intro_True_r; first done); last first.
+ { by rewrite lookup_insert. }
+ { done. }
+ rewrite -later_intro. apply wand_intro_l. rewrite right_id.
+ rewrite -wp_lam // -later_intro. asimpl.
+ rewrite -wp_load_pst; first (apply sep_intro_True_r; first done); last first.
+ { by rewrite lookup_insert. }
+ rewrite -later_intro. apply wand_intro_l. rewrite right_id.
+ by apply const_intro.
+ Qed.
+
+ Definition FindPred' n1 Sn1 n2 f := If (Lt Sn1 n2)
+ (App f Sn1)
+ n1.
+ Definition FindPred n2 := Rec (Let (Plus (Var 1) (LitNat 1))
+ (FindPred' (Var 2) (Var 0) n2.[ren(+3)] (Var 1))).
+ Definition Pred := Lam (If (Le (Var 0) (LitNat 0))
+ (LitNat 0)
+ (App (FindPred (Var 0)) (LitNat 0))
+ ).
+
+ Lemma FindPred_spec n1 n2 E Q :
+ (■(n1 < n2) ∧ Q (LitNatV $ pred n2)) ⊑
+ wp E (App (FindPred (LitNat n2)) (LitNat n1)) Q.
+ Proof.
+ revert n1. apply löb_all_1=>n1.
+ rewrite -wp_rec //. asimpl.
+ (* Get rid of the â–· in the premise. *)
+ etransitivity; first (etransitivity; last eapply equiv_spec, later_and).
+ { apply and_mono; first done. by rewrite -later_intro. }
+ apply later_mono.
+ (* Go on. *)
+ rewrite -(wp_let _ _ (FindPred' (LitNat n1) (Var 0) (LitNat n2) (FindPred $ LitNat n2))).
+ rewrite -wp_plus. asimpl.
+ rewrite -(wp_bindi (CaseCtx _ _)).
+ rewrite -!later_intro /=.
+ apply wp_lt; intros Hn12.
+ * (* TODO RJ: It would be better if we could use wp_if_true here
+ (and below). But we cannot, because the substitutions in there
+ got already unfolded. *)
+ rewrite -wp_case_inl //.
+ rewrite -!later_intro. asimpl.
+ rewrite (forall_elim (S n1)).
+ eapply impl_elim; first by eapply and_elim_l. apply and_intro.
+ + apply const_intro; omega.
+ + by rewrite !and_elim_r.
+ * rewrite -wp_case_inr //.
+ rewrite -!later_intro -wp_value' //.
+ rewrite and_elim_r. apply const_elim_l=>Hle.
+ by replace n1 with (pred n2) by omega.
+ Qed.
+
+ Lemma Pred_spec n E Q :
+ ▷Q (LitNatV $ pred n) ⊑ wp E (App Pred (LitNat n)) Q.
+ Proof.
+ rewrite -wp_lam //. asimpl.
+ rewrite -(wp_bindi (CaseCtx _ _)).
+ apply later_mono, wp_le=> Hn.
+ - rewrite -wp_case_inl //.
+ rewrite -!later_intro -wp_value' //.
+ by replace n with 0 by omega.
+ - rewrite -wp_case_inr //.
+ rewrite -!later_intro -FindPred_spec.
+ auto using and_intro, const_intro with omega.
+ Qed.
+
+ Goal ∀ E,
+ True ⊑ wp (Σ:=Σ) E
+ (Let (App Pred (LitNat 42)) (App Pred (Var 0))) (λ v, ■(v = LitNatV 40)).
+ Proof.
+ intros E. rewrite -wp_let. rewrite -Pred_spec -!later_intro.
+ asimpl. (* TODO RJ: Can we somehow make it so that Pred gets folded again? *)
+ rewrite -Pred_spec -later_intro. by apply const_intro.
+ Qed.
+End LiftingTests.
diff --git a/iris_check.v b/iris_check.v
deleted file mode 100644
index fc398078474494c010291298fb7a31664ed0087d..0000000000000000000000000000000000000000
--- a/iris_check.v
+++ /dev/null
@@ -1,116 +0,0 @@
-Require Import Arith Ssreflect.ssreflect.
-Require Import world_prop world_prop_recdom core_lang lang iris_core iris_plog iris_meta iris_vs_rules iris_ht_rules.
-Require Import ModuRes.RA ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.RAConstr.
-
-Set Bullet Behavior "Strict Subproofs".
-
-(* This is a really stupid instantiation of the Iris paremeters.
- We use it solely to show that there are no assumptions hidden
- in the development. *)
-
-Module StupidLang : CORE_LANG.
- Inductive exprI :=
- | unitI: exprI.
- Implicit Types (e: exprI).
- Definition expr := exprI.
-
-
- Definition is_value e := True.
- Definition value : Type := {e: expr | is_value e}.
- Definition is_value_dec e : is_value e + ~is_value e.
- left. exact I.
- Defined.
-
- (** Shared machine state (e.g., the heap) **)
- Definition state : Type := Datatypes.unit.
- Implicit Types (σ: state).
-
- (** Primitive (single thread) machine configurations **)
- Definition prim_cfg : Type := (expr * state)%type.
-
- (** The primitive atomic stepping relation **)
- Definition prim_step (cfg1 cfg2: prim_cfg) (ef: option expr) := False.
-
- Definition reducible e: Prop :=
- exists sigma cfg' ef, prim_step (e, sigma) cfg' ef.
-
- Definition is_ctx (ctx : expr -> expr) : Prop :=
- (forall e, is_value (ctx e) -> is_value e) /\
- (forall e1 σ1 e2 σ2 ef, prim_step (e1, σ1) (e2, σ2) ef -> prim_step (ctx e1, σ1) (ctx e2, σ2) ef) /\
- (forall e1 σ1 e2 σ2 ef, ~is_value e1 -> prim_step (ctx e1, σ1) (e2, σ2) ef ->
- exists e2', e2 = ctx e2' /\ prim_step (e1, σ1) (e2', σ2) ef).
-
- (** Atomic expressions **)
- Definition atomic e := False.
-
- (** Properties *)
- Lemma values_stuck :
- forall e, is_value e -> ~reducible e.
- Proof.
- firstorder.
- Qed.
-
-
- Lemma atomic_not_value :
- forall e, atomic e -> ~is_value e.
- Proof.
- firstorder.
- Qed.
-
- Lemma atomic_step: forall e σ e' σ' ef,
- atomic e ->
- prim_step (e, σ) (e', σ') ef ->
- is_value e'.
- Proof.
- firstorder.
- Qed.
-
-End StupidLang.
-
-Module TrivialRA : VIRA_T.
- Definition res := ex unit.
- Instance res_type : Setoid res := _.
- Instance res_op : RA_op res := _.
- Instance res_unit : RA_unit res := _.
- Instance res_valid: RA_valid res := _.
- Instance res_ra : RA res := _.
- Instance res_vira : VIRA res := _.
-End TrivialRA.
-
-(* Now we can instantiate all the things *)
-Module Res := IrisRes TrivialRA StupidLang.
-Module World := WorldProp Res.
-Module Import Core := IrisCore TrivialRA StupidLang Res World.
-Module Import Plog := IrisPlog TrivialRA StupidLang Res World Core.
-Module Import VSRules := IrisVSRules TrivialRA StupidLang Res World Core Plog.
-Module Import HTRules := IrisHTRules TrivialRA StupidLang Res World Core Plog.
-Module Import Meta := IrisMeta TrivialRA StupidLang Res World Core Plog VSRules HTRules.
-
-(* Make sure the precondition of Bind can actually be met. *)
-Lemma id_is_ctx: is_ctx (fun e => e).
-Proof.
- split; last split.
- - by firstorder.
- - by firstorder.
- - intros. eexists. split; reflexivity || eassumption.
-Qed.
-
-(* And now we check for axioms *)
-Print Assumptions adequacy_obs.
-Print Assumptions adequacy_safe.
-
-Print Assumptions lift_atomic_step.
-Print Assumptions lift_pure_det_step.
-
-(* We just check some rules here - listing all of them
- (including the base logic) would take too long. *)
-Print Assumptions pvsOpen.
-Print Assumptions pvsClose.
-Print Assumptions pvsTrans.
-Print Assumptions pvsGhostUpd.
-
-Print Assumptions wpPreVS.
-Print Assumptions wpACons.
-Print Assumptions wpFrameRes.
-Print Assumptions wpBind.
-
diff --git a/iris_core.v b/iris_core.v
deleted file mode 100644
index 39a051e1c6149a9332071941cc5bf47156bd2816..0000000000000000000000000000000000000000
--- a/iris_core.v
+++ /dev/null
@@ -1,1048 +0,0 @@
-Require Import Ssreflect.ssreflect Omega.
-Require Import world_prop core_lang.
-Require Import ModuRes.RA ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.RAConstr ModuRes.Agreement.
-Require Import ModuRes.CMRA ModuRes.DecEnsemble.
-
-Set Bullet Behavior "Strict Subproofs".
-
-(* We hack a bit here to avoid spelling out module types for functor results.
- The hack that involves least work is to duplicate the definition of our final
- resource type as a module type (which is how we can use it, circumventing the
- Coq restrictions) and as a module (to show the type can be instantiated). *)
-Module Type IRIS_RES (RL : VIRA_T) (C : CORE_LANG) <: CMRA_EXT_T.
- Instance state_type : Setoid C.state := discreteType.
- Instance state_metr : metric (ex C.state) := discreteMetric.
- Instance state_cmetr : cmetric (ex C.state) := discreteCMetric.
- Instance state_cmra_valid : CMRA_valid (ex C.state) := discreteCMRA_valid.
- Instance state_cmra : CMRA (ex C.state) := discreteCMRA.
- Instance state_cmra_ext : CMRAExt (ex C.state) := discreteCMRAExt.
-
- Instance logR_metr : metric RL.res := discreteMetric.
- Instance logR_cmetr : cmetric RL.res := discreteCMetric.
- Instance logR_cmra_valid : CMRA_valid RL.res := discreteCMRA_valid.
- Instance logR_cmra : CMRA RL.res := discreteCMRA.
- Instance logR_cmra_ext : CMRAExt RL.res := discreteCMRAExt.
-
- Definition res := (ex C.state * RL.res)%type.
- Instance res_type : Setoid res := _.
- Instance res_op : RA_op res := _.
- Instance res_unit : RA_unit res := _.
- Instance res_valid: RA_valid res := _.
- Instance res_ra : RA res := _.
-
- Instance res_metric : metric res := _.
- Instance res_cmetric : cmetric res := _.
- Instance res_pord: preoType res := pord_ra.
- Instance res_pcmetric : pcmType res := _.
-
- Instance res_cmra_valid : CMRA_valid res := _.
- Instance res_cmra : CMRA res := _.
- Instance res_cmra_ext : CMRAExt res := _.
- Instance res_vira : VIRA res := _.
-
-End IRIS_RES.
-
-Module IrisRes (RL : VIRA_T) (C : CORE_LANG) <: IRIS_RES RL C.
- Include IRIS_RES RL C. (* I cannot believe Coq lets me do this... *)
-End IrisRes.
-
-(* This instantiates the framework(s) provided by ModuRes to obtain a higher-order
- separation logic with ownership, later, necessitation and equality.
- The logic has "worlds" in its model, but nothing here uses them yet. *)
-Module Type IRIS_CORE (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R).
- Export C.
- Export R.
- Export WP.
-
- Delimit Scope iris_scope with iris.
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
-
- (** Instances for a bunch of types (some don't even have Setoids) *)
- Instance state_type : Setoid C.state := _.
- Instance state_metr : metric C.state := discreteMetric.
- Instance state_cmetr : cmetric C.state := discreteCMetric.
-
- Instance nat_type : Setoid nat := discreteType.
- Instance nat_metr : metric nat := discreteMetric.
- Instance nat_cmetr : cmetric nat := discreteCMetric.
-
- Definition mask := DecEnsemble nat.
- Instance mask_type : Setoid mask := _.
- Instance mask_metr : metric mask := discreteMetric.
- Instance mask_cmetr : cmetric mask := discreteCMetric.
-
- Instance expr_type : Setoid expr := discreteType.
- Instance expr_metr : metric expr := discreteMetric.
- Instance expr_cmetr : cmetric expr := discreteCMetric.
-
- (* We use this type quite a bit, so give it and its instances names *)
- Definition vPred := value -n> Props.
- Instance vPred_type : Setoid vPred := _.
- Instance vPred_metr : metric vPred := _.
- Instance vPred_cmetr : cmetric vPred := _.
-
- (** The final thing we'd like to check is that the space of
- propositions does indeed form a complete BI algebra.
-
- The following instance declaration checks that an instance of
- the complete BI class can be found for Props (and binds it with
- a low priority to potentially speed up the proof search).
- *)
- (* RJ: For some reason, these terms do not (all) use the Wld_op, Wld_RA, ... instances.
- I have no idea, why. *)
- Instance Props_valid : validBI Props | 0 := _.
- Instance Props_top : topBI Props | 0 := _.
- Instance Props_bot : botBI Props | 0 := _.
- Instance Props_and : andBI Props | 0 := _.
- Instance Props_or : orBI Props | 0 := _.
- Instance Props_impl : implBI Props | 0 := _.
- Instance Props_sc : scBI Props | 0 := _.
- Instance Props_si : siBI Props | 0 := _.
- Instance Props_eq : eqBI Props | 0 := _.
- Instance Props_all : allBI Props | 0 := _.
- Instance Props_xist : xistBI Props | 0 := _.
- Instance Props_Lattice : Lattice Props | 0 := _.
- Instance Props_CBI : ComplBI Props | 0 := _.
- Instance Props_Eq : EqBI Props | 0 := _.
-
- Implicit Types (P Q : Props) (w : Wld) (n i k : nat) (r : res) (g : RL.res) (σ : state).
-
- (* Helpful when dealing with Iris propositions *)
- Definition Invs (w: Wld) := Mfst w.
- Arguments Invs w /.
- Definition State (w: Wld) := Mfst (Msnd w).
- Arguments State w /.
- Definition Res (w: Wld) := Msnd (Msnd w).
- Arguments Res w /.
-
- (* This probably doesn't reduce in helpful ways. But re-defining the entire thing here is too annoying. *)
- Definition pconst (p: Prop): Props := pcmconst(sp_const p).
-
- (* Simple view lemmas. *)
-
- Section Views.
- Lemma lelt {n k} (H : k < n) : k <= n.
- Proof. by omega. Qed.
-
- Lemma lt0 (n : nat) : ~ n < 0. Proof. by omega. Qed.
-
- Lemma propsMW {P w n w'} (HSw : w ⊑ w') : P w n -> P w' n.
- Proof. exact: (mu_mono P HSw). Qed.
-
- Lemma propsMN {P w n n'} (HLe : n' <= n) : P w n -> P w n'.
- Proof. apply: dpred HLe. Qed.
-
- Lemma propsM {P w n w' n' } (HSw : w ⊑ w') (HLe : n' <= n) :
- P w n -> P w' n'.
- Proof.
- move=> HP. eapply propsMW, propsMN, HP; assumption.
- Qed.
-
- Lemma biimpL {P Q : Props} {w n} : (P ↔ Q) w n -> (P → Q) w n.
- Proof. by move=>[L _]. Qed.
-
- Lemma biimpR {P Q : Props} {w n} : (P ↔ Q) w n -> (Q → P) w n.
- Proof. by move=>[_ R]. Qed.
-
- Lemma applyImpl {P Q: Props} {w n w' n'} (HImpl: (P → Q) w n) (HSw : w ⊑ w') (HLe : n' <= n):
- P w' n' -> Q w' n'.
- Proof.
- move=>HP. destruct HSw as [wF EQw]. rewrite <-EQw. rewrite comm. eapply HImpl; first assumption.
- simpl morph. by rewrite comm EQw.
- Qed.
-
- Lemma propsNE {P : Props} {w1 w2 n} (EQw : w1 = n = w2) :
- P w1 n -> P w2 n.
- Proof.
- apply spredNE. by rewrite EQw.
- Qed.
-
- Lemma pure_to_ctx (P: Prop) (Q R: Props):
- (P -> Q ⊑ R) -> pconst P ∧ Q ⊑ R.
- Proof.
- intros H.
- intros w n [p q]. destruct n; first exact:bpred.
- apply H; assumption.
- Qed.
-
- Lemma ctx_to_pure (P: Prop) (Q R: Props):
- pconst P ∧ Q ⊑ R -> (P -> Q ⊑ R).
- Proof.
- intros H.
- intros p w n q. destruct n; first exact:bpred.
- apply H. split; assumption.
- Qed.
-
-
- End Views.
-
- Section SimplProper.
-
- Lemma dist_props_simpl U (R : relation U) (f : U -> Props) n {RS : Symmetric R}
- (HP : forall u1 u2 w m, m <= n -> R u1 u2 -> f u1 w m -> f u2 w m) :
- Proper (R ==> dist n) f.
- Proof.
- intros u1 u2 HRu m; split; intros HF;
- eapply HP; eassumption || symmetry; eassumption.
- Qed.
-
- Lemma dist_props_simpl2 U V (RU : relation U) (RV : relation V)
- (f : U -> V -> Props) n {RS : Symmetric RU} {VS : Symmetric RV}
- (HP : forall u1 u2 v1 v2 w m, m <= n -> RU u1 u2 -> RV v1 v2 -> f u1 v1 w m -> f u2 v2 w m) :
- Proper (RU ==> RV ==> dist n) f.
- Proof.
- intros u1 u2 HRu v1 v2 HRv m; split; intros HF;
- eapply HP; eassumption || symmetry; eassumption.
- Qed.
-
- End SimplProper.
-
- Section Resources.
-
- Lemma state_sep {σ g rf} (Hv : ↓(ex_own σ, g) · rf) : fst rf == 1 (ex_own σ).
- Proof. move: (ra_sep_prod Hv) => [Hs _]. by rewrite (ra_sep_ex Hs). Qed.
-
- Lemma state_fps {σ g σ' rf} (Hv : ↓(ex_own σ, g) · rf) : ↓(ex_own σ', g) · rf.
- Proof. exact: (ra_fps_fst (ra_fps_ex σ σ') rf). Qed.
-
- End Resources.
-
- Section FinmapInvs.
- Lemma finmap_invs_unit (I: nat -f> ra_agree PreProp):
- 1 I == I.
- Proof.
- move=>i. rewrite /= /fdMap_pre. destruct (I i); last reflexivity.
- reflexivity.
- Qed.
-
- Lemma world_invs_valid w1 w2 μ i n:
- cmra_valid w1 n -> w2 ⊑ w1 -> Invs w2 i = n = Some μ -> cmra_valid μ n.
- Proof.
- move=>Hval Hle Heq. destruct w1 as [I1 [S1 g1]], w2 as [I2 [S2 g2]]. destruct Hval as [Hval _]. simpl in Heq. apply ra_pord_iff_prod_pord in Hle.
- destruct Hle as [Hle _]. simpl in Hle.
- apply ra_pord_iff_ext_pord in Hle.
- clear S1 g1 S2 g2. specialize (Hval i). specialize (Hle i).
- destruct n; first exact:bpred.
- destruct (I2 i); last contradiction Heq.
- destruct (I1 i); last contradiction Hle. simpl in Hle.
- simpl in Heq. eapply spredNE.
- - rewrite -Heq. reflexivity.
- - eapply cmra_valid_ord; eassumption.
- Qed.
-
- Lemma world_invs_extract w1 w2 μ μ' i n:
- cmra_valid w1 n -> w2 ⊑ w1 -> Invs w2 i = n = Some (μ' · μ) ->
- Invs w1 i = n = Some μ.
- Proof.
- move=> Hval [w' Hleq] Hlu. unfold Invs. rewrite -Hleq.
- simpl morph. rewrite {1}/ra_op /ra_op_finprod fdComposeRed.
- destruct n; first exact:dist_bound.
- rewrite /Invs /= in Hlu. destruct (fst w2 i) as [μ2|] eqn:Hw2; last contradiction Hlu.
- destruct (fst w' i) as [μ1|] eqn:Hw1; simpl in *.
- - rewrite Hlu assoc (comm _ μ). apply ra_ag_prod_dist. eapply world_invs_valid; first eexact Hval; first reflexivity.
- rewrite -Hleq. rewrite /Invs. simpl morph. instantiate (1:=i).
- rewrite {1}/ra_op /ra_op_finprod fdComposeRed. rewrite Hw2 Hw1. rewrite /finprod_op.
- apply option_dist_Some.
- now rewrite Hlu (comm μ) assoc.
- - rewrite Hlu comm. apply ra_ag_prod_dist. eapply world_invs_valid; first eexact Hval; first reflexivity.
- rewrite -Hleq. rewrite /Invs. simpl morph. instantiate (1:=i).
- rewrite {1}/ra_op /ra_op_finprod fdComposeRed. rewrite Hw2 Hw1. simpl.
- now rewrite comm.
- Qed.
- End FinmapInvs.
-
- (** And now we're ready to build the IRIS-specific connectives! *)
-
- Section Later.
- (** Note: this could be moved to BI, since it's possible to define
- more generally. However, we should first figure out a concise
- set of axioms. **)
- Program Definition later: Props -> Props :=
- fun P => m[(fun w => later_sp (P w))].
- Next Obligation.
- move=>w1 w2 EQw. simpl. eapply later_sp_dist. rewrite EQw. reflexivity.
- Qed.
- Next Obligation.
- move=>w1 w2 Hw n H. destruct n as [|n]; first exact I.
- simpl. rewrite <-Hw. exact H.
- Qed.
-
- Global Instance later_contractive: contractive later.
- Proof.
- move=>n P Q EQ w. rewrite/later. simpl morph. eapply contr.
- rewrite EQ. reflexivity.
- Qed.
-
- Global Instance later_dist n : Proper (dist n ==> dist n) later.
- Proof.
- pose (lf := contractive_nonexp later _).
- move=> ? ? ?.
- by apply: (met_morph_nonexp lf).
- Qed.
-
- Global Instance later_equiv : Proper (equiv ==> equiv) later.
- Proof.
- eapply dist_equiv; now apply _.
- Qed.
-
- Global Instance later_pord: Proper (pord ++> pord) later.
- Proof.
- move=>P Q HPQ w n HP. destruct n; first done. simpl in *. by apply HPQ.
- Qed.
- End Later.
- Notation " â–¹ p " := (later p) (at level 35) : iris_scope.
-
-
- Section LaterProps.
- Lemma later_mon P: P ⊑ ▹P.
- Proof.
- move=>w n H. simpl morph.
- destruct n as [|n]; first exact I.
- simpl. eapply dpred; last eassumption. omega.
- Qed.
-
- Lemma loeb P (HL: later P ⊑ P): valid P.
- intros w n. induction n.
- - eapply HL. exact I.
- - eapply HL. exact IHn.
- Qed.
-
- Lemma later_impl P Q:
- ▹(P → Q) == ▹P → ▹Q.
- Proof.
- intros w n. split; (destruct n; first (intro; exact:bpred)); intro H.
- - simpl in H. move=>wf /= m Hle HP.
- destruct m; first exact I. apply H; assumption || omega.
- - move=>wf /= m Hle HP. apply (H wf (S m)); assumption || omega.
- Qed.
-
- Lemma later_wand P Q:
- â–¹(P -* Q) == â–¹P -* â–¹Q.
- Proof.
- intros w n. split; (destruct n; first (intro; exact:bpred)); intro H.
- - simpl in H. move=>wf /= m Hle HP.
- destruct m; first exact I. apply H; assumption || omega.
- - move=>wf /= m Hle HP. apply (H wf (S m)); assumption || omega.
- Qed.
-
- Lemma later_top P:
- ▹⊤ == ⊤.
- Proof.
- intros w [|n]; split; simpl; tauto.
- Qed.
-
- Lemma later_disj P Q :
- ▹(P ∨ Q) == ▹P ∨ ▹Q.
- Proof.
- intros w [|n]; split; simpl; tauto.
- Qed.
-
- Lemma later_conj P Q :
- ▹(P ∧ Q) == ▹P ∧ ▹Q.
- Proof.
- intros w [|n]; split; simpl; tauto.
- Qed.
-
- Lemma later_star P Q:
- â–¹(P * Q) == â–¹P * â–¹Q.
- Proof.
- intros w n; split; (destruct n; first tauto).
- - destruct n.
- { move=>_. exists (1 w, w). simpl.
- split; last (split; exact:bpred).
- now rewrite ra_op_unit. }
- move=>[[w1 w2] [/= Heq [HP HQ]]].
- edestruct Wld_CMRAExt as [w'1 [w'2 [Heq' [Hdist1 Hdist2]]]]; first eexact Heq; first reflexivity.
- exists (w'1, w'2). split; first now rewrite Heq'. simpl in *.
- split; (eapply propsNE; last eassumption); assumption.
- - move=>[[w1 w2] [Heq [HP HQ]]]. destruct n; first exact I.
- exists (w1, w2). simpl in *. split; last tauto.
- now apply dist_mono.
- Qed.
-
- Lemma strong_loeb P: (▹P → P) ⊑ P.
- Proof.
- transitivity (⊤ ∧ (▹P → P)).
- { apply and_R; split; last reflexivity. apply top_true. }
- apply and_impl. apply top_valid. apply loeb. apply and_impl.
- eapply modus_ponens; last by apply and_projR.
- rewrite later_impl. eapply modus_ponens; last by eapply and_projL.
- rewrite->and_projR. apply later_mon.
- Qed.
-
- Section LaterQuant.
- Context {T} `{cT : cmetric T}.
- Context (φ : T -n> Props).
-
- Lemma later_all : ▹all φ == all (n[(later)] <M< φ).
- Proof.
- intros w n; split; intros H; (destruct n; first exact:bpred); intros t; simpl in *; apply H.
- Qed.
-
- Lemma xist_later : xist (n[(later)] <M< φ) ⊑ ▹xist φ. (* The other direction does not hold for empty T. *)
- Proof.
- intros w n H. do 2 (destruct n; first done). exact H.
- Qed.
-
- Lemma later_xist (HI: inhabited T):
- ▹xist φ ⊑ xist (n[(later)] <M< φ).
- Proof.
- move=>w n /= H. destruct n; first done.
- destruct n.
- - destruct HI as [t]. exists t. simpl. exact:bpred.
- - destruct H as [t H]. by exists t.
- Qed.
-
- End LaterQuant.
-
-
- End LaterProps.
-
- Section Necessitation.
- (** Note: this could be moved to BI, since it's possible to define
- more generally. However, we should first figure out a concise
- set of axioms. **)
-
-(* Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances. *)
-
- Program Definition box : Props -> Props :=
- fun P => m[(fun w => p[(fun n => P (1 w) n)] )].
- Next Obligation.
- exact: bpred.
- Qed.
- Next Obligation.
- intros n m HLe. by apply propsMN.
- Qed.
- Next Obligation.
- intros w1 w2 EQw m HLt.
- have/(met_morph_nonexp P) H : 1 w1 = n = 1 w2 by apply cmra_unit_dist.
- by apply H.
- Qed.
- Next Obligation.
- intros w1 w2 HSub.
- have/(propsMW (P := P)) : 1 w1 ⊑ 1 w2.
- { destruct HSub as [wr HSub].
- rewrite -HSub.
- rewrite comm.
- destruct (ra_unit_mono w1 wr) as [wm Hm].
- rewrite Hm. exists wm. rewrite comm. reflexivity.
- }
- tauto.
- Qed.
-
- Global Instance box_dist n: Proper (dist n ==> dist n) box.
- Proof.
- intros p1 p2 EQp w m HLt.
- by apply EQp.
- Qed.
-
- Global Instance box_equiv : Proper (equiv ==> equiv) box.
- Proof.
- eapply dist_equiv; now apply _.
- Qed.
-
- End Necessitation.
-
- Notation "â–¡ P" := (box P) (at level 35, right associativity) : iris_scope.
-
- (** Lemmas about box **)
- Section NecessitationProps.
- Lemma box_intro P Q (Hpr : □P ⊑ Q) :
- □P ⊑ □Q.
- Proof.
- intros w n HP. apply Hpr.
- by rewrite /box/= ra_unit_idem.
- Qed.
-
- Lemma box_elim P :
- □P ⊑ P.
- Proof.
- move=>w n. rewrite /box/=. apply propsMW.
- exists w. now rewrite comm ra_op_unit.
- Qed.
-
- Lemma box_top : □⊤ == ⊤.
- Proof.
- now auto.
- Qed.
-
- Lemma box_disj P Q :
- □(P ∨ Q) == □P ∨ □Q.
- Proof.
- intros w n.
- split; intros [|]; by [left|right].
- Qed.
-
- Lemma box_conj P Q :
- □(P ∧ Q) == □P ∧ □Q.
- Proof.
- intros w n.
- split; tauto.
- Qed.
-
- Lemma box_star P Q :
- â–¡(P * Q) == â–¡P * â–¡Q.
- Proof.
- intros w n. split; (destruct n; first (intro; exact:bpred)); intros [[wP wQ] [Heq [HP HQ]]].
- - rewrite (lock (1 w)) /= -lock in Heq.
- exists (1 w, w). simpl; split_conjs; simpl.
- + now rewrite ra_op_unit.
- + rewrite ra_unit_idem. eapply propsNE; first eexact Heq.
- eapply propsMW, HP. eexists; now erewrite comm.
- + eapply propsNE; first eexact Heq.
- eapply propsMW, HQ. simpl. eexists; now erewrite comm.
- - simpl in Heq. exists (1 w, 1 w). rewrite (lock (1w)) /= -lock; split_conjs.
- + rewrite /fst /snd. rewrite -{1}(ra_unit_idem w). rewrite ra_op_unit. reflexivity.
- + simpl. eapply propsNE; first (eapply cmra_unit_dist; eexact Heq).
- eapply propsMW, HP. apply ra_unit_proper_pord. exists wQ; now rewrite comm.
- + simpl. eapply propsNE; first (eapply cmra_unit_dist; eexact Heq).
- eapply propsMW, HQ. apply ra_unit_proper_pord. exists wP; now rewrite comm.
- Qed.
-
- Lemma box_conj_star P Q :
- □P * Q == □P ∧ Q.
- Proof.
- apply pord_antisym; first by eapply sc_and.
- intros w n [HP HQ]. destruct n; first exact I. exists (1w, w).
- split; last split; simpl.
- - now rewrite ra_op_unit.
- - rewrite ra_unit_idem. assumption.
- - assumption.
- Qed.
-
- Lemma box_impl P Q:
- □(P → Q) ⊑ □P → □Q.
- (* The backwards direction does NOT hold: We can have □⊤ → own m
- without having □(⊤ → own m). *)
- Proof.
- apply and_impl. rewrite -box_conj. apply box_intro.
- rewrite ->box_elim. apply and_impl. reflexivity.
- Qed.
-
- Lemma box_wand P Q:
- □(P -* Q) ⊑ □P -* □Q.
- (* The backwards direction does NOT hold: We can have □⊤ -* own m
- without having □(⊤ -* own m). *)
- Proof.
- apply sc_si. rewrite -box_star. apply box_intro.
- rewrite ->box_elim. apply sc_si. reflexivity.
- Qed.
-
- Lemma box_impl_si P Q:
- □(P → Q) == □(P -* Q).
- Proof.
- apply pord_antisym.
- { apply box_intro. rewrite ->box_elim. apply impl_si. }
- apply box_intro. apply and_impl. rewrite <-box_conj_star.
- rewrite ->box_elim. apply sc_si. reflexivity.
- Qed.
-
- Lemma box_dup P :
- â–¡P == â–¡P * â–¡P.
- Proof.
- apply pord_antisym.
- - intros w n.
- intros HP. destruct n; first exact:bpred.
- exists (w, 1 w).
- split; last by simpl; rewrite !ra_unit_idem. simpl morph.
- do 3 red.
- now rewrite (ra_op_unit2).
- - by apply sc_projL.
- Qed.
-
- Lemma box_box P :
- â–¡ â–¡ P == â–¡ P.
- Proof.
- apply pord_antisym.
- - exact: box_elim.
- - apply box_intro. reflexivity.
- Qed.
-
- Lemma box_later P:
- (▹□P) == □▹P.
- Proof.
- move=>w n; split; intros H; exact H.
- Qed.
-
- Section BoxQuant.
- Context {T} `{cT : cmetric T}.
-
- Lemma box_eq (t1 t2: T):
- t1 === t2 == â–¡(t1 === t2).
- Proof.
- apply pord_antisym; last exact:box_elim.
- move=>w n H. exact H.
- Qed.
-
- Context (φ : T -n> Props).
-
- Lemma box_all : □all φ == all (n[(box)] <M< φ).
- Proof. done. Qed.
-
- Lemma box_xist : □xist φ == xist (n[(box)] <M< φ).
- Proof. done. Qed.
-
- End BoxQuant.
- End NecessitationProps.
-
- Section IntEqProps.
-
- (* On Props, valid biimplication, valid internal equality, and external equality coincide. *)
-
-
- Remark valid_biimp_intEq {P Q} : valid(P ↔ Q) -> valid(P === Q).
- Proof.
- move=> H _ nz wz n HLt.
- move/(_ wz n): H => [Hpq Hqp]. split.
- - move/(_ (1 wz) n _) : Hpq => Hpq. by rewrite -(ra_op_unit2 (t:=wz)).
- - move/(_ (1 wz) n _) : Hqp => Hqp. by rewrite -(ra_op_unit2 (t:=wz)).
- Qed.
-
- Remark valid_intEq_equiv {P Q} : valid(P === Q) -> P == Q.
- Proof. move=> H w n; exact: H. Qed.
-
- Remark valid_equiv_biimp {P Q} : P == Q -> valid(P ↔ Q).
- Proof.
- move=> H wz nz; split; move=> w HSw n HLe.
- - by rewrite -(H (wz · w)).
- - by rewrite (H (wz · w)).
- Qed.
-
- (* Internal equality implies biimplication, but not vice versa. *)
-
- Remark biimp_equiv {P Q}: P === Q ⊑ (P ↔ Q).
- Proof.
- have HLt n n' : n' <= n -> n' < S n by omega.
- move=> w n H. destruct n; first exact:bpred.
- split;
- move=> w' n' HLt' HP;
- move/(_ (w · w') n' _): H => [Hpq Hqp];
- [exact: Hpq | exact: Hqp].
- Qed.
-
- (* Note that (P ↔ Q) ⊑ (P === Q) does NOT hold: The first says
- that the equivalence holds in all future worlds, the second says
- it holds in *all* worlds. *)
-
- End IntEqProps.
-
- Section Timeless.
-
- Definition timelessP P w n :=
- forall w' k (HLt : (S k) < n) (Hp : P w' (S k)), P w' (S (S k)).
-
- Program Definition timeless P : Props :=
- m[(fun w => p[(fun n => timelessP P w n)] )].
- Next Obligation.
- move=>? ? ? ?. exfalso. omega.
- Qed.
- Next Obligation.
- intros n1 n2 HLe HP w' k HLt. eapply HP.
- omega.
- Qed.
- Next Obligation.
- intros w1 w2 EQw k; simpl. intros HLt.
- split; intros HT w' m HLt' Hp.
- - eapply HT; done.
- - eapply HT; done.
- Qed.
- Next Obligation.
- intros w1 w2 Hsub n; simpl; intros HT w' m HLt Hp.
- eapply HT, Hp; done.
- Qed.
-
- Global Instance timeless_dist n:
- Proper (dist n ==> dist n) timeless.
- Proof.
- apply dist_props_simpl; first apply _.
- move=>P1 P2 w m Hle Heq HT; repeat intro.
- eapply spredNE, HT; try eassumption; [|].
- - eapply mmorph_proper; last reflexivity. eapply mono_dist, Heq. omega.
- - eapply spredNE, Hp. eapply mmorph_proper; last reflexivity.
- symmetry. eapply mono_dist, Heq. omega.
- Qed.
-
- Lemma timeless_boxed P:
- timeless P == â–¡timeless P.
- Proof.
- apply pord_antisym; last exact:box_elim.
- move=>w n H. exact H.
- Qed.
-
- Lemma timeless_conj P Q:
- timeless P ∧ timeless Q ⊑ timeless (P ∧ Q).
- Proof.
- move=>w n [HTP HTQ] /=. repeat intro. split.
- - eapply HTP, Hp; done.
- - eapply HTQ, Hp; done.
- Qed.
-
- Lemma timeless_disj P Q:
- timeless P ∧ timeless Q ⊑ timeless (P ∨ Q).
- Proof.
- move=>w n [HTP HTQ] /=. repeat intro. destruct Hp.
- - left. eapply HTP; done.
- - right. eapply HTQ; done.
- Qed.
-
- Lemma timeless_star P Q:
- timeless P ∧ timeless Q ⊑ timeless (P * Q).
- Proof.
- move=>w n [HTP HTQ] /=. repeat intro. destruct Hp as [[w1 w2] [Heq [HP HQ]]]. simpl in *.
- edestruct Wld_CMRAExt as [w'1 [w'2 [Heq' [Hdist1 Hdist2]]]]; first eexact Heq; first reflexivity.
- exists (w'1, w'2). simpl in *. split_conjs.
- - now rewrite Heq'.
- - eapply HTP; first done. eapply spredNE, HP.
- eapply met_morph_nonexp, Hdist1.
- - eapply HTQ; first done. eapply spredNE, HQ.
- eapply met_morph_nonexp, Hdist2.
- Qed.
-
- Lemma timeless_box P:
- timeless P ⊑ timeless(□P).
- Proof.
- intros w n HTP. repeat intro.
- simpl. eapply HTP; done.
- Qed.
-
- Lemma timeless_impl P Q:
- timeless Q ⊑ timeless (P → Q).
- Proof.
- move=>w n HTQ /= w' k Ltk HPQ w'' [|[|m]] Lem HP; first exact: bpred.
- { apply HPQ, HP. omega. }
- eapply HTQ, HPQ; [omega|omega|].
- eapply dpred, HP. omega.
- Qed.
-
- Lemma timeless_si P Q:
- timeless Q ⊑ timeless (P -* Q).
- Proof.
- move=>w n HTQ /= w' k Ltk HPQ w'' [|[|m]] Lem HP; first exact: bpred.
- { apply HPQ, HP. omega. }
- eapply HTQ, HPQ; [omega|omega|].
- eapply dpred, HP. omega.
- Qed.
-
- Section TimelessQuant.
- Context {T} `{cT : cmetric T}.
- Context (φ : T -n> Props).
-
- Lemma all_timeless :
- all (n[(timeless)] <M< φ) ⊑ timeless (all φ).
- Proof.
- move => w n HAT. simpl in *. repeat intro. simpl.
- eapply HAT; first done. apply Hp.
- Qed.
-
- Lemma xist_timeless :
- all (n[(timeless)] <M< φ) ⊑ timeless (xist φ).
- Proof.
- move => w n HAT. simpl in *. repeat intro. simpl.
- destruct Hp as [t Hφ]. exists t. eapply HAT; first done.
- exact Hφ.
- Qed.
- End TimelessQuant.
-
- End Timeless.
-
- Section IntEqTimeless.
- Context {T} `{cmT: Setoid T}.
- (* This only works for types with the discrete metric! *)
- Existing Instance discreteMetric.
- Existing Instance discreteCMetric.
-
- Lemma intEqTimeless (t1 t2: T):
- valid(timeless(intEq t1 t2)).
- Proof.
- intros w n. intros w' k HLt Hsq. simpl.
- tauto.
- Qed.
- End IntEqTimeless.
-
- Section Ownership.
-
- Local Obligation Tactic := idtac.
-
- (** General Ownership - used to show that the other assertions make sense **)
- Program Definition own: Wld -> Props :=
- fun w0 => m[(fun w => ∃ wr, (w0 · wr) === w )].
- Next Obligation.
- intros. move=>wr0 wr1 EQwr. apply intEq_dist; last reflexivity.
- apply cmra_op_dist; first reflexivity. assumption.
- Qed.
- Next Obligation.
- intros w0 n w1 w2 EQw k HLt.
- destruct k; first reflexivity.
- split; move => [wr Hwr];
- exists wr.
- - eapply spredNE, Hwr. simpl morph. eapply intEq_dist; first reflexivity. (* RJ: another instance of simpl going too far *)
- eapply mono_dist, EQw. assumption.
- - eapply spredNE, Hwr. simpl morph. eapply intEq_dist; first reflexivity.
- symmetry. eapply mono_dist, EQw. assumption.
- Qed.
- Next Obligation.
- intros w w1 w2 [wd Hequ] k. destruct k; first reflexivity.
- case=>wr. move/sp_eq_iff=>Heq. exists (wd · wr).
- apply sp_eq_iff. rewrite -Hequ. rewrite assoc (comm w) -assoc.
- apply cmra_op_dist; first reflexivity. assumption.
- Qed.
- Arguments own _ : simpl never.
-
- Global Instance own_dist n:
- Proper (dist n ==> dist n) own.
- Proof.
- move=>w0 w1 Heq w m HLt. destruct m; first reflexivity.
- split; case=>wd; move/sp_eq_iff=>Heqd; exists wd; apply sp_eq_iff; rewrite -Heqd;
- (apply cmra_op_dist; last reflexivity); eapply mono_dist; first eassumption; eassumption || symmetry; eassumption.
- Qed.
-
- Global Instance own_equiv : Proper (equiv ==> equiv) own.
- Proof.
- eapply dist_equiv; now apply _.
- Qed.
-
- Lemma own_sc (u v : Wld):
- own (u · v) == own u * own v.
- Proof.
- move => w n; destruct n; first (split; intro; exact:bpred). split; simpl.
- - move => [wr Hwr].
- exists (u, v · wr); split; last split.
- + split; now rewrite -Hwr -assoc.
- + exists (1u). now rewrite ra_op_unit2.
- + exists wr; reflexivity.
- - move : w => [wu wr] [[w1 w2] [Hw] [[w1r Hw1r] [w2r Hw2r]]].
- exists (w1r · w2r). rewrite -assoc (assoc v) (comm v) -assoc. rewrite -Hw. split.
- (* RJ: Simplification here is not nice... *)
- + rewrite [ra_op]lock /= -lock. simpl in Hw1r, Hw2r. rewrite -Hw1r -Hw2r.
- rewrite !assoc. reflexivity.
- + rewrite [ra_op]lock /=. simpl in Hw1r, Hw2r. rewrite -Hw1r -Hw2r.
- rewrite !assoc. split; reflexivity.
- Qed.
-
- Program Definition inv i : Props -> Props :=
- fun P => m[(fun w => ∃Pr, Invs w i === Some (Pr · (ra_ag_inj (ı' (halved P)))) )].
- Next Obligation.
- intros. move=>Pr1 Pr2 EQPr. apply intEq_dist; first reflexivity.
- apply option_dist_Some. apply ra_ag_op_dist; last reflexivity. assumption.
- Qed.
- Next Obligation.
- move=>i P n w1 w2 EQw. apply xist_dist=>Pr. simpl morph. apply intEq_dist; last reflexivity.
- now rewrite EQw.
- Qed.
- Next Obligation.
- move => i P w1 w2 [wd Hw] n. simpl morph. destruct n; first reflexivity.
- move=>[Pr HPr]. simpl morph in HPr. destruct w1 as [I1 R1], w2 as [I2 R2], wd as [Id Rd].
- destruct Hw as [EQI _]. simpl in *. clear R1 R2 Rd. specialize (EQI i).
- simpl in EQI. destruct (Id i) as [Pd|].
- - exists (Pd · Pr). change (I2 i = S n = (Some (Pd · Pr · ra_ag_inj (ı' (halved P))))).
- etransitivity; first (eapply dist_refl; symmetry; exact:EQI).
- destruct (I1 i) as [P1|]; last contradiction HPr.
- unfold finprod_op. do 3 red. rewrite -assoc. apply cmra_op_dist; first reflexivity.
- exact HPr.
- - exists Pr. change (I2 i = S n = (Some (Pr · ra_ag_inj (ı' (halved P))))).
- etransitivity; last eexact HPr. symmetry. apply dist_refl.
- destruct (I1 i) as [P1|]; last contradiction HPr.
- exact EQI.
- Qed.
-
- Global Instance inv_contractive i : contractive (inv i).
- Proof.
- move => n P1 P2 EQP w [|k /le_S_n Hk] //; split; move => [p /= EQwi]; simpl;
- exists p; rewrite EQwi {EQwi} /dist /option_metric /option_dist;
- rewrite (_ : ra_ag_inj _ = S k = ra_ag_inj _); [reflexivity| |reflexivity|];
- split; try reflexivity; move => [|m] Hm _; apply met_morph_nonexp => //;
- eapply (mono_dist _ _ _ (S _)); [|exact: EQP| |symmetry; exact EQP]; omega.
- Qed.
-
- Global Instance inv_dist i n: Proper (dist n ==> dist n) (inv i).
- Proof.
- pose (f' := contractive_nonexp _ (inv_contractive i)).
- move=>P1 P2 EQP. exact: (met_morph_nonexp f').
- Qed.
-
- Lemma inv_box i P:
- inv i P == â–¡inv i P.
- Proof.
- apply pord_antisym; last by apply:box_elim.
- intros [u r] n. destruct n; first (intro; exact:bpred).
- case=>Pr. move/sp_eq_iff=>Heq. exists Pr. apply sp_eq_iff.
- rewrite -Heq. unfold ra_unit, Wld_unit, ra_unit_prod, Invs, fst. now rewrite finmap_invs_unit.
- Qed.
-
- Program Definition inv_own i P: Props :=
- ∃ r, own (fdStrongUpdate i (Some (ra_ag_inj (ı' (halved P)))) fdEmpty, r).
- Next Obligation.
- intros. move=>r1 r2 EQr. apply (own_dist). split; first reflexivity.
- exact EQr.
- Qed.
-
- Lemma inv_iff i P:
- inv i P == inv_own i P.
- Proof.
- move=>w n. destruct n; first reflexivity. split.
- - case=>Pr /= Heq. exists (1 (snd w)). exists w.
- destruct w as [I R]. unfold ra_op, ra_op_prod. split; last first.
- { rewrite /= ra_op_unit. reflexivity. }
- simpl. move=>j. rewrite /ra_op /ra_op_finprod fdComposeRed.
- destruct (dec_eq i j).
- + subst j. rewrite fdStrongUpdate_eq. simpl in Heq.
- destruct (I i) as [Ii|]; last contradiction Heq.
- simpl in *.
- rewrite Heq=>{Heq}. apply dist_refl. rewrite assoc (comm _ Pr) -assoc.
- rewrite ra_ag_dupl. reflexivity.
- + erewrite fdStrongUpdate_neq by assumption. destruct (I j); reflexivity.
- - case=>r. case=>wf /= Heq. destruct w as [I R], wf as [If Rf].
- destruct Heq as [HeqI _]. simpl in HeqI. specialize (HeqI i).
- rewrite /ra_op /ra_op_finprod fdComposeRed fdStrongUpdate_eq in HeqI.
- destruct (If i) as [Ifi|].
- + exists Ifi. unfold Invs, fst. rewrite -HeqI /finprod_op.
- rewrite comm. reflexivity.
- + exists (1 (ra_ag_inj (ı' (halved P)))). unfold Invs, fst.
- rewrite -HeqI /finprod_op. rewrite ra_op_unit. reflexivity.
- Qed.
-
- (** Proper physical state: ownership of the machine state **)
- Program Definition ownS : state -> Props :=
- fun σ => m[(fun w => sp_const (ex_own σ ⊑ State w) )].
- Next Obligation.
- intros σ n w1 w2 EQw; destruct n as [| n]; [exact:dist_bound |].
- move=>m HLt. destruct m; first reflexivity. simpl.
- destruct w1 as [I1 [σ1 g1]], w2 as [I2 [σ2 g2]], EQw as [_ [EQσ _]]. simpl in EQσ.
- unfold State. simpl. rewrite EQσ. reflexivity.
- Qed.
- Next Obligation.
- move=>σ [I1 [σ1 g1]] [I2 [σ2 g2]] [[I3 [σ3 g3]] /= [_ [EQσ _]]] n.
- simpl. destruct n; first reflexivity. simpl=>Hle. rewrite <-EQσ, Hle.
- exists σ3. reflexivity.
- Qed.
-
- Global Instance ownS_dist n: Proper (dist n ==> dist n) ownS.
- Proof.
- move=>σ1 σ2 EQσ w. simpl morph. destruct n; first exact:dist_bound.
- hnf in EQσ. subst. reflexivity.
- Qed.
-
- Lemma ownS_timeless {σ} : valid(timeless(ownS σ)).
- Proof.
- unfold ownS. move=>w n w' k Hwle Hle. simpl. tauto.
- Qed.
-
- Program Definition own_state σ: Props :=
- ∃ I, ∃ g, own (I, (ex_own σ, g)).
- Next Obligation.
- intros. move=>g1 g2 EQg. cbv beta. apply own_dist.
- split; first reflexivity. split; first reflexivity.
- simpl. assumption.
- Qed.
- Next Obligation.
- intros. move=>I1 I2 EQI. cbv beta. apply xist_dist=>r.
- apply own_dist.
- split; last reflexivity. simpl. assumption.
- Qed.
-
- Lemma ownS_iff σ:
- ownS σ == own_state σ.
- Proof.
- move=>w n. destruct n; first reflexivity. split; simpl.
- - move=>[Sr Heq]. destruct w as [I [S g]]. exists (1 I) (1 g) (I, (Sr, g)).
- simpl. split; last split.
- + apply dist_refl. rewrite ra_op_unit. reflexivity.
- + rewrite comm. exact Heq.
- + apply dist_refl. rewrite ra_op_unit. reflexivity.
- - move=>[Id [rd [w' Heq]]]. destruct w as [I [S g]], w' as [I' [S' g']].
- simpl in *. exists S'. destruct Heq as [_ [Heq _]]. rewrite comm. exact Heq.
- Qed.
-
- (** Proper ghost state: ownership of logical **)
- Program Definition ownL : RL.res -> Props :=
- fun g => m[(fun w => sp_const (g ⊑ Res w) )].
- Next Obligation.
- intros r n w1 w2 EQw; destruct n as [| n]; [exact:dist_bound |].
- move=>m HLt. destruct m; first reflexivity. simpl.
- destruct w1 as [I1 [σ1 g1]], w2 as [I2 [σ2 g2]], EQw as [_ [_ EQg]]. simpl in EQg. simpl.
- rewrite EQg. reflexivity.
- Qed.
- Next Obligation.
- move=>r [I1 [σ1 g1]] [I2 [σ2 g2]] [[I3 [σ3 g3]] /= [_ [_ EQg]]] n.
- simpl. destruct n; first reflexivity. simpl=>Hle. rewrite <-EQg, Hle.
- exists g3. reflexivity.
- Qed.
-
- Global Instance ownL_dist n: Proper (dist n ==> dist n) ownL.
- Proof.
- move=>g1 g2 EQg w. simpl morph. destruct n; first exact:dist_bound.
- move=>m Hle. simpl. destruct m; first reflexivity. simpl.
- rewrite EQg. reflexivity.
- Qed.
-
- Lemma ownL_timeless {g} : valid(timeless(ownL g)).
- Proof.
- unfold ownL. move=>w n w' k Hwle Hle. simpl. tauto.
- Qed.
-
- Program Definition own_ghost g: Props :=
- ∃ I, ∃ S, own (I, (S, g)).
- Next Obligation.
- intros. move=>g1 g2 EQr. apply own_dist.
- split; first reflexivity. split; last reflexivity.
- simpl. assumption.
- Qed.
- Next Obligation.
- intros. move=>I1 I2 EQI. cbv beta. apply xist_dist=>S.
- apply own_dist.
- split; last reflexivity. simpl. assumption.
- Qed.
-
- Lemma ownL_iff g:
- ownL g == own_ghost g.
- Proof.
- move=>w n. destruct n; first reflexivity. split; simpl.
- - move=>[gr Heq]. destruct w as [I [S r]]. exists (1 I) (1 S) (I, (S, gr)).
- simpl. split; last split.
- + apply dist_refl. rewrite ra_op_unit. reflexivity.
- + apply dist_refl. rewrite ra_op_unit. reflexivity.
- + rewrite comm. exact Heq.
- - move=>[Id [rd [w' Heq]]]. destruct w as [I [S g0]], w' as [I' [S' g']].
- simpl in *. exists g'. destruct Heq as [_ [_ Heq]]. rewrite comm. exact Heq.
- Qed.
-
- Lemma ownL_sc (g1 g2 : RL.res) :
- ownL (g1 · g2) == ownL g1 * ownL g2.
- Proof.
- intros [I [S g]] n. destruct n; first (split; intro; exact:bpred). split; simpl.
- - move => [gd Heq]. exists ((I, (S, gd · g1)), (1 I, (1 S, g2))). simpl. split_conjs.
- + rewrite ra_op_unit2. reflexivity.
- + rewrite ra_op_unit2. reflexivity.
- + rewrite -assoc. apply dist_refl. assumption.
- + exists gd. reflexivity.
- + reflexivity.
- - move=>[[[I1 [S1 g'1]] [I2 [S2 g'2]]] /= [[_ [_ Heq]] [Hg1 Hg2]]].
- rewrite ->Hg1, Hg2. apply pordR. exact Heq.
- Qed.
-
- Lemma ownL_box (g: RL.res) :
- ownL (1 g) == â–¡ownL (1 g).
- Proof.
- apply pord_antisym; last exact:box_elim.
- move=>w n. destruct n; first (intro; exact:bpred).
- case=>[gr Heq]. simpl. destruct (ra_unit_mono (1 g) gr) as [g' Heq'].
- simpl in Heq. rewrite -Heq. exists g'.
- rewrite (comm gr) Heq' ra_unit_idem comm. reflexivity.
- Qed.
-
- Lemma ownL_something:
- valid(xist n[(ownL)]).
- Proof.
- move=>w n. destruct n; first exact:bpred. exists (Res w).
- simpl. reflexivity.
- Qed.
-
- End Ownership.
-
-End IRIS_CORE.
-
-Module IrisCore (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) : IRIS_CORE RL C R WP.
- Include IRIS_CORE RL C R WP.
-End IrisCore.
diff --git a/iris_derived_rules.v b/iris_derived_rules.v
deleted file mode 100644
index 9b6c8852ba77a569c2e98df4ba0b0082b77266d9..0000000000000000000000000000000000000000
--- a/iris_derived_rules.v
+++ /dev/null
@@ -1,375 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Import world_prop core_lang lang iris_core iris_plog iris_vs_rules iris_ht_rules.
-Require Import ModuRes.RA ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.CMRA ModuRes.DecEnsemble.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Module Type IRIS_DERIVED_RULES (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE) (VS_RULES: IRIS_VS_RULES RL C R WP CORE PLOG) (HT_RULES: IRIS_HT_RULES RL C R WP CORE PLOG).
- Export VS_RULES.
- Export HT_RULES.
-
- Local Open Scope ra_scope.
- Local Open Scope de_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
-
- (* These rules and their proofs should never talk about worlds or step-indices. *)
-
- Section DerivedVSRules.
-
- Implicit Types (P : Props) (i : nat) (m : DecEnsemble nat) (e : expr) (r : res) (l: RL.res).
-
- Lemma pvsImpl P Q m1 m2 :
- □ (P → Q) ∧ pvs m1 m2 P ⊑ pvs m1 m2 Q.
- Proof.
- rewrite -box_conj_star comm. rewrite ->pvsFrameRes. eapply pvsMon.
- rewrite comm box_conj_star. apply and_impl, box_elim.
- Qed.
-
- Lemma pvsWeakenMask P m m' (HIncl: m ⊑ m'):
- pvs m m P ⊑ pvs m' m' P.
- Proof.
- etransitivity; first eapply pvsFrameMask with (mf := m' \ m); first by de_auto_eq.
- apply pordR. eapply pvs_mproper; de_auto_eq.
- Qed.
-
- Lemma vsFalse m1 m2 :
- valid (vs m1 m2 ⊥ ⊥).
- Proof.
- apply vsValid. apply bot_false.
- Qed.
-
- Lemma vsOwnValid m l:
- valid (vs m m (ownL l) (ownL l ∧ pcmconst (sp_const (↓l)))).
- Proof.
- apply vsValid. etransitivity.
- { rewrite ownL_iff /own_ghost. reflexivity. }
- apply xist_L=>I. apply xist_L=>S. rewrite {1}/met_morph /mkNMorph {1}/morph.
- etransitivity; first by eapply pvsOwnValid.
- eapply pvsMon. apply and_pord.
- - rewrite ownL_iff. apply (xist_R I). apply (xist_R S). reflexivity.
- - (* We now prove this in the model. It does not really warrant it's own metatheory... *)
- move=>w n. destruct n; first (intro; exact:bpred). simpl. tauto.
- Qed.
-
- Lemma vsOwnSTwice m σ1 σ2:
- valid (vs m m (ownS σ1 * ownS σ2) ⊥).
- Proof.
- apply vsValid. etransitivity.
- { rewrite !ownS_iff /own_state. reflexivity. }
- etransitivity; first apply xist_sc. apply xist_L=>I1. simpl.
- etransitivity; first apply xist_sc. apply xist_L=>g1. simpl.
- etransitivity; first apply xist_sc_r. apply xist_L=>I2. simpl.
- etransitivity; first apply xist_sc_r. apply xist_L=>g2. simpl.
- rewrite /const. rewrite- own_sc. etransitivity; first eapply pvsOwnValid.
- eapply pvsMon. rewrite ->and_projR.
- (* We now prove this in the model. It does not really warrant it's own metatheory... *)
- move=>w n [_ [HSval _]]. destruct n; first exact:bpred.
- destruct HSval.
- Qed.
-
- Lemma vsTimeless m P : (* TODO RJ: the box is missing in the appendix? timeless will become a modality anyway. *)
- □(timeless P) ⊑ vs m m (▹P) P.
- Proof.
- apply vsIntro. etransitivity; last by eapply pvsTimeless.
- rewrite ->box_elim. reflexivity.
- Qed.
-
- Lemma vsTrans P Q R m1 m2 m3 (HMS : m2 ⊑ m1 ∪ m3) :
- vs m1 m2 P Q ∧ vs m2 m3 Q R ⊑ vs m1 m3 P R.
- Proof.
- rewrite {1 2}/vs -box_conj. apply vsIntro.
- etransitivity; last by eapply pvsTrans.
- etransitivity; last by eapply pvsImpl. apply and_R; split.
- - rewrite ->and_projL, box_conj. apply and_projR.
- - eapply modus_ponens; last first.
- + rewrite ->and_projL, box_conj, ->and_projL.
- now apply box_elim.
- + now apply and_projR.
- Qed.
-
- Lemma vsEnt P Q m :
- □(P → Q) ⊑ vs m m P Q.
- Proof.
- apply vsIntro.
- etransitivity; last by eapply pvsEnt.
- apply and_impl, box_elim.
- Qed.
-
- Lemma vsGhostUpd m rl (P : RL.res -> Prop) (HU : rl â‡âˆˆ P) :
- valid (vs m m (ownL rl) (xist (ownLP P))).
- Proof.
- apply vsValid.
- eapply pvsGhostUpd; assumption.
- Qed.
-
- Lemma pvsGhostStep m (rl rl': RL.res) (HU : rl ⇠rl') :
- ownL rl ⊑ pvs m m (ownL rl').
- Proof.
- etransitivity.
- - pose(P:= fun r:RL.res => r = rl').
- eapply pvsGhostUpd with (P:=P).
- clear -HU. move=>rf Hval. exists rl'.
- split; first reflexivity.
- by eapply HU.
- - eapply pvsMon. apply xist_L=>s. case:s=>[s Heq]. subst s.
- rewrite /ownLP. simpl. reflexivity.
- Qed.
-
- Lemma vsGhostStep m (rl rl': RL.res) (HU : rl ⇠rl') :
- valid (vs m m (ownL rl) (ownL rl')).
- Proof.
- apply vsValid.
- eapply pvsGhostStep; assumption.
- Qed.
-
- Lemma vsOpen i m P :
- i ∈ m = false ->
- valid (vs (de_sing i ∪ m) m (inv i P) (▹P)).
- Proof.
- intros Hm.
- apply vsValid. etransitivity; first by apply pvsOpen.
- etransitivity; last eapply pordR.
- - eapply pvsFrameMask with (mf:=m). move=>j. de_tauto.
- - eapply pvs_mproper; move=>j; de_tauto.
- Qed.
-
- Lemma vsClose i m P :
- i ∈ m = false ->
- valid (vs m (de_sing i ∪ m) (inv i P ∧ ▹P) ⊤).
- Proof.
- intros Hm. apply vsValid.
- etransitivity; first by apply pvsClose.
- etransitivity; last eapply pordR.
- - eapply pvsFrameMask with (mf:=m). move=>j. de_tauto.
- - eapply pvs_mproper; move=>j; de_tauto.
- Qed.
-
- Lemma vsNewInv P m (HInf : de_infinite m) :
- valid (vs m m (â–¹P) (xist (inv' m P))).
- Proof.
- apply vsValid. eapply pvsNewInv. assumption.
- Qed.
-
- Lemma vsFrame m1 m2 mf P Q R:
- mf # m1 ∪ m2 ->
- vs m1 m2 P Q ⊑ vs (m1 ∪ mf) (m2 ∪ mf) (P * R) (Q * R).
- Proof.
- move=>H. rewrite {1}/vs. apply vsIntro.
- etransitivity; last by eapply pvsFrameRes.
- etransitivity; last first.
- { eapply sc_pord; last reflexivity. eapply pvsFrameMask. assumption. }
- rewrite -box_conj_star assoc. apply sc_pord; last reflexivity.
- rewrite box_conj_star. apply and_impl, box_elim.
- Qed.
-
- End DerivedVSRules.
-
- Section DerivedHTRules.
-
- Implicit Types (P : Props) (i : nat) (m : DecEnsemble nat) (e : expr) (r : res) (φ Q : vPred) (w : Wld) (n k : nat).
-
- Lemma wpImpl safe m e φ φ':
- (□all (lift_bin BI.impl φ φ')) ∧ wp safe m e φ ⊑ wp safe m e φ'.
- Proof.
- rewrite -box_conj_star comm. rewrite ->wpFrameRes. eapply wpMon.
- move=>v. rewrite /lift_bin [box]lock /= /const /= -lock.
- rewrite comm box_conj_star.
- eapply modus_ponens; first by apply and_projR.
- etransitivity; first by apply and_projL.
- etransitivity; first by apply box_elim.
- apply (all_L v). reflexivity.
- Qed.
-
- Lemma wpFrameMask safe m1 m2 e φ (*HD : m1 # m2*) :
- wp safe m1 e φ ⊑ wp safe (m1 ∪ m2) e φ.
- Proof.
- eapply wpWeakenMask. de_auto_eq.
- Qed.
-
- Lemma htRet e (HV : is_value e) safe m :
- valid (ht safe m ⊤ e (eqV (exist _ e HV))).
- Proof.
- apply htValid. etransitivity; last eapply wpMon.
- - apply top_valid. eapply wpRet.
- - intros v. eapply pvsEnt.
- Qed.
-
- (** Much like in the case of the plugging, we need to show that
- the map from a value to a view shift between the applied
- postconditions is nonexpansive *)
- Program Definition vsLift m1 m2 (φ φ' : vPred) :=
- n[(fun v => vs m1 m2 (φ v) (φ' v))].
- Next Obligation.
- intros v1 v2 EQv; unfold vs.
- rewrite ->EQv; reflexivity.
- Qed.
-
- Program Definition pvsLift m1 m2 (φ φ' : vPred) :=
- n[(fun v => φ v → pvs m1 m2 (φ' v))].
- Next Obligation.
- intros v1 v2 EQv. apply impl_dist; first now rewrite EQv.
- apply (met_morph_nonexp (pvs m1 m2)). now rewrite EQv.
- Qed.
-
- Lemma pvsWpCompose {safe m m' P e φ}:
- pvs m m' P ∧ ht safe m' P e φ ⊑ pvs m m' (wp safe m' e (pvs m' m' <M< φ)).
- Proof.
- rewrite /ht comm. etransitivity; first by apply pvsImpl.
- apply pvsMon. reflexivity.
- Qed.
-
- Lemma vsLiftBox m' m φ φ':
- □all (pvsLift m' m φ φ') == all (vsLift m' m φ φ').
- Proof.
- etransitivity; first by eapply (box_all (pvsLift m' m φ φ')).
- apply all_equiv=>v. reflexivity.
- Qed.
-
- Lemma wpPvsCompose {safe m m' e φ φ'}:
- wp safe m' e φ ∧ all (vsLift m' m φ φ') ⊑ wp safe m' e (pvs m' m <M< φ').
- Proof.
- rewrite -vsLiftBox /vs.
- rewrite comm. etransitivity; last by apply wpImpl.
- eapply and_pord; last reflexivity. apply pordR.
- apply box_equiv. apply all_equiv=>v. reflexivity.
- Qed.
-
- Lemma wpPreVS' m safe e φ:
- pvs m m (wp safe m e (pvs m m <M< φ)) ⊑ wp safe m e (pvs m m <M< φ).
- Proof.
- etransitivity; first eapply wpPreVS. eapply wpMon=>v. simpl morph. eapply pvsTrans.
- de_auto_eq.
- Qed.
-
- (* pvs before and after the hoare triple can be collapsed into it *)
- Lemma htMCons m m' safe e P P' Q Q':
- □((P → (pvs m m') P')
- ∧ (P' → (((wp safe) m') e) (pvs m' m' <M< Q')) ∧ all (pvsLift m' m Q' Q))
- ∧ P ⊑ (pvs m m') ((((wp safe) m') e) (pvs m' m <M< Q)).
- Proof. (* Stupid Coq makes me write out these things... *)
- transitivity ((pvs m m') P' ∧ □((P' → (((wp safe) m') e) (pvs m' m' <M< Q')) ∧ all (pvsLift m' m Q' Q))).
- - apply and_R; split.
- + apply and_impl. rewrite ->box_elim. apply and_projL.
- + rewrite ->and_projL. apply box_intro. rewrite ->box_elim. apply and_projR.
- - etransitivity; last eapply pvsImpl. apply and_R; split; last by apply and_projL.
- rewrite ->and_projR. apply box_intro. rewrite ->box_conj, ->box_elim. rewrite -and_impl.
- transitivity ((□all (pvsLift m' m Q' Q)) ∧ (((wp safe) m') e) (pvs m' m' <M< Q') ).
- + apply and_R; split.
- * rewrite ->and_projL. apply and_projR.
- * apply and_impl. apply and_projL.
- + etransitivity; last eapply wpImpl. apply and_R; split; last by apply and_projR.
- rewrite ->and_projL. apply box_intro. apply all_R. intros v.
- apply and_impl. etransitivity; last eapply pvsTrans with (m2:=m'); last by de_auto_eq.
- etransitivity; last eapply pvsImpl. apply and_R; split; last first.
- * apply and_projR.
- * rewrite ->and_projL. apply box_intro. rewrite ->box_elim. apply (all_L v). reflexivity.
- Qed.
-
- Lemma htCons P P' Q Q' safe m e :
- vs m m P P' ∧ ht safe m P' e Q' ∧ all (vsLift m m Q' Q) ⊑ ht safe m P e Q.
- Proof.
- rewrite /vs {1}/ht -vsLiftBox -!box_conj. apply htIntro.
- etransitivity; first by eapply htMCons. etransitivity; first by eapply wpPreVS'.
- reflexivity.
- Qed.
-
- Lemma htACons safe m m' e P P' Q Q'
- (HAt : atomic e)
- (HSub : m' ⊑ m) :
- vs m m' P P' ∧ ht safe m' P' e Q' ∧ all (vsLift m' m Q' Q) ⊑ ht safe m P e Q.
- Proof.
- rewrite /vs {1}/ht -vsLiftBox -!box_conj. apply htIntro.
- etransitivity; last (eapply wpACons; eassumption).
- etransitivity; first by eapply htMCons.
- eapply pvsMon. eapply wpMon=>v. eapply pvsMon. eapply pvsEnt.
- Qed.
-
-
- Section Bind.
- (** Quantification in the logic works over nonexpansive maps, so
- we need to show that plugging the value into the postcondition
- and context is nonexpansive. *)
- Program Definition plug_bind (ctx: expr -> expr) safe m Q Q' :=
- n[(fun v : value => ht safe m (Q v) (ctx v) Q' )].
- Next Obligation.
- intros v1 v2 EQv; unfold ht; eapply box_dist.
- eapply impl_dist.
- - apply Q; assumption.
- - destruct n as [| n]; [apply dist_bound | hnf in EQv].
- rewrite EQv; reflexivity.
- Qed.
-
- Lemma htBind ctx P Q R e safe m (HCtx: is_ctx ctx) :
- ht safe m P e Q ∧ all (plug_bind ctx safe m Q R) ⊑ ht safe m P (ctx e) R.
- Proof.
- rewrite /plug_bind {1 2}/ht. etransitivity; last eapply htIntro.
- { erewrite box_conj. apply and_pord; first reflexivity.
- erewrite (box_all (plug_bind ctx safe m (pvs m m <M< Q) R)). apply all_pord=>v. simpl morph.
- rewrite /ht. apply box_intro, box_intro. apply and_impl.
- etransitivity; last eapply wpPreVS'. etransitivity; first by eapply pvsImpl. reflexivity. }
- etransitivity; last by eapply wpBind.
- etransitivity; last eapply wpImpl with (φ:=pvs m m <M< Q). apply and_R; split.
- - rewrite ->and_projL. apply box_intro. rewrite ->box_elim, ->and_projR.
- apply all_pord=>v. simpl morph. rewrite /ht. rewrite ->box_elim. reflexivity.
- - eapply modus_ponens; first by apply and_projR.
- rewrite ->and_projL, ->box_elim, and_projL. reflexivity.
- Qed.
- End Bind.
-
-
- Lemma htWeakenMask safe m m' P e Q (HD: m ⊑ m'):
- ht safe m P e Q ⊑ ht safe m' P e Q.
- Proof.
- rewrite {1}/ht. apply htIntro.
- etransitivity; last by eapply wpWeakenMask.
- eapply and_impl. rewrite ->box_elim. eapply impl_pord; first reflexivity.
- eapply wpMon. intros v. by eapply pvsWeakenMask.
- Qed.
-
- Lemma htFrame safe m m' P R e Q (*HD: m # m' *):
- ht safe m P e Q ⊑ ht safe (m ∪ m') (P * R) e (lift_bin sc Q (umconst R)).
- Proof.
- etransitivity; first eapply htWeakenMask with (m' := m ∪ m').
- { de_auto_eq. }
- rewrite {1}/ht. apply htIntro.
- transitivity ((wp safe (m ∪ m') e) (lift_bin sc (pvs (m ∪ m') (m ∪ m') <M< Q) (umconst R))); last first.
- { eapply wpMon. intros v. transitivity ((pvs (m ∪ m') (m ∪ m') (Q v) * R)); first reflexivity. (* ARGH! *)
- etransitivity; first eapply pvsFrameRes. reflexivity. }
- etransitivity; last eapply wpFrameRes.
- rewrite -box_conj_star assoc. apply sc_pord; last reflexivity.
- rewrite box_conj_star. apply and_impl, box_elim.
- Qed.
-
- Lemma htSFrame safe m m' P R e Q
- (HD : m # m')
- (HNv : ~is_value e) :
- ht safe m P e Q ⊑ ht safe (m ∪ m') (P * ▹R) e (lift_bin sc Q (umconst R)).
- Proof.
- rewrite {1}/ht. apply htIntro.
- transitivity ((wp safe (m ∪ m') e) (lift_bin sc (pvs (m ∪ m') (m ∪ m') <M< Q) (umconst R))); last first.
- { eapply wpMon. intros v. transitivity ((pvs (m ∪ m') (m ∪ m') (Q v) * R)); first reflexivity. (* ARGH! *)
- etransitivity; first eapply pvsFrameRes. reflexivity. }
- etransitivity; last (eapply wpSFrameRes; assumption).
- etransitivity; last first.
- { eapply sc_pord; last reflexivity. eapply wpFrameMask. }
- rewrite -box_conj_star assoc. apply sc_pord; last reflexivity.
- rewrite box_conj_star. eapply and_impl. rewrite ->box_elim. eapply impl_pord; first reflexivity.
- eapply wpMon. intros v. eapply pvsWeakenMask. de_auto_eq.
- Qed.
-
- Lemma htUnsafe {m P e Q} :
- ht true m P e Q ⊑ ht false m P e Q.
- Proof.
- rewrite {1}/ht. apply htIntro. eapply and_impl. rewrite ->box_elim.
- eapply impl_pord; first reflexivity.
- by eapply wpUnsafe.
- Qed.
-
- End DerivedHTRules.
-
-End IRIS_DERIVED_RULES.
-
-Module IrisDerivedRules (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE) (VS_RULES: IRIS_VS_RULES RL C R WP CORE PLOG) (HT_RULES: IRIS_HT_RULES RL C R WP CORE PLOG) : IRIS_DERIVED_RULES RL C R WP CORE PLOG VS_RULES HT_RULES.
- Include IRIS_DERIVED_RULES RL C R WP CORE PLOG VS_RULES HT_RULES.
-End IrisDerivedRules.
diff --git a/iris_ht_rules.v b/iris_ht_rules.v
deleted file mode 100644
index 26a6ae8c5c3fbe5e10155fa9f461bf34280cf035..0000000000000000000000000000000000000000
--- a/iris_ht_rules.v
+++ /dev/null
@@ -1,220 +0,0 @@
-Require Import Ssreflect.ssreflect Ssreflect.ssrfun Omega.
-Require Import world_prop core_lang lang iris_core iris_plog.
-Require Import ModuRes.RA ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.Agreement ModuRes.DecEnsemble ModuRes.CMRA.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Module Type IRIS_HT_RULES (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE).
- Export PLOG.
-
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
- Local Open Scope de_scope.
-
- Section HoareTripleProperties.
-
- Implicit Types (P : Props) (i : nat) (safe : bool) (m : DecEnsemble nat) (e : expr) (Q φ : vPred) (r : res) (σ : state) (g : RL.res).
-
- Lemma wpMon safe m e φ φ':
- φ ⊑ φ' -> wp safe m e φ ⊑ wp safe m e φ'.
- Proof.
- move=>Himpl w n. move: n w e. elim/wf_nat_ind=>n0 IH w0 e.
- rewrite ->unfold_wp. intros [HV Hwp]. split; intros.
- { eapply Himpl, HV. assumption. }
- edestruct (Hwp wf) as [Hstep Hsafe]; try eassumption; [].
- split; last assumption.
- move=>σ' ei' ef Hpstep. destruct (Hstep _ _ _ Hpstep) as (w2 & w2f & Hnext & Hnextf & Hsat)=>{Hstep Hsafe}.
- exists w2 w2f. split; last (split; last assumption).
- - eapply IH; assumption.
- - assumption.
- Qed.
-
- (** Ret **)
- Program Definition eqV v : vPred :=
- n[(fun v' : value => v === v')].
- Next Obligation.
- intros v1 v2 EQv. apply intEq_dist; reflexivity || assumption.
- Qed.
-
- Lemma wpRet e (HV : is_value e) safe m :
- valid (wp safe m e (eqV (exist _ e HV))).
- Proof.
- intros w n. eapply wpValue.
- destruct n; first exact:bpred.
- simpl. reflexivity.
- Grab Existential Variables.
- { assumption. }
- Qed.
-
- (** Consequence **)
- Lemma wpPreVS m safe e φ:
- pvs m m (wp safe m e φ) ⊑ wp safe m e (pvs m m <M< φ).
- Proof.
- move=>w0 n0 Hvswp. rewrite ->unfold_wp. split; intros.
- { intros w; intros. edestruct (Hvswp w k mf σ) as [w2 [Hφ HE2]];try assumption;[].
- exists w2. split; last assumption. rewrite ->unfold_wp in Hφ.
- destruct Hφ as [Hφ _]. eapply Hφ. omega. }
- move:Hvswp. case/(_ wf k mf σ HLt _ HE); last move=>w2 [Hwp Hsat].
- { de_auto_eq. }
- assert (Hwp': wp safe m e (pvs m m <M< φ) w2 (S (S k))).
- { eapply wpMon, Hwp. intros v. eapply pvsEnt. }
- clear Hwp. rewrite ->unfold_wp in Hwp'. destruct Hwp' as [_ Hwp]. move: Hwp.
- case/(_ wf k mf σ _ _ Hsat)/Wrap; last move=>Hcases {HE Hsat}.
- - omega.
- - assumption.
- - apply Hcases.
- Qed.
-
- Lemma wpACons safe m m' e φ
- (HAt : atomic e)
- (HSub : m' ⊑ m) :
- pvs m m' (wp safe m' e ((pvs m' m) <M< φ)) ⊑ wp safe m e φ.
- Proof.
- move=>w0 n0 Hvswpvs. rewrite->unfold_wp. split; intros.
- { contradiction (atomic_not_value e). }
- edestruct (Hvswpvs wf k mf) as (w2 & Hwpvs & Hsat2);[eassumption|de_auto_eq|eassumption|].
- rewrite->unfold_wp in Hwpvs. destruct Hwpvs as [_ Hwpvs].
- edestruct (Hwpvs wf k mf) as (Hwpstep & Hwpsafe);[|de_auto_eq|eassumption|]; first omega.
- split; last assumption.
- move=>e' σ' ef' Hstep {Hwpsafe Hvswpvs Hwpvs Hsat2 HE}.
- destruct (Hwpstep _ _ _ Hstep) as (w3 & w3f & Hwpvs & Hwpf & Hsat3)=>{Hwpstep}.
- assert (HVal := atomic_step _ HAt Hstep)=>{Hstep e HAt σ}.
- edestruct Hwpvs as (Hvs & _)=>{Hwpvs}. specialize (Hvs HVal).
- destruct k.
- { exists w3 w3f. (* Witnesses do not matter *)
- split; last split; done || destruct ef'; exact:wp1. }
- move:Hvs. case/(_ _ (w3f · wf) k mf σ' _ _ _)/Wrap; last intros (w4 & Hφ & Hsat4);
- first omega; first omega; first de_auto_eq.
- { eapply spredNE, Hsat3. eapply dist_refl, wsat_equiv; first reflexivity.
- rewrite assoc (comm _ w3). reflexivity. }
- exists w4 w3f. split; last (split; first assumption).
- - eapply wpValue. eassumption.
- - eapply spredNE, Hsat4. eapply dist_refl, wsat_equiv; first reflexivity.
- rewrite assoc (comm _ w4). reflexivity.
- Qed.
-
- (** Bind - in general **)
- Section Bind.
- Program Definition plug_bind (ctx: expr -> expr) safe m φ :=
- n[(fun v : value => wp safe m (ctx v) φ )].
- Next Obligation.
- intros v1 v2 EQv.
- destruct n as [|n]; first by apply: dist_bound.
- hnf in EQv. now rewrite EQv.
- Qed.
-
- Lemma wpBind ctx φ e safe m (HCtx: is_ctx ctx):
- wp safe m e (plug_bind ctx safe m φ) ⊑ wp safe m (ctx e) φ.
- Proof.
- intros w n He. destruct HCtx as (HCval & HCstep & HCfstep).
- revert e w He; induction n using wf_nat_ind; intros; rename H into IH.
- (* We need to actually decide whether e is a value, to establish safety in the case that
- it is not. *)
- destruct (is_value_dec e) as [HVal | HNVal]; [clear IH |].
- - rewrite ->unfold_wp in He. destruct He as [HeV _].
- destruct n; first exact:dpred. destruct n; first exact:wp1.
- eapply (HeV HVal). omega.
- - rewrite ->unfold_wp in He; rewrite unfold_wp. split; intros.
- { exfalso. apply HNVal, HCval, HV. }
- edestruct He as [_ He']; try eassumption; []; clear He.
- edestruct He' as [HS HSf]; try eassumption; []; clear He' HE HD.
- split; last first.
- { intros Heq. destruct (HSf Heq) as [?|[σ' [e' [ef Hstep]]]]; first contradiction.
- right. do 3 eexists. eapply HCstep. eassumption. }
- intros. edestruct (HCfstep e σ e' σ' ef) as (e'' & Heq' & Hstep'); first done; first done.
- destruct (HS _ _ _ Hstep') as (wret & wfk & Hret & Hfk & HE). subst e'.
- exists wret wfk. split; last tauto.
- clear Hfk HE. eapply IH; assumption.
- Qed.
- End Bind.
-
- (** Mask weakening **)
- Lemma wpWeakenMask safe m1 m2 e φ (HD : m1 ⊑ m2) :
- wp safe m1 e φ ⊑ wp safe m2 e φ.
- Proof.
- intros w n; revert w e φ; induction n using wf_nat_ind; rename H into HInd; intros w e φ.
- rewrite unfold_wp. intros [HV HW]. split; intros; first exact:HV.
- edestruct HW with (mf := mf ∪ (m2 \ m1)) as [HS HSf]; try eassumption;
- [| eapply wsat_equiv, HE; try reflexivity; de_auto_eq |]; first de_auto_eq.
- clear HW HE; split; [intros; clear HV | intros; clear HV HS].
- - destruct (HS _ _ _ HStep) as [wret [wfk [HWR [HWF HE]]]]; clear HS.
- do 2 eexists. split; [eapply HInd; eassumption|].
- split; first eassumption.
- eapply wsat_equiv, HE; try reflexivity; clear; de_auto_eq.
- - now auto.
- Qed.
-
- (** Framing **)
- Lemma wpFrameRes safe m e φ R:
- (wp safe m e φ) * R ⊑ wp safe m e (lift_bin sc φ (umconst R)).
- Proof.
- move=> w n; revert w e φ R; induction n using wf_nat_ind; rename H into HInd; intros w e φ R HW.
- destruct n; first exact:bpred.
- rewrite unfold_wp; rewrite ->unfold_wp in HW.
- destruct HW as [[w1 w2] [EQw [[HV Hwp] HR]]].
- split; intros.
- { exists (w1, w2). split; first assumption. split; last exact HR. exact:HV. }
- simpl in EQw. pose (wf' := w2 · wf).
- edestruct Hwp with (wf:=wf') as [HS HSf]; try eassumption; [|].
- { eapply wsat_dist, HE; first reflexivity; last reflexivity.
- simpl morph. rewrite /wf' assoc. apply cmra_op_dist; last reflexivity.
- eapply mono_dist, EQw. omega. }
- clear Hwp HE; split; last by auto. clear HSf HV. intros.
- destruct (HS _ _ _ HStep) as [wret [wfk [HWR [HWF HE]]]]; clear HS.
- do 2 eexists. split; last split.
- - eapply HInd; first omega.
- exists (wret, w2). simpl. split; first reflexivity.
- split; first assumption.
- eapply propsMN, HR; omega.
- - eassumption.
- - eapply wsat_equiv, HE; try reflexivity.
- rewrite /wf'. now rewrite !assoc.
- Qed.
-
- Lemma wpSFrameRes safe m R e φ
- (HNv : ~is_value e) :
- (wp safe m e φ) * ▹R ⊑ wp safe m e (lift_bin sc φ (umconst R)).
- Proof.
- intros w n. destruct n; first (intro; exact:bpred).
- move=>[[w1 w2] [/= EQr [Hwp HLR]]].
- rewrite->unfold_wp; rewrite ->unfold_wp in Hwp.
- split; intros; first by contradiction.
- destruct Hwp as [_ Hwp].
- edestruct (Hwp (w2 · wf) k mf) as [HS HSf]; [omega|assumption| |].
- { eapply wsat_dist, HE; first reflexivity; last reflexivity.
- rewrite assoc. apply cmra_op_dist; last reflexivity.
- eapply mono_dist, EQr. omega. }
- split; last by auto. intros.
- edestruct (HS _ _ _ HStep) as [wret [wfk [He' [Ht' HE']]]]; try eassumption; [].
- clear HE Hwp HS; rewrite ->assoc in HE'.
- exists (wret · w2) wfk. split; [| split; rewrite ->?assoc; eassumption].
- eapply wpFrameRes. exists (wret, w2).
- split; first (apply sp_eq_iff; reflexivity).
- split; first assumption.
- eapply dpred, HLR. omega.
- Qed.
-
- (* Unsafe and safe weakest-pre *)
- Lemma wpUnsafe {m e φ} : wp true m e φ ⊑ wp false m e φ.
- Proof.
- move=> w n. move: n w e φ m; elim/wf_nat_ind. move=> n IH w e φ m.
- rewrite unfold_wp. move=>[HV HW]. rewrite unfold_wp. split; intros; first by auto.
- move/(_ _ HLt): IH => IH.
- move/(_ _ _ _ _ HLt HD HE): HW => [HS _] {HLt HD HE HV}.
- split; [ | done].
- - move=> e' σ' ef HStep.
- move/(_ _ _ _ HStep): HS => [wret [wfk [Hk [He' HW']]]] {HStep}.
- exists wret wfk. split; [exact: IH | split; [case:ef He'=>[ef|]; [exact: IH|done] | done] ].
- Qed.
-
- End HoareTripleProperties.
-
- Global Opaque pvs.
- Global Opaque wpF.
-
-End IRIS_HT_RULES.
-
-Module IrisHTRules (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE) : IRIS_HT_RULES RL C R WP CORE PLOG.
- Include IRIS_HT_RULES RL C R WP CORE PLOG.
-End IrisHTRules.
diff --git a/iris_meta.v b/iris_meta.v
deleted file mode 100644
index 6e554413426cc63bbe8e5f67a4db436aff3cd328..0000000000000000000000000000000000000000
--- a/iris_meta.v
+++ /dev/null
@@ -1,565 +0,0 @@
-Require Import Ssreflect.ssreflect Ssreflect.ssrfun Omega List.
-Require Import core_lang world_prop iris_core iris_plog iris_ht_rules iris_vs_rules.
-Require Import ModuRes.RA ModuRes.CMRA ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.RAConstr ModuRes.DecEnsemble ModuRes.Agreement ModuRes.Lists ModuRes.Relations.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Module Type IRIS_META (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE) (VS_RULES: IRIS_VS_RULES RL C R WP CORE PLOG) (HT_RULES: IRIS_HT_RULES RL C R WP CORE PLOG).
- Export VS_RULES.
- Export HT_RULES.
-
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
-
- Section Adequacy.
-
- Local Open Scope list_scope.
-
- Implicit Types (P : Props) (w : Wld) (i n : nat) (safe : bool) (m : DecEnsemble nat) (e : expr) (Q φ : vPred) (r : res) (σ : state) (g : RL.res) (t : tpool).
-
-
- (* weakest-pre for a threadpool *)
- Inductive wptp (safe : bool) n : tpool -> list Wld -> list vPred -> Prop :=
- | wp_emp : wptp safe n nil nil nil
- | wp_cons e φ tp w ws φs
- (WPE : wp safe de_full e φ w n)
- (WPTP : wptp safe n tp ws φs) :
- wptp safe n (e :: tp) (w :: ws) (φ :: φs).
-
- (* Trivial lemmas about split over append *)
- Lemma wptp_app safe n tp1 tp2 ws1 ws2 φs1 φs2
- (HW1 : wptp safe n tp1 ws1 φs1)
- (HW2 : wptp safe n tp2 ws2 φs2) :
- wptp safe n (tp1 ++ tp2) (ws1 ++ ws2) (φs1 ++ φs2).
- Proof.
- induction HW1; [| constructor]; now trivial.
- Qed.
-
- Lemma wptp_app_tp safe n t1 t2 ws φs
- (HW : wptp safe n (t1 ++ t2) ws φs) :
- exists ws1 ws2 φs1 φs2, ws1 ++ ws2 = ws /\ φs1 ++ φs2 = φs /\ wptp safe n t1 ws1 φs1 /\ wptp safe n t2 ws2 φs2.
- Proof.
- revert ws φs HW; induction t1; intros; inversion HW; simpl in *; subst; clear HW.
- - do 4 eexists. split; [|split; [|split; now econstructor]]; reflexivity.
- - do 4 eexists. split; [|split; [|split; now eauto using wptp]]; reflexivity.
- - apply IHt1 in WPTP; destruct WPTP as [ws1 [ws2 [φs1 [φs2 [EQws [EQφs [WP1 WP2]]]]]]]; clear IHt1.
- exists (w :: ws1) ws2 (φ :: φs1) φs2; simpl; subst; now auto using wptp.
- Qed.
-
- (* Closure under smaller steps *)
- Lemma wptp_closure safe n1 n2 tp ws φs
- (HLe : n2 <= n1)
- (HW : wptp safe n1 tp ws φs) :
- wptp safe n2 tp ws φs.
- Proof.
- induction HW; constructor; [| assumption].
- eapply dpred, WPE. assumption.
- Qed.
-
- Definition comp_wlist := @fold_left Wld Wld ra_op.
-
- Global Instance comp_wlist_equiv ws:
- Proper (equiv ==> equiv) (comp_wlist ws).
- Proof.
- induction ws; intros w0 w1 EQw.
- - exact EQw.
- - rewrite /comp_wlist /=. eapply IHws. now rewrite EQw.
- Qed.
-
- Lemma comp_wlist_tofront w w0 ws:
- w · comp_wlist ws w0 == comp_wlist (w::ws) w0.
- Proof.
- revert w0. induction ws; intros; simpl comp_wlist.
- - simpl comp_wlist. now rewrite comm.
- - rewrite IHws /comp_wlist /=. rewrite -(assoc _ w) (comm w) assoc.
- reflexivity.
- Qed.
-
- Lemma preserve_wptp w0 safe n k tp tp' σ σ' ws φs
- (HSN : stepn n (tp, σ) (tp', σ'))
- (HWTP : wptp safe (n + (S k)) tp ws φs)
- (HE : wsat σ de_full (comp_wlist ws w0) (n + (S k))) :
- exists ws' φs',
- wptp safe (S k) tp' ws' (φs ++ φs') /\ wsat σ' de_full (comp_wlist ws' w0) (S k).
- Proof.
- revert tp σ w0 ws φs HSN HWTP HE. induction n; intros; inversion HSN; subst; clear HSN.
- (* no step is taken *)
- { inversion H; subst; clear H.
- exists ws (@nil vPred). split.
- - rewrite app_nil_r. assumption.
- - assumption.
- }
- rewrite -plus_n_Sm in HWTP, HE.
- inversion HS; subst; clear HS.
- (* a step is taken *)
- inversion H; subst; clear H.
- apply wptp_app_tp in HWTP. destruct HWTP as [ws1 [ws2 [φs1 [φs2 [EQws [EQφs [HWTP1 HWTP2]]]]]]].
- inversion HWTP2; subst; clear HWTP2; rewrite ->unfold_wp in WPE. destruct WPE as [_ WPE].
- edestruct (WPE (comp_wlist (ws1 ++ ws0) w0) (n + k) de_emp) as [HS _].
- - omega.
- - clear; de_auto_eq.
- - eapply spredNE, HE.
- apply dist_refl. eapply wsat_equiv.
- + clear; de_auto_eq.
- + rewrite /comp_wlist !fold_left_app /= comp_wlist_tofront /comp_wlist /=. reflexivity.
- - edestruct HS as (w' & wfk' & HE' & HE'' & HWS); [eassumption | clear WPE HS]. destruct ef as [ef|].
- + edestruct IHn as [ws'' [φs'' [HSWTP'' HSE'']]]; first eassumption; first 2 last.
- * exists ws'' ([umconst ⊤] ++ φs''). split; last eassumption.
- rewrite List.app_assoc. eassumption.
- * rewrite -List.app_assoc. apply wptp_app.
- { eapply wptp_closure, HWTP1; omega. }
- rewrite -plus_n_Sm.
- constructor; [eassumption|].
- apply wptp_app; [eapply wptp_closure, WPTP; omega |].
- constructor; [|now constructor]. eassumption.
- * rewrite -plus_n_Sm. eapply spredNE, HWS.
- apply dist_refl. eapply wsat_equiv; first de_auto_eq.
- rewrite /comp_wlist !fold_left_app /= !fold_left_app. simpl fold_left.
- rewrite (comm _ wfk') -assoc. apply ra_op_proper; first reflexivity.
- rewrite comp_wlist_tofront /comp_wlist /=. reflexivity.
- + eapply IHn; clear IHn; first eassumption.
- * apply wptp_app.
- { eapply wptp_closure, HWTP1. omega. }
- rewrite -plus_n_Sm. simpl. rewrite app_nil_r.
- constructor; last (eapply wptp_closure, WPTP; omega).
- eapply propsMW, HE'. exists wfk'. reflexivity.
- * rewrite -plus_n_Sm. eapply spredNE, HWS.
- apply dist_refl. eapply wsat_equiv; first de_auto_eq.
- rewrite /comp_wlist !fold_left_app /= comp_wlist_tofront /comp_wlist /=. reflexivity.
- Qed.
-
- Lemma adequacy_ht {safe m e P Q n k tp' σ σ' w}
- (HT : valid (ht safe m P e Q))
- (HSN : stepn n ([e], σ) (tp', σ'))
- (HP : P w (n + S k))
- (HE : wsat σ de_full w (n + S k)) :
- exists ws' φs',
- wptp safe (S k) tp' ws' ((pvs m m <M< Q) :: φs') /\ wsat σ' de_full (comp_wlist ws' (1 w)) (S k).
- Proof.
- edestruct (preserve_wptp (1 w)) with (ws := [w]) as [ws' [φs' [HSWTP' HSWS']]]; first eassumption.
- - specialize (HT w (n + S k)). apply (applyImpl HT) in HP; try reflexivity; [|now apply unit_min].
- econstructor; [|now econstructor].
- eapply wpWeakenMask; last eassumption.
- de_auto_eq.
- - simpl comp_wlist. rewrite ra_op_unit. eassumption.
- - exists ws' φs'. now auto.
- Qed.
-
- (** This is a (relatively) generic adequacy statement for triples about an entire program: They always execute to a "good" threadpool. It does not expect the program to execute to termination. *)
- Theorem adequacy_glob safe m e Q tp' σ σ' k'
- (HT : valid (ht safe m (ownS σ) e Q))
- (HSN : steps ([e], σ) (tp', σ')):
- exists w0 ws' φs',
- wptp safe (S (S k')) tp' ws' ((pvs m m <M< Q) :: φs') /\ wsat σ' de_full (comp_wlist ws' w0) (S (S k')).
- Proof.
- destruct (refl_trans_n _ HSN) as [n HSN']. clear HSN.
- destruct (RL.res_vira) as [l Hval].
- pose (w := (fdEmpty, (ex_own σ, l)) : Wld).
- edestruct (adequacy_ht (w:=w) (k:=S k') HT HSN') as [ws' [φs' [HSWTP HWS]]]; clear HT HSN'.
- - rewrite -!plus_n_Sm. eexists ex_unit. reflexivity.
- - rewrite -!plus_n_Sm. hnf. eexists fdEmpty. intro.
- split.
- { rewrite /wt /=. split_conjs.
- - move=>i. exact I.
- - exact I.
- - assumption. }
- split.
- + rewrite /wt. reflexivity.
- + move=>i agP Heq. exfalso. rewrite /wt /= in Heq. exact Heq.
- - do 3 eexists. split; [eassumption|]. eassumption.
- Qed.
-
- Program Definition lift_vPred (Q : value -=> Prop): vPred :=
- n[(fun v => pcmconst (sp_const (Q v)))].
- Next Obligation.
- move=>v1 v2 EQv. destruct n; first exact:dist_bound.
- intros w m Hlt. rewrite /=. destruct m; first reflexivity.
- rewrite EQv. reflexivity.
- Qed.
-
- (* Adequacy as stated in the paper: for observations of the return value, after termination *)
- Theorem adequacy_obs safe m e (Q : value -=> Prop) e' tp' σ σ'
- (HT : valid (ht safe m (ownS σ) e (lift_vPred Q)))
- (HSN : steps ([e], σ) (e' :: tp', σ'))
- (HV : is_value e') :
- Q (exist _ e' HV).
- Proof.
- edestruct adequacy_glob with (k':=0) as [w0 [ws' [φs' [HSWTP HWS]]]]; try eassumption; [].
- inversion HSWTP; subst; clear HSWTP WPTP.
- rewrite ->unfold_wp in WPE. destruct WPE as [WPV _].
- move:WPV. case/(_ HV _ (comp_wlist ws w0) O (de_minus de_full m) σ' _ _ _)/Wrap; last intros (w' & HQ & HWS').
- - omega.
- - omega.
- - clear; de_auto_eq.
- - eapply spredNE, HWS. eapply dist_refl. eapply wsat_equiv.
- + clear; de_auto_eq.
- + rewrite comp_wlist_tofront. reflexivity.
- - clear- HQ HWS'. exact HQ.
- Qed.
-
- (* Adequacy for safe triples *)
- Lemma adequacy_safe_expr m e (Q : vPred) tp' σ σ' e'
- (HT : valid (ht true m (ownS σ) e Q))
- (HSN : steps ([e], σ) (tp', σ'))
- (HE : e' ∈ tp'):
- safeExpr e' σ'.
- Proof.
- edestruct adequacy_glob as [w' [rs' [φs' [HSWTP HWS]]]]; try eassumption.
- destruct (List.in_split _ _ HE) as [tp1 [tp2 HTP]]. clear HE. subst tp'.
- apply wptp_app_tp in HSWTP; destruct HSWTP as [ws1 [ws2 [_ [φs2 [EQrs [_ [_ HWTP2]]]]]]].
- inversion HWTP2; subst; clear HWTP2 WPTP.
- rewrite ->unfold_wp in WPE. destruct WPE as [_ WPE].
- edestruct (WPE (comp_wlist (ws1++ws) w') O de_emp) as [_ HSafe]; [unfold lt; reflexivity | de_auto_eq | |].
- - rewrite de_emp_union.
- eapply wsat_equiv, HWS; try reflexivity.
- rewrite /comp_wlist !fold_left_app. rewrite comp_wlist_tofront. reflexivity.
- - apply HSafe. reflexivity.
- Qed.
-
- Theorem adequacy_safe m e (Q : vPred) tp' σ σ'
- (HT : valid (ht true m (ownS σ) e Q))
- (HSN : steps ([e], σ) (tp', σ')):
- (forall e', e' ∈ tp' -> is_value e') \/ exists tp'' σ'', step (tp', σ') (tp'', σ'').
- Proof. (* FIXME TODO use tp_safe *)
- assert (Hsafe: forall e', e' ∈ tp' -> safeExpr e' σ').
- { move=>e' HE. eapply adequacy_safe_expr; eassumption. }
- clear -Hsafe. induction tp' as [|e tp' IH].
- - left. move=>? [].
- - move:IH. case/(_ _)/Wrap.
- { move=>e' Hin. apply Hsafe. right. assumption. }
- case=>IH; last first.
- { destruct IH as [tp'' [σ'' Hstep]]. right.
- destruct Hstep.
- inversion H0=>{H0}; inversion H=>{H}; subst.
- do 2 eexists. eapply step_atomic; last eassumption; last reflexivity.
- rewrite app_comm_cons. reflexivity.
- }
- move:(Hsafe e)=>{Hsafe}. case/(_ _)/Wrap; first by left.
- case=>[Hsafe|[σ'' [e'' [ef Hstep]]]].
- + left. move=>e'. case.
- * by move =><-.
- * by auto.
- + right. do 2 eexists. eapply step_atomic with (t1:=[]); last eassumption; last reflexivity.
- reflexivity.
- Qed.
-
- End Adequacy.
-
- Section StatefulLifting.
-
- Implicit Types (P : Props) (n k : nat) (safe : bool) (m : DecEnsemble nat) (e : expr) (r : res) (σ : state) (w : Wld).
-
- Implicit Types (φ : expr * state * option expr -> Prop).
- Implicit Types (Q : vPred).
-
- (* Obligation common to lift_pred and lemma statement. *)
- Program Definition lift_esPred φ : expr * state * option expr -n> Props :=
- n[(fun c => pconst (φ c))].
- Next Obligation.
- move=>[[e1 σ1] ef1] [[e2 σ2] ef2] [[EQe EQσ] EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQσ, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- Program Definition plug_step_wp safe m1 m2 φ Q : expr * state * option expr -n> Props :=
- n[(fun c => let: (e',σ',ef) := c in
- ((□lift_esPred φ c) ∧ ownS σ') -* pvs m1 m2
- (wp safe m2 e' Q * match ef return _ with None => ⊤ | Some ef => wp safe de_full ef (umconst ⊤) end) )].
- Next Obligation.
- move=>[[e1 σ1] ef1] [[e2 σ2] ef2] [[EQe EQσ] EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQσ, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- Lemma lift_step_wp {m1 m2 safe e σ φ Q}
- (NVAL : ~is_value e) (MASK : m1 ⊑ m2)
- (STEP : forall e' σ' ef, prim_step (e,σ) (e',σ') ef -> φ(e',σ',ef))
- (SAFE : if safe then safeExpr e σ else True) :
- pvs m2 m1 (ownS σ * ▹(all (plug_step_wp safe m1 m2 φ Q))) ⊑ wp safe m2 e Q.
- Proof.
- intros w n. destruct n; first (intro; exact:bpred).
- intros Hpvs. rewrite ->unfold_wp. split; intros.
- { contradiction. }
- edestruct (Hpvs wf k mf) as (w1 & Hsep & HE1);[assumption|de_auto_eq|eassumption|].
- destruct Hsep as [[w2 w2'] [Heqw [HoS Hwpe]]]. clear Hpvs HE. simpl in Heqw, Hwpe.
- destruct HE1 as [rs HWT]. rename σ0 into σi.
- cbv zeta in HWT. rewrite ->comp_finmap_move in HWT.
- have Hσ: σ = σi /\ State (w2' · comp_finmap wf rs) = ex_unit.
- { clear - HoS Heqw HWT HLt. destruct HWT as [[_ [pv _]] [HS _]].
- destruct HoS as [t Heq]. destruct Heqw as [_ [HeqS _]]. simpl in *.
- unfold ra_op, ra_valid in *.
- destruct (fst (snd w2)), (fst (snd w2')), (fst (snd w1)), t; simpl in *; try tauto; [].
- destruct (fst (snd (comp_finmap wf rs))); simpl in *; try tauto; [].
- split; last reflexivity. rewrite -HS -HeqS -Heq. reflexivity. }
- destruct Hσ as [Hσ HStUnit]. clear HoS. subst σi.
- split; last first.
- { by move: SAFE {Hwpe} ; case: safe. }
- move=> e' σ' ef HStep {SAFE NVAL}.
- pose (w2'' := (Invs w2, (ex_own σ', Res w2))).
- move: (Hwpe (e', σ', ef) w2'' _ (le_refl _))=>{Hwpe}. destruct n; first by (exfalso; omega).
- destruct k.
- { intros _. exists w1 w1. (* Witnesses do not matter. *)
- split; last split; done || destruct ef; done || exact:wp1. }
- case/(_ _ wf k mf σ' _ _ _)/Wrap; last move=>[w3 [[[w3e w3f] [Hw3 [Hwpe Hwpf]]] HE3]].
- - split; first by apply STEP. simpl. eexists ex_unit. reflexivity.
- - omega.
- - de_auto_eq.
- - (* wsat σ' follows from wsat σ (by the construction of the new world). *)
- exists rs. cbv zeta. rewrite comp_finmap_move.
- (* Rewrite Heqw in HWT - needs manual work *)
- assert(HWT': wsatTotal (S k) σ rs (m1 ∪ mf)%de (w2' · w2 · comp_finmap wf rs)).
- { eapply wsatTotal_proper, wsatTotal_dclosed, HWT; try reflexivity; last omega; [].
- apply cmra_op_dist; last reflexivity. rewrite comm. eapply mono_dist, Heqw. omega. }
- clear HWT. destruct HWT' as [pv [HS HI]].
- (* Get the projection to the physical state *)
- assert (HSt: State (w2' · w2'' · comp_finmap wf rs) == ex_own σ').
- { clear -HStUnit. simpl in HStUnit. rewrite /State -assoc. simpl.
- rewrite (comm (ex_own _)) assoc HStUnit. reflexivity. }
- clear HStUnit.
- (* Now, finally, prove the actual thing *)
- split; last split.
- + clear- pv HSt Heqw HLt.
- destruct pv as [HIVal [HSVal HRVal]]. rewrite /w2''.
- split; last split; last 1 first.
- * assumption.
- * assumption.
- * simpl in HSt. by rewrite HSt.
- + rewrite HSt. reflexivity.
- + assumption.
- - exists w3e w3f. split; first assumption. split; first (destruct ef; assumption).
- (* Rewrite Hw3 in the goal - needs manual work *)
- rewrite /Mfst /Msnd in Hw3. simpl morph in Hw3. apply sp_eq_iff in Hw3.
- eapply wsat_dist, HE3; first reflexivity; last reflexivity.
- apply cmra_op_dist; last reflexivity. rewrite (comm w3f). exact: Hw3.
- Qed.
-
- (* The "nicer looking" (ht-based) lemma is now a derived form. *)
- Program Definition plug_step safe m1 m2 φ F (R R': expr * state * option expr -n> Props) Q:
- expr * state * option expr -n> Props :=
- n[(fun c => let: (e',σ',ef) := c in vs m1 m2 (□lift_esPred φ c ∧ (F * ownS σ')) (R c * R' c) ∧ ht safe m2 (R c) e' Q ∧ match ef return _ with None => ⊤ | Some ef => ht safe de_full (R' c) ef (umconst ⊤) end )].
- Next Obligation.
- move=>[[e1 σ1] ef1] [[e2 σ2] ef2] [[EQe EQσ] EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQσ, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- Theorem lift_step {m1 m2 safe e σ φ P F R R' Q}
- (NVAL : ~is_value e) (MASK : m1 ⊑ m2)
- (STEP : forall e' σ' ef, prim_step (e,σ) (e',σ') ef -> φ(e',σ',ef))
- (SAFE : if safe then safeExpr e σ else True) :
- (vs m2 m1 P (▹F * ownS σ)) ∧ all (plug_step safe m1 m2 φ F R R' Q) ⊑ ht safe m2 P e Q.
- Proof.
- rewrite /vs.
- etransitivity; first (etransitivity; last eapply and_pord; first reflexivity; first reflexivity).
- { etransitivity; last by (eapply pordR; symmetry; eapply (box_all (plug_step safe m1 m2 φ F R R' Q))).
- apply all_pord. move=>[[e' σ'] ef]. simpl morph. rewrite !box_conj. rewrite /ht /vs !box_box.
- destruct ef; last by (rewrite box_top; reflexivity). rewrite box_box. reflexivity. }
- rewrite -box_conj. apply htIntro. etransitivity; last eapply (lift_step_wp (φ:=φ)); try eassumption; [].
- clear NVAL STEP SAFE. rewrite box_conj. etransitivity.
- { rewrite (comm _ P) assoc. eapply and_pord; last reflexivity.
- rewrite comm. apply and_impl. apply box_elim. }
- rewrite comm -box_conj_star comm. etransitivity; first eapply pvsFrameRes. eapply pvsMon.
- rewrite (comm (â–¹F)) -assoc. apply sc_pord; first reflexivity.
- rewrite ->(later_mon (â–¡_)). rewrite -later_star. apply later_pord.
- rewrite box_all. rewrite ->comm, ->all_sc. apply all_pord.
- move=>[[e' σ'] ef]. simpl morph. rewrite -sc_si /vs !box_conj.
- rewrite {1}[â–¡pconst _]lock -!box_conj_star. unlock.
- rewrite !assoc (comm _ F) !assoc (comm _ (â–¡pconst _)) !assoc comm.
- rewrite -!assoc 3!assoc. etransitivity.
- { eapply sc_pord; last reflexivity. eapply modus_ponens; last first.
- - rewrite ->sc_projR. etransitivity; first by eapply box_elim. eapply box_elim.
- - rewrite ->sc_projL. apply and_R; split.
- + rewrite ->sc_projL, sc_projR. reflexivity.
- + rewrite (comm F). apply sc_pord; last reflexivity.
- apply sc_projL. }
- etransitivity; first eapply pvsFrameRes. eapply pvsMon.
- rewrite !assoc (comm _ (â–¡ht _ _ _ _ _)). rewrite -!assoc 1!assoc. eapply sc_pord.
- - rewrite /ht. rewrite ->!box_elim. eapply modus_ponens; last eapply sc_projL.
- apply sc_projR.
- - destruct ef; last exact:top_true. rewrite /ht. rewrite ->!box_elim.
- eapply modus_ponens; last first.
- + rewrite ->sc_projR. eapply impl_pord; first reflexivity.
- eapply wpMon. move=>v. apply top_true.
- + apply sc_projL.
- Qed.
-
- Program Definition plug_atomic_step φ safe P': expr * state * option expr -n> Props :=
- n[(fun c => let: (e',σ',ef) := c in match ef return _ with None => ⊤ | Some ef => ht safe de_full (lift_esPred φ c ∧ P') ef (umconst ⊤) end )].
- Next Obligation.
- move=>[[e1 σ1] ef1] [[e2 σ2] ef2] [[EQe EQσ] EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQσ, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- Program Definition plug_atomic_step_post φ : value -n> Props :=
- n[(fun v:value => xist n[(fun c:state*option expr => ownS (Mfst c) ∧ lift_esPred φ (v, Mfst c, Msnd c))] )].
- Next Obligation.
- move=> [σ ef] [σ' ef'] [HEq1 HEq2]. destruct n; first exact:dist_bound.
- destruct ef, ef'; cbv in HEq1, HEq2; subst; now destruct HEq2 || reflexivity.
- Qed.
- Next Obligation.
- move=> v v' HEq. destruct n; first exact:dist_bound.
- hnf in HEq. eapply xist_dist=>σ' w. rewrite [dist]lock /= HEq -lock. reflexivity.
- Qed.
-
- Lemma lift_atomic_step {m safe e σ φ P Q}
- (AT : atomic e)
- (STEP : forall e' σ' ef, prim_step (e,σ) (e',σ') ef -> φ(e',σ',ef))
- (SAFE : if safe then safeExpr e σ else True) :
- all (plug_atomic_step φ safe P) ⊑ ht safe m (▹P * ownS σ) e (plug_atomic_step_post φ).
- Proof.
- pose(φ' := fun (c : expr*state*option expr) => let: (e', σ', ef) := c in φ c /\ is_value e').
- rewrite -{2}(sc_top_unit P). etransitivity;
- last eapply (lift_step (φ := φ') (R':=lift_bin and (lift_esPred φ') (umconst P)) (R:=lift_bin and (lift_esPred φ') (n[(ownS)] <M< Msnd <M< Mfst)));
- try (eassumption || exact: atomic_not_value); [|reflexivity|]; last first.
- { intros. split; first by exact:STEP. eapply atomic_step; eassumption. }
- apply and_R; split.
- { etransitivity; first exact:top_true. apply top_valid. apply vsValid.
- etransitivity; last eapply pvsEnt. rewrite ->sc_top_unit. reflexivity. }
- apply all_pord. move=>[[e' σ' ef]]. simpl morph. apply and_R; split; last (apply and_R; split).
- - transitivity ⊤; first by exact:top_true. apply top_valid. apply vsValid.
- etransitivity; last eapply pvsEnt. rewrite ->(and_self (â–¡pconst _)).
- rewrite -!box_conj_star -box_star -!box_conj_star. rewrite ->box_elim.
- rewrite !assoc (comm _ P) -!assoc 1!assoc comm. apply sc_pord.
- + apply sc_and.
- + rewrite comm. apply sc_and.
- - transitivity ⊤; first by exact:top_true. apply top_valid. apply htValid.
- apply pure_to_ctx=>[] [Hφ Hval]. etransitivity; last by eapply (wpValue _ Hval).
- etransitivity; last by eapply pvsEnt. rewrite /plug_atomic_step_post. simpl morph.
- apply (xist_R (σ', ef)). simpl morph. apply and_R; split; first reflexivity.
- move: Hφ. apply ctx_to_pure. apply and_projL.
- - destruct ef; last reflexivity.
- rewrite {1}/ht. apply htIntro. rewrite ->box_elim. eapply modus_ponens; last first.
- + apply and_projL.
- + apply and_R; split.
- * rewrite ->and_projR. apply pure_to_ctx=>[] [Hφ _]. move:Hφ. apply ctx_to_pure.
- apply and_projL.
- * rewrite ->and_projR. apply and_projR.
- Qed.
-
- End StatefulLifting.
-
- Section StatelessLifting.
-
- Implicit Types (P : Props) (n k : nat) (safe : bool) (m : DecEnsemble nat) (e : expr) (r : res) (σ : state) (w : Wld).
- Implicit Types (Q R: vPred) (φ : expr * option expr -> Prop).
-
- Program Definition lift_ePred (φ : expr * option expr -> Prop) : expr * option expr -n> Props :=
- n[(fun c => pconst (φ c))].
- Next Obligation.
- move=>[e1 ef1] [e2 ef2] [EQe EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- Program Definition plug_pure_step_wp safe m φ Q : expr * option expr -n> Props :=
- n[(fun c => let: (e',ef) := c in
- (□lift_ePred φ c) →
- (wp safe m e' Q * match ef return _ with None => ⊤ | Some ef => wp safe de_full ef (umconst ⊤) end) )].
- Next Obligation.
- move=>[e1 ef1] [e2 ef2] [EQe EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- Lemma lift_pure_step_wp {safe m e φ Q}
- (NVAL : ~is_value e)
- (STEP : forall σ e2 σ2 ef, prim_step (e, σ) (e2, σ2) ef -> σ2 = σ /\ φ (e2,ef))
- (SAFE : forall σ, if safe then safeExpr e σ else True):
- ▹all (plug_pure_step_wp safe m φ Q) ⊑ wp safe m e Q.
- Proof.
- intros w n Hwpe. destruct n; first (exact:bpred).
- simpl. rewrite ->unfold_wp. split; intros.
- { contradiction. }
- split; last first.
- { by move: SAFE {Hwpe} ; case: safe. }
- (* The step-case of WP. *)
- move=>e' σ' ef Hstep.
- specialize (STEP _ _ _ _ Hstep). destruct STEP as [Hσ Hφ]. subst σ'.
- destruct n; first (exfalso; omega).
- case:(Hwpe (e', ef) (1 w) (S n) (le_refl _)); last move=>[wret wfk] [Hw [Hret Hfk]] {Hwpe}.
- { exact Hφ. }
- exists wret wfk. split; last split.
- - eapply propsMN, Hret. omega.
- - destruct ef; last done. eapply propsMN, Hfk. omega.
- - eapply spredNE, dpred, HE; last omega.
- eapply wsat_dist; first reflexivity.
- simpl morph in Hw. apply sp_eq_iff in Hw. eapply (mono_dist _ _ _ (S n)); first omega.
- rewrite (comm wfk). apply cmra_op_dist; last reflexivity. rewrite Hw. rewrite comm ra_op_unit.
- reflexivity.
- Qed.
-
- Program Definition plug_pure_step safe m φ P P' Q: expr * option expr -n> Props :=
- n[(fun c => let: (e',ef) := c in ht safe m (lift_ePred φ c ∧ P) e' Q ∧ match ef return _ with None => ⊤ | Some ef => ht safe de_full (lift_ePred φ c ∧ P') ef (umconst ⊤) end )].
- Next Obligation.
- move=>[e1 ef1] [e2 ef2] [EQe EQef].
- destruct n; first exact:dist_bound.
- destruct ef1, ef2; cbv in EQe, EQef; subst; now destruct EQef || reflexivity.
- Qed.
-
- (* Again, the "ht-based" theorem is a derived form. *)
- Theorem lift_pure_step {safe m e φ} P P' Q
- (NVAL : ~is_value e)
- (STEP : forall σ e2 σ2 ef, prim_step (e, σ) (e2, σ2) ef -> σ2 = σ /\ φ (e2,ef))
- (SAFE : forall σ, if safe then safeExpr e σ else True):
- (all (plug_pure_step safe m φ P P' Q)) ⊑ ht safe m (▹(P * P')) e Q.
- Proof.
- etransitivity; first (etransitivity; last by (eapply pordR; symmetry; eapply (box_all (plug_pure_step safe m φ P P' Q)))).
- { apply all_pord. move=>[e' ef]. simpl morph. rewrite /ht box_conj box_box.
- destruct ef; last by (rewrite box_top; reflexivity). rewrite box_box. reflexivity. }
- apply htIntro. etransitivity; last eapply (lift_pure_step_wp (φ:=φ)); try eassumption; [].
- clear NVAL STEP SAFE.
- rewrite -box_conj_star. rewrite ->(later_mon (â–¡_)). rewrite -later_star.
- apply later_pord. rewrite ->box_elim, ->all_sc. apply all_pord. move=>[e' ef]. simpl morph.
- apply and_impl. rewrite (comm _ (â–¡pconst _)).
- rewrite ->(and_self (â–¡pconst _)). rewrite /ht -!assoc -3!box_conj_star.
- rewrite !assoc (comm _ P). rewrite !assoc (comm _ (□(_ → _))). (* Move the right things to the front *)
- rewrite -!assoc 2!assoc. (* Get the parentheses right *)
- rewrite ->!box_elim. apply sc_pord.
- - eapply modus_ponens; last first.
- + rewrite ->2!sc_projL. reflexivity.
- + apply and_R; split.
- * apply sc_projR.
- * rewrite ->sc_projL. apply sc_projR.
- - destruct ef; last by exact:top_true.
- eapply modus_ponens; last first.
- + rewrite ->box_elim, sc_projR, sc_projL. eapply impl_pord; first reflexivity.
- eapply wpMon. move=>v. simpl morph. apply top_true.
- + apply and_R; split.
- * rewrite ->sc_projL. reflexivity.
- * rewrite ->2!sc_projR. reflexivity.
- Qed.
-
- Lemma lift_pure_det_step safe m e e' ef P P' Q
- (NVAL : ~is_value e)
- (STEP : forall σ e2 σ2 ef2, prim_step (e, σ) (e2, σ2) ef2 -> σ2 = σ /\ e2 = e' /\ ef2 = ef)
- (SAFE : forall σ, if safe then safeExpr e σ else True):
- ht safe m P e' Q ∧ match ef with None => ⊤ | Some ef => ht safe de_full P' ef (umconst ⊤) end ⊑ ht safe m (▹(P * P')) e Q.
- Proof.
- pose(φ := fun c => c = (e', ef)).
- etransitivity; last (eapply (lift_pure_step (φ := φ)); try assumption); last first; [|].
- { intros. unfold φ. apply STEP in H. destruct_conjs. subst. split; reflexivity. }
- apply all_R=>[] [e'' ef'']. simpl morph.
- apply and_R; split.
- - rewrite ->and_projL. apply htIntro. rewrite ->box_elim.
- rewrite assoc (comm _ (pconst _)) -assoc. apply pure_to_ctx=>[] [EQe EQef]. subst e'' ef''.
- apply and_impl. reflexivity.
- - rewrite ->and_projR. destruct ef''; last exact:top_true.
- destruct ef; last first.
- { (* This case can't happen *)
- apply top_valid. apply htValid. apply pure_to_ctx. rewrite /φ.
- (* RJ: Wtf, "move=>[A B]" does complete nonsense here?!?? *)
- intros H. inversion H. }
- apply htIntro. rewrite ->box_elim.
- rewrite assoc (comm _ (pconst _)) -assoc. apply pure_to_ctx=>[] [EQe EQef]. subst e'' e1.
- apply and_impl. reflexivity.
- Qed.
-
- End StatelessLifting.
-
-End IRIS_META.
-
-Module IrisMeta (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE) (VS_RULES: IRIS_VS_RULES RL C R WP CORE PLOG) (HT_RULES: IRIS_HT_RULES RL C R WP CORE PLOG) : IRIS_META RL C R WP CORE PLOG VS_RULES HT_RULES.
- Include IRIS_META RL C R WP CORE PLOG VS_RULES HT_RULES.
-End IrisMeta.
diff --git a/iris_plog.v b/iris_plog.v
deleted file mode 100644
index 4f1eae712a1a3841b77ebfef6aa0f0e2682f7e0a..0000000000000000000000000000000000000000
--- a/iris_plog.v
+++ /dev/null
@@ -1,547 +0,0 @@
-Require Import Ssreflect.ssreflect Ssreflect.ssrfun Omega.
-Require Import world_prop core_lang lang iris_core.
-Require Import ModuRes.DecEnsemble ModuRes.RA ModuRes.CMRA ModuRes.SPred ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.RAConstr ModuRes.Agreement ModuRes.Lists.
-
-Set Bullet Behavior "Strict Subproofs".
-
-(* This enriches the Iris core logic with program logic features:
- Invariants, View Shifts, and Hoare Triples. The last two make use
- of a notion of "world satisfaction" (which you can also think of
- as the erasure from logical states to physical ones). *)
-Module Type IRIS_PLOG (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP).
- Export CORE.
- Module Export L := Lang C.
-
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
- Local Open Scope de_scope.
-
- Implicit Types (P : Props) (u v w : Wld) (n i k : nat) (m : mask) (r : res) (σ : state) (φ : vPred) (s : nat -f> Wld).
-
- Section WorldSatisfaction.
-
- (* First, we need to compose the resources of a finite map. *)
- Definition comp_finmap w0 : (nat -f> Wld) -> Wld :=
- fdFold w0 (fun k w' wt => wt · w').
-
- Global Instance comp_finmap_dist n: Proper (dist n ==> dist n ==> dist n) comp_finmap.
- Proof.
- move=>w01 w02 EQw0 s1 s2 EQs. rewrite /comp_finmap.
- etransitivity.
- - eapply fdFoldExtP_dist; last eexact EQs.
- + move=>k1 k2 w1 w2 w. unfold compose.
- rewrite -assoc (comm w2) assoc; reflexivity.
- + move=>k k' EQk w1 w2 EQw wt1 wt2 EQwt.
- apply cmra_op_dist; assumption.
- - eapply fdFoldExtT.
- + move=>k k' EQk w1 w2 EQw wt1 wt2 EQwt. subst k' w2.
- apply cmra_op_dist; reflexivity || assumption.
- + move=>k v t. reflexivity.
- + assumption.
- Qed.
-
- Global Instance comp_finmap_ext: Proper (equiv ==> equiv ==> equiv) comp_finmap.
- Proof.
- move=>w01 w02 EQw0 s1 s2 EQs. apply dist_refl=>n.
- apply comp_finmap_dist; assumption || apply dist_refl; assumption.
- Qed.
-
- Lemma comp_finmap_remove w0 (s: nat -f> Wld) i w:
- s i == Some w ->
- comp_finmap w0 s == comp_finmap w0 (s \ i) · w.
- Proof.
- revert s i w. apply:fdRect.
- - move=>s1 s2 EQs IH i w Hindom.
- etransitivity; last (etransitivity; first eapply IH); first apply equivR; last apply equivR.
- + rewrite EQs. reflexivity.
- + destruct EQs as [EQw _]. rewrite (EQw i). eassumption.
- + f_equal. rewrite EQs. reflexivity.
- - move=>? ? [].
- - move=>k v f Hnew IH i w Hindom. destruct (dec_eq i k) as [EQ|NEQ].
- + subst i. clear IH. rewrite fdStrongUpdateShadow /comp_finmap.
- erewrite fdFoldAdd by assumption. rewrite fdStrongUpdate_eq in Hindom.
- simpl in Hindom. apply ra_op_proper; last assumption.
- symmetry. apply equivR. eapply fdFoldRedundantRemove. assumption.
- + erewrite fdStrongUpdateCommute by assumption.
- erewrite fdStrongUpdate_neq in Hindom by (now apply not_eq_sym). specialize (IH _ _ Hindom).
- rewrite /comp_finmap fdFoldAdd; last assumption. rewrite fdFoldAdd; last first.
- { apply fdLookup_notin. erewrite fdStrongUpdate_neq by assumption.
- apply fdLookup_notin. assumption. }
- rewrite -assoc (comm v) assoc. apply ra_op_proper; last reflexivity.
- rewrite /comp_finmap in IH. apply IH.
- Qed.
-
- Lemma comp_finmap_move w0 w1 f:
- comp_finmap (w0 · w1) f == w0 · comp_finmap w1 f.
- Proof.
- rewrite /comp_finmap. revert f. apply:fdRect.
- - move=>f1 f2 EQf IH.
- etransitivity; last (etransitivity; first eapply IH).
- + now rewrite EQf.
- + f_equiv. now rewrite EQf.
- - rewrite !fdFoldEmpty. reflexivity.
- - move=>k v f Hnew IH. erewrite !fdFoldAdd by assumption.
- rewrite assoc. apply ra_op_proper; last reflexivity.
- eapply IH.
- Qed.
-
- Lemma comp_finmap_add w0 s i w:
- s i == None ->
- comp_finmap w0 s · w == comp_finmap w0 (s + [fd i <- w] ).
- Proof.
- revert s. apply:fdRect.
- - move=>f1 f2 EQf IH Hnew. rewrite -{2}EQf. rewrite -IH=>{IH}; last first.
- { rewrite EQf. assumption. }
- f_equiv. rewrite /comp_finmap. rewrite EQf. reflexivity.
- - move=>Hnew. rewrite /comp_finmap fdFoldEmpty fdFoldAdd.
- + rewrite !fdFoldEmpty. reflexivity.
- + move=>[].
- - move=>k v f Hnew IH Hfresh. destruct (dec_eq i k) as [EQ|NEQ].
- + subst k. clear IH. rewrite fdStrongUpdateShadow /comp_finmap. erewrite fdFoldAdd by assumption.
- rewrite fdStrongUpdate_eq in Hfresh. destruct Hfresh.
- + erewrite fdStrongUpdateCommute by assumption.
- erewrite fdStrongUpdate_neq in Hfresh by (now apply not_eq_sym).
- rewrite /comp_finmap fdFoldAdd; last assumption. rewrite fdFoldAdd; last first.
- { apply fdLookup_notin. erewrite fdStrongUpdate_neq by assumption.
- now apply fdLookup_notin. }
- specialize (IH Hfresh). unfold comp_finmap in IH.
- rewrite -assoc (comm v) assoc. apply ra_op_proper; last reflexivity.
- apply IH.
- Qed.
-
- Lemma comp_finmap_le w0 s:
- w0 ⊑ comp_finmap w0 s.
- Proof.
- exists (comp_finmap (1 w0) s).
- rewrite comm -comp_finmap_move comm ra_op_unit. reflexivity.
- Qed.
-
- (** Now we define world satisfaction **)
- Lemma world_inv_val {wt n}:
- forall (pv: cmra_valid wt n) {i agP} (Heq: (Invs wt) i = n = Some agP), cmra_valid agP n.
- Proof.
- intros pv i agP Heq.
- destruct wt as [I O]. destruct pv as [HIval _]. specialize (HIval i).
- simpl Invs in Heq. destruct (I i).
- - eapply spredNE, HIval. apply cmra_valid_dist.
- destruct n; first exact:dist_bound.
- exact Heq.
- - destruct n; first exact:bpred. destruct Heq.
- Qed.
-
- (* RJ: Possible simplification: Could we match on (Invs wt i) instead of asking for
- a proof of an equality? The proofs end up having to reason about an equality
- anyway, so it may or may not end up actually simplifying anything. *)
- Definition wsatTotal n' σ (s: nat -f> Wld) m wt :=
- (cmra_valid wt (S n')) /\
- (State wt == ex_own σ) /\
- forall i agP (Heq: (Invs wt) i = S n' = Some agP),
- match (i ∈ m)%de, s i with
- | true , Some w => let P := ra_ag_unInj agP (S n') in unhalved (ı P) w n'
- | false, None => True
- | _ , _ => False
- end.
-
- Global Instance wsatTotal_proper n' σ s:
- Proper (equiv ==> dist (S n') ==> equiv) (wsatTotal n' σ s).
- Proof.
- apply proper_sym_impl_iff_2; try apply _; [].
- move=>m1 m2 EQm wt1 wt2 EQwt. move=>[pv [HS HI]].
- split.
- { eapply spredNE, pv. apply cmra_valid_dist. assumption. }
- split.
- { rewrite <-HS. destruct EQwt as [_ [HwtS _]].
- symmetry. exact HwtS. }
- move=>i agP Heq.
- move:(HI i agP). case/(_ _)/Wrap; last move=>{HI} HI.
- { rewrite -Heq. rewrite EQwt. reflexivity. }
- rewrite -EQm. assumption.
- Qed.
-
- Lemma wsatTotal_dclosed n'1 n'2 σ s m wt:
- n'1 <= n'2 -> wsatTotal n'2 σ s m wt ->
- wsatTotal n'1 σ s m wt.
- Proof.
- intros HLe (pv & Hσ & H).
- assert (pv': cmra_valid wt (S n'1)).
- { eapply dpred, pv. omega. }
- split; first assumption.
- split; [assumption|]. move => {Hσ} i agP Heq.
- case HagP':(Invs wt i) => [agP'|]; last first.
- { exfalso. rewrite HagP' in Heq. exact Heq. }
- move:(H i agP'). case/(_ _)/Wrap; last move=>{H}.
- { now apply equivR. }
- destruct (s i) as [ws|], (i ∈ m)%de; simpl; tauto || (try contradiction); []=>H.
- eapply spredNE; last first.
- - eapply dpred; last exact H. omega.
- - specialize (halve_eq (T:=Props) n'1)=>Huneq. apply Huneq=>{Huneq H ws}.
- apply met_morph_nonexp. move:(Heq). rewrite HagP' in Heq=>Heq''.
- etransitivity.
- + symmetry. eapply ra_ag_unInj_move. omega.
- eapply world_inv_val; first eassumption. apply equivR. eassumption.
- + eapply ra_ag_unInj_dist; last assumption.
- eapply world_invs_valid; first eexact pv'; first reflexivity.
- rewrite Heq. eassumption.
- Qed.
-
- (* It may be possible to use "later_sp" here, but let's avoid indirections where possible. *)
- Program Definition wsat σ m w : SPred :=
- p[(fun n => match n return _ with
- | S (S n') => exists s : nat -f> Wld,
- let wt := comp_finmap w s in
- wsatTotal (S n') σ s m wt
- | _ => True
- end)].
- Next Obligation.
- intros n1 n2 HLe. do 2 (destruct n2; first (intro; exact I)).
- do 2 (destruct n1; first (exfalso; omega)).
- intros (s & HWT). exists s.
- eapply wsatTotal_dclosed, HWT. omega.
- Qed.
-
- Global Instance wsat_dist n σ : Proper (equiv ==> dist n ==> dist n) (wsat σ).
- Proof.
- eapply dist_spred_simpl2; try apply _; [].
- intros m1 m2 w1 w2 m Hlt EQm EQw.
- do 2 (destruct m; first reflexivity).
- do 2 (destruct n as [| n]; [now inversion Hlt |]).
- intros [s HwsT]; exists s; intro wt.
- eapply wsatTotal_proper, HwsT; symmetry; first assumption.
- rewrite /wt. eapply comp_finmap_dist; last reflexivity.
- eapply mono_dist, EQw. omega.
- Qed.
-
- Global Instance wsat_equiv σ : Proper (equiv ==> equiv ==> equiv) (wsat σ).
- Proof.
- move=> m1 m2 EQm w1 w2 EQw. apply dist_refl=>n.
- apply wsat_dist; (assumption || eapply dist_refl; eassumption).
- Qed.
-
- Lemma wsat_valid {σ m w k} :
- wsat σ m w (S (S k)) -> cmra_valid w (S (S k)).
- Proof.
- move=> [s [pv _]]. eapply cmra_valid_ord, pv.
- exact:comp_finmap_le.
- Qed.
-
- End WorldSatisfaction.
-
- Section PrimitiveViewShifts.
- Local Obligation Tactic := intros.
-
- Program Definition preVS m1 m2 P w : SPred :=
- p[(fun n => forall (wf: Wld) k mf σ (HLe : S k < n)
- (HD : mf # m1 ∪ m2)
- (HE : wsat σ (m1 ∪ mf) (w · wf) (S (S k))),
- exists w', P w' (S (S k))
- /\ wsat σ (m2 ∪ mf) (w' · wf) (S (S k)))].
- Next Obligation.
- repeat intro.
- by inversion HLe.
- Qed.
- Next Obligation.
- intros n1 n2 HLe HP wf; intros.
- destruct (HP wf k mf σ) as [w2 [HP' HE'] ].
- - omega.
- - assumption.
- - assumption.
- - exists w2.
- split; assumption.
- Qed.
-
- Program Definition pvs m1 m2 : Props -n> Props :=
- n[(fun P => m[(preVS m1 m2 P)])].
- Next Obligation.
- apply dist_spred_simpl; try apply _; [].
- intros w1 w2 n' HLt EQw; destruct n as [| n]; [now inversion HLt |]. intros HV wf; intros.
- edestruct HV as [w1' [HP HE']]; try eassumption.
- - eapply wsat_dist, HE; first reflexivity.
- + eapply cmra_op_dist; last reflexivity. eexact EQw.
- + omega.
- - exists w1'. split; first assumption.
- eapply wsat_dist, HE'; try reflexivity; omega.
- Qed.
- Next Obligation.
- intros w1 w2 [wd EQw] n HV wf; intros.
- edestruct (HV (wd · wf) k mf) as [w1' [HP HE']]; try eassumption.
- - eapply wsat_dist, HE; try reflexivity.
- rewrite assoc (comm w1) EQw. reflexivity.
- - exists (w1' · wd). split.
- + eapply propsMW, HP. exists wd; now rewrite comm.
- + eapply wsat_dist, HE'; try reflexivity. now rewrite assoc.
- Qed.
- Next Obligation.
- apply dist_props_simpl; try apply _; [].
- intros p1 p2 w n' HLt EQp HV w1; intros.
- edestruct HV as [w2 [HP' HE']]; try eassumption; [].
- exists w2. split; last assumption.
- apply EQp; assumption || omega.
- Qed.
-
- Global Instance pvs_mproper:
- Proper (equiv ==> equiv ==> equiv) pvs.
- Proof.
- move=>m11 m12 EQm1 m21 m22 EQm2 P w n. split=>Hvs.
- - move=>wf; intros.
- destruct (Hvs wf k mf σ) as [w' [HP HW]]; [assumption|de_auto_eq|now rewrite EQm1|].
- exists w'. split; first assumption. now rewrite <-EQm2.
- - move=>wf; intros.
- destruct (Hvs wf k mf σ) as [w' [HP HW]]; [assumption|de_auto_eq|now rewrite <-EQm1|].
- exists w'. split; first assumption. now rewrite EQm2.
- Qed.
-
- (* Some global properties are proven here directly. *)
- Lemma pvsEnt P m :
- P ⊑ pvs m m P.
- Proof.
- intros w0 n HP wf; intros.
- exists w0. split; last assumption.
- eapply propsMN, HP. omega.
- Qed.
-
- Lemma pvsMon P Q m1 m2 :
- P ⊑ Q -> pvs m1 m2 P ⊑ pvs m1 m2 Q.
- Proof.
- move => HPQ w0 n HvsP.
- intros wf k mf σ Hlt HD HSat.
- destruct (HvsP wf _ mf σ Hlt) as (w1 & HP & HSat2); [de_auto_eq|assumption|].
- exists w1. split; last assumption.
- eapply HPQ, HP.
- Qed.
-
- End PrimitiveViewShifts.
-
-
- Section WeakestPre.
-
- Local Obligation Tactic := intros; eauto with typeclass_instances.
-
- Definition safeExpr e σ :=
- is_value e \/
- (exists σ' e' ef, prim_step (e, σ) (e', σ') ef).
-
- Definition wpFP safe (WP : mask -n> expr -n> vPred -n> Props) m e φ w n :=
- (forall (HV : is_value e),
- n > 1 -> φ (exist _ e HV) w n) /\
- forall wf k mf σ (HLt : S k < n) (HD : mf # m)
- (HE : wsat σ (m ∪ mf) (w · wf) (S (S k))),
- (forall e' σ' ef (HStep : prim_step (e, σ) (e', σ') ef),
- exists wret wfk, WP m e' φ wret (S k)
- /\ match ef with None => True |
- Some ef' => WP de_full ef' (umconst ⊤) wfk (S k) end
- /\ wsat σ' (m ∪ mf) (wfk · wret · wf) (S k)) /\
- (forall HSafe : safe = true, safeExpr e σ).
-
- (* Define the function wp will be a fixed-point of *)
- Program Definition wpF safe : (mask -n> expr -n> vPred -n> Props) -> (mask -n> expr -n> vPred -n> Props) :=
- fun WP => n[(fun m => n[(fun e => n[(fun φ => m[(fun w => p[(wpFP safe WP m e φ w)] )])])])].
- Next Obligation.
- split.
- - intros. exact: bpred.
- - intros. inversion HLt.
- Qed.
- Next Obligation.
- intros n1 n2 HLe Hwp. split.
- { intros. destruct Hwp as [Hwp _]. eapply dpred, Hwp; assumption || omega. }
- intros wf k mf σ HLt HD HE. destruct Hwp as [_ Hwp].
- destruct (Hwp wf k mf σ) as [HSt HSf]; first omega; try assumption; [].
- split; intros.
- - specialize (HSt _ _ _ HStep); destruct HSt as [w'' [HWP HE']].
- exists w''. eexists. eassumption.
- - now auto.
- Qed.
- Next Obligation.
- eapply dist_spred_simpl; first now apply _.
- intros w1 w2 n' HLt EQw [HV Hwp]; simpl. split.
- { intros. eapply spredNE, HV; last by assumption. rewrite EQw. reflexivity. }
- intros. edestruct (Hwp wf) as [HS HSf]; try eassumption;
- [eapply wsat_dist, HE; [reflexivity| eapply cmra_op_dist; eassumption || reflexivity | omega] |].
- split; intros.
- - specialize (HS _ _ _ HStep); destruct HS as [w1'' [HWP HE']]. exists w1''.
- eexists; eassumption.
- - now auto.
- Qed.
- Next Obligation.
- intros w1 w2 [wd EQw] n. simpl; intros [HV Hwp]. split; intros.
- { eapply propsMW, HV; last by assumption. eexists. eassumption. }
- edestruct (Hwp (wd · wf) k mf) as [HS HSf]; try assumption; [|].
- { eapply wsat_dist, HE; try reflexivity. now rewrite -EQw assoc (comm w1). }
- split; intros.
- - specialize (HS _ _ _ HStep); destruct HS as [wret [wfk [HWR [HWF HE']]]].
- exists (wret · wd). exists wfk. split; [|split].
- + eapply propsMW, HWR. exists wd; now rewrite comm.
- + assumption.
- + eapply wsat_dist, HE'; try reflexivity. now rewrite !assoc.
- - now auto.
- Qed.
- Next Obligation.
- eapply dist_props_simpl; first now apply _.
- intros φ1 φ2 w k HLt EQφ [HV Hwp]; simpl; split; intros.
- { eapply spredNE, HV; last by assumption. eapply mmorph_proper; last reflexivity. eapply mono_dist, EQφ. assumption. }
- clear HV. edestruct Hwp as [HS HSf]; try eassumption; [].
- split; intros.
- - specialize (HS _ _ _ HStep); destruct HS as [wret [wfk [HWR [HWF HE']]]].
- exists wret wfk. split; last tauto.
- eapply (met_morph_nonexp (WP _ _)), HWR; [symmetry; eassumption | omega].
- - now auto.
- Qed.
- Next Obligation.
- intros e1 e2 EQe φ w. destruct n as [| n]; first exact:dist_bound.
- simpl in EQe; hnf in EQe; subst e2; reflexivity.
- Qed.
- Next Obligation.
- move=>m1 m2 EQm e φ w. destruct n; first exact:dist_bound.
- move:φ w e. split=>[] [HV Hwp]; split; intros.
- - eapply HV. assumption.
- - destruct (Hwp wf k mf σ) as (Hstep & Hsafe); [assumption|de_auto_eq|now rewrite EQm|].
- split; last assumption.
- move=>? ? ? Hprim. specialize (Hstep _ _ _ Hprim).
- destruct Hstep as (wfk & wret & Hwp' & Hwp'' & HW).
- exists wfk wret. split; last split.
- + eapply spredNE, Hwp'. eapply mmorph_proper; last reflexivity.
- eapply pcm_dist_inherit, mmorph_proper; last reflexivity.
- eapply mmorph_proper; last reflexivity. eapply met_morph_nonexp.
- eapply dist_mono, EQm.
- + assumption.
- + now rewrite -EQm.
- - eapply HV. assumption.
- - destruct (Hwp wf k mf σ) as (Hstep & Hsafe); [assumption|de_auto_eq|now rewrite -EQm|].
- split; last assumption.
- move=>? ? ? Hprim. specialize (Hstep _ _ _ Hprim).
- destruct Hstep as (wret & wfk & Hwp' & Hwp'' & HW).
- exists wret wfk. split; last split.
- + eapply spredNE, Hwp'. eapply mmorph_proper; last reflexivity.
- eapply pcm_dist_inherit, mmorph_proper; last reflexivity.
- eapply mmorph_proper; last reflexivity. eapply met_morph_nonexp.
- symmetry. eapply dist_mono, EQm.
- + assumption.
- + now rewrite EQm.
- Qed.
-
- Instance contr_wpF safe : contractive (wpF safe).
- Proof.
- intros n WP1 WP2 EQWP m e φ w k HLt.
- split; intros [HV Hwp]; (split; first by auto); intros; edestruct Hwp as [HS HSf]; try eassumption; [|].
- - split; intros.
- + clear HV; specialize (HS _ _ _ HStep); destruct HS as [wret [wfk [HWR [HWF HE']]]].
- exists wret wfk.
- split; [| split; [| assumption] ].
- * eapply EQWP; try eassumption; omega.
- * intros. destruct ef; last done. eapply EQWP, HWF; try assumption; omega.
- + now auto.
- - split; intros.
- + clear HV; specialize (HS _ _ _ HStep); destruct HS as [wret [wfk [HWR [HWF HE']]]].
- exists wret wfk.
- split; [| split; [| assumption] ].
- * eapply EQWP; try eassumption; omega.
- * intros. destruct ef; last done. eapply EQWP, HWF; try assumption; omega.
- + now auto.
- Qed.
-
- Definition wp safe : mask -n> expr -n> vPred -n> Props :=
- fixp (wpF safe) (umconst (umconst (umconst ⊤))).
-
- Lemma unfold_wp safe :
- wp safe == (wpF safe) (wp safe).
- Proof.
- unfold wp; apply fixp_eq.
- Qed.
-
- Global Opaque wp.
-
- (* Some global properties are proven here directly. *)
- Lemma wp1 safe m e φ w:
- wp safe m e φ w 1%nat.
- Proof.
- split; intros; exfalso; omega.
- Qed.
-
- Lemma wpValue e (HV : is_value e) safe m φ :
- φ (exist _ e HV) ⊑ wp safe m e φ.
- Proof.
- rewrite unfold_wp.
- intros w n Hφ. split; last (intros; split; intros).
- - intros. eapply spredNE, Hφ. eapply mmorph_proper; last reflexivity.
- apply (met_morph_nonexp φ). destruct n; first done. reflexivity.
- - contradiction (values_stuck _ HV). repeat eexists. eassumption.
- - unfold safeExpr. auto.
- Qed.
-
- End WeakestPre.
-
- Section DerivedForms.
- (* We define the derived forms here, so that iris_meta can also use them. *)
-
- (** View Shifts **)
- Definition vs m1 m2 P Q : Props :=
- □(P → pvs m1 m2 Q).
-
- Global Instance vsProper: Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv) vs.
- Proof.
- move=>m11 m12 EQm1 m21 m22 EQm2 P1 P2 EQP Q1 Q2 EQQ. unfold vs.
- apply box_equiv. apply impl_equiv; first assumption.
- apply equiv_morph; last assumption.
- now rewrite EQm1 EQm2.
- Qed.
-
- Lemma vsIntro R m1 m2 P Q:
- □R ⊑ vs m1 m2 P Q <-> □R ∧ P ⊑ pvs m1 m2 Q.
- Proof.
- split=>H.
- - unfold vs in H.
- apply and_impl. etransitivity; last by eapply box_elim. assumption.
- - unfold vs; apply box_intro. rewrite <-and_impl. assumption.
- Qed.
-
- Lemma vsValid m1 m2 P Q:
- valid (vs m1 m2 P Q) <-> P ⊑ pvs m1 m2 Q.
- Proof.
- rewrite ->top_valid, <-box_top. split=>H.
- - etransitivity; last by erewrite <-vsIntro. apply and_R; split; last reflexivity.
- rewrite ->box_top. apply top_true.
- - etransitivity; first apply vsIntro; last reflexivity.
- rewrite <-H. apply and_projR.
- Qed.
-
- (** Hoare Triples **)
- Definition ht safe m P e Q := □(P → wp safe m e (pvs m m <M< Q)).
-
- Global Instance ht_proper safe: Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv) (ht safe).
- Proof.
- move=>m0 m1 EQm P0 P1 HEQP e0 e1 HEQe Q0 Q1 HEQQ.
- unfold ht. apply box_equiv. apply impl_equiv; first assumption.
- apply equiv_morph.
- - hnf in HEQe. subst e1.
- eapply mmorph_inherit. eapply equiv_morph; last reflexivity.
- eapply mmorph_inherit, morph_resp. assumption.
- - eapply dist_refl=>n. eapply ndist_umcomp; eapply dist_refl; last assumption.
- rewrite EQm. reflexivity.
- Qed.
-
- Lemma htIntro R safe m e P Q:
- □R ⊑ ht safe m P e Q <-> □R ∧ P ⊑ wp safe m e (pvs m m <M< Q).
- Proof.
- split=>H.
- - unfold ht in H.
- apply and_impl. etransitivity; last by eapply box_elim. assumption.
- - unfold ht; apply box_intro. rewrite <-and_impl. assumption.
- Qed.
-
- Lemma htValid safe m e P Q:
- valid (ht safe m P e Q) <-> P ⊑ wp safe m e (pvs m m <M< Q).
- Proof.
- rewrite ->top_valid, <-box_top. split=>H.
- - etransitivity; last by erewrite <-htIntro. apply and_R; split; last reflexivity.
- rewrite ->box_top. apply top_true.
- - etransitivity; first apply htIntro; last reflexivity.
- rewrite <-H. apply and_projR.
- Qed.
-
- End DerivedForms.
-
-End IRIS_PLOG.
-
-Module IrisPlog (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) : IRIS_PLOG RL C R WP CORE.
- Include IRIS_PLOG RL C R WP CORE.
-End IrisPlog.
diff --git a/iris_vs_rules.v b/iris_vs_rules.v
deleted file mode 100644
index 0122b03dd07ee68eae55289a430ce71062aba8cb..0000000000000000000000000000000000000000
--- a/iris_vs_rules.v
+++ /dev/null
@@ -1,263 +0,0 @@
-Require Import Ssreflect.ssreflect Ssreflect.ssrfun Omega.
-Require Import world_prop core_lang iris_core iris_plog.
-Require Import ModuRes.RA ModuRes.DecEnsemble ModuRes.SPred ModuRes.BI ModuRes.PreoMet ModuRes.Finmap ModuRes.Agreement ModuRes.CMRA.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Module Type IRIS_VS_RULES (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE).
- Export PLOG.
-
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
- Local Open Scope iris_scope.
- Local Open Scope de_scope.
-
- Implicit Types (P Q R : Props) (w : Wld) (n i k : nat) (m : DecEnsemble nat) (r : res) (σ : state) (g : RL.res).
-
- Section ViewShiftProps.
-
- Lemma pvsTimeless m P :
- timeless P ∧ ▹P ⊑ pvs m m P.
- Proof.
- intros w n [HTL Hp] ?; intros.
- exists w. split; last assumption.
- destruct n as [| n]; [exfalso;omega |]; simpl in Hp.
- destruct n as [| n]; first omega.
- eapply propsMN, HTL, Hp.
- - omega.
- - omega.
- Qed.
-
- Lemma pvsOpen i P :
- (inv i P) ⊑ pvs (de_sing i) de_emp (▹P).
- Proof.
- intros w n HInv.
- destruct n; first exact:bpred. repeat intro.
- destruct HInv as [Pr HInv].
- destruct HE as [rs [pv [HS HM]]]. simpl in HInv.
- move:(HM i (ra_ag_inj (ı' (halved P)))). case/(_ _)/Wrap.
- { clear -HInv pv HLe. eapply world_invs_extract; first assumption; last first.
- - eapply mono_dist, HInv. omega.
- - etransitivity; last eapply comp_finmap_le. exists wf. now rewrite comm. }
- erewrite de_in_true by de_tauto.
- destruct (rs i) as [wi |] eqn: HLr; last by move=>[]. move=>HP.
- exists (w · wi). split.
- { simpl. eapply propsMW; first (eexists; reflexivity). eapply spredNE, HP.
- simpl. rewrite isoR. reflexivity. }
- clear HInv HP.
- exists (fdStrongUpdate i None rs). intros wt.
- assert (Heqwt: comp_finmap (w · wf) rs == wt).
- { rewrite /wt (comm _ wi) -assoc (comp_finmap_move wi).
- rewrite (comm wi) -comp_finmap_remove; last now rewrite HLr. reflexivity. }
- split.
- { eapply spredNE, pv. rewrite -Heqwt. reflexivity. }
- split.
- - rewrite /= -Heqwt. assumption.
- - move=>j agP Hlu. rewrite (comm de_emp) de_emp_union. move:(HM j agP)=>{HM}.
- case/(_ _)/Wrap.
- { rewrite Heqwt. exact Hlu. }
- destruct (j ∈ mf) eqn:Hm.
- + erewrite de_in_true by de_tauto.
- destruct (dec_eq i j) as [EQ|NEQ].
- { exfalso. subst j. move:(HD i) Hm. clear. de_tauto. }
- erewrite fdStrongUpdate_neq by assumption. done.
- + destruct (dec_eq i j) as [EQ|NEQ].
- { move=>_. subst j. rewrite fdStrongUpdate_eq. done. }
- erewrite de_in_false by de_tauto.
- erewrite fdStrongUpdate_neq by assumption. done.
- Qed.
-
- Lemma pvsClose i P :
- (inv i P ∧ ▹P) ⊑ pvs de_emp (de_sing i) ⊤.
- Proof.
- intros w n [HInv HP] wf; intros. destruct n; first by inversion HLe.
- destruct HInv as [Pr HInv].
- destruct HE as [rs [pv [HS HM]]].
- case HLu:(Invs w i) => [μ |] ; simpl in HInv; last first.
- { exfalso. rewrite HLu in HInv. destruct HInv. }
- exists (1 w). split; first exact I.
- exists (fdStrongUpdate i (Some w) rs). intros wt.
- assert (HeqP: (Invs (comp_finmap (w · wf) rs)) i = S (S k) =
- Some (ra_ag_inj (ı' (halved P)))).
- { eapply world_invs_extract; first assumption; last first.
- - etransitivity; first (eapply mono_dist, HInv; omega). reflexivity.
- - rewrite <-comp_finmap_le. exists wf. now rewrite comm. }
- assert (Heqwt: comp_finmap (w · wf) rs == wt).
- { rewrite /wt. erewrite <-comp_finmap_add; last first.
- { move:(HM i (ra_ag_inj (ı' (halved P))) HeqP).
- erewrite de_in_false; last first.
- { move:(HD i). clear. de_tauto. }
- destruct (rs i); first move=> [].
- move=>_. reflexivity. }
- rewrite -(comm w) -(comp_finmap_move w) assoc (comm _ (1w)) ra_op_unit.
- reflexivity. }
- split.
- { eapply spredNE, pv. rewrite -Heqwt. reflexivity. }
- split.
- - rewrite /State -Heqwt. assumption.
- - move=>j agP Hlu. destruct (dec_eq i j) as [EQ|NEQ].
- + subst j. erewrite de_in_true by de_tauto.
- rewrite fdStrongUpdate_eq. clear HS HM. simpl in HP.
- eapply spredNE, dpred, HP; last omega.
- rewrite ->Heqwt, ->Hlu in HeqP. simpl. simpl in HeqP.
- etransitivity; last first.
- * assert(Heq:=halve_eq (T:=Props) (S k)). apply Heq=>{Heq}.
- eapply (met_morph_nonexp ı). eapply ra_ag_unInj_dist; last (symmetry; eexact HeqP).
- exact I.
- * simpl. rewrite isoR. reflexivity.
- + move:(HM j agP)=>{HM}. case/(_ _)/Wrap.
- { rewrite Heqwt. assumption. }
- rewrite comm de_emp_union. destruct (j ∈ mf) eqn:Hjin.
- * erewrite de_in_true by de_tauto. by erewrite fdStrongUpdate_neq.
- * erewrite de_in_false by de_tauto. by erewrite fdStrongUpdate_neq.
- Qed.
-
- Lemma pvsTrans P m1 m2 m3 (HMS : m2 ⊑ m1 ∪ m3) :
- pvs m1 m2 (pvs m2 m3 P) ⊑ pvs m1 m3 P.
- Proof.
- intros w1 n HP wf; intros.
- destruct (HP wf _ mf σ HLe) as (w2 & HP2 & HSat2); [ de_auto_eq | by auto | ].
- destruct (HP2 wf k mf σ) as (w3 & HP3 & HSat3);
- [ omega | de_auto_eq | auto | ].
- exists w3; split; assumption.
- Qed.
-
- Lemma pvsFrameMask P m1 m2 mf (HDisj : mf # m1 ∪ m2) :
- pvs m1 m2 P ⊑ pvs (m1 ∪ mf) (m2 ∪ mf) P.
- Proof.
- move => w0 n HvsP wf; intros.
- edestruct (HvsP wf k (mf ∪ mf0)) as (w2 & HP & HSat2); eauto.
- - de_auto_eq.
- - rewrite assoc. eassumption.
- - exists w2. split; first assumption.
- rewrite -assoc. assumption.
- Qed.
-
- Lemma pvsFrameRes P Q m1 m2:
- (pvs m1 m2 P) * Q ⊑ pvs m1 m2 (P * Q).
- Proof.
- move => w0 n. destruct n; first (intro; exact:bpred).
- intros [[wp wq] [HEr [HvsP HQ]]].
- move => wf mf σ k Hlt HD HSat.
- edestruct (HvsP (wq · wf) mf) as (w2 & HP & HSat2); eauto.
- { simpl morph. eapply wsat_dist, HSat;[reflexivity| |reflexivity].
- simpl in HEr. rewrite assoc. apply cmra_op_dist; last reflexivity.
- eapply mono_dist, HEr. omega. }
- exists (w2 · wq). split.
- - exists (w2, wq). split; last split.
- + rewrite [ra_op]lock. simpl. reflexivity.
- + assumption.
- + eapply propsMN, HQ. omega.
- - now rewrite -assoc.
- Qed.
-
- Definition ownLP (P : RL.res -> Prop) : {s : RL.res | P s} -n> Props :=
- n[(ownL)] <M< inclM.
-
- Lemma pvsGhostUpd m g (P : RL.res -> Prop) (HU : g â‡âˆˆ P) :
- ownL g ⊑ pvs m m (xist (ownLP P)).
- Proof.
- unfold ownLP. intros w n. destruct n; first (intros; exact:bpred).
- intros [g' Hg'] wf; intros.
- destruct HE as [rs HwsT ]. simpl in HwsT. rewrite ->comp_finmap_move in HwsT.
- destruct HwsT as [pv [HS HI]]. move:(pv). move/cmra_prod_valid=>[HIval]. move/cmra_prod_valid=>[HSval Hgval].
- destruct w as [I0 [S0 g0]]. simpl in Hg'.
- destruct (HU (g' · Res (comp_finmap wf rs))) as [g1 [HP HVal1] ].
- - clear - Hgval Hg'. simpl in Hgval. now rewrite assoc (comm g) Hg'.
- - exists (I0, (S0, g1 · g')). split.
- + simpl. exists (exist _ _ HP). simpl.
- eexists. now erewrite comm.
- + exists rs. simpl. rewrite comp_finmap_move. clear HP Hgval.
- split.
- { split; last split; try assumption; [].
- now rewrite ->assoc in HVal1. }
- done.
- Qed.
-
- Program Definition inv' m : Props -n> {n : nat | n ∈ m = true } -n> Props :=
- n[(fun P => n[(fun N => inv (proj1_sig N) P)])].
- Next Obligation.
- intros [i Hi] [i' Hi'] EQi; destruct n as [| n]; [apply dist_bound |].
- cbv in EQi. subst i'. apply dist_refl; reflexivity.
- Qed.
- Next Obligation.
- intros p1 p2 EQp i; simpl morph.
- apply inv_dist. assumption.
- Qed.
-
- Lemma fresh_region (w : Wld) (s: nat -f> Wld) m (HInf : de_infinite m) :
- exists i, i ∈ m = true /\ Invs w i = None /\ s i = None.
- Proof.
- pose (l := (dom (Invs w) ++ dom s)%list).
- pose (j := Lists.list_max l).
- destruct (HInf (S j)) as [i [HGe Hm] ].
- exists i; split; [assumption |]; clear - HGe.
- specialize (Lists.list_max_ge l i)=>Hin. subst l.
- split; apply fdLookup_notin_strong=>Hin'; move:Hin.
- - case/(_ _)/Wrap; first (apply List.in_app_iff; tauto).
- intros Hle. subst j. omega.
- - case/(_ _)/Wrap; first (apply List.in_app_iff; tauto).
- intros Hle. subst j. omega.
- Qed.
-
- Lemma pvsNewInv P m (HInf : de_infinite m) :
- ▹P ⊑ pvs m m (xist (inv' m P)).
- Proof.
- intros w n HP wf; intros.
- destruct n as [| n]; [now inversion HLe | simpl in HP].
- case:HE=>rs. cbv zeta. rewrite comp_finmap_move. move =>[pv [HS HI]].
- destruct (fresh_region (w · comp_finmap wf rs) rs m HInf) as [i [Hm [HLi Hrsi]]].
- pose (w' := (fdStrongUpdate i (Some (ra_ag_inj (ı' (halved P)))) fdEmpty, 1 (snd w))).
- exists w'. split.
- { eexists (exist _ i Hm). eexists. rewrite /w' /= DecEq_refl.
- apply dist_refl. symmetry. eapply ra_ag_dupl. }
- exists (fdStrongUpdate i (Some w) rs). simpl. simpl in HLi.
- rewrite comp_finmap_move. erewrite <-comp_finmap_add by (now apply equivR). rewrite (comm _ w).
- split.
- { destruct pv as [pvI pvR]. split.
- - rewrite /w' /= =>j /=. destruct (dec_eq i j).
- + subst j. rewrite HLi /=. done.
- + exact:(pvI j).
- - rewrite assoc /w' /= !ra_op_unit. exact pvR. }
- split.
- - rewrite /State assoc /w' /= ra_op_unit. assumption.
- - move=>j agP Heq. destruct (dec_eq i j) as [EQ|NEQ].
- + subst j. erewrite de_in_true by de_tauto. rewrite fdStrongUpdate_eq.
- move:(Heq)=>Heq'. move:Heq. rewrite /= DecEq_refl HLi /==>Heq.
- eapply spredNE, dpred, HP; last omega.
- eapply mmorph_proper; last reflexivity.
- etransitivity; last first.
- * assert(Hheq:=halve_eq (T:=Props) (S k)). apply Hheq=>{Hheq}.
- eapply (met_morph_nonexp ı). eapply ra_ag_unInj_dist; last eexact Heq.
- exact I.
- * simpl. rewrite isoR. reflexivity.
- + erewrite fdStrongUpdate_neq by assumption.
- move:(HI j agP)=>{HI Hrsi HLi Hm}. case/(_ _)/Wrap.
- { rewrite -Heq. simpl. destruct (dec_eq i j); last reflexivity.
- contradiction. }
- tauto.
- Qed.
-
- Lemma pvsOwnValid m w:
- own w ⊑ pvs m m (own w ∧ pcmconst (cmra_valid w)).
- Proof.
- intros w0 n. destruct n; first (intro; exact:bpred).
- move=>Hown wf; intros. exists w0.
- split; last done. split; first (eapply propsMN, Hown; omega).
- destruct HE as [rs [pv _]]. simpl. destruct Hown as [wr Heq]. simpl in Heq.
- eapply cmra_valid_ord, spredNE, pv; last first.
- - eapply cmra_valid_dist. erewrite comp_finmap_move.
- eapply cmra_op_dist; last reflexivity. symmetry. eapply mono_dist, Heq. omega.
- - rewrite -assoc. eexists. now erewrite (comm _ w).
- Qed.
-
- End ViewShiftProps.
-
- Global Opaque pvs.
- Global Opaque wpF.
-
-End IRIS_VS_RULES.
-
-Module IrisVSRules (RL : VIRA_T) (C : CORE_LANG) (R: IRIS_RES RL C) (WP: WORLD_PROP R) (CORE: IRIS_CORE RL C R WP) (PLOG: IRIS_PLOG RL C R WP CORE): IRIS_VS_RULES RL C R WP CORE PLOG.
- Include IRIS_VS_RULES RL C R WP CORE PLOG.
-End IrisVSRules.
diff --git a/lang.v b/lang.v
deleted file mode 100644
index 84e02853815c0aaf03b1d889c9bc58888775e342..0000000000000000000000000000000000000000
--- a/lang.v
+++ /dev/null
@@ -1,44 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Import List.
-Require Import core_lang.
-Require Import ModuRes.Relations ModuRes.CSetoid.
-
-(******************************************************************)
-(** * Derived language with threadpool steps **)
-(******************************************************************)
-
-Set Bullet Behavior "Strict Subproofs".
-
-Module Lang (C : CORE_LANG).
-
- Export C.
-
- Arguments atomic_step {_ _ _ _} _ _ _.
-
- (** Thread pools **)
- Definition tpool : Type := list expr.
-
- (** Machine configurations **)
- Definition cfg : Type := (tpool * state)%type.
-
- (* Threadpool stepping relation *)
- Definition option_to_list {A: Type} (o: option A): list A :=
- match o with
- | None => []
- | Some a => [a]
- end.
-
- Inductive step (Ï Ï' : cfg) : Prop :=
- | step_atomic : forall e e' ef σ σ' t1 t2,
- Ï = (t1 ++ e :: t2, σ) ->
- Ï' = (t1 ++ e' :: t2 ++ option_to_list ef, σ') ->
- prim_step (e, σ) (e', σ') ef ->
- step Ï Ï'
- .
-
- (* Reflexive, transitive closure of the step relation *)
- Global Instance cfg_type : Setoid cfg := discreteType.
- Definition steps := refl_trans_closure step.
- Definition stepn := n_closure step.
-
-End Lang.
diff --git a/lib/ModuRes/.dir-locals.el b/lib/ModuRes/.dir-locals.el
deleted file mode 100644
index a13fe1a9d4d5f45b8e23c2ae0a53f5ab40e51a44..0000000000000000000000000000000000000000
--- a/lib/ModuRes/.dir-locals.el
+++ /dev/null
@@ -1,8 +0,0 @@
-;;; Directory Local Variables
-;;; See Info node `(emacs) Directory Variables' for more information.
-
-((coq-mode
- (coq-load-path
- (rec "../../" "_"))))
-
-
diff --git a/lib/ModuRes/Agreement.v b/lib/ModuRes/Agreement.v
deleted file mode 100644
index 4f8e9f8d2a2f021a6bbfe3a6065fc32c36ce2215..0000000000000000000000000000000000000000
--- a/lib/ModuRes/Agreement.v
+++ /dev/null
@@ -1,614 +0,0 @@
-Require Import Ssreflect.ssreflect Ssreflect.ssrfun Omega.
-Require Import SPred PreoMet RA CMRA.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Local Open Scope ra_scope.
-Local Open Scope predom_scope.
-Local Open Scope general_if_scope.
-
-Section Agreement.
- (* This is more complex than above, and it does not require a decidable equality. However, it needs
- a metric. It also comes with a CMRA. *)
- Context {T} `{T_ty : Setoid T} {mT: metric T}.
- Local Open Scope ra_scope.
- Local Open Scope nat.
-
- Implicit Type (v: SPred).
-
- Definition cvChain v (ts: chain T): Prop :=
- forall n i (HLe: n <= i) (pv: v i), ts i = n = ts n.
-
- CoInductive ra_agree : Type :=
- ag_inj (v: SPred) (ts: chain T) (tsx: cvChain v ts).
- (* To understand why we need a chain of Ts, imagine for a moment that we would not.
- How would we define the limit of a chain of ra_agree? Clearly, we would have
- to take the limit of the embedded Ts to get the T of the limit. To call the
- limit function on Ts, we need to prove that the chain of Ts converges.
- However, that is, in general, not the case: Because of the way (dist n)
- on ra_agree is defined (which is motived by needing a commutative multiplication),
- the Ts of a convering ra_agree chain converge only insofar as the ra_agree are valid.
- By using a chain of Ts here, we can entirely avoid even calling the limit function
- on T, sidestepping the issue.
- RJ: The only alternative I see is to declare that the limit function always has to return
- something, no matter whether the chain converges. Of course, only for converging chains
- it needs to produce anything sensible. However, it is unclear to me how to define
- limits of sigma-types in that setting. *)
-
- Local Ltac ra_ag_destr := repeat (match goal with [ x : ra_agree |- _ ] => destruct x end).
-
- Definition ra_ag_ts : ra_agree -> chain T :=
- fun x => match x with ag_inj _ ts _ => ts end.
-
- Global Instance ra_agree_unit : RA_unit ra_agree := fun x => x.
- Global Instance ra_ag_v : CMRA_valid _ :=
- fun x => match x with
- | ag_inj v _ _ => v
- end.
- Global Instance ra_agree_valid : RA_valid _ := compose valid_sp ra_ag_v.
-
- Global Program Instance ra_ag_op : RA_op _ :=
- fun x y => ag_inj p[(fun n => ra_ag_v x n /\ ra_ag_v y n /\ ra_ag_ts x n = n = ra_ag_ts y n)] (ra_ag_ts x) _.
- Next Obligation.
- split; last split; exact:dist_bound||exact:bpred.
- Qed.
- Next Obligation.
- intros n m ? (pv1 & pv2 & EQ). split; last split.
- - eapply dpred, pv1. assumption.
- - eapply dpred, pv2. assumption.
- - ra_ag_destr. simpl.
- transitivity (ts n); last by eapply tsx.
- transitivity (ts0 n); first by (symmetry; eapply tsx0).
- eapply mono_dist; eassumption.
- Qed.
- Next Obligation.
- move=> n i HLe [pv1 [pv2 EQ]].
- destruct x as [v ts tsx].
- eapply tsx; assumption.
- Qed.
-
-
- Program Definition ra_ag_inj (t: T): ra_agree :=
- ag_inj top_sp (fun _ => t) (fun _ _ _ _ => _).
- Next Obligation.
- eapply dist_refl. reflexivity.
- Qed.
-
- Lemma ra_ag_inj_valid t:
- ra_agree_valid (ra_ag_inj t).
- Proof.
- intros n. exact I.
- Qed.
-
- Definition ra_agree_eq (x y: ra_agree): Prop :=
- match x, y with
- | ag_inj v1 ts1 _, ag_inj v2 ts2 _ => v1 == v2 /\ (forall n, v1 n -> ts1 n = n = ts2 n)
- (* Also, only the n-valid elements have to be only n-equal. Otherwise,
- commutativity breaks: Beyond the end of validity of the product,
- the two factors can differ, so using either one for the chain of
- the product means the result changes when the order of factors
- is changed. *)
- end.
-
- Global Instance ra_agree_eq_equiv : Equivalence ra_agree_eq.
- Proof.
- split; repeat intro; ra_ag_destr; try (exact I || contradiction); [| |]. (* 3 goals left. *)
- - split; intros; reflexivity.
- - destruct H. split; intros; first by symmetry.
- symmetry. apply H0. rewrite H. assumption.
- - destruct H, H0.
- split; first (etransitivity; now eauto).
- intro; etransitivity; [now eapply H1 | ].
- eapply H2. rewrite -H. assumption.
- Qed.
- Global Instance ra_agree_type : Setoid ra_agree := mkType ra_agree_eq.
-
- Lemma ra_ag_dupl (x : ra_agree):
- x · x == x.
- Proof.
- ra_ag_destr. split.
- - split; simpl; first by firstorder. now firstorder.
- - move=>n ?. reflexivity.
- Qed.
-
- Global Instance ra_agree_res : RA ra_agree.
- Proof.
- split; repeat intro.
- - ra_ag_destr; [].
- destruct H as (HeqV1 & HeqT1), H0 as (HeqV2 & HeqT2).
- split.
- + split; intros (pv1 & pv2 & Heq).
- * move:(pv1)(pv2)=>pv1' pv2'. simpl in *. rewrite ->HeqV1 in pv1'. rewrite ->HeqV2 in pv2'.
- split; first assumption. split; first assumption.
- erewrite <-HeqT1, <-HeqT2 by assumption. eapply Heq; eassumption.
- * move:(pv1)(pv2)=>pv1' pv2'. simpl in *. rewrite <-HeqV1 in pv1'. rewrite <-HeqV2 in pv2'.
- split; first assumption. split; first assumption.
- rewrite ->HeqT1, ->HeqT2 by assumption. eapply Heq; eassumption.
- + intros n [pv1 [pv1' _]]. by apply: HeqT1.
- - ra_ag_destr; []. split.
- + intros n. rewrite /=. split.
- * intros [pv1 [[pv2 [pv3 EQ']] EQ]].
- split_conjs; try assumption; []. by rewrite EQ.
- * intros [[pv1 [pv2 EQ']] [pv3 EQ]]. split_conjs; try assumption; [].
- by rewrite -EQ'.
- + intros n _. reflexivity.
- - ra_ag_destr. unfold ra_op, ra_ag_op. split.
- + intros n. rewrite /=. split; intros; split_conjs; try tauto; symmetry; tauto.
- + intros n [pv1 [pv2 EQ]]. assumption.
- - eapply ra_ag_dupl.
- - ra_ag_destr; unfold ra_valid, ra_agree_valid in *; firstorder.
- - exists t'. reflexivity.
- - ra_ag_destr; unfold ra_valid, ra_agree_valid in *. split; first reflexivity.
- intros. reflexivity.
- - ra_ag_destr; unfold ra_valid, ra_agree_valid in *; firstorder.
- - ra_ag_destr; [].
- destruct (H n) as [Hn _]. assumption.
- Qed.
-
- Lemma ra_ag_pord (x y: ra_agree):
- x ⊑ y <-> y · x == y.
- Proof.
- split.
- - move=>[z EQ]. ra_ag_destr; destruct EQ as [EQv EQts]; split.
- + split.
- * intros (pv1 & pv2 & EQt). assumption.
- * intros pv0. hnf. move:(pv0). rewrite -{1}EQv. move=>[pv1 [pv2 EQ']].
- do 2 (split; first assumption). erewrite <-EQts by (simpl; tauto). assumption.
- + intros. reflexivity.
- - intros EQ. exists y. assumption.
- Qed.
-
- (* We also have a metric *)
- Definition ra_agree_dist n :=
- fun x y => match x, y with
- | ag_inj v1 ts1 _, ag_inj v2 ts2 _ =>
- v1 = n = v2 /\ (forall n', n' <= n -> v1 n' -> ts1 n' = n' = ts2 n')
- (* Since == has to imply (dist n), we cannot ask for equality beyond validity *)
- end.
-
- Global Program Instance ra_agree_metric : metric ra_agree := mkMetr ra_agree_dist.
- Next Obligation.
- repeat intro.
- ra_ag_destr. destruct H as [EQv1 EQts1], H0 as [EQv2 EQts2]. split; move=>[EQv EQts]; split.
- - rewrite -EQv1 -EQv2. assumption.
- - move=> n' HLe pv1. etransitivity; first (symmetry; eapply EQts1; by apply EQv1).
- etransitivity; last (eapply EQts2; by eapply EQv, EQv1). eapply EQts; first assumption.
- by apply EQv1.
- - rewrite EQv1 EQv2. assumption.
- - move=> n' HLe pv1. etransitivity; first (by eapply EQts1).
- etransitivity; last (symmetry; eapply EQts2; by eapply EQv2, EQv, EQv1).
- by eapply EQts, EQv1.
- Qed.
- Next Obligation.
- split.
- - intros Hall. ra_ag_destr.
- split.
- + eapply dist_refl. move=> [|n]; first by apply: dist_bound. destruct (Hall (S n)) as [EQ _].
- assumption.
- + intros n pv1. specialize (Hall (S n)). destruct n as [|n]; first by apply: dist_bound.
- now firstorder.
- - repeat intro. ra_ag_destr; now firstorder.
- Qed.
- Next Obligation.
- repeat intro.
- ra_ag_destr; now firstorder.
- Qed.
- Next Obligation.
- repeat intro.
- ra_ag_destr.
- destruct H as [EQv1 EQts1], H0 as [EQv2 EQts2].
- split; first now firstorder. intros.
- etransitivity; first by eapply EQts1. by eapply EQts2, EQv1.
- Qed.
- Next Obligation.
- repeat intro.
- ra_ag_destr. destruct H as [EQv EQts]. split.
- - move=>n' HLe. eapply EQv. omega.
- - move=>n'' HLe pv1. eapply EQts, pv1. omega.
- Qed.
- Next Obligation.
- repeat intro; ra_ag_destr. split.
- - apply dist_bound.
- - intros. eapply mono_dist, dist_bound. assumption.
- Qed.
-
- Global Instance ra_ag_op_dist n:
- Proper (dist n ==> dist n ==> dist n) ra_ag_op.
- Proof.
- move=>a1 aa2 EQa b1 b2 EQb. destruct n as [|n]; first by apply: dist_bound.
- ra_ag_destr; try firstorder; []. destruct EQa as [EQv1 EQts1], EQb as [EQv2 EQts2]. split.
- - move=>n' HLe. simpl. split; move=>[pv1 [pv2 EQ]].
- + split; first by apply EQv1. split; first by apply EQv2.
- etransitivity; first by (symmetry; eapply EQts1).
- etransitivity; last by (eapply EQts2). eassumption.
- + split; first by apply EQv1. split; first by apply EQv2.
- etransitivity; first by eapply EQts1, EQv1.
- etransitivity; last by (symmetry; eapply EQts2, EQv2). eassumption.
- - move=>n' HLe [pv1 [pv2 EQ]]. now eapply EQts1.
- Qed.
-
- Global Instance ra_ag_inj_dist n:
- Proper (dist n ==> dist n) ra_ag_inj.
- Proof.
- move=>t1 t2 EQt. destruct n as [|n]; first by apply: dist_bound.
- simpl. rewrite -/dist. split.
- - move=>? _. reflexivity.
- - move=>m Hle _. eapply mono_dist, EQt. omega.
- Qed.
-
- Lemma ra_ag_prod_dist x y n:
- cmra_valid (x · y) n ->
- x · y = n = x.
- Proof.
- move=>Hval. destruct n as [|n]; first exact: dist_bound.
- unfold cmra_valid in Hval. ra_ag_destr. simpl in Hval.
- destruct Hval as [pv1 [pv2 Heq]].
- split.
- - move=>m Hle /=. split.
- + move=>_. eapply dpred, pv1. omega.
- + move=>_.
- split; first by (eapply dpred, pv1; omega).
- split; first by (eapply dpred, pv2; omega).
- etransitivity; last (etransitivity; first (eapply mono_dist, Heq; omega)).
- * symmetry. etransitivity; first now eapply tsx0. reflexivity.
- * etransitivity; first now eapply tsx. reflexivity.
- - intros. reflexivity.
- Qed.
-
- Program Definition ra_ag_vchain (σ: chain ra_agree) {σc: cchain σ} : chain SPred :=
- fun i => match σ i with
- | ag_inj v' _ _ => v'
- end.
-
- Instance ra_ag_vchain_c (σ: chain ra_agree) {σc: cchain σ} : cchain (ra_ag_vchain σ).
- Proof.
- intros n j m HLe1 HLe2. destruct n as [|n]; first by apply: dist_bound. unfold ra_ag_vchain.
- ddes (σ j) at 1 3 as [v1 ts1 tsx1] deqn:EQ1.
- ddes (σ m) at 1 3 as [v2 ts2 tsx2] deqn:EQ2.
- cchain_eleq σ at j m lvl:(S n); move=>[EQv _].
- assumption.
- Qed.
-
- Lemma ra_ag_vchain_compl_n (σ: chain ra_agree) {σc: cchain σ} n:
- compl (ra_ag_vchain σ) n ->
- forall m k, m <= n -> k >= n -> ra_ag_vchain σ k m.
- Proof.
- move=>pv m k HLe HLe'.
- assert (HTv := conv_cauchy (ra_ag_vchain σ) (S n) _ (le_refl _)).
- apply HTv in pv; last by omega.
- clear HTv. move:pv. unfold ra_ag_vchain.
- ddes (σ (S n)) at 1 3 as [v1 ts1 tsx1] deqn:EQ1.
- ddes (σ k) at 1 3 as [v2 ts2 tsx2] deqn:EQ2=>pv.
- destruct m; first exact:bpred.
- cchain_eleq σ at (S n) k lvl:(S m); move=>[EQv _].
- apply EQv; first omega. eapply dpred; eassumption.
- Qed.
-
- Lemma ra_ag_vchain_ucompl_n (σ: chain ra_agree) {σc: cchain σ} n:
- ra_ag_vchain σ n n ->
- compl (ra_ag_vchain σ) n.
- Proof.
- move=>pv.
- assert (HTv := conv_cauchy (ra_ag_vchain σ) n _ (le_refl _)).
- apply HTv in pv; last by omega. assumption.
- Qed.
-
- Lemma ra_ag_vchain_n (σ: chain ra_agree) {σc: cchain σ} n m:
- ra_ag_vchain σ n m -> forall v' ts' tsx', σ n = ag_inj v' ts' tsx' -> v' m.
- Proof.
- move=>pv v' ts' tsx' EQ. move:pv EQ.
- unfold ra_ag_vchain.
- ddes (σ n) at 1 3 as [vSn tsSn tsxSSn] deqn:EQSSn.
- move=>pv EQ. rewrite EQ in EQSSn. injection EQSSn=>{EQSSn EQ}EQ. destruct EQ.
- move=><-. assumption.
- Qed.
-
- Program Definition ra_ag_compl (σ : chain ra_agree) {σc : cchain σ} :=
- ag_inj (compl (ra_ag_vchain σ))
- (fun n => match σ n return _ with
- | ag_inj v' ts' tsx' => ts' n end) _.
- Next Obligation.
- move=>n i HLe pv. simpl. rewrite -/dist.
- assert (pvc: compl (ra_ag_vchain σ) i) by assumption.
- destruct n as [|n]; first by apply: dist_bound.
- ddes (σ i) at 1 3 as [vi tsi tsxi] deqn:EQi.
- ddes (σ (S n)) at 1 3 as [vSn tsSn tsxSn] deqn:EQSn.
- cchain_eleq σ at i (S n) lvl:(S n); move=>[EQv EQts].
- assert (pv': vi i).
- { move:pvc. move/ra_ag_vchain_compl_n. case/(_ i i _ _)/Wrap; [omega|].
- move/ra_ag_vchain_n=>H. eapply H. symmetry. eassumption. }
- etransitivity; last first.
- { eapply EQts; first omega. eapply dpred, pv'. assumption. }
- move:(tsxi (S n) i). move/(_ _ pv')=>EQ.
- etransitivity; last eassumption. reflexivity.
- Qed.
-
- Global Program Instance ra_ag_cmt : cmetric ra_agree := mkCMetr ra_ag_compl.
- Next Obligation.
- intros [| n]; [now intros; apply dist_bound | unfold ra_ag_compl].
- intros i HLe. destruct (σ i) as [vi] eqn: EQi; split.
- - assert (HT:=conv_cauchy (ra_ag_vchain σ)).
- rewrite (HT (S n)). unfold ra_ag_vchain.
- ddes (σ i) at 1 3 as [vSi tsSi tsxSi] deqn:EQSi.
- inversion EQi; subst. reflexivity.
- - move=>j HLej pv1.
- destruct j as [|j]; first by apply: dist_bound.
- rewrite /ra_ag_vchain /= in pv1. move:pv1.
- ddes (σ (S j)) at 1 3 6 as [vSSj tsSSj tsxSSj] deqn:EQSSj.
- intros pv1. cchain_eleq σ at (S j) i lvl:(S j); move=>[EQv EQts].
- eapply EQts; first reflexivity. assumption.
- Qed.
-
- (* And we have a pcmType, too! *)
- Global Instance ra_ag_pcm: pcmType ra_agree.
- Proof.
- split. repeat intro. eapply ra_ag_pord. unfold compl, ra_ag_cmt, ra_ag_compl.
- split.
- - move=>n. split; first by (intros (pv1 & pv2 & _); tauto).
- simpl. move=>pv. move:(pv). rewrite {1}/ra_ag_vchain. simpl.
- ddes (Ï n) at 1 3 as [vÏn tsÏn tsxÏn] deqn:EQÏn.
- move=>pvÏ.
- assert (pvσ: (ra_ag_vchain σ n) n).
- { unfold ra_ag_vchain.
- ddes (σ n) at 1 3 as [vσn tsσn tsxσn] deqn:EQσn.
- specialize (H n). rewrite ->ra_ag_pord, <-EQÏn, <-EQσn, comm in H.
- destruct H as [EQv _]. rewrite <-EQv in pvÏ. destruct pvÏ as [pv1 _]. assumption. }
- do 2 (split; first assumption). symmetry.
- destruct n as [|n]; first by apply: dist_bound.
- rewrite -EQÏn. destruct (σ (S n)) as [vσn tsσn rsxσn] eqn:EQσn.
- specialize (H (S n)). rewrite ->ra_ag_pord in H.
- rewrite ->EQσn, <-EQÏn, comm in H. destruct H as [EQv EQts].
- apply EQts. rewrite EQv. rewrite /ra_ag_vchain -EQÏn in pv. assumption.
- - intros n (pv1 & pv2 & EQ). reflexivity.
- Qed.
-
- (* And finally, be ready for the CMRA *)
- Global Instance ra_ag_cmra : CMRA ra_agree.
- Proof.
- split.
- - now apply _.
- - by move=>[|n] t1 t2 EQt.
- - move=>n t1 t2 EQt. destruct n as [|n]; first exact: dist_bound.
- ra_ag_destr; now firstorder.
- - move=>t. reflexivity.
- - move=> t1 t2. ra_ag_destr.
- move=>n [pv _]. exact pv.
- Qed.
-
- (* We need to provide a CMRAExt. *)
- Program Definition ra_ag_cmra_extend_elem (me part rem: ra_agree) n (Hdist: me = n = rem · part) :=
- ag_inj p[(fun m => ra_ag_v me m \/ (m <= n /\ ra_ag_v part m))]
- (fun m => if le_lt_dec m n then ra_ag_ts part m else ra_ag_ts me m) _.
- Next Obligation.
- left. exact:bpred.
- Qed.
- Next Obligation.
- move=>m j Hlej [Hme|[Hlem Hpart]].
- - left. eapply dpred, Hme. assumption.
- - right. split; first omega. eapply dpred, Hpart. assumption.
- Qed.
- Next Obligation.
- move=>m j Hle.
- destruct part as [pv pts ptsx], me as [mv mts mtsx].
- move=>/= [Hme|[Hlem Hpart]].
- - simpl.
- destruct (le_lt_dec j n) as [Hle_jn|Hlt_jn].
- + destruct (le_lt_dec m n); last (exfalso; omega).
- destruct n.
- { destruct m; last omega. exact:dist_bound. }
- apply ptsx; first assumption. destruct Hdist as [Heqv1 _].
- eapply Heqv1; assumption.
- + destruct (le_lt_dec m n) as [Hle_mn|Hlt_mn].
- * transitivity (mts m).
- { eapply mono_dist, mtsx; assumption || omega. }
- destruct n.
- { destruct m; last omega. exact:dist_bound. }
- destruct Hdist as [Heqv1 Heqts1].
- etransitivity; first (now eapply Heqts1, dpred, Hme).
- apply Heqv1; first assumption.
- eapply dpred, Hme. assumption.
- * eapply mtsx; assumption.
- - destruct n.
- { destruct j; last (exfalso; omega).
- destruct m; last (exfalso; omega). exact:dist_bound. }
- destruct Hdist as [Heqv _].
- destruct (le_lt_dec j (S n)) as [Hle_jn|Hlt_jn]; last omega.
- destruct (le_lt_dec m (S n)) as [Hle_mn|Hlt_mn]; last omega.
- apply ptsx; assumption.
- Qed.
-
- Global Instance ra_ag_cmra_extend: CMRAExt ra_agree.
- Proof.
- move=>n; intros.
- assert (EQt1_1: t2 = n = t12 · t11) by now rewrite ->comm, <-EQt1.
- exists (ra_ag_cmra_extend_elem t2 t11 _ _ EQt1_1).
- assert (EQt1_2: t2 = n = t11 · t12) by now rewrite <-EQt1.
- exists (ra_ag_cmra_extend_elem t2 t12 _ _ EQt1_2).
- destruct t11 as [t11v t11ts t11tsx], t12 as [t12v t12ts t12tsx], t1 as [t1v t1ts t1tsx], t2 as [t2v t2ts t2tsx].
- split; last split.
- - split.
- + move=>m. simpl. clear EQt1_1 EQt1_2. split.
- * move=>Hval. split; first tauto. split; first tauto.
- destruct (le_lt_dec m n) as [Hle_mn|Hlt_mn]; last reflexivity.
- destruct n.
- { destruct m; last omega. exact:dist_bound. }
- apply EQt1. apply EQt; assumption.
- * case. move=>[Hval|[Hle Hval1]]; first tauto.
- case. move=>[Hval|[_ Hval2]]; first tauto.
- destruct (le_lt_dec m n) as [Hle_mn|Hlt_mn]; last (exfalso; omega).
- move=>Heq.
- destruct n.
- { destruct m; last omega. exact:bpred. }
- apply EQt; first assumption. apply EQt1. simpl. tauto.
- + move=>m Hval. simpl.
- destruct (le_lt_dec m n) as [Hle_mn|Hlt_mn]; last reflexivity.
- destruct n.
- { destruct m; last omega. exact:dist_bound. }
- symmetry in EQt.
- transitivity (t1ts m); first (eapply EQt; assumption).
- apply EQt1. apply EQt; assumption.
- - destruct n; first exact:dist_bound. split.
- + move=>m Hle. simpl. split; first tauto.
- move=>[Hval|?]; last tauto.
- apply EQt1. apply EQt; assumption.
- + intros m; intros.
- destruct (le_lt_dec m (S n)) as [Hle_mn|Hlt_mn]; last (exfalso; omega).
- simpl. reflexivity.
- - destruct n; first exact:dist_bound. split.
- + move=>m Hle. simpl. split; first tauto.
- move=>[Hval|?]; last tauto.
- apply EQt1. apply EQt; assumption.
- + intros m; intros.
- destruct (le_lt_dec m (S n)) as [Hle_mn|Hlt_mn]; last (exfalso; omega).
- simpl. reflexivity.
- Qed.
-
- (* Provide a way to get an n-approximation of the element out of an n-valid agreement. *)
- Definition ra_ag_unInj x n: T :=
- match x with
- | ag_inj v ts _ => ts n
- end.
-
- Lemma ra_ag_unInj_dist x y n (HVal1: cmra_valid x n): (* we need validity, hence no "Proper" can be registered *)
- x = n = y -> ra_ag_unInj x n = n = ra_ag_unInj y n.
- Proof.
- move=>EQ. destruct n as [|n]; first exact: dist_bound.
- ra_ag_destr; now firstorder.
- Qed.
-
- Lemma ra_ag_unInj_move x n1 n2 (Hle: n1 <= n2) {HVal2: cmra_valid x n2}:
- ra_ag_unInj x n1 = n1 = ra_ag_unInj x n2.
- Proof.
- ra_ag_destr.
- rewrite /ra_ag_unInj. symmetry.
- etransitivity; last (etransitivity; first eapply (tsx n1 n2)); assumption || reflexivity.
- Qed.
-
- Lemma ra_ag_inj_unInj_ext x n (HVal: cmra_valid x n) t d:
- d · ra_ag_inj t = n = x -> ra_ag_unInj x n = n = t.
- Proof.
- rewrite comm.
- destruct x as [v ts tsx], d as [v' ts' tsx'] =>Heq.
- destruct n as [|n]; first exact: dist_bound.
- unfold ra_ag_inj in Heq. destruct Heq as [EQv EQts]. unfold ra_ag_unInj.
- symmetry. eapply EQts; first reflexivity.
- eapply spredNE, HVal. symmetry. exact EQv.
- Qed.
-
- (* Provide a way to get the full T out of the agreement again. We don't need this, but I proved it before
- I realized. *)
- (* For this, we need a complete metric! *)
- Context {cmT: cmetric T}.
-
- Lemma ra_ag_tschain_c {v} (ts: chain T) (tsx: cvChain v ts) {HVal: ↓(ag_inj v ts tsx)} : cchain ts.
- Proof.
- intros n j m HLe1 HLe2. destruct n as [|n]; first by apply: dist_bound.
- etransitivity; first by eapply (tsx (S n)).
- symmetry. etransitivity; first by eapply (tsx (S n)).
- reflexivity.
- Qed.
-
- Program Definition ra_ag_unInjFull x {HVal: ↓x}: T :=
- match x with
- | ag_inj v ts tsx => compl ts (σc:=ra_ag_tschain_c ts tsx (HVal:=_))
- end.
-
- Lemma ra_ag_unInjFull_dist x y {HVal1: ↓x} {HVal2: ↓y} n: (* The function is dependent, hence no "Proper" can be registered *)
- x = n = y -> ra_ag_unInjFull x (HVal:=HVal1) = n = ra_ag_unInjFull y (HVal:=HVal2).
- Proof.
- move=>EQ. destruct n as [|n]; first exact: dist_bound.
- destruct x as [xv xts xtsx].
- destruct y as [yv yts ytsx].
- destruct EQ as [_ EQts]. unfold ra_valid, ra_agree_valid in HVal1. unfold ra_valid, ra_agree_valid in HVal2.
- simpl. eapply umet_complete_extn.
- eapply EQts.
- - reflexivity.
- - apply HVal1.
- Qed.
-
- (* Correctness of the embedding (and of the entire construction, really - together with the duplicability shown above) *)
- Lemma ra_ag_inj_unInjFull x {HVal: ↓x} t:
- ra_ag_inj t ⊑ x -> ra_ag_unInjFull x (HVal:=HVal) == t.
- Proof.
- rewrite ra_ag_pord comm. destruct x as [v ts tsx]=>Heq.
- unfold ra_ag_inj in Heq. destruct Heq as [EQv EQts]. simpl. rewrite <-(umet_complete_const t).
- apply umet_complete_ext=>i. symmetry.
- eapply EQts. rewrite EQv. apply HVal.
- Qed.
-
-End Agreement.
-Arguments ra_agree T {_ _} : clear implicits.
-
-Section AgreementMap.
- Context {T U: Type} `{cmT: cmetric T} `{cmU: cmetric U}.
- Local Open Scope pumet_scope.
-
- Program Definition ra_agree_map (f: T -n> U): ra_agree T -m> ra_agree U :=
- m[(fun x => match x with
- | ag_inj v ts tsx => ag_inj v (compose f ts) _
- end)].
- Next Obligation.
- move=>n i HLe pv. simpl. eapply met_morph_nonexp. specialize (tsx n i HLe pv).
- rewrite tsx.
- eapply dist_refl. reflexivity.
- Qed.
- Next Obligation.
- move=> x y EQxy.
- destruct n as [|n]; first by apply: dist_bound.
- repeat (match goal with [ x : ra_agree _ |- _ ] => destruct x end); try (contradiction EQxy || reflexivity); [].
- destruct EQxy as [Hv Hts]. split; first assumption.
- move=>n' HLe pv1. specialize (Hts n' HLe pv1). unfold compose. rewrite Hts. reflexivity.
- Qed.
- Next Obligation.
- move=>x y EQxy. apply ra_ag_pord. apply ra_ag_pord in EQxy.
- repeat (match goal with [ x : ra_agree _ |- _ ] => destruct x end); try (contradiction EQxy || reflexivity); [].
- destruct EQxy as [EQv EQts]. split; first split.
- - intros (pv1 & pv2 & _). assumption.
- - move=>pv. move/EQv:(pv)=>[pv1 [pv2 EQ]]. do 2 (split; first assumption).
- unfold compose. simpl in *. rewrite EQ. reflexivity.
- - unfold compose. intros n [pv1 [pv2 EQ]]. reflexivity.
- Qed.
-
- Global Instance ra_agree_map_resp: Proper (equiv ==> equiv) ra_agree_map.
- Proof.
- move=> x1 x2 EQx y.
- repeat (match goal with [ x : ra_agree _ |- _ ] => destruct x end).
- split; first reflexivity.
- move=>n pv1. rewrite EQx. unfold compose. reflexivity.
- Qed.
- Global Instance ra_agree_map_dist n: Proper (dist n ==> dist n) ra_agree_map.
- Proof.
- move=> x1 x2 EQx y.
- repeat (match goal with [ x : ra_agree _ |- _ ] => destruct x end).
- destruct n as [|n]; first by apply: dist_bound.
- split; first reflexivity.
- move=>n' HLe pv1. rewrite /compose. eapply mono_dist; last first.
- - rewrite EQx. reflexivity.
- - omega.
- Qed.
-End AgreementMap.
-
-Section AgreementMapComp.
- Local Open Scope pumet_scope.
- Context {T: Type} `{cmT: cmetric T}.
-
- Lemma ra_agree_map_id:
- ra_agree_map (umid T) == (pid (ra_agree T)).
- Proof.
- intros x.
- repeat (match goal with [ x : ra_agree _ |- _ ] => destruct x end).
- simpl. split; first reflexivity.
- reflexivity.
- Qed.
-
- Context {U V: Type} `{cmU: cmetric U} `{cmV: cmetric V}.
-
- Lemma ra_agree_map_comp (f: T -n> U) (g: U -n> V):
- (ra_agree_map g) ∘ (ra_agree_map f) == ra_agree_map (g <M< f).
- Proof.
- intros x.
- repeat (match goal with [ x : ra_agree _ |- _ ] => destruct x end).
- simpl. split; first reflexivity.
- intros. reflexivity.
- Qed.
-End AgreementMapComp.
diff --git a/lib/ModuRes/BI.v b/lib/ModuRes/BI.v
deleted file mode 100644
index a96d3b411849e13ce3d1f6ecac765b0dfa5df334..0000000000000000000000000000000000000000
--- a/lib/ModuRes/BI.v
+++ /dev/null
@@ -1,410 +0,0 @@
-Require Import Ssreflect.ssreflect Omega.
-Require Import PreoMet.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Section CompleteBI.
- Context {T : Type}.
- Local Open Scope type.
-
- Class validBI:= valid: T -> Prop.
- Class topBI := top : T.
- Class botBI := bot : T.
- Class andBI := and : T -> T -> T.
- Class orBI := or : T -> T -> T.
- Class implBI := impl : T -> T -> T.
- Class scBI := sc : T -> T -> T.
- Class siBI := si : T -> T -> T.
- Class eqBI := intEq : forall {U} `{pU : cmetric U}, U -> U -> T.
- (* This does not go to full generality: Compared to "adjoint of the projection", we fix
- the type that's "kept" to be unit (and simplify accordingly). *)
- Class allBI `{cmT : cmetric T} :=
- all : forall {U} `{pU : cmetric U}, (U -n> T) -> T.
- Class xistBI `{cmT : cmetric T} :=
- xist : forall {U} `{pU : cmetric U}, (U -n> T) -> T.
-
-
- (* Lattices. *)
- Class Lattice `{preoT : pcmType T, BIV: validBI, BIT : topBI, BIB : botBI, BIA : andBI, BIO : orBI}: Prop :=
- mkBounded {
- (* Anti-symmetry: Necessary for commutativity of addition, and commutativity of SC of the lifted BI *)
- pord_antisym: forall P Q, P ⊑ Q -> Q ⊑ P -> P == Q;
- top_true : forall P, P ⊑ top;
- bot_false : forall P, bot ⊑ P;
- top_valid : forall P, valid P <-> top ⊑ P;
- consistency : ~valid bot;
- and_self : forall P, P ⊑ and P P;
- and_projL : forall P Q, and P Q ⊑ P;
- and_projR : forall P Q, and P Q ⊑ Q;
- and_equiv :> Proper (equiv ==> equiv ==> equiv) and;
- and_dist n :> Proper (dist n ==> dist n ==> dist n) and;
- and_pord :> Proper (pord ++> pord ++> pord) and;
- or_injL : forall P Q, P ⊑ or P Q;
- or_injR : forall P Q, Q ⊑ or P Q;
- or_self : forall P, or P P ⊑ P;
- or_equiv :> Proper (equiv ==> equiv ==> equiv) or;
- or_dist n :> Proper (dist n ==> dist n ==> dist n) or;
- or_pord :> Proper (pord ++> pord ++> pord) or
- }.
-
- Class ComplBI `{bL : Lattice} {BII : implBI} {BISC : scBI} {BISI : siBI} {BIAll : allBI} {BIXist : xistBI}: Prop :=
- mkCBI {
- and_impl : forall P Q R, and P Q ⊑ R <-> P ⊑ impl Q R;
- impl_dist n :> Proper (dist n ==> dist n ==> dist n) impl;
- sc_comm :> Commutative sc;
- sc_assoc :> Associative sc;
- sc_top_unit : forall P, sc top P == P;
- sc_equiv :> Proper (equiv ==> equiv ==> equiv) sc;
- sc_dist n :> Proper (dist n ==> dist n ==> dist n) sc;
- sc_pord :> Proper (pord ++> pord ++> pord) sc;
- sc_si : forall P Q R, sc P Q ⊑ R <-> P ⊑ si Q R;
- si_dist n :> Proper (dist n ==> dist n ==> dist n) si;
- all_R U `{cmU : cmetric U} :
- forall P (Q : U -n> T), (forall u, P ⊑ Q u) <-> P ⊑ all Q;
- all_dist U `{cmU : cmetric U} n :> Proper (dist n ==> dist n) all;
- xist_L U `{cmU : cmetric U} :
- forall (P : U -n> T) Q, (forall u, P u ⊑ Q) <-> xist P ⊑ Q;
- xist_dist U `{cmU : cmetric U} n :> Proper (dist n ==> dist n) xist
- }.
-
- (* A BI that can reflect equality. We don't bother with "a specific type here", as we already did
- not bother with that for completion. *)
- Program Definition bi_leibnitz `{BCBI: ComplBI} {U: Type} `{cmetric U} (u1 u2: U): T :=
- all n[(fun p: U -n> T => impl (p u1) (p u2))].
- Next Obligation.
- move=>p1 p2 EQp. simpl. eapply impl_dist; rewrite EQp; reflexivity.
- Qed.
-
- Class EqBI `{BCBI: ComplBI} {BIEQ: eqBI}: Prop :=
- { intEq_equiv U `{cmU : cmetric U} :> Proper (equiv ==> equiv ==> equiv) intEq;
- intEq_dist U `{cmU : cmetric U} n :> Proper (dist n ==> dist n ==> dist n) intEq;
- intEq_leibnitz {U} `{cmU : cmetric U} (u1 u2: U) : intEq u1 u2 == bi_leibnitz u1 u2
- }.
-
-End CompleteBI.
-
-Arguments validBI : default implicits.
-Arguments topBI : default implicits.
-Arguments botBI : default implicits.
-Arguments andBI : default implicits.
-Arguments orBI : default implicits.
-Arguments implBI : default implicits.
-Arguments scBI : default implicits.
-Arguments siBI : default implicits.
-Arguments eqBI : default implicits.
-Arguments allBI T {_ _ _}.
-Arguments xistBI T {_ _ _}.
-Arguments Lattice T {_ _ _ _ _ _ _ _ _ _}.
-Arguments ComplBI T {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
-Arguments EqBI T {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
-
-Delimit Scope bi_scope with bi.
-Notation "⊤" := (top) : bi_scope.
-Notation "⊥" := (bot) : bi_scope.
-Notation "p ∧ q" := (and p q) (at level 39, right associativity) : bi_scope.
-Notation "p ∨ q" := (or p q) (at level 51, right associativity) : bi_scope.
-Notation "p * q" := (sc p q) (at level 40, left associativity) : bi_scope.
-Notation "p → q" := (impl p q) (at level 55, right associativity) : bi_scope.
-Notation "P ↔ Q" := ((P → Q) ∧ (Q → P))%bi (at level 57, no associativity) : bi_scope.
-Notation "p '-*' q" := (si p q) (at level 55, right associativity) : bi_scope.
-Notation "∀ x , p" := (all n[(fun x => p)]) (at level 60, x ident, right associativity) : bi_scope.
-Notation "∃ x , p" := (xist n[(fun x => p)]) (at level 60, x ident, right associativity) : bi_scope.
-Notation "∀ x : T , p" := (all n[(fun x : T => p)]) (at level 60, x ident, right associativity) : bi_scope.
-Notation "∃ x : T , p" := (xist n[(fun x : T => p)]) (at level 60, x ident, right associativity) : bi_scope.
-Notation "t1 '===' t2" := (intEq t1 t2) (at level 35) : bi_scope.
-
-Local Open Scope bi_scope.
-
-(* Derive some general BI rules *)
-Section LatticeProps.
- Context {B} `{Lattice B}.
-
- Lemma and_R P Q R: (R ⊑ P /\ R ⊑ Q) <-> R ⊑ P ∧ Q.
- Proof.
- split.
- - move=>[H1 H2]. transitivity (R ∧ R).
- + apply and_self.
- + apply and_pord; assumption.
- - move=>EQ. split; (transitivity (P ∧ Q); first assumption).
- + apply and_projL.
- + apply and_projR.
- Qed.
-
- Lemma and_pcomm P Q: and P Q ⊑ and Q P.
- Proof.
- apply and_R; split.
- - apply and_projR.
- - apply and_projL.
- Qed.
-
- Global Instance and_comm: Commutative and.
- Proof.
- move=>b1 b2. apply pord_antisym; now apply and_pcomm.
- Qed.
-
- Global Instance and_assoc: Associative and.
- Proof.
- move=>b1 b2 b3. apply pord_antisym.
- - apply and_R; split; first (apply and_R; split).
- + apply and_projL.
- + rewrite ->and_projR. apply and_projL.
- + rewrite ->and_projR. apply and_projR.
- - apply and_R; split; last (apply and_R; split).
- + rewrite ->and_projL. apply and_projL.
- + rewrite ->and_projL. apply and_projR.
- + apply and_projR.
- Qed.
-
- Lemma or_L P Q R: (P ⊑ R /\ Q ⊑ R) <-> or P Q ⊑ R.
- Proof.
- split.
- - move=>[HPR HQR]. transitivity (R ∨ R).
- + apply or_pord; [apply HPR|apply HQR].
- + apply or_self.
- - move=>HPQR. rewrite <-HPQR=>{HPQR R}. split.
- + apply or_injL.
- + apply or_injR.
- Qed.
-
- Lemma or_pcomm P Q: or P Q ⊑ or Q P.
- Proof.
- apply or_L. split; [apply or_injR|apply or_injL].
- Qed.
-
- Global Instance or_comm: Commutative or.
- Proof.
- move=>b1 b2. apply pord_antisym; now apply or_pcomm.
- Qed.
-
- Global Instance or_assoc: Associative or.
- Proof.
- move=>b1 b2 b3. apply pord_antisym.
- - apply or_L; split; last (apply or_L; split).
- + rewrite <-or_injL. apply or_injL.
- + rewrite <-or_injL. apply or_injR.
- + apply or_injR.
- - apply or_L; split; first (apply or_L; split).
- + apply or_injL.
- + rewrite <-or_injR. apply or_injL.
- + rewrite <-or_injR. apply or_injR.
- Qed.
-End LatticeProps.
-
-Section ComplBIProps.
- Context {B} `{ComplBI B}.
-
- Global Instance impl_pord :
- Proper (pord --> pord ++> pord) impl.
- Proof.
- move=>P1 P2 EQP Q1 Q2 EQQ. rewrite <-and_impl. rewrite <-EQQ=>{Q2 EQQ}.
- unfold flip in EQP. rewrite ->EQP, ->and_impl. reflexivity.
- Qed.
-
- Global Instance impl_equiv :
- Proper (equiv ==> equiv ==> equiv) impl.
- Proof.
- move=>P1 P2 EQP Q1 Q2 EQQ. apply pord_antisym; apply impl_pord; rewrite ?EQP ?EQQ; reflexivity.
- Qed.
-
- Lemma modus_ponens P Q R: P ⊑ Q -> P ⊑ Q → R -> P ⊑ R.
- Proof.
- move=>HQ HQR. transitivity ((Q → R) ∧ Q).
- - apply and_R; split; assumption.
- - clear P HQ HQR. apply and_impl. reflexivity.
- Qed.
-
- Global Instance si_pord :
- Proper (pord --> pord ++> pord) si.
- Proof.
- move=>P1 P2 EQP Q1 Q2 EQQ. rewrite <-sc_si. rewrite <-EQQ=>{Q2 EQQ}.
- unfold flip in EQP. rewrite ->EQP. rewrite ->sc_si. reflexivity.
- Qed.
-
- Global Instance si_equiv :
- Proper (equiv ==> equiv ==> equiv) si.
- Proof.
- move=>P1 P2 EQP Q1 Q2 EQQ. apply pord_antisym; apply si_pord; rewrite ?EQP ?EQQ; reflexivity.
- Qed.
-
- Lemma sc_projR P Q: P * Q ⊑ Q.
- Proof.
- transitivity (top * Q).
- - apply sc_pord; last reflexivity. apply top_true.
- - apply pordR. apply sc_top_unit.
- Qed.
-
- Lemma sc_projL P Q: P * Q ⊑ P.
- Proof.
- rewrite comm. apply sc_projR.
- Qed.
-
- Lemma sc_and P Q: P * Q ⊑ P ∧ Q.
- Proof.
- apply and_R; split.
- - apply sc_projL.
- - apply sc_projR.
- Qed.
-
- Lemma sc_or P Q R: (P ∨ Q) * R ⊑ (P * R) ∨ (Q * R).
- Proof.
- apply sc_si. apply or_L. split; apply sc_si.
- - apply or_injL.
- - apply or_injR.
- Qed.
-
- Lemma impl_si P Q:
- P → Q ⊑ P -* Q.
- Proof.
- apply sc_si. rewrite ->sc_and.
- apply and_impl. reflexivity.
- Qed.
-
- Lemma all_L {U} `{cmU : cmetric U} u (P: U -n> B) Q:
- P u ⊑ Q -> all P ⊑ Q.
- Proof.
- move=>Hpq. rewrite <-Hpq=>{Hpq Q}.
- specialize (all_R _ (all P) P)=>Hall. eapply Hall. reflexivity.
- Qed.
-
- Global Instance all_pord U `{cmU : cmetric U} :
- Proper (pord ++> pord) all.
- Proof.
- move=>f1 f2 Hf. apply all_R=>u. rewrite <-Hf.
- apply (all_L u). reflexivity.
- Qed.
-
- Global Instance all_equiv U `{cmU : cmetric U} :
- Proper (equiv ==> equiv) all.
- Proof.
- move=>f1 f2 Hf. apply pord_antisym; eapply all_pord; rewrite Hf; reflexivity.
- Qed.
-
- Lemma all_and U `{cmU : cmetric U} : (* the converse does not hold for empty U *)
- forall (P : U -n> B) Q, (all P) ∧ Q ⊑ all (lift_bin and P (umconst Q)).
- Proof.
- move=>P Q.
- apply all_R=>u. apply and_impl. apply (all_L u). apply and_impl. reflexivity.
- Qed.
-
- Lemma all_sc U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, (all P) * Q ⊑ all (lift_bin sc P (umconst Q)).
- Proof.
- move=>P Q. apply all_R=>u. apply sc_si.
- apply (all_L u). apply sc_si. reflexivity.
- Qed.
-
- Lemma all_sc_r U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, Q * (all P) ⊑ all (lift_bin sc (umconst Q) P).
- Proof.
- move=>P Q. rewrite (comm Q). etransitivity; first eapply all_sc.
- eapply all_pord. move=>u. simpl morph. rewrite comm. reflexivity.
- Qed.
-
- Lemma all_and_r U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, Q ∧ (all P) ⊑ all (lift_bin and (umconst Q) P).
- Proof.
- move=>P Q. rewrite (comm Q). etransitivity; first eapply all_and.
- eapply all_pord. move=>u. simpl morph. rewrite comm. reflexivity.
- Qed.
-
-
- Lemma xist_R {U} `{cmU : cmetric U} u P (Q: U -n> B):
- P ⊑ Q u -> P ⊑ xist Q.
- Proof.
- move=>Hpq. rewrite ->Hpq=>{Hpq P}.
- specialize (xist_L _ Q (xist Q))=>Hxist.
- eapply Hxist. reflexivity.
- Qed.
-
- Global Instance xist_pord U `{cmU : cmetric U} :
- Proper (pord ++> pord) xist.
- Proof.
- move=>f1 f2 Hf. apply xist_L=>u. rewrite ->Hf.
- apply (xist_R u). reflexivity.
- Qed.
-
- Global Instance xist_equiv U `{cmU : cmetric U} :
- Proper (equiv ==> equiv) xist.
- Proof.
- move=>f1 f2 Hf. apply pord_antisym; eapply xist_pord; rewrite Hf; reflexivity.
- Qed.
-
- Lemma xist_and U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, (xist P) ∧ Q ⊑ xist (lift_bin and P (umconst Q)).
- Proof.
- move=>P Q. apply and_impl.
- apply xist_L=>u. apply and_impl.
- apply (xist_R u). simpl morph. reflexivity.
- Qed.
-
- Lemma xist_sc U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, (xist P) * Q ⊑ xist (lift_bin sc P (umconst Q)).
- Proof.
- move=>P Q. apply sc_si.
- apply xist_L=>u. apply sc_si.
- apply (xist_R u). simpl morph. reflexivity.
- Qed.
-
- Lemma xist_sc_r U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, Q * (xist P) ⊑ xist (lift_bin sc (umconst Q) P).
- Proof.
- move=>P Q. rewrite (comm Q). etransitivity; first eapply xist_sc.
- eapply xist_pord. move=>u. simpl morph. rewrite comm. reflexivity.
- Qed.
-
- Lemma xist_and_r U `{cmU : cmetric U} :
- forall (P : U -n> B) Q, Q ∧ (xist P) ⊑ xist (lift_bin and (umconst Q) P).
- Proof.
- move=>P Q. rewrite (comm Q). etransitivity; first eapply xist_and.
- eapply xist_pord. move=>u. simpl morph. rewrite comm. reflexivity.
- Qed.
-End ComplBIProps.
-
-Section EqBIProps.
- Context {B} `{EqBI B}.
-
- Program Definition intEq_l {T} `{cmT : cmetric T} t1: T -n> B :=
- n[(fun t2 => t1 === t2)]. Next Obligation. move=>u1 u2
- EQu. simpl. rewrite EQu. reflexivity. Qed.
-
- Program Definition intEq_r {T} `{cmT : cmetric T} t2: T -n> B :=
- n[(fun t1 => t1 === t2)].
- Next Obligation.
- move=>u1 u2 EQu. simpl. rewrite EQu. reflexivity.
- Qed.
-
- Lemma intEq_refl {T} `{_ : cmetric T} t:
- (⊤:B) ⊑ (t === t).
- Proof.
- rewrite intEq_leibnitz /bi_leibnitz. apply all_R=>P. simpl morph.
- apply and_impl. apply and_projR.
- Qed.
-
- Lemma intEq_rewrite_goal {T} `{cmetric T} (t1 t2: T) P (φ: _ -n> B):
- P ⊑ t1 === t2 -> P ⊑ φ t1 -> P ⊑ φ t2.
- Proof.
- move=>HEQ Hφ. transitivity (t1 === t2 ∧ φ t1).
- - apply and_R. split; assumption.
- - move=>{P HEQ Hφ}. rewrite -/pord. apply and_impl. rewrite intEq_leibnitz /bi_leibnitz.
- apply (all_L φ). simpl morph. reflexivity.
- Qed.
-
- Lemma intEq_sym {T} `{cmetric T} (t1 t2: T):
- t1 === t2 ⊑ t2 === t1.
- Proof.
- rewrite intEq_leibnitz /bi_leibnitz.
- apply (all_L (intEq_r t1)). simpl morph. rewrite <-intEq_refl.
- eapply modus_ponens; last reflexivity.
- apply top_true.
- Qed.
-
- Lemma intEqR {T} `{cmetric T} (t1 t2: T) P:
- t1 == t2 -> P ⊑ t1 === t2.
- Proof.
- move=>EQ. transitivity (t1 === t1).
- - setoid_rewrite <-intEq_refl. apply top_true.
- - apply pordR. now apply intEq_equiv.
- Qed.
-
-End EqBIProps.
-
diff --git a/lib/ModuRes/CBUltInst.v b/lib/ModuRes/CBUltInst.v
deleted file mode 100644
index 7adb699ff4e0088769bb22129fcfbd210520c695..0000000000000000000000000000000000000000
--- a/lib/ModuRes/CBUltInst.v
+++ /dev/null
@@ -1,127 +0,0 @@
-(** This file provides the proof that CBUlt, the category of complete,
- bisected, ultrametric spaces, forms an M-category. *)
-
-Require Import CSetoid.
-Require Import MetricCore CatBasics MetricRec.
-
-Module CBUlt <: MCat.
- Local Open Scope cat_scope.
- Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
-
- Definition M := cmtyp.
- Instance MArr : BC_morph M := fun U V : cmtyp => cmfromType (U -n> V).
- Instance MComp : BC_comp M := fun U V W => comp.
- Instance MId : BC_id M := fun U => (umid _).
- Instance MTermO : BC_term M := cmfromType unit.
- Program Instance MTermA : BC_terminal M := fun U => n[(const tt)].
-
- Instance Cat : BaseCat M.
- Proof.
- split; intros; intros n; simpl; reflexivity || exact I. exact tt.
- Qed.
-
- Section Limits.
- Context (T : Tower).
-
- Definition guard := fun (σ : forall i, tow_objs T i) => forall n, tow_morphs T n (σ (S n)) == σ n.
- Instance lpg : LimitPreserving guard.
- Proof.
- intros σ σc HG n.
- rewrite !dep_chain_compl.
- rewrite nonexp_continuous; apply umet_complete_ext; intros k.
- simpl; apply dist_refl, HG.
- Qed.
-
- Definition lim_obj : cmtyp := cmfromType {σ : forall i, tow_objs T i | guard σ}.
- Definition lim_proj i : lim_obj -n> tow_objs T i := MprojI i <M< inclM.
-
- Program Definition lim_cone : Cone T := mkBaseCone T lim_obj lim_proj _.
- Next Obligation.
- intros [σ HG]; simpl; apply HG.
- Qed.
-
- Program Definition lim_map (C : Cone T) : (cone_t T C : cmtyp) -n> (cone_t T lim_cone : cmtyp) :=
- n[(fun m => exist _ (fun i => cone_m T C i m) _)].
- Next Obligation.
- intros n; simpl.
- assert (HT := cone_m_com T C n m); apply HT.
- Qed.
-
- Lemma AllLimits : Limit T.
- Proof.
- refine (mkBaseLimit T lim_cone lim_map _ _).
- + intros C n x; simpl; reflexivity.
- + intros C h HCom x n; simpl.
- specialize (HCom n x); simpl in HCom.
- symmetry; apply HCom.
- Qed.
-
- End Limits.
-End CBUlt.
-
-(* We can use the halve operation as functor *)
-Section Halving_Fun.
- Context F {FA : BiFMap F} {FFun : BiFunctor F}.
- Local Obligation Tactic := intros; resp_set || eauto.
-
- Definition HF := fun T1 T2 => halveCM (F T1 T2).
-
- Program Instance halveFMap : BiFMap HF :=
- fun m1 m2 m3 m4 => lift2m (lift2s (fun (ars: (m2 -t> m1) * (m3 -t> m4)) (ob: halveCM (F m1 m3)) => halvedT (fmorph (F := F) (BiFMap := FA) ars (unhalvedT ob))) _ _) _ _.
- Next Obligation.
- repeat intro. unfold halvedT, unhalvedT, HF in *. simpl.
- unhalveT. destruct n; first exact I. simpl in *. rewrite H. reflexivity.
- Qed.
- Next Obligation.
- intros p1 p2 EQp x; (destruct n; first exact I). simpl.
- unfold unhalvedT, HF in *. unhalveT. simpl. apply dist_mono. rewrite EQp. reflexivity.
- Qed.
-
- Instance halveF : BiFunctor HF.
- Proof.
- split; intros.
- + intros T; simpl.
- unfold unhalvedT, HF in *. unhalveT. simpl.
- apply (fmorph_comp (BiFunctor := FFun) _ _ _ _ _ _ _ _ _ _ T).
- + intros T; simpl.
- unfold unhalvedT, HF in *. unhalveT. simpl.
- apply (fmorph_id (BiFunctor := FFun) _ _ T).
- Qed.
-
- Instance halve_contractive {m0 m1 m2 m3} :
- contractive (@fmorph _ _ HF _ m0 m1 m2 m3).
- Proof.
- intros n p1 p2 EQ f; simpl.
- unfold unhalvedT, HF in *. unhalveT. simpl.
- change ((fmorph (F := F) (BiFMap := FA) p1) f = n = (fmorph (BiFMap := FA) p2) f).
- rewrite EQ; reflexivity.
- Qed.
-
-End Halving_Fun.
-
-Module Type SimplInput(Cat : MCat).
- Import Cat.
-
- Parameter F : M -> M -> M.
- Parameter FArr : BiFMap F.
- Parameter FFun : BiFunctor F.
-
- Parameter F_ne : (1 -t> F 1 1)%cat.
-End SimplInput.
-
-Module InputHalve (S : SimplInput (CBUlt)) : InputType(CBUlt)
- with Definition F := fun T1 T2 => halveCM (S.F T1 T2).
- Import CBUlt.
- Local Existing Instance S.FArr.
- Local Existing Instance S.FFun.
- Local Open Scope cat_scope.
-
- Definition F T1 T2 := halveCM (S.F T1 T2).
- Definition FArr := halveFMap S.F.
- Definition FFun := halveF S.F.
-
- Definition tmorph_ne : 1 -t> F 1 1 :=
- umconst (halvedT (S.F_ne tt)).
-
- Definition F_contractive := @halve_contractive S.F _.
-End InputHalve.
diff --git a/lib/ModuRes/CMRA.v b/lib/ModuRes/CMRA.v
deleted file mode 100644
index b130729eba8cd658141836316b69b8032035506a..0000000000000000000000000000000000000000
--- a/lib/ModuRes/CMRA.v
+++ /dev/null
@@ -1,628 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Import RA MetricCore PreoMet BI SPred.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Local Open Scope ra_scope.
-
-(* CMRA ("camera"): RAs with a complete metric. *)
-Section CMRA.
- Context {T: Type} {eqT: Setoid T} `{raT: RA (eqT:=eqT) T}.
-
- Class CMRA_valid:= cmra_valid : T -> SPred.
-
-
- Class CMRA `{pcmT: pcmType (eqT:=eqT) (pTA:=pord_ra) T} {TCV: CMRA_valid}: Prop := (* force this to become an actual argument *)
- { cmra_op_dist n :> Proper (dist n ==> dist n ==> dist n) ra_op ;
- cmra_unit_dist n :> Proper (dist n ==> dist n) ra_unit ;
- cmra_valid_dist n :> Proper (dist n ==> dist n) cmra_valid ;
- cmra_ra_valid t: (valid_sp (cmra_valid t)) <-> ra_valid t ;
- cmra_op_valid {t1 t2}: cmra_valid (t1 · t2) ⊑ cmra_valid t1
- }.
-End CMRA.
-Arguments CMRA_valid : clear implicits.
-Arguments CMRA T {_ _ _ _ _ _ _ _ _}: clear implicits.
-
-Section CMRAProps.
- Context {T: Type} `{cmraT: CMRA T}.
-
- Program Definition ra_op_n : T -n> T -n> T :=
- n[(fun t1:T => n[(fun t2:T => t1 · t2)])].
- Next Obligation.
- move=>t2 t2' EQt2. simpl. rewrite EQt2. reflexivity.
- Qed.
- Next Obligation.
- move=>t1 t1' EQt1 t2. simpl. rewrite EQt1. reflexivity.
- Qed.
-
- Global Instance cmra_valid_equiv:
- Proper (equiv ==> equiv) cmra_valid.
- Proof.
- move=>t1 t2 EQt. apply dist_refl=>n.
- eapply cmra_valid_dist. by apply dist_refl.
- Qed.
-
- Lemma cmra_op_valid2 {t1 t2} : cmra_valid (t1 · t2) ⊑ cmra_valid t2.
- Proof.
- rewrite comm. now eapply cmra_op_valid.
- Qed.
-
- Global Instance cmra_valid_ord : Proper (pord ==> flip pord) cmra_valid.
- Proof.
- move=>t1 t2 [t' HEq]. rewrite -HEq.
- rewrite /flip /=.
- exact: cmra_op_valid2.
- Qed.
-
-End CMRAProps.
-
-Section CMRAExt.
- Context (T: Type).
-
- (* "Extend" allows carrying separation over an n-equality:
- Imagine you have some n-equal elements a, b: a = n = b
- and you know that a can be factored: a = a1 · a2.
- With cmra_extend, you can "carry over" the separation,
- obtaining elements b1, b2 which factor b: b = b1 · b2
- in the "n-same way" that a was factored: (a1, a2) = n = (b1, b2).
- You can also see this as filling a square, with a, b and a1 · a2
- being the three given corners, and b1 · b2 being the missing corner.
- *)
- Class CMRAExt `{cmraT: CMRA T} :=
- (* For finprod and infprod, this needs to be informative. For Agreement, the equalities
- are needed to even construct the witnesses. *)
- cmra_extend: forall n (t1 t11 t12 t2: T) (EQt: t1 = n = t2) (EQt1: t1 == t11 · t12),
- { t21 : T & { t22 | t2 == t21 · t22 /\ (t11, t12) = n = (t21, t22) } }.
-End CMRAExt.
-Arguments cmra_extend {T} {_ _ _ _ _ _ _ _ _ _ _} n _ _ _ _ _ _.
-
-Section DiscreteCMRA.
- Context {T: Type} `{raT: RA T}.
- Existing Instance discreteMetric.
- Existing Instance discreteCMetric.
-
- Instance discreteCMRA_valid : CMRA_valid T :=
- fun t => sp_const (↓t).
-
- Instance discreteCMRA : CMRA T.
- Proof.
- split.
- - move=>n a1 a2 EQa b1 b2 EQb.
- destruct n as [|n]; first by exact I.
- simpl in *. rewrite EQa EQb. reflexivity.
- - move=>n a1 a2 EQa.
- destruct n as [|n]; first by exact I. rewrite EQa. reflexivity.
- - move=>n t1 t2 EQt. destruct n as [|n]; first exact: dist_bound.
- simpl in EQt. move=>m Hle. simpl.
- destruct m; first reflexivity. simpl.
- rewrite ->EQt. reflexivity.
- - move=>t. split.
- + move=>H. specialize (H 1%nat). exact H.
- + move=>H n. simpl. destruct n; simpl; tauto.
- - move=>t1 t2 n. destruct n; first reflexivity.
- exact: ra_op_valid.
- Qed.
-
- Instance discreteCMRAExt : CMRAExt T.
- Proof.
- move=>n; intros. destruct n.
- { exists (1 t2) t2. split; last exact:dist_bound.
- now rewrite ra_op_unit. }
- exists t11 t12. split; last reflexivity. rewrite /dist /= in EQt.
- rewrite -EQt EQt1. reflexivity.
- Qed.
-End DiscreteCMRA.
-
-(* Pairs work as CMRA *)
-Section PairsCMRA.
- Context {S T: Type} `{cmraS: CMRA S} `{cmraT: CMRA T}.
-
- Global Instance ra_prod_pcm: pcmType (pTA:=pord_ra) (S * T).
- Proof.
- split. intros σ Ï Ïƒc Ïc HC.
- apply ra_pord_iff_prod_pord.
- eapply pcm_respC; first by apply _.
- move=>i. apply ra_pord_iff_prod_pord. by apply: HC.
- Qed.
-
- Global Instance ra_prod_cmra_valid : CMRA_valid (S * T) :=
- fun st => let (s, t) := st in and (cmra_valid s) (cmra_valid t).
-
- Global Instance ra_prod_cmra: CMRA (S * T).
- Proof.
- split.
- - move=>n [s11 t11] [s12 t12] /= [EQs1 EQt1] [s21 t21] [s22 t22] /= [EQs2 EQt2].
- split.
- + rewrite EQs1 EQs2. reflexivity.
- + rewrite EQt1 EQt2. reflexivity.
- - move=>n [s11 t11] [s12 t12] /= [EQs1 EQt1].
- split.
- + rewrite EQs1. reflexivity.
- + rewrite EQt1. reflexivity.
- - move=>n [t1 s1] [t2 s2] /= [EQt EQs]. eapply and_sp_dist; eapply cmra_valid_dist; assumption.
- - move=>[t s]. split=>H.
- + split; eapply cmra_ra_valid; intro n; eapply H.
- + move=>n. split; eapply cmra_ra_valid; eapply H.
- - move=>[s1 t1] [s2 t2] n H. split; eapply cmra_op_valid; eapply H.
- Qed.
-
- Lemma cmra_prod_valid {p n} :
- cmra_valid p n <-> cmra_valid (fst p) n /\ cmra_valid (snd p) n.
- Proof. by move: p=>[s t]. Qed.
-
- Section PairsCMRAExt.
- Context {cmraSe: CMRAExt S} {cmraTe: CMRAExt T}.
-
- Global Instance ra_prod_ext: CMRAExt (S * T).
- Proof.
- move=>n [s1 t1] [s11 t11] [s12 t12] [s2 t2] [EQs EQt] [EQs1 EQt1].
- destruct (cmra_extend n s1 s11 s12 s2) as [s21 [s22 [EQs2 [EQss1 EQss2]]]]; [assumption|assumption|].
- destruct (cmra_extend n t1 t11 t12 t2) as [t21 [t22 [EQt2 [EQtt1 EQtt2]]]]; [assumption|assumption|].
- exists (s21, t21) (s22, t22). repeat split; assumption.
- Qed.
- End PairsCMRAExt.
-
-End PairsCMRA.
-
-Section PairsMap.
- Context {S T U V: Type} `{cmraS: CMRA S} `{cmraT: CMRA T} `{cmraU: CMRA U} `{cmraV: CMRA V}.
-
- Local Instance ra_force_pord_TS: preoType (T * S) := pord_ra.
- Local Instance ra_force_pord_UV: preoType (U * V) := pord_ra.
-
- Program Definition RAprod_map (f: T -m> U) (g: S -m> V): (T * S) -m> (U * V) :=
- mkMUMorph (pcmprod_map f g) _.
- Next Obligation. (* If one day, this obligation disappears, then probably the instances are not working out anymore *)
- move=>x y EQxy. change (pcmprod_map f g x ⊑ pcmprod_map f g y).
- apply ra_pord_iff_prod_pord. apply ra_pord_iff_prod_pord in EQxy.
- by eapply mu_mono.
- Qed.
-
- Global Instance RAprod_map_resp: Proper (equiv ==> equiv ==> equiv) RAprod_map.
- Proof.
- move=>f1 f2 EQf g1 g2 EQg. change (pcmprod_map f1 g1 == pcmprod_map f2 g2).
- rewrite EQf EQg. reflexivity.
- Qed.
- Global Instance RAprod_map_nonexp n : Proper (dist n ==> dist n ==> dist n) RAprod_map.
- Proof.
- move=>f1 f2 EQf g1 g2 EQg. change (pcmprod_map f1 g1 = n = pcmprod_map f2 g2).
- rewrite EQf EQg. reflexivity.
- Qed.
- Global Instance RAprod_map_monic : Proper (pord ++> pord ++> pord) RAprod_map.
- Proof.
- move=>f1 f2 EQf g1 g2 EQg x. apply ra_pord_iff_prod_pord.
- revert x. change (pcmprod_map f1 g1 ⊑ pcmprod_map f2 g2).
- by eapply pcmprod_map_monic.
- Qed.
-End PairsMap.
-Section PairsMapComp.
- Context {S T: Type} `{cmraS: CMRA S} `{cmraT: CMRA T}.
-
- Lemma RAprod_map_id:
- RAprod_map (pid T) (pid S) == pid (T*S).
- Proof. (* doing the proof again here is actually easier than using the ones from PreoMet... *)
- intros x. simpl. split; reflexivity.
- Qed.
-
- Context {U V W X: Type} `{cmraU: CMRA U} `{cmraV: CMRA V} `{cmraW: CMRA W} `{cmraX: CMRA X}.
-
- Lemma RAprod_map_comp (f: T -m> U) (g: U -m> V) (h: S -m> W) (i: W -m> X):
- RAprod_map g i ∘ RAprod_map f h == RAprod_map (g ∘ f) (i ∘ h).
- Proof.
- intros x. simpl. split; reflexivity.
- Qed.
-End PairsMapComp.
-Lemma RAprod_map_comp_fst {S T U V W: Type}
- `{cmraS: CMRA S} `{cmraT: CMRA T} `{cmraU: CMRA U} `{cmraV: CMRA V} `{cmraW: CMRA W}
- (f: T -m> U) (g: U -m> V) (h: S -m> W):
- RAprod_map g h ∘ RAprod_map f (pid _) == RAprod_map (g ∘ f) h.
-Proof.
- intros x. simpl. split; reflexivity.
-Qed.
-
-
-(* Show that any BI can close over "future Us", for U being a CMRA. *)
-Section MComplBI.
- Context {B} `{ComplBI B}.
- Context {T} `{CMRA T}.
- Local Obligation Tactic := intros; try resp_set.
-
- Program Definition mclose : (T -n> B) -n> T -m> B :=
- n[(fun f: T -n> B => m[(fun t => (all (U:=T) (f <M< n[(ra_op t)])))])].
- Next Obligation.
- move=>t1 t2 EQt. eapply all_dist. eapply ndist_umcomp; first reflexivity.
- move=>u. now eapply cmra_op_dist.
- Qed.
- Next Obligation.
- intros t1 t2 [t3 EQt]. simpl. eapply all_R=>u.
- simpl. rewrite <-EQt. rewrite-> (comm t3), <-assoc.
- transitivity ((f <M< n[(ra_op t1)]) (t3 · u)%ra); last first.
- - eapply pordR. simpl. reflexivity.
- - eapply all_R. eapply pordR, all_equiv. move=>?. reflexivity.
- Qed.
- Next Obligation.
- intros f1 f2 EQf t. simpl. eapply all_dist. move=>u. simpl. rewrite EQf. reflexivity.
- Qed.
-
- Lemma mclose_cl f : (mclose f: T -n> B) ⊑ f.
- Proof.
- unfold mclose=>u. simpl.
- transitivity ((f <M< n[(ra_op u)]) (1 u)%ra).
- - eapply all_R. eapply all_pord=>t. reflexivity.
- - simpl. rewrite ra_op_unit2. reflexivity.
- Qed.
- Lemma mclose_fw (f : T -n> B) u t (HFW : forall u' (HS : u ⊑ u'), t ⊑ f u'):
- t ⊑ mclose f u.
- Proof.
- unfold mclose. simpl. eapply all_R=>u'.
- eapply HFW. exists u'. rewrite comm. reflexivity.
- Qed.
-
-End MComplBI.
-
-(* Monotone functions from a CMRA to a BI form a BI. *)
-Section MonotoneExtLattice.
- Context B `{BL: Lattice B}.
- Context T `{cmraT: CMRA T} {cmraI: VIRA T}.
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
-
- Local Obligation Tactic := intros; resp_set || mono_resp || eauto with typeclass_instances.
-
- Global Instance top_mm : topBI (T -m> B) := pcmconst top.
- Global Instance bot_mm : botBI (T -m> B) := pcmconst bot.
- Global Instance valid_mm : validBI (T -m> B) := fun P => forall t, valid (P t).
-
- Global Program Instance and_mm : andBI (T -m> B) :=
- fun P Q => m[(lift_bin and P Q)].
- Global Program Instance or_mm : orBI (T -m> B) :=
- fun P Q => m[(lift_bin or P Q)].
-
- Global Instance and_mm_equiv : Proper (equiv ==> equiv ==> equiv) and_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply and_equiv; [apply EQP | apply EQQ].
- Qed.
- Global Instance and_mm_dist n : Proper (dist n ==> dist n ==> dist n) and_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply and_dist; [apply EQP | apply EQQ].
- Qed.
- Global Instance and_mm_ord : Proper (pord ==> pord ==> pord) and_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply and_pord; [apply EQP | apply EQQ].
- Qed.
-
- Global Instance or_mm_equiv : Proper (equiv ==> equiv ==> equiv) or_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply or_equiv; [apply EQP | apply EQQ].
- Qed.
- Global Instance or_mm_dist n : Proper (dist n ==> dist n ==> dist n) or_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply or_dist; [apply EQP | apply EQQ].
- Qed.
- Global Instance or_mm_ord : Proper (pord ==> pord ==> pord) or_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply or_pord; [apply EQP | apply EQQ].
- Qed.
-
- Global Program Instance lattice_mm : Lattice (T -m> B).
- Next Obligation.
- move=>t. apply pord_antisym; auto.
- Qed.
- Next Obligation.
- intros t. apply top_true.
- Qed.
- Next Obligation.
- intros t. apply bot_false.
- Qed.
- Next Obligation.
- split; intros HV.
- - intros t. simpl morph. unfold const. rewrite <-top_valid. eapply HV.
- - intros t. rewrite ->top_valid. eapply HV.
- Qed.
- Next Obligation.
- move=>H. destruct cmraI as [t _].
- specialize (H t). simpl in H. unfold const in H. apply consistency in H.
- contradiction.
- Qed.
- Next Obligation.
- intros t; simpl morph; apply and_self.
- Qed.
- Next Obligation.
- intros t; simpl morph; apply and_projL.
- Qed.
- Next Obligation.
- intros t; simpl morph; apply and_projR.
- Qed.
- Next Obligation.
- intros t; simpl morph; apply or_injL.
- Qed.
- Next Obligation.
- intros t; simpl morph; apply or_injR.
- Qed.
- Next Obligation.
- intros t; simpl morph; apply or_self.
- Qed.
-End MonotoneExtLattice.
-
-Section MonotoneExtCBI.
- Context B `{BL: EqBI B}.
- Context T `{cmraT: CMRA T} {cmraI: VIRA T}.
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
-
- Local Obligation Tactic := intros; resp_set || mono_resp || eauto with typeclass_instances.
-
- Global Program Instance impl_mm : implBI (T -m> B) :=
- fun P Q => mclose (lift_bin impl P Q).
-
- Global Program Instance sc_mm : scBI (T -m> B) :=
- fun P Q => m[(fun t:T => xist n[(fun ts:T*T => (Mfst ts · Msnd ts) === t ∧ (P (Mfst ts) * Q (Msnd ts)))])].
- Next Obligation.
- move=>t1 t2 EQt. rewrite /= -/dist. eapply xist_dist. move=>[ts1 ts2] /=. rewrite -/dist.
- rewrite EQt. reflexivity.
- Qed.
- Next Obligation.
- move=>t1 t2 [tx EQt]. simpl. eapply xist_L. intros [ts1 ts2]. eapply xist_R with (u:=(ts1·tx, ts2)).
- simpl. eapply and_pord; last eapply sc_pord.
- - rewrite !intEq_leibnitz /bi_leibnitz. eapply all_R=>φ/=.
- eapply all_L with (u:= φ <M< ra_op_n tx). simpl. apply pordR.
- eapply impl_equiv; f_equiv.
- + rewrite (comm ts1 tx) (assoc _ ts1). reflexivity.
- + assumption.
- - eapply mu_mono. exists tx. rewrite comm. reflexivity.
- - reflexivity.
- Qed.
-
- Global Program Instance si_mm : siBI (T -m> B) :=
- fun P Q => m[(fun t1 => all n[(fun t2 => (P t2) -* (Q (t1 · t2)))])].
- Next Obligation.
- move=>u1 u2 EQu. simpl. eapply si_dist.
- - rewrite EQu. reflexivity.
- - rewrite EQu. reflexivity.
- Qed.
- Next Obligation.
- move=>u1 u2 EQu. eapply all_dist. move=>t. simpl. eapply si_dist; first reflexivity.
- rewrite EQu. reflexivity.
- Qed.
- Next Obligation.
- intros t1 t2 [t3 EQt]. simpl. eapply all_R=>u.
- simpl. transitivity (P (t3 · u) -* Q (t3 · t1 · u)); last first.
- - rewrite -sc_si. assert (HP: P u ⊑ P (t3 · u)).
- { eapply mu_mono. exists t3. reflexivity. }
- setoid_rewrite HP. rewrite sc_si. eapply si_pord; first reflexivity. eapply mu_mono, pordR.
- rewrite EQt. reflexivity.
- - eapply (all_L (t3 · u)). simpl. eapply si_pord; first reflexivity. eapply mu_mono, pordR.
- rewrite assoc (comm t1). reflexivity.
- Qed.
-
- Global Instance impl_mm_dist n : Proper (dist n ==> dist n ==> dist n) impl_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ; apply met_morph_nonexp; intros t; simpl morph.
- apply impl_dist; [apply EQP | apply EQQ].
- Qed.
-
- Global Instance sc_mm_equiv : Proper (equiv ==> equiv ==> equiv) sc_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply xist_equiv; move=>[t1 t2]. simpl. apply and_equiv; first reflexivity.
- apply sc_equiv; [apply EQP | apply EQQ].
- Qed.
- Global Instance sc_mm_dist n : Proper (dist n ==> dist n ==> dist n) sc_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply xist_dist; move=>[t1 t2]. simpl morph. apply and_dist; first reflexivity.
- apply sc_dist; [apply EQP | apply EQQ].
- Qed.
- Global Instance sc_mm_ord : Proper (pord ++> pord ++> pord) sc_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
- apply xist_pord. intros [t1 t2]. simpl morph. eapply and_pord; first reflexivity.
- apply sc_pord; [apply EQP | apply EQQ].
- Qed.
-
- Global Instance sc_mm_comm : Commutative sc_mm.
- Proof.
- intros f1 f2 t; simpl morph. apply pord_antisym.
- - apply xist_L; move=>[u1 u2]. simpl morph. apply (xist_R (u2, u1)). simpl morph. apply and_pord.
- + apply pordR. apply intEq_equiv; last reflexivity. rewrite comm. reflexivity.
- + rewrite comm. reflexivity.
- - apply xist_L; move=>[u1 u2]. simpl morph. apply (xist_R (u2, u1)). simpl morph. apply and_pord.
- + apply pordR. apply intEq_equiv; last reflexivity. rewrite comm. reflexivity.
- + rewrite comm. reflexivity.
- Qed.
-
- Program Definition sc_mm_assoc_f1 u1 u2 t (f1 f2 f3: T -n> B) :=
- lift_bin and (umconst ((u1 · u2) === t)) (lift_bin sc (umconst (f1 u1)) n[(fun ts => ((fst ts · snd ts) === u2) ∧ (f2 (fst ts) * f3 (snd ts)))]).
-
- Program Definition sc_mm_assoc_f2 u1 u2 t (f1 f2 f3: T -n> B) :=
- lift_bin and (umconst ((u1 · u2) === t)) (lift_bin sc n[(fun ts => (fst ts · snd ts) === u1 ∧ (f1 (fst ts) * f2 (snd ts)))] (umconst (f3 u2))).
-
- Existing Instance sc_equiv.
-
- Global Instance sc_mm_assoc : Associative sc_mm.
- Proof.
- intros f1 f2 f3 t; simpl morph. apply pord_antisym.
- - apply xist_L; move=>[u1 u2]. simpl morph.
- transitivity (xist (sc_mm_assoc_f1 u1 u2 t f1 f2 f3)); unfold sc_mm_assoc_f1.
- + etransitivity; last eapply xist_and_r. apply and_pord; first reflexivity.
- etransitivity; last eapply xist_sc_r. apply sc_pord; first reflexivity.
- reflexivity.
- + apply xist_L; move=>[u3 u4]. simpl morph. unfold const.
- apply (xist_R (u1 · u3, u4)). simpl morph. apply and_R; split.
- * transitivity ((u1 · u2) === t ∧ (u3 · u4) === u2).
- { apply and_pord; first reflexivity. setoid_rewrite and_projL.
- apply sc_projR. }
- eapply intEq_rewrite_goal with (φ := intEq_l (u1 · u3 · u4)).
- { rewrite ->and_projL. reflexivity. }
- setoid_rewrite and_projR. eapply intEq_rewrite_goal with (t2:=u2) (φ := intEq_l (u1 · u3 · u4) <M< ra_op_n u1).
- { reflexivity. }
- simpl morph. eapply intEqR. now rewrite assoc.
- * transitivity ((f1 u1 * f2 u3) * f3 u4).
- { rewrite ->and_projR, and_projR. rewrite assoc. reflexivity. }
- apply sc_pord; last reflexivity.
- apply (xist_R (u1, u3)). simpl morph.
- apply and_R; split; last reflexivity.
- setoid_rewrite <-intEq_refl. apply top_true.
- - apply xist_L; move=>[u1 u2]. simpl morph.
- transitivity (xist (sc_mm_assoc_f2 u1 u2 t f1 f2 f3)); unfold sc_mm_assoc_f2.
- + etransitivity; last eapply xist_and_r. apply and_pord; first reflexivity.
- eapply xist_sc.
- + apply xist_L; move=>[u3 u4]. simpl morph. unfold const.
- apply (xist_R (u3, u4·u2)). simpl morph. apply and_R; split.
- * transitivity ((u1 · u2) === t ∧ (u3 · u4) === u1).
- { apply and_pord; first reflexivity. rewrite ->and_projL, sc_projL. reflexivity. }
- eapply intEq_rewrite_goal with (φ := intEq_l (u3 · (u4 · u2))).
- { rewrite ->and_projL. reflexivity. }
- rewrite ->and_projR. simpl morph. eapply intEq_rewrite_goal with (t2:=u1) (φ := intEq_l (u3 · (u4 · u2)) <M< Mswap ra_op_n u2).
- { reflexivity. }
- simpl morph. eapply intEqR. now rewrite assoc.
- * transitivity (f1 u3 * (f2 u4 * f3 u2)).
- { rewrite ->and_projR, and_projR. rewrite assoc. reflexivity. }
- apply sc_pord; first reflexivity.
- apply (xist_R (u4, u2)). simpl morph. apply and_R; split; last reflexivity.
- setoid_rewrite <-intEq_refl. apply top_true.
- Qed.
-
- Global Instance si_mm_dist n : Proper (dist n ==> dist n ==> dist n) si_mm.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ t. simpl morph.
- apply all_dist; move=>u. simpl morph.
- apply si_dist; [apply EQP | apply EQQ].
- Qed.
-
- Global Program Instance all_mm : allBI (T -m> B) :=
- fun U eqU mU cmU R =>
- m[(fun t => all n[(fun u => R u t)])].
- Next Obligation.
- intros t1 t2 EQt; apply all_dist; intros u; simpl morph.
- rewrite EQt; reflexivity.
- Qed.
- Next Obligation.
- intros t1 t2 Subt; apply all_pord; intros u; simpl morph.
- rewrite ->Subt; reflexivity.
- Qed.
-
- Global Program Instance xist_mm : xistBI (T -m> B) :=
- fun U eqU mU cmU R =>
- m[(fun t => xist n[(fun u => R u t)])].
- Next Obligation.
- intros t1 t2 EQt; apply xist_dist; intros u; simpl morph.
- rewrite EQt; reflexivity.
- Qed.
- Next Obligation.
- intros t1 t2 Subt; apply xist_pord; intros u; simpl morph.
- rewrite ->Subt; reflexivity.
- Qed.
-
- Section Quantifiers.
- Context V `{cmV : cmetric V}.
-
- Global Instance all_mm_dist n : Proper (dist (T := V -n> T -m> B) n ==> dist n) all.
- Proof.
- intros R1 R2 EQR t; simpl morph.
- apply all_dist; intros u; simpl morph; apply EQR.
- Qed.
-
- Global Instance xist_mm_dist n : Proper (dist (T := V -n> T -m> B)n ==> dist n) xist.
- Proof.
- intros R1 R2 EQR t; simpl morph.
- apply xist_dist; intros u; simpl morph; apply EQR.
- Qed.
-
- End Quantifiers.
-
- Global Program Instance cbi_mm : ComplBI (T -m> B).
- Next Obligation.
- split; intros HH t; simpl morph.
- - apply mclose_fw; intros t' Subt; specialize (HH t'); simpl morph in *.
- rewrite ->Subt, <- and_impl; assumption.
- - rewrite ->and_impl, (HH t); apply mclose_cl.
- Qed.
- Next Obligation.
- intros t; simpl morph. apply pord_antisym.
- - apply xist_L;move=>[ts1 ts2]. simpl morph.
- eapply intEq_rewrite_goal with (φ := P).
- { rewrite ->and_projL. reflexivity. }
- rewrite ->and_projR, ->sc_projR. apply mu_mono. exists ts1. reflexivity.
- - apply (xist_R (1 t, t)). simpl morph. apply and_R; split.
- + eapply intEqR. now rewrite ra_op_unit.
- + unfold const. rewrite sc_top_unit. reflexivity.
- Qed.
- Next Obligation.
- split; move=>HLE t.
- - simpl. apply all_R=>u. simpl morph.
- eapply sc_si. rewrite <-(HLE _). simpl morph. apply (xist_R (t, u)). simpl morph.
- apply and_R; split; last reflexivity.
- eapply intEqR. reflexivity.
- - simpl. apply xist_L;move=>[u1 u2]. simpl morph.
- eapply intEq_rewrite_goal with (φ := R).
- { rewrite ->and_projL. reflexivity. }
- rewrite ->and_projR=>{t}. apply sc_si. rewrite ->HLE=>{HLE}. simpl.
- apply (all_L u2). reflexivity.
- Qed.
- Next Obligation.
- split.
- - intros HH t; simpl morph; rewrite <- all_R; intros u; simpl morph; apply HH.
- - intros HH u t; specialize (HH t); simpl morph in *; rewrite <- all_R in HH.
- simpl morph in HH; apply HH.
- Qed.
- Next Obligation.
- split.
- - intros HH t; simpl morph; rewrite <- xist_L; intros u; simpl morph; apply HH.
- - intros HH u t; specialize (HH t); simpl morph in *.
- rewrite <- xist_L in HH; simpl morph in HH; apply HH.
- Qed.
-End MonotoneExtCBI.
-
-Section MonotoneExtEQ.
- Context B `{LB: EqBI B}
- T `{cmraT : CMRA T} {cmraI : VIRA T}.
- Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
- Local Open Scope ra_scope.
- Local Open Scope bi_scope.
-
- Global Instance eq_mm : eqBI (T -m> B) :=
- fun U {eqU mU cmU u1 u2} => pcmconst (u1 === u2).
-
- Global Instance eqbi_mm : EqBI (T -m> B).
- Proof.
- split; intros.
- - move=>t1 t2 EQt u1 u2 EQu x. simpl morph. unfold const. apply intEq_equiv; assumption.
- - move=>t1 t2 EQt u1 u2 EQu x. simpl morph. unfold const. apply intEq_dist; assumption.
- - move=>x. simpl morph. unfold const. rewrite intEq_leibnitz /bi_leibnitz. apply pord_antisym.
- + apply all_R=>f. simpl morph. apply all_R=>t. simpl morph.
- pose (φ := fun u => f u (x·t)%ra).
- assert (φ_dist: forall n, Proper (dist n ==> dist n) φ).
- { clear. move=>n u1 u2 EQu. unfold φ. rewrite EQu. reflexivity. }
- apply (all_L n[(φ)]). simpl morph. unfold φ. reflexivity.
- + apply all_R=>f. simpl morph.
- pose (φ := fun u => (pcmconst (T:=T) (U:=B) (f u))).
- assert (φ_dist: forall n, Proper (dist n ==> dist n) φ).
- { clear. move=>n u1 u2 EQu r. unfold φ, pcmconst. simpl morph. unfold const. rewrite EQu. reflexivity. }
- apply (all_L n[(φ)]). simpl morph. apply (all_L x)%ra. simpl morph. unfold const. apply impl_pord.
- * reflexivity.
- * reflexivity.
- Qed.
-
-End MonotoneExtEQ.
-
-(* Package an CMRA as a module type (for use with other modules). *)
-Module Type CMRA_T <: RA_T.
- Include RA_T.
- Declare Instance res_metric : metric res.
- Declare Instance res_cmetric : cmetric res.
- Declare Instance res_pcmetric : pcmType (eqT:=res_type) (pTA:=pord_ra) res.
- Declare Instance res_cmra_valid : CMRA_valid res.
- Declare Instance res_cmra : CMRA res.
-End CMRA_T.
-
-Module Type CMRA_EXT_T <: CMRA_T.
- Include CMRA_T.
- Declare Instance res_cmra_ext : CMRAExt res.
-End CMRA_EXT_T.
diff --git a/lib/ModuRes/CSetoid.v b/lib/ModuRes/CSetoid.v
deleted file mode 100644
index 660d95561341a7c2e3995b1dbf032cee14ff5d72..0000000000000000000000000000000000000000
--- a/lib/ModuRes/CSetoid.v
+++ /dev/null
@@ -1,433 +0,0 @@
-(** Basic categorical definitions. The role of objects is played by
- the class [type] which is a type equipped with an equivalence
- relation.
-
- Then there are standard constructions defined using these objects
- (product, exponential, initial objects and functors at the end)
- and some of their properties are proved.
- *)
-
-Require Import Ssreflect.ssreflect.
-Require Export Coq.Program.Program.
-Require Export Morphisms SetoidTactics.
-Require Export SetoidClass.
-Require Export Util.
-
-Generalizable Variables T U V W.
-
-Local Open Scope type.
-
-(* Proof by reflexivity *)
-Lemma equivR {T : Type} {R: relation T} {eqR : Equivalence R} {a b : T} :
- a = b -> R a b.
-Proof.
- intros Heq. subst a. reflexivity.
-Qed.
-
-Notation "'mkType' R" := (@Build_Setoid _ R _) (at level 10).
-Arguments equiv {_ _} !_ !_ /.
-Arguments const {_ _} _ _ /.
-
-Class Associative {T} `{eqT : Setoid T} (op : T -> T -> T) :=
- assoc : forall t1 t2 t3, op t1 (op t2 t3) == op (op t1 t2) t3.
-Class Commutative {T} `{eqT : Setoid T} (op : T -> T -> T) :=
- comm : forall t1 t2, op t1 t2 == op t2 t1.
-
-
-(** A morphism between two types is an actual function together with a
- proof that it preserves equality. *)
-Record morphism T U `{eqT : Setoid T} `{eqU : Setoid U} :=
- mkMorph {
- morph :> T -> U;
- morph_resp : Proper (equiv ==> equiv) morph}.
-
-Arguments mkMorph [T U] {_ _} _ _.
-Arguments morph [T U] {_ _} !_ _ /.
-Arguments morph_resp [T U] {_ _} _ _ _ _.
-
-Infix "-=>" := morphism (at level 45, right associativity).
-Notation "'s[(' f ')]'" := (mkMorph f _).
-Ltac resp_set :=
- intros t1 t2 HEqt; repeat (intros ?); simpl in *; try rewrite -> !HEqt; reflexivity.
-
-Section Morphisms.
- Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V}.
-
- (* This should really also be somewhere in the stdlib... *)
- Global Program Instance pmorph_type : Setoid (T -> U) :=
- mkType (fun f g => forall x, f x == g x).
- Next Obligation.
- clear; split.
- - intros f x; reflexivity.
- - intros f g HS x; symmetry; apply HS.
- - intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
- Qed.
-
- (** The type of equivalence-preserving maps is again a type with
- equivalence, defined pointwise. *)
- Global Program Instance morph_type : Setoid (T -=> U) :=
- mkType (fun f g => forall x, f x == g x).
- Next Obligation.
- clear; split.
- - intros f x; reflexivity.
- - intros f g HS x; symmetry; apply HS.
- - intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
- Qed.
-
- (** The application of [morphsm] to its argument preserves equality
- in both the function and the argument. *)
- Global Instance equiv_morph :
- Proper (equiv ==> equiv ==> equiv) (morph (T:=T) (U:=U)).
- Proof.
- intros f g HEq x y HEq'; etransitivity; [apply HEq | apply g, HEq'].
- Qed.
-
- (** Definition of composition of morphisms. Note the different
- arrows, i.e., -=> and ->. *)
- Program Definition mcomp (f: U -=> V) (g: T -=> U) : (T -=> V) :=
- s[(f ∘ g)].
- Next Obligation.
- intros x y HEq; apply f, g; assumption.
- Qed.
-
- Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
-
- (** Two specific morphisms, identity and constant maps. *)
- Program Definition mid : T -=> T := s[(fun x => x)].
-
- Program Definition mconst (u : U) : T -=> U := s[(const u)].
-
-End Morphisms.
-
-Infix "<<" := mcomp (at level 35).
-Arguments mid T {eT}.
-Arguments compose {_ _ _} _ _ _ /.
-
-Section MorphConsts.
- Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V} `{eW : Setoid W}.
-
- (** Composition maps equal morphism to equal morphisms. *)
- Global Instance equiv_mcomp :
- Proper (equiv (A := U -=> V) ==> equiv ==> equiv) mcomp.
- Proof.
- intros f f' HEq g g' HEq' x; simpl; rewrite ->HEq, HEq'; reflexivity.
- Qed.
-
- (** Composition of morphisms is associative. *)
- Lemma mcomp_assoc (f: V -=> W) (g: U -=> V) (h: T -=> U) :
- f << (g << h) == (f << g) << h.
- Proof. intros x; reflexivity. Qed.
-
- (** Identity is left- and right- identity for composition *)
- Lemma mcomp_idR (f : U -=> V) :
- f << mid _ == f.
- Proof. intros x; reflexivity. Qed.
- Lemma mcomp_idL (f : U -=> V) :
- mid _ << f == f.
- Proof. intros x; reflexivity. Qed.
-
- (** Lift an ordinary function to a function on [type]'s. *)
- Definition lift2s (f : T -> U -> V) p q : (T -=> U -=> V) :=
- mkMorph (fun x => mkMorph (f x) (p x)) q.
-
- Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
-
- (** Pre- and postcomposition, as equality-preserving maps *)
- Program Definition precomp (f : T -=> U) : (U -=> V) -=> (T -=> V) :=
- s[(fun g => g << f)].
-
- Program Definition postcomp (f : T -=> U) : (V -=> T) -=> (V -=> U) :=
- s[(fun g => f << g)].
-
-End MorphConsts.
-
-(*Instance Equiv_PropP : Equiv Prop := iff.
-Instance type_PropP : type Prop := iff_equivalence.*)
-
-Section SetoidProducts.
- Context `{eU : Setoid U} `{eV : Setoid V}.
-
- (** The product of two types is another type, with equality defined pointwise. *)
- Global Program Instance prod_type : Setoid (U * V) :=
- mkType (fun p1 p2 : U * V => (fst p1) == (fst p2) /\ (snd p1) == (snd p2)).
- Next Obligation.
- split.
- - intros [u v]; split; reflexivity.
- - intros [u1 v1] [u2 v2] [Hu Hv]; split; symmetry; assumption.
- - intros [u1 v1] [u2 v2] [u3 v3] [Hu12 Hv12] [Hu23 Hv23]; split; etransitivity; eassumption.
- Qed.
-
- Global Instance prod_proper : Proper (equiv ==> equiv ==> equiv) (@pair U V).
- Proof.
- intros u1 u2 Hu v1 v2 Hv; split; assumption.
- Qed.
-
- Global Instance mfst_proper : Proper (equiv ==> equiv) (@fst U V).
- Proof.
- intros [u1 v1] [u2 v2] [Hu Hv]; assumption.
- Qed.
-
- Global Instance msnd_proper : Proper (equiv ==> equiv) (@snd U V).
- Proof.
- intros [u1 v1] [u2 v2] [Hu Hv]; assumption.
- Qed.
-
- Local Obligation Tactic := intros; resp_set || program_simpl.
-
- (** The projections are in fact proper morphisms, i.e. they preserve equality. *)
- Program Definition mfst : (U * V) -=> U := s[(fst)].
-
- Program Definition msnd : (U * V) -=> V := s[(snd)].
-
- Context `{eT : Setoid T}.
-
- (** Tupling is also a proper morphism, i.e. respects equality. *)
- Program Definition mprod (f: T -=> U) (g: T -=> V) : T -=> (U * V) :=
- s[(fun t => (f t, g t))].
- Next Obligation.
- add_morphism_tactic; intros.
- rewrite H. split; reflexivity.
- Qed.
-
- Lemma mprod_unique (f: T -=> U) (g: T -=> V) (h: T -=> U * V) :
- mfst << h == f -> msnd << h == g -> h == mprod f g.
- Proof.
- intros HL HR x; split; simpl; [rewrite <- HL | rewrite <- HR]; reflexivity.
- Qed.
-
-End SetoidProducts.
-
-Arguments mprod_unique [U eU V eV T eT f g h] _ _ _.
-
-Section SetoidSums.
- Context `{eU : Setoid U} `{eV : Setoid V}.
-
- (** The sum of two types is another type, with equality defined pointwise. *)
- Definition sum_equiv (s1 s2: U + V) :=
- match s1, s2 with
- | inl u1, inl u2 => u1 == u2
- | inr v1, inr v2 => v1 == v2
- | _ , _ => False
- end.
-
- Global Program Instance sum_type : Setoid (U + V) :=
- mkType sum_equiv.
- Next Obligation.
- split.
- - intros [u|v]; simpl; reflexivity.
- - move=> [u1|v1] [u2|v2] /=; try tauto; move=>H; symmetry; assumption.
- - move=> [u1|v1] [u2|v2] [u3|v3] /=; try tauto; move=>H1 H2; etransitivity; eassumption.
- Qed.
-End SetoidSums.
-
-
-Section Exponentials.
- Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V} `{eW : Setoid W}.
-
- Local Obligation Tactic := intros; resp_set || program_simpl.
-
- (** Composition of morphism _as a morphims_. *)
- Program Definition comps : (U -=> V) -=> (T -=> U) -=> T -=> V :=
- lift2s (fun f g => f << g) _ _.
-
- Program Definition muncurry (f : T -=> U -=> V) : T * U -=> V :=
- s[(fun p => f (fst p) (snd p))].
-
- (** Currying map, i.e. the exponential transpose. *)
- Program Definition mcurry (f : T * U -=> V) : T -=> U -=> V :=
- lift2s (fun t u => f (t, u)) _ _.
-
- (** f × g, i.e. 〈 f ∘ π, g ∘ π' 〉 *)
- Definition mprod_map (f : T -=> U) (g : V -=> W) := mprod (f << mfst) (g << msnd).
-
- (** Evaluation map. *)
- Program Definition meval : (T -=> U) * T -=> U :=
- s[(fun p => fst p (snd p))].
-
-End Exponentials.
-
-Section Exp_props.
- Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V} `{eW : Setoid W}.
-
- (** (Λ(f) × id) ; eval = f, where Λ(f) is the exponential transpose. *)
- Lemma mcurry_com (f : T * U -=> V) : f == meval << (mprod_map (mcurry f) (mid _)).
- Proof. intros [a b]; reflexivity. Qed.
-
- (** Exponential transposes are unique. *)
- Lemma mcurry_unique (f : T * U -=> V) h :
- f == meval << (mprod_map h (mid _)) -> h == mcurry f.
- Proof. intros HEq a b; simpl; rewrite HEq; reflexivity. Qed.
-
-End Exp_props.
-
-Program Instance unit_type : Setoid unit := mkType (fun _ _ => True).
-Next Obligation.
- split.
- - intros _; exact I.
- - intros _ _ _; exact I.
- - intros _ _ _ _ _; exact I.
-Qed.
-
-(** The [unit] type is the terminal object, i.e., there's a unique
- morphism from any [Setoid] to [unit] *)
-Section Terminals.
- Context `{eT : Setoid T}.
-
- Definition mone_term : T -=> unit := mconst tt.
-
- Lemma mone_term_unique (f g : T -=> unit) : f == g.
- Proof.
- intros x; destruct (f x); destruct (g x); reflexivity.
- Qed.
-
-End Terminals.
-
-Inductive empty : Set :=.
-Program Instance empty_type : Setoid empty := mkType (fun _ _ => False).
-Next Obligation.
- split; intros x; case x.
-Qed.
-
-
-(** The empty [type] is the initial element, i.e. there is unique a
- morphism from it to any other [type]. *)
-Section Initials.
- Context `{eT : Setoid T}.
-
- Program Definition mzero_init : empty -=> T := s[(fun x => match x with end)].
- Next Obligation. intros x; case x; fail. Qed.
-
- Lemma mzero_init_unique (f g : empty -=> T) : f == g.
- Proof. intros x; case x. Qed.
-
-End Initials.
-
-(** Subsets. *)
-Section Subsetoid.
- Context `{eT : Setoid T} {P : T -> Prop}.
-
- (** [type] of elements that satisfy the predicate P, i.e. a
- subset. Equality is inherited from the carrier type. *)
- Global Program Instance subset_type : Setoid {t : T | P t} :=
- mkType (fun x y => ` x == ` y).
- Next Obligation.
- split.
- - intros [x Hx]; simpl; reflexivity.
- - intros [x Hx] [y Hy] HS; simpl in *; symmetry; assumption.
- - intros [x Hx] [y Hy] [z Hz] Hxy Hyz; simpl in *; etransitivity; eassumption.
- Qed.
-
- Global Instance proj1sig_proper :
- Proper (equiv (A := {t : T | P t}) ==> equiv) (@proj1_sig _ _).
- Proof. intros [x Hx] [y Hy] HEq; simpl in *; assumption. Qed.
-
- (** Inclusion from the subset to the superset is an
- equality-preserving morphism. *)
- Program Definition mincl : {t : T | P t} -=> T := s[(@proj1_sig _ _)].
-
- (** If we have a morphism from B to A whose image is in the subset
- determined by P, then this morphism restricts to the one into
- the subset determined by P. *)
- Context `{eU : Setoid U}.
- Program Definition minherit (f : U -=> T) (HB : forall u, P (f u)) :
- U -=> {t : T | P t} := s[(fun u => exist P (f u) (HB u))].
- Next Obligation.
- intros x y HEq; red; simpl; rewrite HEq; reflexivity.
- Qed.
-
- (** Inclusion from subset determined by P to the superset is a monomorphism. *)
- Lemma mforget_mono (f g : U -=> {t : T | P t}) :
- mincl << f == mincl << g -> f == g.
- Proof.
- intros HEq x; simpl. specialize (HEq x). simpl in HEq. exact HEq.
- Qed.
-
-End Subsetoid.
-
-(** Lifting of a type by adding a new distinct element.
-
- This is used for several constructions: lookups in finite maps
- return function types, for instance.
- *)
-Section Option.
- Context `{eT : Setoid T}.
-
- Definition opt_eq (x y : option T) :=
- match x, y with
- | None, None => True
- | Some x, Some y => x == y
- | _, _ => False
- end.
-
- Global Instance opt_eq_equiv: Equivalence opt_eq.
- Proof.
- split.
- - intros [a |]; simpl; reflexivity.
- - intros [a |] [b |] HS; simpl in *; now trivial || symmetry; assumption.
- - intros [a |] [b |] [c |] Hab Hbc; simpl in *; try (exact I || contradiction); [].
- etransitivity; eassumption.
- Qed.
-
- Global Instance option_type : Setoid (option T) := mkType opt_eq.
-
- Lemma option_eq_Some x y:
- Some x == Some y <-> x == y.
- Proof.
- reflexivity.
- Qed.
-
-End Option.
-
-Section OptDefs.
- Context `{eT : Setoid T} `{eU : Setoid U}.
-
- Global Instance Some_proper : Proper (equiv ==> equiv) (@Some T).
- Proof. intros a b HEq; simpl; apply HEq. Qed.
-
- Program Definition msome : T -=> option T := s[(@Some T)].
-
- Definition optbind (f : T -> option U) (ov : option T) : option U :=
- match ov with
- | Some v => f v
- | None => None
- end.
-
- Program Definition moptbind : (T -=> option U) -=> option T -=> option U :=
- lift2s (T:=T-=>option U) optbind _ _.
- Next Obligation.
- intros [v1 |] [v2 |] EQv; try (contradiction EQv || exact I); [].
- unfold optbind; apply x, EQv.
- Qed.
- Next Obligation.
- intros f1 f2 EQf [x |]; [simpl morph | exact I].
- apply EQf.
- Qed.
-
- Lemma opt_eq_iff x y : (forall v, x == Some v <-> y == Some v) -> x == y.
- Proof.
- intros. destruct x as [vx|] eqn:X, y as [vy|] eqn:Y.
- - generalize (H vy). intros H1y.
- rewrite H1y. reflexivity.
- - specialize (H vx). destruct H as [H1 _]. destruct H1. reflexivity.
- - specialize (H vy). destruct H as [_ H1]. destruct H1. reflexivity.
- - reflexivity.
- Qed.
-
-End OptDefs.
-
-Section DiscreteType.
- Context {T : Type}.
-
- Program Instance discreteType : Setoid T := mkType (@eq T).
-End DiscreteType.
-
-Section ViewLemmas.
- Context {T} `{eqT : Setoid T}.
- Implicit Types (t : T).
-
- Lemma srefl t : t == t.
- Proof. by reflexivity. Qed.
-
- Lemma strans {t1 t2 t3} (HL : t1 == t2) (HU : t2 == t3) : t1 == t3.
- Proof. by transitivity t2. Qed.
-End ViewLemmas.
diff --git a/lib/ModuRes/CatBasics.v b/lib/ModuRes/CatBasics.v
deleted file mode 100644
index 28dd93a81becc395407596b6eceb52e84a1376c5..0000000000000000000000000000000000000000
--- a/lib/ModuRes/CatBasics.v
+++ /dev/null
@@ -1,531 +0,0 @@
-(** This module provides the basics to do category theory on metric spaces:
- Bundled types, indexed products on bundled types, and some functors. *)
-
-Require Import Ssreflect.ssreflect.
-Require Import Arith Min Max.
-Require Import MetricCore PreoMet.
-Require Fin.
-
-Module NatDec.
- Definition U := nat.
- Definition eq_dec := eq_nat_dec.
-End NatDec.
-
-Module D := Coq.Logic.Eqdep_dec.DecidableEqDep(NatDec).
-
-(** This packs together all the
- ingredients of [type], i.e. the carrier set, the relation and the
- property that the relation is an equivalence relation. *)
-Record eqType :=
- {eqtyp :> Type;
- eqtype : Setoid eqtyp}.
-Instance eqType_proj_type {ET : eqType} : Setoid ET := eqtype _.
-Definition fromType T `{eT : Setoid T} : eqType := Build_eqType T _.
-
-Section IndexedProductsSetoid.
- Context {I : Type} {P : I -> eqType}.
-
- (** Equality on the indexed product. Essentially the same as for binary products, i.e. pointwise. *)
- Global Program Instance prodI_type : Setoid (forall i, P i) :=
- mkType (fun p1 p2 => forall i, p1 i == p2 i).
- Next Obligation.
- split.
- - intros X x; reflexivity.
- - intros X Y HS x; symmetry; apply HS.
- - intros X Y Z HPQ HQR x; etransitivity; [apply HPQ | apply HQR].
- Qed.
-
- Local Obligation Tactic := intros; resp_set || program_simpl.
-
- (** Projection functions. *)
- Program Definition mprojI (i : I) : (forall i, P i) -=> P i :=
- s[(fun X => X i)].
-
- Context {T: Type} `{eT : Setoid T}.
-
- (** Tupling into the indexed products. *)
- Program Definition mprodI (f : forall i, T -=> P i) : T -=> (forall i, P i) :=
- s[(fun t i => f i t)].
- Next Obligation.
- move=>f1 f2 EQf. simpl. apply EQf.
- Qed.
-
- Lemma mprod_projI (f : forall i, T -=> P i) i : mprojI i << mprodI f == f i.
- Proof. intros X; reflexivity. Qed.
-
- (** Product with the projections is an actual product. *)
- Lemma mprodI_unique (f : forall i, T -=> P i) (h : T -=> forall i, P i) :
- (forall i, mprojI i << h == f i) -> h == mprodI f.
- Proof.
- intros HEq x i; simpl; rewrite <- HEq; reflexivity.
- Qed.
-
-End IndexedProductsSetoid.
-
-Record Mtyp :=
- { mtyp :> eqType;
- mmetr : metric mtyp}.
-Instance mtyp_proj_metr {M : Mtyp} : metric M := mmetr M.
-Definition mfromType (T : Type) `{mT : metric T} := Build_Mtyp (fromType T) _.
-
-Record cmtyp :=
- { cmm :> Mtyp;
- iscm : cmetric cmm}.
-Instance cmtyp_cmetric {M : cmtyp} : cmetric M := iscm M.
-Definition cmfromType (T : Type) `{cT : cmetric T} := Build_cmtyp (mfromType T) _.
-
-
-(** Indexed product, very similar to binary product. The metric is pointwise, the supremum. *)
-Section MetricIndexed.
- Context {I : Type} {P : I -> Mtyp}.
-
- Local Obligation Tactic := intros; apply _ || resp_set || program_simpl.
-
- Definition distI n (a b : forall i, P i) := forall i, mprojI i a = n = mprojI i b.
- Global Arguments distI n a b /.
-
- Global Program Instance prodI_metr : metric (forall i, P i) :=
- mkMetr distI.
- Next Obligation.
- intros x y EQxy u v EQuv; split; intros EQ i; [symmetry in EQxy, EQuv |]; rewrite-> (EQxy i), (EQuv i); apply EQ.
- Qed.
- Next Obligation.
- split; intros HEq n.
- + rewrite <- dist_refl; intros m; apply (HEq m).
- + intros i; revert n; rewrite dist_refl; apply HEq.
- Qed.
- (*Next Obligation.
- intros x y HS i; symmetry; apply HS.
- Qed.*)
- Next Obligation.
- intros x y z Hxy Hyz i; etransitivity; [apply Hxy | apply Hyz].
- Qed.
- Next Obligation.
- eapply mono_dist, H; auto.
- Qed.
- Next Obligation.
- apply dist_bound.
- Qed.
-
- Program Definition MprojI (i : I) : (forall i, P i) -n> P i :=
- n[(mprojI i)].
- Next Obligation.
- move=>f1 f2 EQf. simpl. apply EQf.
- Qed.
-
- Context {T: Type} `{mT : metric T}.
- Program Definition MprodI (f : forall i, T -n> P i) : T -n> forall i, P i :=
- n[(mprodI f)].
-
- Lemma MprodI_proj f i : MprojI i <M< MprodI f == f i.
- Proof. intros x; reflexivity. Qed.
-
- Lemma MprodI_unique f g (HEq : forall i, MprojI i <M< g == f i) : g == MprodI f.
- Proof. apply (mprodI_unique f g HEq). Qed.
-
-End MetricIndexed.
-
-(** Indexed product of complete spaces is again a complete space. *)
-Section CompleteIndexed.
- Context {I : Type} {P : I -> cmtyp}.
-
- Definition prodI_compl (σ : chain (forall i, P i)) (σc : cchain σ) (i : I) :=
- compl (liftc (MprojI i) σ).
- Arguments prodI_compl σ σc i /.
- Global Program Instance prodI_cmetric : cmetric (forall i, P i) :=
- mkCMetr prodI_compl.
- Next Obligation.
- intros n; intros m HLe i.
- assert (Hk:=conv_cauchy (liftc (MprojI i) σ) n); simpl in *.
- rewrite -> Hk; [| apply le_max_r]; clear Hk.
- unfold liftc; apply σc; eauto using le_trans, le_max_l.
- Qed.
-
-End CompleteIndexed.
-
-Section Chains_of_IProds.
- Context {I : Type} {P : I -> cmtyp} (σ : chain (forall i, P i)) {σc : cchain σ}.
-
- Global Instance dep_chain_app (x : I) : cchain (fun n => σ n x).
- Proof.
- unfold cchain; intros; apply σc; assumption.
- Qed.
-
- Lemma dep_chain_compl (x : I) :
- compl σ x == compl (fun n => σ n x).
- Proof.
- apply umet_complete_ext; intros n; reflexivity.
- Qed.
-
-End Chains_of_IProds.
-
-Record preotyp :=
- {ptyp :> eqType;
- pprTyp : preoType ptyp}.
-Instance preotyp_pTyp {T : preotyp} : preoType T := pprTyp T.
-
-Section IndexedProductsPreo.
- Local Open Scope predom_scope.
- Context {I : Type} {P : I -> preotyp}.
-
- Definition ordI (f1 f2 : forall i, P i) := forall i, f1 i ⊑ f2 i.
-
- Global Program Instance ordTypeI : preoType (forall i, P i) := mkPOType ordI _.
- Next Obligation.
- split.
- + intros f i; reflexivity.
- + intros f g h Hfg Hgh i; etransitivity; [apply Hfg | apply Hgh].
- Qed.
- Next Obligation.
- move=> f1 f2 EQf g1 g2 EQg LE i.
- by rewrite -(EQf i) -(EQg i).
- Qed.
-
- Program Definition ordProjI (i : I) : (forall i, P i) -m> P i :=
- mkMMorph (mprojI i) _.
- Next Obligation. intros x y HSub; apply HSub. Qed.
-
- Context {T: Type} `{pT : preoType T}.
- Program Definition ordProdI (f : forall i, T -m> P i) : T -m> forall i, P i :=
- mkMMorph (mprodI f) _.
- Next Obligation. intros x y HSub i; simpl; apply f; assumption. Qed.
-
- Lemma ordProdI_proj f i : ordProjI i ∘ ordProdI f ⊑ f i.
- Proof. intros x; reflexivity. Qed.
- Lemma ordProdI_proj_rev f i : f i ⊑ ordProjI i ∘ ordProdI f.
- Proof. intros x; reflexivity. Qed.
-
- Lemma ordProdI_unique f g (HEq : forall i, ordProjI i ∘ g ⊑ f i) : g ⊑ ordProdI f.
- Proof. intros x i; apply (HEq i x). Qed.
-
- Lemma ordProdI_unique_rev f g (HEq : forall i, f i ⊑ ordProjI i ∘ g) : ordProdI f ⊑ g.
- Proof. intros x i; apply (HEq i x). Qed.
-
-End IndexedProductsPreo.
-
-Global Arguments ordI {_ _} _ _ /.
-
-
-Record pcmtyp :=
- { pcmt_cmt :> cmtyp;
- pcmt_PO : preoType pcmt_cmt;
- pcmt_T : pcmType pcmt_cmt}.
-
-Instance proj_preoType {U : pcmtyp} : preoType U := pcmt_PO U.
-Instance proj_pcmType {U : pcmtyp} : pcmType U := pcmt_T U.
-Definition pcmFromType (T : Type) `{pcmT : pcmType T} := Build_pcmtyp (cmfromType T) _ _.
-
-Section IndexedProductsPCM.
- Context {I : Type} {P : I -> pcmtyp}.
- Local Obligation Tactic := intros; apply _ || mono_resp || program_simpl.
-
- (* We have to repeat those due to coercions not going into preotyp *)
- Definition pcOrdI (f1 f2 : forall i, P i) := forall i, f1 i ⊑ f2 i.
-
- Global Program Instance pcOrdTypeI : preoType (forall i, P i) :=
- mkPOType pcOrdI _.
- Next Obligation.
- split.
- + intros f i; reflexivity.
- + intros f g h Hfg Hgh i; etransitivity; [apply Hfg | apply Hgh].
- Qed.
- Next Obligation.
- move=> f1 f2 Rf g1 g2 Rg H i.
- rewrite -(Rf i) -(Rg i); exact: H.
- Qed.
-
- Global Instance pcmTypI : pcmType (forall i, P i).
- Proof.
- split.
- + intros σ Ï Ïƒc Ïc SUBc i; eapply pcm_respC; [apply _ | intros n; simpl; apply SUBc].
- Qed.
-
- Program Definition pcmProjI (i : I) : (forall i, P i) -m> P i :=
- m[(MprojI _)].
- Next Obligation. intros x y HSub; apply HSub. Qed.
-
- Context {A} `{mA : pcmType A}.
- Program Definition pcmProdI (f : forall i, A -m> P i) : A -m> forall i, P i :=
- m[(MprodI f)].
-
- Lemma pcmProdI_proj f i : pcmProjI i ∘ pcmProdI f == f i.
- Proof. intros x; reflexivity. Qed.
-
- Lemma pcmProdI_unique f g (HEq : forall i, pcmProjI i ∘ g == f i) : g == pcmProdI f.
- Proof. apply (mprodI_unique f g HEq). Qed.
-
-End IndexedProductsPCM.
-
-
-Section Halving.
- Definition halveT (T: eqType): eqType := fromType (halve T).
- Definition halvedT {T}: eqtyp T -> eqtyp (halveT T) := fun h => halved h.
- Definition unhalvedT {T}: eqtyp (halveT T) -> eqtyp T := fun h => unhalved h.
-
- Definition halveM (T: Mtyp) : Mtyp := Build_Mtyp (halveT T) halve_metr.
- Definition halveCM (T: cmtyp): cmtyp := Build_cmtyp (halveM T) halve_cm.
-End Halving.
-Ltac unhalveT := repeat (unhalve || match goal with
- | x: eqtyp (mtyp (cmm (halveCM _))) |- _ => destruct x as [x]
- end).
-
-
-(** Trivial extension of a nonexpansive morphism to monotone one on a
- metric space equipped with a trivial preorder. *)
-Section DiscM_Defs.
- Context {U V} `{cmU : cmetric U} `{cmV : cmetric V}.
-
- Local Instance pt_disc P `{cmetric P} : preoType P | 2000 := disc_preo P.
- Local Instance pcm_disc P `{cmetric P} : pcmType P | 2000 := disc_pcm P.
-
- Definition disc_m (m : V -n> U) : V -m> U := m[(m)].
-
-End DiscM_Defs.
-
-Section DiscM_Props.
- Context U V W `{cmU : cmetric U} `{cmV : cmetric V} `{cmW : cmetric W}.
-
- Global Instance disc_equiv : Proper (equiv (A := U -n> V) ==> equiv) disc_m.
- Proof. resp_set. Qed.
- Global Instance disc_dist n : Proper (dist (T := U -n> V) n ==> dist n) disc_m.
- Proof. resp_set. Qed.
-
- Lemma disc_m_comp (f : V -n> W) (g : U -n> V) :
- disc_m (f <M< g) == disc_m f ∘ disc_m g.
- Proof. intros x; simpl morph; reflexivity. Qed.
-
- Lemma disc_m_id : disc_m (umid W) == pid W.
- Proof. intros x; simpl morph; reflexivity. Qed.
-
-End DiscM_Props.
-
-Definition transfer {A} {T : A -> Type} {x y : A} (EQ : x = y) (t : T x) : T y :=
- eq_rect x T t y EQ.
-
-Definition transfer_nat_eq {T : nat -> Type} (x : nat) (EQ : x = x) (t : T x) :
- transfer EQ t = t.
-Proof.
- symmetry; apply D.eq_rect_eq.
-Qed.
-
-Section FiniteProducts.
- Context {T : cmtyp}.
-
- Definition FinI n := forall i : Fin.t n, T.
-
- (* Type context extension *)
- Definition extFinI {n} (RC : FinI n) (R : T) : FinI (S n) :=
- fun i => match i in Fin.t k return (match k with
- O => False
- | S m => FinI m -> T end) with
- | Fin.F1 n => fun _ => R
- | Fin.FS n i => fun RC => RC i
- end RC.
-
- Global Instance extFinI_equiv n : Proper (equiv ==> equiv ==> equiv) (@extFinI n).
- Proof.
- intros RC1 RC2 EQRC R1 R2 EQR i.
- refine (match i as i in Fin.t k return match k return Fin.t k -> Prop with
- O => fun _ => False
- | S m => fun i => forall (RC1 RC2 : FinI m),
- RC1 == RC2 ->
- extFinI RC1 R1 i == extFinI RC2 R2 i
- end i with
- Fin.F1 n => fun _ _ _ => EQR
- | Fin.FS n i => fun RC1 RC2 EQRC => EQRC i
- end RC1 RC2 EQRC).
- Qed.
-
- Global Instance extTC_dist n k : Proper (dist k ==> dist k ==> dist k) (@extFinI n).
- Proof.
- intros RC1 RC2 EQRC R1 R2 EQR i.
- refine (match i as i in Fin.t m return match m return Fin.t m -> Prop with
- O => fun _ => False
- | S m => fun i => forall (RC1 RC2 : FinI m),
- RC1 = k = RC2 ->
- extFinI RC1 R1 i = k = extFinI RC2 R2 i
- end i with
- Fin.F1 n => fun _ _ _ => EQR
- | Fin.FS n i => fun RC1 RC2 EQRC => EQRC i
- end RC1 RC2 EQRC).
- Qed.
-
- Fixpoint fin_sum_split {k n} (x : Fin.t (k + n)) : Fin.t k + Fin.t n :=
- match k return Fin.t (k + n) -> Fin.t k + Fin.t n with
- | 0 => fun x => inr x
- | S k => fun x =>
- match x in Fin.t m return m = S k + n -> Fin.t (S k) + Fin.t n with
- | Fin.F1 _ => fun _ => inl Fin.F1
- | Fin.FS m x' => fun EQ =>
- match fin_sum_split (transfer (eq_add_S _ _ EQ) x') with
- | inl y => inl (Fin.FS y)
- | inr y => inr y
- end
- end eq_refl
- end x.
-
- Definition extFinEnv {k n} (η : FinI k) (Ï : FinI n) : FinI (n + k) :=
- fun x => match fin_sum_split x with
- | inl y => Ï y
- | inr y => η y
- end.
-
- Global Instance extFinEnv_equiv k n :
- Proper (equiv ==> equiv ==> equiv) (@extFinEnv k n).
- Proof.
- intros η1 η2 EQη Ï1 Ï2 EQÏ x; unfold extFinEnv.
- destruct (fin_sum_split x) as [y | y]; [apply EQÏ | apply EQη].
- Qed.
-
- Global Instance extFinEnv_dist k m n :
- Proper (dist n ==> dist n ==> dist n) (@extFinEnv k m).
- Proof.
- intros η1 η2 EQη Ï1 Ï2 EQÏ x; simpl; unfold extFinEnv.
- destruct (fin_sum_split x) as [y | y]; [apply EQÏ | apply EQη].
- Qed.
-
- Definition empFinI : FinI 0 :=
- fun x => match x in Fin.t k return match k with
- | O => T
- | S n => True
- end with
- | Fin.F1 _ => I
- | Fin.FS _ _ => I
- end.
-
- Lemma FinI_invert_O (Ï : FinI 0) :
- Ï == empFinI.
- Proof.
- intros x; inversion x.
- Qed.
-
- Lemma extFinEnv_empR k (η : FinI k) : extFinEnv η empFinI == η.
- Proof.
- reflexivity.
- Qed.
-
- Definition FinI_tail {k} (Ï : FinI (S k)) : FinI k :=
- fun x => Ï (Fin.FS x).
-
- Lemma FinI_invert_S {k} (Ï : FinI (S k)) :
- Ï == extFinI (FinI_tail Ï) (Ï Fin.F1).
- Proof.
- intros x.
- refine (match x as x in Fin.t m return
- match m return Fin.t m -> Prop with
- | O => fun _ => False
- | S n => fun x => forall (Ï : FinI (S n)),
- Ï x == extFinI (FinI_tail Ï) (Ï Fin.F1) x
- end x with
- | Fin.F1 m => _
- | Fin.FS m y => _
- end Ï); intros.
- - simpl; reflexivity.
- - unfold FinI_tail; simpl.
- reflexivity.
- Qed.
-
- Lemma extFin_env_one {k m} (η : FinI k) (Ï : FinI m) R :
- extFinI (extFinEnv η Ï) R == extFinEnv η (extFinI Ï R).
- Proof.
- intros xx.
- refine (match xx as x in Fin.t i return
- match i return Fin.t i -> Prop with
- | O => fun _ => False
- | S i => fun x => forall m k (η : FinI k) (Ï : FinI m)
- (HEq : S i = S m + k),
- extFinI (extFinEnv η Ï) R (transfer HEq x) ==
- extFinEnv η (extFinI Ï R) (transfer HEq x)
- end x with
- | Fin.F1 n => fun m k η Ï EQ => _
- | Fin.FS n x => fun m k η Ï EQ => _
- end m k η Ï eq_refl).
- - simpl in EQ; assert (EQ' := eq_add_S _ _ EQ); subst n.
- rewrite !transfer_nat_eq.
- unfold extFinEnv; simpl.
- reflexivity.
- - simpl in EQ; assert (EQ' := eq_add_S _ _ EQ); subst n.
- rewrite transfer_nat_eq; clear EQ.
- unfold extFinEnv; simpl.
- destruct (fin_sum_split x); simpl; reflexivity.
- Qed.
-
- Lemma extFinI_eq {n m} R (η : FinI m) (EQ : m = n) :
- extFinI (transfer EQ η) R = transfer (eq_S _ _ EQ) (extFinI η R).
- Proof.
- subst n; rewrite transfer_nat_eq; reflexivity.
- Qed.
-
- (* TODO: make it so this thing works as an instance, and the casts are less horrible *)
- Instance transfer_FinI_equiv n m (EQ : n = m) : Proper (equiv ==> equiv) (transfer (T := FinI) EQ).
- Proof.
- intros η1 η2 EQη; subst n; rewrite transfer_nat_eq; assumption.
- Qed.
-
- Lemma of_nat_lt_ext {n k} (HLt1 HLt2 : n < k) :
- Fin.of_nat_lt HLt1 = Fin.of_nat_lt HLt2.
- Proof.
- revert n HLt1 HLt2; induction k; intros; [inversion HLt1 |].
- destruct n as [| n]; simpl; [reflexivity |].
- f_equal; apply IHk.
- Qed.
-
- Lemma fin_split_left {n m k}
- (HLt : n < m) (HLt2 : n < m + k) :
- fin_sum_split (Fin.of_nat_lt HLt2) = inl (Fin.of_nat_lt HLt).
- Proof.
- revert n HLt HLt2; induction m; intros; [inversion HLt |].
- destruct n as [| n]; simpl in *.
- - eexists; reflexivity.
- - erewrite IHm; reflexivity.
- Qed.
-
- Lemma fin_split_right {n m k}
- (HLt : n < k) (HLt2 : m + n < m + k) :
- fin_sum_split (Fin.of_nat_lt HLt2) = inr (Fin.of_nat_lt HLt).
- Proof.
- induction m; intros; simpl in *; [f_equal; apply of_nat_lt_ext |].
- erewrite IHm; reflexivity.
- Qed.
-
- Lemma extFinEnv_lookup_left {n m k} (η : FinI k) (Ï : FinI m)
- (HLt : n < m) (HLt2 : n < m + k) :
- extFinEnv η Ï (Fin.of_nat_lt HLt2) == Ï (Fin.of_nat_lt HLt).
- Proof.
- unfold extFinEnv.
- erewrite fin_split_left; reflexivity.
- Qed.
-
- Lemma minus_le_lt {k m n} (HGe : m <= n) (HLt : n < m + k) :
- n - m < k.
- Proof.
- apply Plus.plus_lt_reg_l with m.
- replace (m + (n - m)) with n by auto with arith; assumption.
- Qed.
-
- Lemma extFinEnv_lookup_right {k m n} (η : FinI k) (Ï : FinI m)
- (HGe : m <= n) (HLt : n < m + k) :
- extFinEnv η Ï (Fin.of_nat_lt HLt) == η (Fin.of_nat_lt (minus_le_lt HGe HLt)).
- Proof.
- generalize (minus_le_lt HGe HLt) as HL'; intros.
- revert HLt; pattern n at 1 2; replace n with (m + (n - m)) by auto with arith; intros.
- unfold extFinEnv; erewrite fin_split_right; reflexivity.
- Qed.
-
- Lemma extFinEnv_lookup_right_sum {n m k} (η : FinI k) (Ï : FinI m)
- (HLt : n < k) (HLt2 : m + n < m + k) :
- extFinEnv η Ï (Fin.of_nat_lt HLt2) == η (Fin.of_nat_lt HLt).
- Proof.
- unfold extFinEnv.
- erewrite fin_split_right; reflexivity.
- Qed.
-
- Lemma transfer_lookup {m n k} (η : FinI m) (EQ : m = n) (LT : k < n) :
- transfer EQ η (Fin.of_nat_lt LT) = η (Fin.of_nat_lt (transfer (eq_sym EQ) LT)).
- Proof.
- subst; rewrite !transfer_nat_eq; reflexivity.
- Qed.
-
-End FiniteProducts.
-
-Global Arguments FinI : default implicits.
diff --git a/lib/ModuRes/DecEnsemble.v b/lib/ModuRes/DecEnsemble.v
deleted file mode 100644
index 0cb4d3e9a396e1532600699fef34dcbde87ce07c..0000000000000000000000000000000000000000
--- a/lib/ModuRes/DecEnsemble.v
+++ /dev/null
@@ -1,264 +0,0 @@
-(* Like Ensembles in Coq, but decidable. *)
-Require Import Ssreflect.ssreflect.
-Require Import CSetoid Predom.
-
-Delimit Scope de_scope with de.
-Local Open Scope general_if_scope.
-Local Open Scope type.
-Local Open Scope bool_scope.
-Local Open Scope de_scope.
-
-Section DecEnsemble.
- Context {T: Type}.
-
- CoInductive DecEnsemble := DE: (T -> bool) -> DecEnsemble.
-
- Implicit Types (de: DecEnsemble).
-
- Definition de_in t de: bool :=
- let (de):=de in de t.
-
-End DecEnsemble.
-
-Arguments DecEnsemble T: clear implicits.
-Notation "t '∈' de" := (de_in t de) (at level 31, no associativity) : de_scope.
-
-Section DecEnsembleOps.
- Context {T: Type}.
- Implicit Types (de: DecEnsemble T).
-
- Definition de_emp : DecEnsemble T := DE (const false).
- Definition de_full : DecEnsemble T := DE (const true).
-
- Definition dele de1 de2 :=
- forall t, implb (t ∈ de1) (t ∈ de2) = true.
-
- Global Instance deeq_PreOrder: PreOrder dele.
- Proof.
- split.
- - intros ? ?. destruct (_ ∈ _); reflexivity.
- - intros x y z. unfold dele. intros IMxy IMyz t. move:(IMxy t) (IMyz t).
- destruct (t ∈ x), (t ∈ y), (t ∈ z); simpl; tauto.
- Qed.
-
- Definition deeq de1 de2 :=
- forall t, t ∈ de1 = t ∈ de2.
-
- Global Instance deeq_Equivalence: Equivalence deeq.
- Proof.
- split.
- - intros ?. unfold deeq. tauto.
- - intros ? ?. unfold deeq. now auto.
- - intros ? ? ? EQxy EQyz t. rewrite EQxy EQyz. reflexivity.
- Qed.
- Global Instance deeq_type : Setoid (DecEnsemble T) := mkType deeq.
-
- Global Program Instance deeq_preo: preoType (DecEnsemble T) := mkPOType dele _.
- Next Obligation.
- move=>t1 t2 EQt s1 s2 EQs Hle t.
- rewrite -EQs. rewrite -EQt. exact:Hle.
- Qed.
-
- (* These dfinitions look weird, to get better control over how they simplify. *)
- Definition de_cap de1 de2 :=
- locked (DE (fun t => t ∈ de1 && t ∈ de2)).
- Definition de_cup de1 de2 :=
- locked (DE (fun t => t ∈ de1 || t ∈ de2)).
- Definition de_minus de1 de2 :=
- locked (DE (fun t => t ∈ de1 && negb (t ∈ de2))).
- Definition de_compl de :=
- locked (DE (fun t => negb (t ∈ de))).
-End DecEnsembleOps.
-
-Notation "de1 ∩ de2" := (de_cap de1 de2) (at level 40) : de_scope.
-Notation "de1 ∪ de2" := (de_cup de1 de2) (at level 50) : de_scope.
-Notation "de1 \ de2" := (de_minus de1 de2) (at level 35) : de_scope.
-Notation "de1 # de2" := (de1 ∩ de2 == de_emp) (at level 70) : de_scope.
-
-(* Some automation.
-
- de_tauto is designed to solve equalities of the form "t ∈ <de> = <bool>".
- It begins by unfolding <de>, then it performs the necessary case distinctions
- to simplify the term. In particular, it supports equalities (as introduced
- by de_set) and nested membership tests (as introduced by de_union, ...).
- "contradiction_eq" solves the goal if we have both "i = j" and "i <> j"
- in context, so that de_tauto can make use of existing proofs of (in)equalities.
- Equalities are destructed first, because the "subst" can make two terms structurally
- equal that used to be different, and hence can extend the effect of a destruct
- of membership.
-
- de_auto_eq is a higher-level tactic, designed to solve (in)equalities between <de>s:
- <de1> = <de2>, <de1> # <de2>, <de1> ⊑ <de2>
- Since equality is defined pointwise, it simply introduces the name of the point,
- specializies all suitable (in)equalities from the context to that point, and calls de_tauto.
- Note that this sometimes throws away too much, e.g. if there is an (in)equality known
- in the context that also occurs in one of the <de>s. In this case, it can help to
- do the specialization manually, and call de_tauto directly.
- *)
-Ltac de_unfold := unfold de_cap, de_cup, de_minus, de_compl; unlock; simpl.
-Ltac de_in_destr := simpl;
- repeat (match goal with
- | [ |- context[dec_eq ?i ?j] ] => destruct (dec_eq i j); first try subst j; try contradiction_eq; simpl
- end);
- repeat (match goal with
- | [ |- context[?t ∈ ?de] ] => destruct (t ∈ de); simpl
- end).
-Ltac de_tauto := de_unfold; de_in_destr; rewrite ?de_ft_eq ?de_tf_eq ?de_tt_eq ?de_ff_eq; repeat (split || intro); (reflexivity || discriminate || tauto).
-Ltac de_auto_eq := destruct_conjs;
- let t := fresh "t" in move=>t;
- repeat (match goal with
- | [ H : _ |- _ ] => try move:(H t); clear H
- end);
- de_tauto.
-
-
-Section DecEnsembleProps.
- Context {T: Type}.
- Implicit Types (de: DecEnsemble T).
-
- Lemma de_union_idem de :
- (de ∪ de) == de.
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_isect_idem de :
- (de ∩ de) == de.
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_emp_union de :
- (de ∪ de_emp) == de.
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_full_union de :
- (de_full ∪ de) == de_full.
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_emp_isect de :
- (de ∩ de_emp) == de_emp.
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_full_isect de :
- (de_full ∩ de) == de.
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_union_isect de1 de2 de3 :
- (de1 ∩ de2) ∪ (de1 ∩ de3) == de1 ∩ (de2 ∪ de3).
- Proof. repeat intro. de_tauto. Qed.
-
- Lemma de_isect_union de1 de2 de3 :
- (de1 ∪ de2) ∩ (de1 ∪ de3) == de1 ∪ (de2 ∩ de3).
- Proof. repeat intro. de_tauto. Qed.
-
- Global Instance de_union_com: Commutative (@de_cup T).
- Proof. repeat intro. de_tauto. Qed.
-
- Global Instance de_union_ass: Associative (@de_cup T).
- Proof. repeat intro. de_tauto. Qed.
-
- Global Instance de_isec_com: Commutative (@de_cap T).
- Proof. repeat intro. de_tauto. Qed.
-
- Global Instance de_isec_ass: Associative (@de_cap T).
- Proof. repeat intro. de_tauto. Qed.
-
- Global Instance de_union_equiv: Proper (equiv ==> equiv ==> equiv) (@de_cup T).
- Proof. do 6 intro. de_auto_eq. Qed.
-
- Global Instance de_isect_equiv: Proper (equiv ==> equiv ==> equiv) (@de_cap T).
- Proof. do 6 intro. de_auto_eq. Qed.
-
- Global Instance de_minus_equiv: Proper (equiv ==> equiv ==> equiv) (@de_minus T).
- Proof. do 6 intro. de_auto_eq. Qed.
-
- Global Instance de_compl_equiv: Proper (equiv ==> equiv) (@de_compl T).
- Proof. do 3 intro. de_auto_eq. Qed.
-
- Lemma de_in_true de t: (* This looks stupid, but it is useful to get de_tauto started. *)
- t ∈ de = true -> t ∈ de = true.
- Proof.
- tauto.
- Qed.
-
- Lemma de_in_false de t: (* This looks stupid, but it is useful to get de_tauto started. *)
- t ∈ de = false -> t ∈ de = false.
- Proof.
- tauto.
- Qed.
-
- Lemma de_union_true de1 de2 t:
- t ∈ de1 = true -> t ∈ (de1 ∪ de2) = true.
- Proof.
- intros. de_tauto.
- Qed.
-
- Lemma de_union_true2 de1 de2 t:
- t ∈ de2 = true -> t ∈ (de1 ∪ de2) = true.
- Proof.
- intros. de_tauto.
- Qed.
-
- Lemma de_union_false de1 de2 t:
- t ∈ de1 = false -> t ∈ de2 = false -> t ∈ (de1 ∪ de2) = false.
- Proof.
- intros. de_tauto.
- Qed.
-
- Lemma de_isect_true de1 de2 t:
- t ∈ de1 = true -> t ∈ de2 = true -> t ∈ (de1 ∩ de2) = true.
- Proof.
- intros. de_tauto.
- Qed.
-
- Lemma de_isect_false de1 de2 t:
- t ∈ de1 = false -> t ∈ (de1 ∩ de2) = false.
- Proof.
- intros. de_tauto.
- Qed.
-
- Lemma de_isect_false2 de1 de2 t:
- t ∈ de2 = false -> t ∈ (de1 ∩ de2) = false.
- Proof.
- intros. de_tauto.
- Qed.
-
-End DecEnsembleProps.
-
-Section DecEqEnsemble.
- Context {T: Type} {eqT: DecEq T}.
-
- Definition de_set de t b :=
- DE (fun t' => if dec_eq t t' then b else t' ∈ de).
-
- Definition de_sing (t: T) := de_set de_emp t true.
-
- Lemma de_sing_union de t:
- de_sing t ∪ de == de_set de t true.
- Proof.
- de_auto_eq.
- Qed.
-
- Lemma de_set_eq de t b:
- t ∈ de_set de t b = b.
- Proof.
- de_tauto.
- Qed.
-
- Lemma de_set_neq de t b t':
- t <> t' -> t' ∈ de_set de t b = t' ∈ de.
- Proof.
- intros. de_tauto.
- Qed.
-
-End DecEqEnsemble.
-
-
-Section DecNatEnsemble.
- Definition de_infinite (m : DecEnsemble nat) :=
- forall i, exists j, j >= i /\ j ∈ m = true.
-
- Lemma de_full_infinite : de_infinite de_full.
- Proof.
- intros i; exists i; split; [now auto with arith | reflexivity].
- Qed.
-
-End DecNatEnsemble.
-
diff --git a/lib/ModuRes/Finmap.v b/lib/ModuRes/Finmap.v
deleted file mode 100644
index b35dd0c7ab969fe37cef43135f62bc88d84fa346..0000000000000000000000000000000000000000
--- a/lib/ModuRes/Finmap.v
+++ /dev/null
@@ -1,1199 +0,0 @@
-Require Import Ssreflect.ssreflect Omega.
-Require Import Arith Min Max List ListSet Lists.
-Require Import MetricCore.
-Require Import PreoMet.
-Require Import RA CMRA SPred.
-
-Set Bullet Behavior "Strict Subproofs".
-
-
-Delimit Scope finmap_scope with fm.
-Local Open Scope finmap_scope.
-Local Open Scope general_if_scope.
-Infix "∈" := In (at level 31, no associativity) : finmap_scope.
-
-
-
-Section Def.
- Context {K V : Type}.
-
- Definition findom_bound (finmap: K -> option V) (findom: list K): Prop :=
- forall k, finmap k <> None -> k ∈ findom.
- Definition findom_approx (finmap: K -> option V) (findom: list K): Prop :=
- forall k, finmap k <> None <-> k ∈ findom.
-
- Record FinMap `{eqK : DecEq K} :=
- mkFD {finmap :> K -> option V;
- findom : list K;
- findom_b : findom_approx finmap findom}.
-
- Context `{eqK : DecEq K}.
-
- Definition dom (f: FinMap) := filter_dupes ([]%list) (findom f).
-
- Lemma dom_nodup (f: FinMap): NoDup (dom f).
- Proof.
- unfold dom. apply filter_dupes_nodup.
- Qed.
-
- Fixpoint filter_None (f: K -> option V) (l: list K) :=
- match l with
- | [] => []
- | k::l => match f k with
- | Some _ => k::(filter_None f l)
- | None => filter_None f l
- end
- end.
-
- Lemma filter_None_isin f l k:
- k ∈ filter_None f l -> f k <> None.
- Proof.
- induction l.
- - intros [].
- - simpl. destruct (f a) eqn:EQf.
- + move=>[EQ|Hin].
- * subst a. rewrite EQf. discriminate.
- * apply IHl. exact Hin.
- + exact IHl.
- Qed.
-
- Lemma filter_None_in f l k:
- f k <> None -> k ∈ l -> k ∈ filter_None f l.
- Proof.
- induction l.
- - move=>_ [].
- - move=>Hneq [EQ|Hin].
- + subst a. simpl. destruct (f k); last (exfalso; now apply Hneq).
- left. reflexivity.
- + simpl. destruct (f a); first right; apply IHl; assumption.
- Qed.
-
- Program Definition mkFDbound (f: K -> option V) (l: list K)
- (Hbound: findom_bound f l) :=
- mkFD _ f (filter_None f l) _.
- Next Obligation.
- move=>k. split.
- - move=>Hnon. apply filter_None_in; first assumption.
- apply Hbound. assumption.
- - move/filter_None_isin. tauto.
- Qed.
-
-End Def.
-
-Arguments mkFD [K V] {eqK} _ _ _.
-Arguments FinMap K V {_} : clear implicits.
-Arguments finmap [K V] {eqK} _ _.
-Arguments findom [K V] {eqK} _.
-Arguments dom [K V] {eqK} _.
-Arguments findom_b [K V] {eqK} _ {k}.
-Notation "K '-f>' V" := (FinMap K V) (at level 45).
-(* TODO: find out what this does if anything *)
-Bind Scope finmap_scope with FinMap.
-
-Section FinDom.
- Context {K} `{eqK : DecEq K}.
-
- Section Props.
- Context {V : Type} `{ev : Setoid V}.
-
- Program Definition fdEmpty : K -f> V := mkFD (fun _ => None) nil _.
- Next Obligation.
- move=>k /=. split; last tauto. move=>H. now apply H.
- Qed.
-
- Lemma fdLookup_notin_strong k (f : K -f> V) : (~ (k ∈ dom f)) <-> f k = None.
- Proof.
- destruct f as [f fd fdb]; unfold dom in *; simpl in *. split.
- - destruct (f k) as [v|] eqn:EQf; last (move=>_; reflexivity).
- move=>Hin. exfalso. apply Hin=>{Hin}. apply filter_dupes_in; first tauto.
- apply fdb. rewrite EQf. discriminate.
- - move=>EQf Hin. apply filter_dupes_isin in Hin. eapply fdb; last eassumption. tauto.
- Qed.
-
- Lemma fdLookup_notin k (f : K -f> V) : (~ (k ∈ dom f)) <-> f k == None.
- Proof.
- split ; intro H.
- + apply fdLookup_notin_strong in H ; rewrite H ; reflexivity.
- + destruct (f k) as [v|] eqn:EQf; first (contradiction H).
- apply fdLookup_notin_strong. assumption.
- Qed.
-
- Lemma fdLookup_in_strong (f : K -f> V) k: k ∈ dom f <-> f k <> None.
- Proof.
- destruct f as [f fd fdb]; unfold dom; simpl. split.
- - move=>Hin. apply filter_dupes_isin in Hin.
- destruct (f k) as [v|] eqn:EQf; first discriminate. exfalso.
- eapply fdb; last eassumption. tauto.
- - move=>EQf. apply filter_dupes_in; first tauto. apply fdb. assumption.
- Qed.
-
- Lemma fdLookup_in : forall (f : K -f> V) k, k ∈ dom f <-> f k =/= None.
- Proof.
- simpl. split.
- - move=>Hin. eapply fdLookup_in_strong in Hin. move=>Heq.
- apply Hin. destruct (f k); contradiction || reflexivity.
- - move=>Hneq. apply fdLookup_in_strong. destruct (f k); first discriminate.
- exfalso. now apply Hneq.
- Qed.
-
- Program Definition fdLookup_indom f k (Hindom: k ∈ dom f): V :=
- match f k with
- | Some v => v
- | None => !
- end.
- Next Obligation.
- apply fdLookup_in_strong in Hindom. rewrite Heq_anonymous in Hindom. apply Hindom. reflexivity.
- Qed.
-
- Lemma fdLookup_indom_corr f k (Hindom: k ∈ dom f) v:
- fdLookup_indom f k Hindom = v <-> f k = Some v.
- Proof.
- split.
- - rewrite /fdLookup_indom. ddes (f k) at 1 3 as [v'|] deqn:EQf.
- + move=><-. now symmetry.
- + unfold False_rect. destruct (_:False).
- - rewrite /fdLookup_indom. ddes (f k) at 1 3 4 as [v'|] deqn:EQf.
- + by move=>[EQ].
- + move=>?. discriminate.
- Qed.
-
- Lemma fdLookup_indom_pi f k (Hindom1: k ∈ dom f) (Hindom2: k ∈ dom f):
- fdLookup_indom f k Hindom1 = fdLookup_indom f k Hindom2.
- Proof.
- rewrite /fdLookup_indom. ddes (f k) at 1 3 7 as [v|] deqn:EQf.
- - reflexivity.
- - exfalso. apply fdLookup_in_strong in Hindom1. apply Hindom1. now rewrite -EQf.
- Qed.
-
- End Props.
-
- Section Instances.
- Context {V: Type}.
-
- Definition equal_fd (f1 f2 : K -f> V):Prop :=
- (forall k, f1 k = f2 k) /\ dom f1 = dom f2.
-
- Global Instance equal_fd_e: Equivalence equal_fd.
- Proof.
- split.
- - intros m. split; intros; reflexivity.
- - intros m1 m2 [Hf Hdom]. split; intros; symmetry; now auto.
- - intros m1 m2 m3 [Hf12 Hdom12] [Hf23 Hdom23]. split; intros; etransitivity; now eauto.
- Qed.
-
- Global Instance equal_fd_lookup:
- Proper (equal_fd ==> eq ==> eq) (finmap (eqK:=eqK)).
- Proof.
- move=>f1 f2 EQf k1 k2 EQk. subst k1. apply EQf.
- Qed.
-
- Global Instance equal_fd_dom:
- Proper (equal_fd ==> eq) (dom (eqK:=eqK)).
- Proof.
- move=>f1 f2 EQf. apply EQf.
- Qed.
-
- Context `{cV : pcmType V}.
-
- Definition equiv_fd (f1 f2 : K -f> V) := forall k, f1 k == f2 k.
-
- Global Instance equiv_fd_e: Equivalence equiv_fd.
- Proof.
- split.
- - intros m k; reflexivity.
- - intros m1 m2 HS k; symmetry; apply HS.
- - intros m1 m2 m3 H12 H23 k; etransitivity; [apply H12 | apply H23].
- Qed.
-
- Global Program Instance type_findom : Setoid (K -f> V) := mkType equiv_fd.
-
- Global Instance fdLookup_proper : Proper (equiv ==> eq ==> equiv) (finmap (V := V)).
- Proof.
- intros f1 f2 HEqf k1 k2 HEqk; subst; apply HEqf.
- Qed.
-
- Lemma dom_proper {f1 f2}:
- f1 == f2 -> (forall k, k ∈ dom f1 <-> k ∈ dom f2).
- Proof.
- move=>EQf k. split; rewrite !fdLookup_in; move=>Hin.
- - now rewrite -EQf.
- - now rewrite EQf.
- Qed.
-
- Lemma fdEmpty_dom f:
- f == fdEmpty <-> (forall k, ~k ∈ dom f).
- Proof.
- split.
- - move=>Hemp k Hin. apply (dom_proper Hemp) in Hin. exact Hin.
- - move=>Hemp k. destruct (f k) as [v|] eqn:EQf.
- + exfalso. apply (Hemp k). apply fdLookup_in_strong. rewrite EQf. discriminate.
- + reflexivity.
- Qed.
-
- Definition dist_fd n (f1 f2 : K -f> V) :=
- forall k, f1 k = n = f2 k.
-
- Global Program Instance metric_findom : metric (K -f> V) := mkMetr dist_fd.
- Next Obligation.
- intros f1 f2 EQf g1 g2 EQg; split;
- intros EQ k; [symmetry in EQf, EQg |]; rewrite -> EQf, EQg; apply EQ.
- Qed.
- Next Obligation.
- split; intros HEq.
- - intros k; rewrite <- dist_refl; intros n. apply (HEq n k).
- - intros n; intros k. apply dist_refl. apply HEq.
- Qed.
- Next Obligation.
- revert n; intros n x y HS; intros k; symmetry; apply HS.
- Qed.
- Next Obligation.
- revert n; intros n x y z Hxy Hyz; intros k; etransitivity; [apply Hxy | apply Hyz].
- Qed.
- Next Obligation.
- intros k; eapply dist_mono, H.
- Qed.
- Next Obligation.
- move=>k. apply dist_bound.
- Qed.
-
- Global Instance lookup_dist n : Proper (dist n ==> eq ==> dist n) (finmap (V := V)).
- Proof.
- intros f1 f2 HEqf k1 k2 HEqk; subst.
- destruct n; first now auto.
- now apply HEqf.
- Qed.
-
- Definition finmap_chainx (σ : chain (K -f> V)) {σc : cchain σ} x : chain (option V) :=
- fun n => (σ n) x.
-
- Program Instance finmap_chainx_cauchy (σ : chain (K -f> V)) {σc : cchain σ} x :
- cchain (finmap_chainx σ x).
- Next Obligation.
- assert (σc':=σc).
- specialize (σc' n i j HLei HLej x). unfold finmap_chainx. assumption.
- Qed.
-
- Program Definition findom_lub (σ : chain (K -f> V)) (σc : cchain σ) : K -f> V :=
- mkFDbound (fun x => compl (finmap_chainx σ x)) (findom (σ 1)) _.
- Next Obligation.
- move=>k /= Hin.
- assert(H:=conv_cauchy (finmap_chainx σ k) 1 1 (le_refl _)).
- simpl in Hin. assert (Hin': (finmap_chainx σ k) 1 <> None).
- { move=>EQ. rewrite EQ in H. apply Hin. symmetry in H. simpl in H.
- destruct (option_compl (finmap_chainx σ k)); first contradiction.
- reflexivity. }
- clear Hin. apply (findom_b (σ 1)). assumption.
- Qed.
-
- Global Program Instance findom_cmetric : cmetric (K -f> V) := mkCMetr findom_lub.
- Next Obligation.
- move => n i LEi k. unfold findom_lub. simpl finmap.
- assert (H := conv_cauchy (finmap_chainx σ k) _ _ LEi). exact H.
- Qed.
-
- Local Existing Instance option_preo_bot.
- Local Existing Instance option_pcm_bot.
-
- Definition extOrd (m1 m2 : K -f> V) := forall k, m1 k ⊑ m2 k.
-
- Global Program Instance extOrd_preo : preoType (K -f> V) := mkPOType extOrd _.
- Next Obligation.
- split.
- - intros m k; reflexivity.
- - intros m1 m2 m3 S12 S23 k; etransitivity; [apply (S12 k) | apply (S23 k) ].
- Qed.
- Next Obligation.
- move=> f1 f2 Rf g1 g2 Rg H k.
- by rewrite -(Rf k) -(Rg k).
- Qed.
-
- Global Instance findom_pcmType : pcmType (K -f> V).
- Proof.
- split.
- - intros σ Ï Ïƒc Ïc HSub k.
- eapply pcm_respC; [now auto with typeclass_instances | intros].
- apply: HSub.
- Qed.
-
- Lemma dom_ext (m1 m2 : K -f> V) k (HSub : m1 ⊑ m2) (HIn : k ∈ dom m1) : k ∈ dom m2.
- Proof.
- specialize (HSub k).
- apply fdLookup_in in HIn.
- apply fdLookup_in. destruct (m2 k) as [v'|].
- - move=>[].
- - exfalso. apply HIn. destruct (m1 k); contradiction || reflexivity.
- Qed.
-
- End Instances.
-
- Section Update.
- Context {V: Type} `{eqV: Setoid V}.
-
- (* The definition of the domain here is carefully tuned to make the recursion principle
- less painful. *)
- Definition fdStrongUpdate_dom k (v: option V) (f: K -f> V) :=
- match v with
- | Some _ => k::(dom f)
- | None => match (dom f) with [] => []
- | k'::dom' => if dec_eq k k' then dom' else filter_dupes ([k]%list) (dom f) end
- end.
- Program Definition fdStrongUpdate k v (f : K -f> V) : K -f> V :=
- mkFD (fun k' => if dec_eq k k' then v else f k')
- (fdStrongUpdate_dom k v f)
- _.
- Next Obligation.
- move=>k'. simpl. unfold fdStrongUpdate_dom. destruct v as [v|]; destruct (dec_eq k k') as [EQ|NEQ]; split; intros Hin.
- - left. assumption.
- - discriminate.
- - right. apply fdLookup_in_strong. assumption.
- - apply fdLookup_in_strong. destruct Hin as [EQ|?]; last assumption. contradiction.
- - exfalso. now apply Hin.
- - exfalso. subst k'. destruct (dom f) as [|k' d] eqn:EQdf; first contradiction.
- destruct (dec_eq k k') as [EQ|NEQ].
- + subst k'. assert (Hndup := dom_nodup f). rewrite EQdf in Hndup. inversion Hndup; subst. contradiction.
- + eapply filter_dupes_notin, Hin. left. reflexivity.
- - apply fdLookup_in_strong in Hin. destruct (dom f) as [|k'' dom'] eqn:Hdom; first assumption.
- destruct (dec_eq k k'') as [EQ'|NEQ'].
- + subst k''. destruct Hin as [?|?]; first contradiction. assumption.
- + unfold dom in Hdom. rewrite -Hdom in Hin.
- rewrite Hdom in Hin. apply filter_dupes_in.
- * move=>[EQk|[]]. contradiction.
- * assumption.
- - apply fdLookup_in_strong. destruct (dom f) as [|k'' dom'] eqn:Hdom; first assumption.
- destruct (dec_eq k k'') as [EQ'|NEQ'].
- + subst k''. right. assumption.
- + apply filter_dupes_isin in Hin. tauto.
- Qed.
-
- Lemma fdStrongUpdate_eq k v f : fdStrongUpdate k v f k = v.
- Proof.
- simpl finmap. rewrite DecEq_refl. reflexivity.
- Qed.
-
- Lemma fdStrongUpdate_neq v f {k k'} (Hneq : k <> k') : fdStrongUpdate k v f k' = f k'.
- Proof.
- simpl finmap. destruct (dec_eq k k') as [EQ|NEQ]; first contradiction. reflexivity.
- Qed.
-
- Lemma fdStrongUpdateShadow k v1 v2 f:
- fdStrongUpdate k v1 (fdStrongUpdate k v2 f) == fdStrongUpdate k v1 f.
- Proof.
- move=>i. simpl. destruct (dec_eq k i); reflexivity.
- Qed.
-
- Lemma fdStrongUpdateCommute k1 v1 k2 v2 f:
- k1 <> k2 -> fdStrongUpdate k1 v1 (fdStrongUpdate k2 v2 f) == fdStrongUpdate k2 v2 (fdStrongUpdate k1 v1 f).
- Proof.
- move=>Hineq i. simpl. destruct (dec_eq k1 i) as [EQ1|NEQ1], (dec_eq k2 i) as [EQ2|NEQ2]; try reflexivity; [].
- subst. exfalso. now apply Hineq.
- Qed.
-
- Global Instance fdStrongUpdate_equal k v:
- Proper (equal_fd ==> equal_fd) (fdStrongUpdate k v).
- Proof.
- move=>f1 f2 [Hf Hdom]. split.
- - move=>k'. simpl. rewrite Hf. reflexivity.
- - rewrite /fdStrongUpdate /dom /= /fdStrongUpdate_dom. rewrite Hdom. reflexivity.
- Qed.
-
- Global Instance fdStrongUpdate_equiv i : Proper(equiv ==> equiv ==> equiv) (fun v => fun f => fdStrongUpdate i v f).
- Proof.
- move=>v v' EQv f f' EQf i' /=. case: (dec_eq i i')=>_; [done | exact: EQf].
- Qed.
-
- End Update.
-
-
- Section Map.
- Context {U V} `{pcmU : pcmType U} `{cmV : pcmType V}.
-
- Definition fdMap_pre (m : U -> V) (f: K -f> U) : K -> option V :=
- fun k => match (f k) with None => None | Some v => Some (m v) end.
-
- (* The nicest solution here would be to have a map on option... *)
- Program Definition fdMapRaw (m : U -> V) : (K -f> U) -> (K -f> V) :=
- fun f => mkFD (fdMap_pre m f) (findom f) _.
- Next Obligation.
- unfold fdMap_pre, findom_approx. move=>k. rewrite -(findom_b f).
- destruct (f k); last tauto.
- split; discriminate.
- Qed.
-
- Program Definition fdMapMorph (m : U -n> V) : (K -f> U) -n> (K -f> V) :=
- n[(fdMapRaw m)].
- Next Obligation.
- unfold fdMapRaw, fdMap_pre.
- intros m1 m2 HEq; destruct n as [| n]; [apply dist_bound |]; intros k; simpl; specialize (HEq k).
- destruct (m1 k) as [u1 |] eqn: HFnd1; destruct (m2 k) as [u2 |] eqn: HFnd2; try contradiction HEq; [|exact I].
- apply met_morph_nonexp. exact HEq.
- Qed.
-
- Program Definition fdMap (m : U -m> V) : (K -f> U) -m> (K -f> V) :=
- m[(fdMapMorph m)].
- Next Obligation.
- move=>f1 f2 EQf k.
- change (fdMapMorph m f1 k = n = fdMapMorph m f2 k).
- now apply (met_morph_nonexp (fdMapMorph m)).
- Qed.
- Next Obligation.
- unfold fdMapRaw, fdMap_pre. intros m1 m2 Subm k; specialize (Subm k); destruct (m1 k) as [u1 |] eqn: HFnd1.
- - rewrite /= HFnd1 /=. destruct (m2 k) as [u2 |] eqn: HFnd2; [| contradiction Subm].
- apply mu_mono, Subm.
- - rewrite /= HFnd1 /=. destruct (m2 k); exact I.
- Qed.
-
- Global Instance fdMap_resp : Proper (equiv ==> equiv) fdMap.
- Proof.
- intros f1 f2 EQf m k; rewrite /opt_eq /fdMap /= /fdMap_pre. destruct (m k).
- - apply EQf.
- - reflexivity.
- Qed.
-
- Global Instance fdMap_nonexp n : Proper (dist n ==> dist n) fdMap.
- Proof.
- intros f1 f2 EQf m k. destruct n as [|n]; first exact: dist_bound.
- rewrite /opt_eq /fdMap /= /fdMap_pre. destruct (m k).
- - apply EQf.
- - reflexivity.
- Qed.
-
- Global Instance fdMap_monic : Proper (pord ==> pord) fdMap.
- Proof.
- intros f1 f2 EQf m k; rewrite /opt_eq /fdMap /= /fdMap_pre. destruct (m k) as [u |] eqn: HFnd.
- - simpl. apply EQf.
- - reflexivity.
- Qed.
-
- End Map.
-
-End FinDom.
-
-Notation "f + '[fd' k <- v ']'" := (fdStrongUpdate k (Some v) f) (at level 0) : finmap_scope.
-Notation "f \ x" := (fdStrongUpdate x None f) (at level 35) : finmap_scope.
-
-Section FinDom2.
-
- Context {K} `{eqK : DecEq K}.
-
- Section MapProps.
-
- Context U V W `{pcmU : pcmType U} `{cmV : pcmType V} `{cmW : pcmType W}.
-
- Lemma fdMap_comp (f : U -m> V) (g : V -m> W) :
- (fdMap g ∘ fdMap f == fdMap (g ∘ f))%pm.
- Proof.
- intros m k. rewrite /= /fdMap /fdMapRaw /fdMap_pre /=.
- destruct (m k); reflexivity.
- Qed.
-
- Lemma fdMap_id : fdMap (pid U) == (pid (K -f> U)).
- Proof.
- intros w k; rewrite /= /fdMap /fdMap_pre /=.
- destruct (w k); reflexivity.
- Qed.
- End MapProps.
-
-
-(* Section Filter.
- Context V `{cmV : cmetric V}.
-
- Lemma filter_split A (p : A -> bool) x xs ys (HEq : x :: xs = filter p ys) :
- exists ysf, exists yst, ys = ysf ++ x :: yst /\ xs = filter p yst /\ filter p ysf = nil.
- Proof.
- induction ys; simpl in *; [discriminate |].
- destruct (p a) eqn: PA; [inversion HEq; subst | specialize (IHys HEq) ].
- + eexists nil; exists ys; tauto.
- + destruct IHys as [ysf [yst [EQ1 [EQ2 EQ3]]]]; exists (a :: ysf); exists yst.
- simpl; subst; rewrite PA; tauto.
- Qed.
-
- Lemma SS_app xs ys (HSS : StrictSorted (xs ++ ys)) :
- StrictSorted xs /\ StrictSorted ys.
- Proof.
- induction xs; simpl in *; [split; [apply SS_nil | assumption] |].
- assert (HSS' : StrictSorted xs /\ StrictSorted ys) by (eapply IHxs, SS_tail, HSS).
- clear IHxs; destruct HSS' as [HSSxs HSSys]; split; [| assumption]; clear HSSys.
- destruct xs; [apply SS_sing | apply SS_cons; [assumption |]].
- inversion HSS; subst; assumption.
- Qed.
-
- Program Definition fdFilter (p : V -> bool) (m : K -f> V) : K -f> V :=
- mkFD (filter (fun a : K * V => p (snd a)) (findom_t m)) _.
- Next Obligation.
- destruct m as [ms mP]; unfold findom_f in *; simpl in *.
- remember (filter (fun a => p (snd a)) ms) as ns.
- generalize dependent ms; induction ns; intros; [apply SS_nil |].
- apply filter_split in Heqns; destruct Heqns as [msf [mst [EQ1 [EQ2 _]]]]; subst.
- rewrite map_app in mP; apply SS_app in mP; destruct mP as [_ mP].
- specialize (IHns mst (SS_tail _ _ mP) (eq_refl _)).
- remember (filter (fun a => p (snd a)) mst) as ns; destruct ns; [apply SS_sing |].
- apply SS_cons; [assumption |]; clear IHns.
- apply filter_split in Heqns; destruct Heqns as [nsf [nst [EQ1 [EQ2 EQ3]]]]; subst.
- clear - mP compK; induction nsf; [simpl; inversion mP; subst; assumption |].
- apply IHnsf; clear IHnsf.
- destruct nsf; simpl in *.
- + inversion mP; subst; clear mP.
- inversion HS; subst; clear HS.
- apply comp_Lt_lt in HLt; apply comp_Lt_lt in HLt0; destruct HLt, HLt0.
- apply SS_cons; [assumption | apply comp_lt_Lt; split; [etransitivity; eassumption | ]].
- intros EQ; rewrite EQ in H.
- apply H2, ord_part; split; assumption.
- + inversion mP; subst; clear mP.
- inversion HS; subst; clear HS.
- apply comp_Lt_lt in HLt; apply comp_Lt_lt in HLt0; destruct HLt, HLt0.
- apply SS_cons; [assumption | apply comp_lt_Lt; split; [etransitivity; eassumption | ]].
- intros EQ; rewrite EQ in H.
- apply H2, ord_part; split; assumption.
- Qed.
-
- End Filter.*)
-
- Section Induction.
- Context {V : Type} `{eV : Setoid V}.
-
- Section Recursion.
- Context (T: (K -f> V) -> Type)
- (Text: forall (f1 f2: K -f> V), equal_fd f1 f2 -> T f1 -> T f2)
- (Temp: T fdEmpty).
- Context (Tstep: forall (k:K) (v:V) (f: K -f> V), ~(k ∈ dom f) -> T f -> T (f + [fd k <- v ] )).
-
- Program Fixpoint fdRectInner l: forall f, dom f = l -> T f :=
- match l as l return (forall f, dom f = l -> T f) with
- | [] => fun f Hdom => Text fdEmpty f _ Temp
- | k::l' => fun f Hdom => let f' := f \ k in
- let Hindom: k ∈ dom f := _ in
- let v' := fdLookup_indom f k Hindom in
- Text (f' + [fd k <- v' ]) f _
- (Tstep k v' f' _ (fdRectInner l' f' _))
- end.
- Next Obligation.
- split.
- - move=>k /=. symmetry. apply fdLookup_notin_strong. rewrite Hdom. tauto.
- - rewrite Hdom. reflexivity.
- Qed.
- Next Obligation.
- rewrite Hdom. left. reflexivity.
- Qed.
- Next Obligation.
- split.
- - move=>k'. destruct (dec_eq k k') as [EQ|NEQ].
- + subst k'. rewrite fdStrongUpdate_eq. symmetry. eapply fdLookup_indom_corr.
- reflexivity.
- + erewrite !fdStrongUpdate_neq by assumption. reflexivity.
- - rewrite Hdom /dom /=. f_equal. rewrite /dom /= Hdom.
- rewrite DecEq_refl.
- assert (Hnod := dom_nodup f). rewrite Hdom in Hnod.
- assert (Hfilt1: (filter_dupes ([])%list l') = l').
- { apply filter_dupes_id. simpl. inversion Hnod; subst. assumption. }
- rewrite Hfilt1. apply filter_dupes_id. assumption.
- Qed.
- Next Obligation.
- apply fdLookup_notin. rewrite fdStrongUpdate_eq. reflexivity.
- Qed.
- Next Obligation.
- rewrite /dom /fdStrongUpdate /=.
- rewrite Hdom. destruct (dec_eq k k) as [_|NEQ]; last (exfalso; now apply NEQ).
- apply filter_dupes_id with (dupes:=[]); simpl.
- assert (Hno:= dom_nodup f). rewrite Hdom in Hno.
- inversion Hno; subst. assumption.
- Qed.
-
- Definition fdRect: forall f, T f :=
- fun f => fdRectInner (dom f) f eq_refl.
- End Recursion.
-
- Section Fold.
- Context {T: Type}.
- Context (Temp: T) (Tstep: K -> V -> T -> T).
-
- Definition fdFold: (K -f> V) -> T :=
- fdRect (fun _ => T) (fun _ _ _ => id) (Temp)
- (fun k v _ _ => Tstep k v).
-
- Lemma fdFoldEmpty: fdFold fdEmpty = Temp.
- Proof.
- reflexivity.
- Qed.
-
- Lemma fdRectInner_eqLF l1 f1 l2 f2 (Heq1: dom f1 = l1) (Heq2: dom f2 = l2):
- l1 = l2 -> (forall k, f1 k = f2 k) ->
- fdRectInner (fun _ => T) (fun _ _ _ => id) (Temp) (fun k v _ _ => Tstep k v) l1 f1 Heq1 =
- fdRectInner (fun _ => T) (fun _ _ _ => id) (Temp) (fun k v _ _ => Tstep k v) l2 f2 Heq2.
- Proof.
- move=>Heql Heqf. assert (Heq': dom f2 = l1).
- { now subst l2. }
- revert f1 f2 l2 Heq' Heq1 Heq2 Heql Heqf. induction l1; intros.
- - destruct l2; last discriminate. reflexivity.
- - destruct l2; first discriminate. inversion Heql; subst; clear Heql.
- assert (Hf: exists v, f1 k = Some v /\ f2 k = Some v).
- { destruct (f1 k) as [v|] eqn:EQf.
- - exists v. split; first reflexivity. rewrite -Heqf. assumption.
- - exfalso. apply fdLookup_notin_strong in EQf. apply EQf. rewrite Heq1.
- left. reflexivity. }
- destruct Hf as [v [Heqf1 Heqf2]].
- simpl. f_equal. f_equal.
- + eapply fdLookup_indom_corr in Heqf1. erewrite Heqf1.
- eapply fdLookup_indom_corr in Heqf2. erewrite Heqf2.
- reflexivity.
- + apply IHl1.
- * rewrite /fdStrongUpdate /dom /=. rewrite Heq' DecEq_refl.
- eapply filter_dupes_id. simpl.
- move:(dom_nodup f2). rewrite Heq'. intros Hnd. inversion Hnd; subst. assumption.
- * reflexivity.
- * intros. destruct (dec_eq k k0) as [EQ|NEQ].
- { subst k0. rewrite !fdStrongUpdate_eq. reflexivity. }
- erewrite !fdStrongUpdate_neq by assumption. now apply Heqf.
- Qed.
-
- Global Instance fdFoldExtF:
- Proper (equal_fd ==> eq) fdFold.
- Proof.
- move=>f1 f2 [Heq Hdom]. rewrite /fdFold /fdRect. eapply fdRectInner_eqLF; assumption.
- Qed.
-
- Lemma fdFoldAdd f k v:
- ~k ∈ (dom f) ->
- fdFold (f + [fd k <- v ] ) = Tstep k v (fdFold f).
- Proof.
- move=>Hindom. rewrite /fdFold /fdRect {2}/dom /=.
- assert (Hl: f + [fd k <- v ] k = Some v).
- { apply fdStrongUpdate_eq. }
- eapply fdLookup_indom_corr in Hl. erewrite Hl.
- unfold id. f_equal.
- apply fdRectInner_eqLF.
- - apply filter_dupes_id. apply NoDup_cons.
- + exact Hindom.
- + apply filter_dupes_nodup.
- - move=>k'. destruct (dec_eq k k') as [EQ|NEQ].
- + subst k'. rewrite fdStrongUpdate_eq. symmetry. apply fdLookup_notin_strong. assumption.
- + erewrite !fdStrongUpdate_neq by assumption. reflexivity.
- Qed.
-
- Lemma fdFoldRedundantRemove f k:
- ~k ∈ (dom f) ->
- fdFold (f \ k) = fdFold f.
- Proof.
- move=>Hindom. eapply fdFoldExtF. split.
- - move=>k'. simpl. apply fdLookup_notin_strong in Hindom.
- destruct (dec_eq k k').
- + subst. now rewrite Hindom.
- + reflexivity.
- - rewrite /fdStrongUpdate /dom /= /dom. rewrite /dom in Hindom.
- destruct (filter_dupes ([])%list (findom f)) as [|k' dom'] eqn:Hdom'.
- + reflexivity.
- + destruct (dec_eq k k') as [EQ|NEQ].
- * subst k'. exfalso. apply Hindom. now left.
- * erewrite filter_dupes_id by apply filter_dupes_nodup.
- erewrite filter_dupes_id; first reflexivity. simpl.
- constructor; first assumption.
- rewrite -Hdom'. apply filter_dupes_nodup.
- Qed.
-
- (* Alternative, more direct formulation of fold. *)
- Definition fdFold'Inner fLookup k: T -> T :=
- fun t => match fLookup k with
- | Some v => Tstep k v t
- (* We know this case never happens, but that would be very annoying to make use of here. *)
- | None => t end.
- Definition fdFold' (f: K -f> V): T :=
- fold_right (fdFold'Inner f) Temp (dom f).
-
- Global Instance fdFold'ExtF:
- Proper (equal_fd ==> eq) fdFold'.
- Proof.
- move=>f1 f2 [Heq Hdom]. rewrite /fdFold' /fdFold'Inner. apply fold_ext_restr.
- + assumption.
- + reflexivity.
- + move=>k t _. rewrite Heq. reflexivity.
- Qed.
-
-
- (* They are equivalent. *)
- Lemma fdFoldBehavior f:
- fdFold f = fdFold' f.
- Proof.
- revert f. elim/fdRect.
- - move=>f1 f2 EQf EQfold. erewrite <-fdFoldExtF by eexact EQf.
- rewrite EQfold. rewrite EQf. reflexivity.
- - reflexivity.
- - move=>k v f Hnin Heq. erewrite fdFoldAdd by assumption.
- rewrite /fdFold' /= /fdFold'Inner.
- destruct (dec_eq k k) as [_|NEQ]; last (exfalso; now apply NEQ). f_equal. rewrite Heq.
- rewrite /fdFold' /fdFold'Inner. apply fold_ext_restr.
- + symmetry. apply filter_dupes_id. apply NoDup_cons; first assumption.
- apply dom_nodup.
- + reflexivity.
- + clear -Hnin. move=>k' t Hin.
- destruct (dec_eq k k'); last reflexivity. exfalso.
- subst k'. contradiction.
- Qed.
-
- End Fold.
-
- Section FoldExtStep.
- (* One can change the step function *)
- Context {T: Type} {eqT: relation T} {eqRT: Equivalence eqT}.
-
- Context (Tstep1 Tstep2: K -> V -> T -> T).
- Context {Tstep1_proper: Proper (eq ==> eq ==> eqT ==> eqT) Tstep1}.
- Context {Tstep2_proper: Proper (eq ==> eq ==> eqT ==> eqT) Tstep2}.
- Context {Tstep_eq: forall k v t, eqT (Tstep1 k v t) (Tstep2 k v t)}.
-
- Lemma fdFoldExtT:
- forall Temp1 Temp2, eqT Temp1 Temp2 ->
- forall f, eqT (fdFold Temp1 Tstep1 f) (fdFold Temp2 Tstep2 f).
- Proof.
- move=>Temp1 Temp2 EQemp f.
- rewrite !fdFoldBehavior /fdFold'.
- apply fold_ext.
- - move=>k k' EQk v1 v2 EQv. subst k'. rewrite /fdFold'Inner. destruct (f k).
- + rewrite EQv. reflexivity.
- + assumption.
- - move=>k t. rewrite /fdFold'Inner. destruct (f k); last reflexivity.
- apply Tstep_eq.
- - assumption.
- Qed.
- End FoldExtStep.
-
- Section FoldExtPerm.
- (* If the step function is commutative, one can change the finmap. *)
- Context {T: Type} `{Setoid T}.
- Context (Temp: T) (Tstep: K -> V -> T -> T).
-
- Definition fdStep_comm: Prop :=
- forall (k1 k2:K) (v1 v2:V),
- compose (Tstep k1 v1) (Tstep k2 v2) == compose (Tstep k2 v2) (Tstep k1 v1).
-
- Context (Tstep_comm: fdStep_comm).
-
- Global Instance fdFoldExtP {Tstep_proper: Proper (eq ==> equiv ==> equiv ==> equiv) Tstep}:
- Proper (equiv ==> equiv) (fdFold Temp Tstep).
- Proof.
- move=>f1 f2 EQf. rewrite !fdFoldBehavior /fdFold'.
- rewrite /fdFold'. etransitivity; last eapply fold_perm.
- - eapply fold_ext.
- + move=>k k' EQk v1 v2 EQv. subst k'. rewrite /fdFold'Inner.
- destruct (f1 k); last assumption. rewrite EQv. reflexivity.
- + move=>k t. rewrite /fdFold'Inner. specialize (EQf k). destruct (f1 k), (f2 k); try contradiction.
- * simpl in EQf. rewrite EQf. reflexivity.
- * reflexivity.
- + reflexivity.
- - move=>k k' EQk v1 v2 EQv. subst k'. rewrite /fdFold'Inner.
- destruct (f2 k); last assumption. rewrite EQv. reflexivity.
- - move=>v1 v2 t. rewrite /fdFold'Inner /=.
- destruct (f2 v1), (f2 v2); try reflexivity; [].
- apply Tstep_comm.
- - split; last split.
- + apply dom_nodup.
- + apply dom_nodup.
- + move=>k. rewrite !fdLookup_in_strong. specialize (EQf k).
- destruct (f1 k), (f2 k); try contradiction; last tauto; [].
- split; discriminate.
- Qed.
- End FoldExtPerm.
-
- Section FoldExtPermDist.
- (* The same, up to n-equality. TODO: Figure out a way not to repeat all this. *)
- Context {mV: metric V} {cmV: cmetric V}.
- Context {T: Type} `{cmetric T}.
- Context (Temp: T) (Tstep: K -> V -> T -> T).
- Context (Tstep_comm: fdStep_comm Tstep).
-
- Lemma fdFoldExtP_dist n {Tstep_proper: Proper (eq ==> dist n ==> dist n ==> dist n) Tstep}:
- Proper (dist n ==> dist n) (fdFold Temp Tstep).
- Proof.
- move=>f1 f2 EQf. rewrite !fdFoldBehavior /fdFold'.
- destruct n as [|n]; first exact:dist_bound.
- rewrite /fdFold'. etransitivity; last eapply fold_perm.
- - eapply fold_ext.
- + move=>k k' EQk v1 v2 EQv. subst k'. rewrite /fdFold'Inner.
- destruct (f1 k); last assumption. apply Tstep_proper; reflexivity || assumption.
- + move=>k t. rewrite /fdFold'Inner.
- specialize (EQf k). destruct (f1 k), (f2 k); try (now destruct EQf).
- * simpl in EQf. apply Tstep_proper; reflexivity || assumption.
- + reflexivity.
- - move=>k k' EQk v1 v2 EQv. subst k'. rewrite /fdFold'Inner.
- destruct (f2 k); last assumption. rewrite EQv. reflexivity.
- - move=>v1 v2 t. rewrite /fdFold'Inner /=.
- destruct (f2 v1), (f2 v2); try reflexivity; [].
- apply dist_refl, Tstep_comm.
- - split; last split.
- + apply dom_nodup.
- + apply dom_nodup.
- + move=>k. rewrite !fdLookup_in_strong. specialize (EQf k).
- destruct (f1 k), (f2 k); split; intro; try (assumption || discriminate || contradiction).
- Qed.
-
- End FoldExtPermDist.
-
- End Induction.
-
- Section Compose.
- Context {V : Type} `{eV : Setoid V}.
- Context (op: option V -> option V -> option V).
- Context {op_nongen: op None None = None}.
-
- Program Definition fdCompose (f1 f2: K -f> V): K -f> V :=
- mkFDbound (fun i => op (f1 i) (f2 i)) (findom f1 ++ findom f2) _.
- Next Obligation.
- move=>k /= Hin. apply in_app_iff.
- destruct (f1 k) eqn:EQf1, (f2 k) eqn:EQf2.
- - left. apply findom_b. rewrite EQf1. discriminate.
- - left. apply findom_b. rewrite EQf1. discriminate.
- - right. apply findom_b. rewrite EQf2. discriminate.
- - contradiction.
- Qed.
-
- Lemma fdComposeRed (f1 f2: K -f> V) i:
- fdCompose f1 f2 i = op (f1 i) (f2 i).
- Proof.
- reflexivity.
- Qed.
-
- End Compose.
-
-End FinDom2.
-
-(*Arguments fdMap {K cT ord equ preo ord_part compK U V eqT mT cmT pTA pcmU eqT0 mT0 cmT0 pTA0 cmV} _.*)
-
-Section RA.
- Context {I : Type} {S : Type} `{eqI : DecEq I} `{RAS : RA S}.
- Implicit Types (i : I) (s : S) (f g : I -f> S).
-
- Local Open Scope ra_scope.
- Local Open Scope finmap_scope.
-
- Global Instance ra_type_finprod : Setoid (I -f> S) := _.
- Global Program Instance ra_unit_finprod : RA_unit (I -f> S) :=
- fdMapRaw ra_unit.
-
- Definition finprod_op (s1 s2: option S) :=
- match s1 with
- | None => s2
- | Some s1 => match s2 with
- Some s2 => Some (s1 · s2)
- | None => Some s1
- end
- end.
- Global Program Instance ra_op_finprod : RA_op (I -f> S) :=
- fdCompose finprod_op.
- Global Instance ra_valid_finprod : RA_valid (I -f> S) :=
- fun f => forall i, match f i with Some s => ra_valid s | None => True end.
-
- Global Instance ra_finprod : RA (I -f> S).
- Proof.
- split; repeat intro.
- - simpl. specialize (H k). specialize (H0 k).
- destruct (x k), (y k), (x0 k), (y0 k); try contradiction; simpl; try reflexivity; try assumption; [].
- simpl in H. simpl in H0. rewrite H H0. reflexivity.
- - simpl. destruct (t1 k), (t2 k), (t3 k); try reflexivity; [].
- simpl. rewrite assoc. reflexivity.
- - simpl. destruct (t1 k), (t2 k); try reflexivity; [].
- simpl. now rewrite comm.
- - simpl. rewrite /fdMap_pre. destruct (t k); last reflexivity.
- simpl. rewrite ra_op_unit. reflexivity.
- - simpl. specialize (H k). rewrite /fdMap_pre.
- destruct (x k), (y k); try (reflexivity || assumption); [].
- simpl in H. simpl. rewrite H. reflexivity.
- - pose (op := fun (os1 os2: option S) =>
- match os1, os2 with
- | Some s, Some s' => Some (proj1_sig (ra_unit_mono s s'))
- | Some s, None => None
- | None , Some s' => Some (ra_unit s')
- | None , None => None end).
- exists (fdCompose op (op_nongen := eq_refl) t t').
- move=>k. simpl. rewrite /fdMap_pre /ra_op /=.
- destruct (t k), (t' k); simpl; try (reflexivity || tauto); [].
- move:(ra_unit_mono s s0)=>[t'' Heq] /=. assumption.
- - simpl. rewrite /fdMap_pre /ra_unit /= /fdMap_pre.
- destruct (t k); last reflexivity.
- apply option_eq_Some, ra_unit_idem.
- - split; rewrite /ra_valid /=; move =>Hval i; specialize (H i); specialize (Hval i); destruct (x i), (y i); try (contradiction || tauto); [|].
- + simpl in H. rewrite -H. assumption.
- + simpl in H. rewrite H. assumption.
- - move:(H i)=>{H}. rewrite /=. destruct (t1 i), (t2 i); simpl; try tauto; [].
- apply ra_op_valid.
- Qed.
-
- (* The RA order on finmaps is the same as the fpfun order over the RA order *)
- Lemma ra_pord_iff_ext_pord {f g}:
- pord (preoType:=pord_ra) f g <-> pord (preoType:=extOrd_preo) f g.
- Proof.
- split.
- { move => [h Hhf] i. move:(Hhf i)=>{Hhf} /=.
- destruct (f i), (g i), (h i); simpl; try tauto; [|].
- - move=>Heq. exists s1. assumption.
- - move=>Heq. rewrite Heq. reflexivity. }
- move:g f. apply: fdRect.
- - move=>f1 f2 [Heqf _] Hleeq f Hle.
- destruct (Hleeq f).
- + move=>k. rewrite (Heqf k). now apply Hle.
- + exists x. move=>k. rewrite -Heqf. apply H.
- - move=>f Hle. exists (fdEmpty (V:=S)). move=>k. simpl.
- specialize (Hle k). destruct (f k); last reflexivity.
- contradiction Hle.
- - move=>k v f Hnin IH g Hle. destruct (IH (g \ k)) as [h Hh]=>{IH}.
- + move=>i. destruct (dec_eq k i) as [EQ|NEQ].
- * subst i. rewrite fdStrongUpdate_eq. exact Logic.I.
- * erewrite fdStrongUpdate_neq by assumption.
- etransitivity; first now apply Hle.
- erewrite fdStrongUpdate_neq by assumption. reflexivity.
- + specialize (Hle k). rewrite fdStrongUpdate_eq in Hle. destruct (g k) eqn:EQg; last first.
- { exists (h + [fd k <- v ] ). move=>i /= {Hle}. specialize (Hh i). simpl in Hh.
- destruct (dec_eq k i) as [EQ|NEQ].
- - subst i. rewrite EQg. reflexivity.
- - assumption. }
- destruct Hle as [s' Hle].
- exists (h + [fd k <- s'] ). move=>i /=.
- specialize (Hh i). simpl in Hh. destruct (dec_eq k i) as [EQ|NEQ].
- * subst i. rewrite EQg. simpl. assumption.
- * assumption.
- Qed.
-
- Lemma ra_fpu_fpfn f i {s} {P : S -> Prop} (Hupd : s â‡âˆˆ P) :
- f + [fd i <- s] â‡âˆˆ (fun f' => exists s', P s' /\ f' = f + [fd i <- s']).
- Proof.
- have compupd : forall f g i i' s, (f + [fd i <- s] · g) i' = finprod_op (f + [fd i <- s] i') (g i').
- { by move=> ? ? ? ? ?; rewrite/ra_op/ra_op_finprod fdComposeRed. }
- move=>g Hv. pose (sf := if finmap g i is Some sf then sf else 1 s).
- have: ↓s · sf.
- { move: (Hv i). rewrite compupd fdStrongUpdate_eq.
- case Hgi: (finmap g i) => [sf'|]; rewrite/sf !Hgi/=; first done.
- by rewrite (ra_op_unit2 (t:=s)).
- }
- move/Hupd => [s' [HP Hsep]]. exists (f + [fd i <- s']). split; first by exists s'.
- rewrite/ra_op/ra_op_finprod => i'; rewrite compupd.
- case: (dec_eq i i') Hsep => [EQ | NEQ].
- - rewrite/sf -EQ /= (DecEq_refl i). case: (g i) =>//=. exact: ra_op_valid.
- - move: (Hv i'). by rewrite compupd !(fdStrongUpdate_neq _ _ NEQ).
- Qed.
-
- Lemma ra_fps_fpfn f i {s s'} : s ⇠s' -> f + [fd i <- s] ⇠f + [fd i <- s'].
- Proof.
- move=> /ra_fps_fpu/(ra_fpu_fpfn f i) => Hupd.
- apply: ra_fpu_fps => g Hsep. move/(_ g Hsep): Hupd => [f' [[s'' [EQs' EQf']] Hsep']].
- exists f'. split; last done. rewrite EQf' EQs'. reflexivity.
- Qed.
-End RA.
-
-Section VIRA.
- Context {I : Type} `{eqI : DecEq I}.
- Context {T: Type} `{raT: RA T}.
-
- Global Instance vira_finmap: VIRA (I -f> T).
- Proof.
- eexists fdEmpty. move=>i. exact Logic.I.
- Qed.
-
-End VIRA.
-
-
-Section CMRA.
- Context {I : Type} `{eqI : DecEq I}.
- Context {T: Type} `{cmraT: CMRA T}.
-
- Local Open Scope ra_scope.
- Local Open Scope finmap_scope.
-
- Global Instance ra_finmap_pcm: pcmType (pTA:=pord_ra) (I -f> T).
- Proof.
- split. intros σ Ï Ïƒc Ïc HC.
- apply ra_pord_iff_ext_pord.
- eapply pcm_respC; first by apply _.
- move=>i. apply ra_pord_iff_ext_pord. by apply: HC.
- Qed.
-
- Definition finmap_cmra_valid_op (f: I -f> T) n :=
- forall i, match f i with Some s => cmra_valid s n
- | None => True end.
-
- Global Program Instance finmap_cmra_valid: CMRA_valid (I -f> T) :=
- fun f => p[(finmap_cmra_valid_op f)].
- Next Obligation.
- move=>i. destruct (f i); last tauto.
- exact: bpred.
- Qed.
- Next Obligation.
- move=>n m Hle /= H i. specialize (H i).
- destruct (f i); last tauto.
- eapply dpred, H. assumption.
- Qed.
-
- Global Instance finmap_cmra : CMRA (I -f> T).
- Proof.
- split.
- - move=>n f1 f2 EQf g1 g2 EQg k.
- destruct n as [|n]; first exact:dist_bound.
- specialize (EQf k). specialize (EQg k). simpl.
- destruct (f1 k), (f2 k), (g1 k), (g2 k); simpl; try (contradiction || assumption || tauto); [].
- simpl in EQf. simpl in EQg. rewrite EQf EQg. reflexivity.
- - move=>n f1 f2 EQf k.
- destruct n as [|n]; first exact:dist_bound.
- specialize (EQf k). rewrite /= /fdMap_pre.
- destruct (f1 k), (f2 k); try (contradiction || assumption); [].
- simpl in EQf. simpl. rewrite EQf. reflexivity.
- - move=>n f1 f2 EQf.
- destruct n as [|n]; first exact:dist_bound.
- move=>m Hle. split; move=>Hval i; specialize (EQf i); specialize (Hval i); destruct (f1 i), (f2 i); simpl; try (contradiction || tauto); [|].
- + simpl in EQf. eapply spredNE, Hval.
- eapply mono_dist; last (now rewrite EQf). omega.
- + simpl in EQf. eapply spredNE, Hval.
- eapply mono_dist; last (now rewrite EQf). omega.
- - move => f1. split => [H|H n] i.
- + destruct (f1 i) eqn:EQf; last tauto.
- eapply cmra_ra_valid =>n.
- specialize (H n i). rewrite EQf in H. assumption.
- + specialize (H i). destruct (f1 i); last tauto.
- now apply cmra_ra_valid.
- - move=>t1 t2 n H i. move:(H i)=>{H}.
- rewrite /=. destruct (t1 i), (t2 i); simpl; try tauto; [].
- apply cmra_op_valid.
- Qed.
-
- Section CMRAExt.
- Context {cmraText: CMRAExt T}.
-
- (* It is crucial for the lower cmra_extend function to be called only once per element
- (or we would need proof irrelevance). So we first define both witnesses at once, and then
- show their projections constitute a finite partial function. *)
- Program Definition finmap_cmra_extend {n} {f1 f11 f12 f2: I -f> T}
- (EQf: f1 = S n = f2) (EQf1: f1 == f11 · f12) i : option T * option T :=
- match f1 i, f2 i with
- | Some t1, Some t2 => match f11 i, f12 i with
- | Some t11, Some t12 => let E := cmra_extend (S n) t1 t11 t12 t2 _ _ in
- (Some (projT1 E), Some (projT1 (projT2 E)))
- | Some t11, None => (Some t2, None)
- | None , Some t12 => (None, Some t2)
- | None , None => (None, None) end
- (* Unfortunately, Program does not like us to use a wildcard here. *)
- | Some _ , None => (None, None)
- | None , Some _ => (None, None)
- | None , None => (None, None) end.
- Next Obligation.
- specialize (EQf i). rewrite -Heq_anonymous -Heq_anonymous0 in EQf.
- exact EQf.
- Qed.
- Next Obligation.
- specialize (EQf1 i). rewrite /ra_op /= -Heq_anonymous -Heq_anonymous1 -Heq_anonymous2 /= in EQf1.
- exact EQf1.
- Qed.
-
- Program Definition finmap_cmra_extend_t21 {n} {f1 f11 f12 f2: I -f> T}
- (EQf: f1 = S n = f2) (EQf1: f1 == f11 · f12) : I -f> T :=
- mkFDbound (fun i => fst (finmap_cmra_extend EQf EQf1 i)) (findom f1) _.
- Next Obligation.
- move=>k. rewrite -(findom_b f1) /finmap_cmra_extend.
- ddes (f1 k) at 1 3 11 as [v1|] deqn:EQf1v.
- - ddes (f2 k) at 1 3 as [v2|] deqn:EQf2v; last discriminate.
- ddes (f11 k) at 1 3 as [v11|] deqn:EQf11v.
- + ddes (f12 k) at 1 3 as [v12|] deqn:EQf12v; discriminate.
- + ddes (f12 k) at 1 3 as [v12|] deqn:EQf12v; discriminate.
- - ddes (f2 k) at 1 3 as [v2|] deqn:EQf2v; tauto.
- Qed.
-
- Program Definition finmap_cmra_extend_t22 {n} {f1 f11 f12 f2: I -f> T}
- (EQf: f1 = S n = f2) (EQf1: f1 == f11 · f12) : I -f> T :=
- mkFDbound (fun i => snd (finmap_cmra_extend EQf EQf1 i)) (findom f1) _.
- Next Obligation.
- move=>k. rewrite /findom_approx -(findom_b f1) /finmap_cmra_extend.
- ddes (f1 k) at 1 3 11 as [v1|] deqn:EQf1v.
- - ddes (f2 k) at 1 3 as [v2|] deqn:EQf2v.
- + ddes (f11 k) at 1 3 as [v11|] deqn:EQf11v; last discriminate.
- ddes (f12 k) at 1 3 as [v12|] deqn:EQf12v; discriminate.
- + discriminate.
- - ddes (f2 k) at 1 3 as [v2|] deqn:EQf2v; tauto.
- Qed.
-
- Global Instance finmap_CMRAExt: CMRAExt (I -f> T).
- Proof.
- intros n f1 f11 f12 f2 EQf EQf1. destruct n.
- { exists (1 f2) f2. split; last exact:dist_bound. now rewrite ra_op_unit. }
- exists (finmap_cmra_extend_t21 EQf EQf1).
- exists (finmap_cmra_extend_t22 EQf EQf1).
- cut (forall i, f2 i ==
- finprod_op (finmap_cmra_extend_t21 EQf EQf1 i) (finmap_cmra_extend_t22 EQf EQf1 i) /\
- f11 i = S n = finmap_cmra_extend_t21 EQf EQf1 i /\
- f12 i = S n = finmap_cmra_extend_t22 EQf EQf1 i).
- { move=>Heq. split; last split.
- - move=>i. specialize (Heq i). tauto.
- - move=>i. specialize (Heq i). tauto.
- - move=>i. specialize (Heq i). tauto. }
- move=>i. rewrite /= /finmap_cmra_extend /=.
- ddes (f1 i) at 1 3 11 19 27 as [v1|] deqn:EQf1v.
- - ddes (f2 i) at 1 3 4 8 12 16 as [v2|] deqn:EQf2v; last first.
- { exfalso. specialize (EQf i). rewrite -EQf1v -EQf2v in EQf. exact EQf. }
- ddes (f11 i) at 1 3 11 19 20 28 as [v11|] deqn:EQf11v.
- + ddes (f12 i) at 1 3 7 11 15 16 as [v12|] deqn:EQf12v; simpl; last first.
- { specialize (EQf1 i). rewrite /ra_op /= -EQf1v -EQf11v -EQf12v /= in EQf1.
- specialize (EQf i). rewrite -EQf1v -EQf2v /= in EQf. split; first reflexivity.
- split; last tauto. rewrite -EQf1. assumption. }
- destruct (cmra_extend (S n) v1 v11 v12 v2
- (finmap_cmra_extend_obligation_1 n f1 f11 f12 f2 EQf EQf1 i v1 v2
- EQf1v EQf2v v11 v12 EQf11v EQf12v)
- (finmap_cmra_extend_obligation_2 n f1 f11 f12 f2 EQf EQf1 i v1 v2
- EQf1v EQf2v v11 v12 EQf11v EQf12v)) as [t21 [t22 [EQ2 [EQd1 EQd2]]]].
- simpl. split_conjs; assumption.
- + ddes (f12 i) at 1 3 7 11 15 16 as [v12|] deqn:EQf12v; simpl.
- { specialize (EQf1 i). rewrite /ra_op /= -EQf1v -EQf11v -EQf12v /= in EQf1.
- specialize (EQf i). rewrite -EQf1v -EQf2v /= in EQf. split; first reflexivity.
- split; first tauto. rewrite -EQf1. assumption. }
- exfalso. specialize (EQf1 i). rewrite /ra_op /= -EQf1v -EQf11v -EQf12v /= in EQf1. exact EQf1.
- - ddes (f2 i) at 1 3 4 8 12 16 as [v2|] deqn:EQf2v.
- + exfalso. specialize (EQf i). rewrite -EQf1v -EQf2v /= in EQf. exact EQf.
- + simpl. split; first tauto.
- specialize (EQf1 i). rewrite /ra_op /= -EQf1v /= in EQf1.
- destruct (f11 i), (f12 i); contradiction || split; reflexivity.
- Qed.
-
- End CMRAExt.
-
-End CMRA.
-
-Section RAMap.
- Context {I : Type} `{CI : DecEq I}.
- Context {T U: Type} `{cmraT: CMRA T} `{cmraU: CMRA U}.
-
- Local Instance ra_force_pord_T: preoType (I -f> T) := pord_ra.
- Local Instance ra_force_pord_U: preoType (I -f> U) := pord_ra.
-
- Program Definition fdRAMap (f: T -m> U): (I -f> T) -m> (I -f> U) :=
- mkMUMorph (fdMap f) _.
- Next Obligation. (* If one day, this obligation disappears, then probably the instances are not working out anymore *)
- move=>x y EQxy. change (fdMap f x ⊑ fdMap f y).
- apply ra_pord_iff_ext_pord. apply ra_pord_iff_ext_pord in EQxy.
- by eapply mu_mono.
- Qed.
-
- Global Instance fdRAMap_resp: Proper (equiv ==> equiv) fdRAMap.
- Proof.
- move=>x y EQxy. change (fdMap x == fdMap y). by eapply fdMap_resp.
- Qed.
- Global Instance fdRAMap_nonexp n : Proper (dist n ==> dist n) fdRAMap.
- Proof.
- move=>x y EQxy. change (fdMap x = n = fdMap y). by eapply fdMap_nonexp.
- Qed.
-
-End RAMap.
-
-Section RAMapComp.
- Context {I : Type} `{CI : DecEq I}.
- Context {T: Type} `{cmraT: CMRA T}.
-
- Lemma fdRAMap_id:
- fdRAMap (pid T) == pid (I -f> T).
- Proof.
- change (fdMap (pid T) == pid (I -f> T)).
- by eapply fdMap_id.
- Qed.
-
- Context {U: Type} `{cmraU: CMRA U}.
- Context {V: Type} `{cmraV: CMRA V}.
-
- Lemma fdRAMap_comp (f: T -m> U) (g: U -m> V):
- fdRAMap g ∘ fdRAMap f == fdRAMap (g ∘ f).
- Proof.
- change (fdMap g ∘ fdMap f == fdMap (g ∘ f)).
- by eapply fdMap_comp.
- Qed.
-
-End RAMapComp.
diff --git a/lib/ModuRes/Lists.v b/lib/ModuRes/Lists.v
deleted file mode 100644
index 55342e6127f993881ce0a11ca1b06cdf8e1ac634..0000000000000000000000000000000000000000
--- a/lib/ModuRes/Lists.v
+++ /dev/null
@@ -1,244 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Import Omega CSetoid List ListSet.
-
-Set Bullet Behavior "Strict Subproofs".
-
-(* Stuff about lists that ought to be in the stdlib... *)
-Lemma NoDup_app3 {T} (l1 l2 l3: list T):
- NoDup (l1 ++ l2 ++ l3) -> NoDup (l2 ++ l1 ++ l3).
-Proof.
- revert l2 l3. induction l1; induction l2; intro l3; simpl; try tauto; [].
- move=>Hndup. change (NoDup (a0 :: l2 ++ (a::nil) ++ l1 ++ l3)).
- apply NoDup_cons; last first.
- - apply IHl2. eapply NoDup_remove_1. eassumption.
- - rewrite app_comm_cons in Hndup. apply NoDup_remove_2 in Hndup.
- move=>Hin. apply Hndup. clear -Hin. rewrite !in_app_iff. rewrite ->!in_app_iff in Hin.
- destruct Hin as [Hin|[[Hin|[]]|[Hin|Hin]]].
- + right. left. assumption.
- + left. left. assumption.
- + left. right. assumption.
- + right. right. assumption.
-Qed.
-
-Infix "∈" := In (at level 31, no associativity) : list_scope.
-
-Section FilterDup.
- Context {K: Type} `{eqK : DecEq K}.
-
- (* Remove the None elements from the list, and duplicates *)
- Fixpoint filter_dupes (dupes l: list K) :=
- match l with
- | nil => nil
- | k::ks => if set_mem dec_eq k dupes then filter_dupes dupes ks
- else k::filter_dupes (k::dupes) ks
- end.
-
- Lemma filter_dupes_notin dupes l:
- forall k, k ∈ dupes -> ~(k ∈ filter_dupes dupes l).
- Proof.
- move:dupes. induction l; intros dupes k Hin_dupes.
- - move=>Hin_dom. destruct Hin_dom.
- - simpl. destruct (set_mem _ a dupes) eqn:EQsm.
- + apply IHl. assumption.
- + apply set_mem_complete1 in EQsm.
- move=>[EQ|Hin].
- * subst a. apply EQsm. apply Hin_dupes.
- * eapply IHl, Hin. right. assumption.
- Qed.
-
- Lemma filter_dupes_nodup dupes l:
- NoDup (filter_dupes dupes l).
- Proof.
- move:dupes. induction l; intros dupes; simpl.
- - apply NoDup_nil.
- - destruct (set_mem _ a dupes) eqn:EQsm.
- { apply IHl. }
- apply set_mem_complete1 in EQsm.
- apply NoDup_cons.
- + eapply filter_dupes_notin. left. reflexivity.
- + apply IHl.
- Qed.
-
- Lemma filter_dupes_in dupes l k:
- ~k ∈ dupes -> k ∈ l -> k ∈ filter_dupes dupes l.
- Proof.
- revert dupes; induction l; intros ? Hdupes Hdom; simpl.
- - exact Hdom.
- - destruct (dec_eq a k) as [EQ|NEQ].
- + subst. destruct (set_mem _ k dupes) eqn:EQsm.
- { exfalso. eapply Hdupes, set_mem_correct1. eassumption. }
- left. reflexivity.
- + destruct Hdom as [Heq|Hdom]; first contradiction.
- destruct (set_mem _ a dupes) eqn:EQsm.
- { eapply IHl; assumption. }
- right. apply IHl; try assumption. move=>[Heq|Hin]; first contradiction.
- apply Hdupes, Hin.
- Qed.
-
- Lemma filter_dupes_isin dupes l k:
- k ∈ filter_dupes dupes l -> ~k ∈ dupes /\ k ∈ l.
- Proof.
- revert dupes; induction l; intros ?; simpl; intros Hin.
- - destruct Hin.
- - destruct (set_mem _ a dupes) eqn:EQsm.
- { specialize (IHl _ Hin). tauto. }
- destruct (dec_eq a k) as [EQ|NEQ].
- + subst a.
- split; first (eapply set_mem_complete1; eassumption).
- left; reflexivity.
- + destruct Hin as [Heq|Hin]; first contradiction.
- specialize (IHl _ Hin). split; last tauto.
- destruct IHl as [Hind _]. move=>Hind'. apply Hind. right. assumption.
- Qed.
-
- Lemma filter_dupes_id dupes l:
- NoDup (dupes++l) ->
- filter_dupes dupes l = l.
- Proof.
- revert dupes; induction l; intros dupes Hndup; simpl.
- - reflexivity.
- - destruct (set_mem _ a dupes) eqn:EQsm.
- { exfalso. apply set_mem_correct1 in EQsm.
- apply NoDup_remove_2 in Hndup. apply Hndup.
- apply in_app_iff. left. assumption. }
- f_equal. apply IHl.
- revert Hndup. clear. change (NoDup(dupes ++ [a] ++ l) -> NoDup ([a] ++ dupes ++ l)).
- eapply NoDup_app3.
- Qed.
-
- Lemma filter_dupes_ext dupes1 dupes2 l:
- (forall k, k ∈ dupes1 <-> k ∈ dupes2) ->
- filter_dupes dupes1 l = filter_dupes dupes2 l.
- Proof.
- revert dupes1 dupes2. induction l; intros ? ? Heq.
- - reflexivity.
- - simpl. destruct (set_mem dec_eq a dupes1) eqn:EQsm.
- + apply set_mem_correct1 in EQsm. apply Heq in EQsm.
- eapply set_mem_correct2 in EQsm. erewrite EQsm.
- now apply IHl.
- + apply set_mem_complete1 in EQsm. unfold set_In in EQsm.
- rewrite ->Heq in EQsm.
- eapply set_mem_complete2 in EQsm. erewrite EQsm.
- f_equal. apply IHl. move=>k. simpl.
- specialize (Heq k). tauto.
- Qed.
-
- Lemma filter_dupes_redundant dupes l a:
- ~a ∈ l ->
- filter_dupes (a::dupes) l = filter_dupes dupes l.
- Proof.
- revert dupes. induction l; intros dupes Hnin; simpl.
- - reflexivity.
- - destruct (dec_eq a0 a) as [EQ|NEQ].
- { exfalso. subst. apply Hnin. left. reflexivity. }
- destruct (set_mem dec_eq a0 dupes) eqn:EQsm.
- { apply IHl. move=>Hin. apply Hnin. right. assumption. }
- f_equal. etransitivity; last first.
- + eapply IHl. move=>Hin. apply Hnin. right. assumption.
- + apply filter_dupes_ext. move=>k. simpl. tauto.
- Qed.
-
-End FilterDup.
-
-Section ListMax.
- Definition list_max := fold_right max 0.
-
- Lemma list_max_ge l n:
- In n l -> n <= list_max l.
- Proof.
- revert n. induction l; intros n HIn.
- - destruct HIn.
- - simpl. apply NPeano.Nat.max_le_iff. destruct HIn as [Heq|HIn].
- + left. subst. reflexivity.
- + right. now apply IHl.
- Qed.
-End ListMax.
-
-Section Fold.
- Context {V T: Type} {eqT: relation T} {eqRT: Equivalence eqT}.
-
- Section FoldExtRestr.
- (* The operation can change for elements that are not even in the list. *)
- Lemma fold_ext_restr op1 op2 (t1 t2: T) (l1 l2: list V):
- l1 = l2 -> t1 = t2 -> (forall k t, k ∈ l1 -> op1 k t = op2 k t) ->
- fold_right op1 t1 l1 = fold_right op2 t2 l2.
- Proof.
- move=>? ?. subst l2 t2. induction l1; intros Heqop.
- - reflexivity.
- - simpl. erewrite IHl1.
- + apply Heqop. left. reflexivity.
- + move=>k t Hin. apply Heqop. right. assumption.
- Qed.
- End FoldExtRestr.
-
- Section FoldExt.
- Context (op1 op2: V -> T -> T).
- Context {op1_proper: Proper (eq ==> eqT ==> eqT) op1}.
- Context {op2_proper: Proper (eq ==> eqT ==> eqT) op2}.
- Context {op_eq: forall v t, eqT (op1 v t) (op2 v t)}.
-
- Lemma fold_ext: forall t1 t2, eqT t1 t2 -> forall l, eqT (fold_right op1 t1 l) (fold_right op2 t2 l).
- Proof.
- intros ? ? EQt ?. induction l.
- - exact EQt.
- - simpl. rewrite IHl. apply op_eq.
- Qed.
- End FoldExt.
-
- Section FoldPerm.
- Context {eqV: DecEq V}.
-
- Definition NoDup_Perm (l1 l2: list V): Prop :=
- NoDup l1 /\ NoDup l2 /\ (forall v, v ∈ l1 <-> v ∈ l2).
-
- Context (op: V -> T -> T) {op_proper: Proper (eq ==> eqT ==> eqT) op}.
- Context (op_comm: forall v1 v2, forall t, eqT (compose (op v1) (op v2) t) (compose (op v2) (op v1) t)).
-
- Lemma fold_tofront (l: list V) a (t1: T):
- NoDup l -> a ∈ l ->
- eqT (fold_right op t1 (a::filter_dupes [a] l)) (fold_right op t1 l).
- Proof.
- induction l; intros Hnod Hin.
- - exfalso. apply Hin.
- - simpl. destruct (dec_eq a0 a) as [EQ|NEQ].
- + subst a. apply op_proper; first reflexivity.
- rewrite filter_dupes_id; first reflexivity.
- assumption.
- + simpl. etransitivity; first now eapply op_comm.
- simpl. apply op_proper; first reflexivity.
- assert (Heq: filter_dupes [a0; a] l = filter_dupes [a] l).
- { apply filter_dupes_redundant. inversion Hnod; subst; assumption. }
- rewrite Heq. eapply IHl.
- * inversion Hnod; subst; assumption.
- * destruct Hin; last assumption. contradiction.
- Qed.
-
- Lemma fold_perm (l1 l2: list V) (t1: T):
- NoDup_Perm l1 l2 ->
- eqT (fold_right op t1 l1) (fold_right op t1 l2).
- Proof.
- revert l2. induction l1; intros l2 Hnodp;
- move:(Hnodp)=>[Hnod1 [Hnod2 Heq]].
- - destruct l2 as [|a l2]; first reflexivity.
- exfalso. destruct (Heq a) as [_ Hin]. apply Hin.
- left. reflexivity.
- - simpl.
- assert (Hin2: a ∈ l2).
- { apply Heq. left. reflexivity. }
- etransitivity; last first.
- + eapply fold_tofront; eassumption.
- + simpl. apply op_proper; first reflexivity.
- apply IHl1. split; last split; last split.
- * inversion Hnod1; subst; assumption.
- * apply filter_dupes_nodup.
- * move=>Hin. apply filter_dupes_in.
- { move=>[EQ|[]].
- inversion Hnod1; subst. contradiction. }
- apply Heq. right. assumption.
- * move=>Hin. apply filter_dupes_isin in Hin.
- destruct Hin as [Hneq Hin]. apply Heq in Hin.
- destruct Hin as [EQ|?]; last assumption.
- subst a. exfalso. apply Hneq. now left.
- Qed.
- End FoldPerm.
-End Fold.
diff --git a/lib/ModuRes/MetricCore.v b/lib/ModuRes/MetricCore.v
deleted file mode 100644
index c9c8cc365ad071a11243aa01499497f410d7ef61..0000000000000000000000000000000000000000
--- a/lib/ModuRes/MetricCore.v
+++ /dev/null
@@ -1,1068 +0,0 @@
-(** This module implements the core theory of complete bisected ultrametric
- spaces. It starts with their definition and simple properties. In the last part
- the standard constructions are defined, the same as in CSetoids.
-
- The distance function is really defined as picking out equivalence classes
- directly, instead of the usual definition with a map into reals. The approaches
- are equivalent for bisected metric spaces. *)
-
-Require Import Ssreflect.ssreflect.
-Require Import Omega.
-Require Import Min Max.
-Require Export CSetoid.
-
-Set Bullet Behavior "Strict Subproofs".
-
-Open Scope nat_scope.
-
-Generalizable Variables T U V W.
-
-(** ** 1-Bounded bisected Ultra Metric type
- d_n(x,y) <-> |x - y| <= 1/2^n *)
-
-(** Metric on the [type] M with requirements. Note that this only covers bisected metric spaces.
- To fully follow the unbundled style, we'd have to factor out "dist" - but things already work
- pretty well this way. *)
-Class metric (T : Type) {eqT : Setoid T} :=
- { dist : nat -> T -> T -> Prop;
- dist_morph n :> Proper (equiv ==> equiv ==> iff) (dist n);
- dist_refl : forall x y, (forall n, dist n x y) <-> x == y;
- dist_sym n :> Symmetric (dist n);
- dist_trans n :> Transitive (dist n);
- dist_mono : forall n x y, dist (S n) x y -> dist n x y;
- dist_bound : forall x y, dist 0 x y}.
-
-Notation "'mkMetr' D" := (Build_metric _ _ D _ _ _ _ _ _) (at level 10).
-Arguments dist {_ _ _} n !_ !_ /.
-
-(* And now it gets annoying that we are not fully unbundled... *)
-Global Instance metric_dist_equiv (T: Type) `{mT: metric T} n: Equivalence (dist n).
-Proof.
- split.
- - intros x. eapply dist_refl. reflexivity.
- - now eapply dist_sym.
- - now eapply dist_trans.
-Qed.
-
-Section DistProps.
- Context `{mT : metric T}.
-
- Lemma mono_dist x y m n (HLe : m <= n) : dist n x y -> dist m x y.
- Proof.
- induction HLe; [tauto |].
- intros HS; apply IHHLe, dist_mono; assumption.
- Qed.
-
- (** The spaces are ultrametric spaces. *)
- Lemma tai_dist x y z n m (HL : dist n x y) (HR : dist m y z) :
- dist (min m n) x z.
- Proof.
- etransitivity; eapply mono_dist; try eassumption; eauto using le_min_r, le_min_l.
- Qed.
-
- Global Instance Reflexive_dist n : Reflexive (dist n).
- Proof. intros x; revert n; rewrite dist_refl; reflexivity. Qed.
-
-End DistProps.
-
-Notation "x '=' n '=' y" := (dist n x y).
-
-Instance dist_iff `{metric T} n : Proper (dist n ==> dist n ==> iff) (dist n).
-Proof.
- intros x y EQxy u v EQuv; split; intros EQ; [symmetry in EQxy, EQuv |];
- rewrite ->EQxy, EQuv; assumption.
-Qed.
-
-Existing Class le.
-
-Existing Instance le_plus_trans.
-Instance le_plus_trans' n m p {HLe : n <= p} : n <= m + p.
-Proof.
- rewrite plus_comm; apply _.
-Qed.
-Existing Instance le_S.
-Existing Instance le_n.
-Instance max_le_tr_l n m p {HLe : n <= m} : n <= max m p.
-Proof.
- rewrite-> HLe; apply le_max_l.
-Qed.
-Instance max_le_tr_r n m p {HLe : n <= p} : n <= max m p.
-Proof.
- rewrite-> HLe; apply le_max_r.
-Qed.
-
-Instance mono_proper `{metric T} m n {HLe : n <= m} :
- Proper (dist m ==> dist m ==> iff) (dist n).
-Proof.
- intros m1 m2 EQm m3 m4 EQm'.
- eapply mono_dist in EQm; [| eassumption].
- eapply mono_dist in EQm'; [| eassumption].
- rewrite-> EQm, EQm'; reflexivity.
-Qed.
-
-(** Cauchy chains of elements of a metric spaces. This is a very strong form of
-convergence, since we require than all elements after the n-th are closer than 2â»â¿.*)
-Definition chain (T : Type) := nat -> T.
-Class cchain `{mT : metric T} (σ : chain T): Prop :=
- chain_cauchy : forall n i j {HLei : n <= i} {HLej : n <= j}, (σ i) = n = (σ j).
-
-Arguments cchain [T eqT mT] σ.
-Arguments chain_cauchy [T eqT mT] _ _ n i j {HLei HLej}.
-
-Section Chains.
- Context `(σ : chain T) `{σc : cchain _ σ}.
-
- (** n-th tail of the sequence *)
- Definition cutn (n : nat) : chain T := fun i => σ (n + i).
- Global Instance cutn_cauchy (n : nat) : cchain (cutn n).
- Proof.
- intros k i j HLei HLej.
- unfold cutn.
- apply mono_dist with (n + k); [apply _ |].
- apply σc; now apply plus_le_compat_l.
- Qed.
-
- (** Constant chains are chains. *)
- Global Instance const_chain m : cchain (fun _ => m).
- Proof. unfold cchain; reflexivity. Qed.
-
- (** Chain [c] converges to [x].
- NOTE: Similar to chain_cauchy, we require that every element after n-th is closer than 2â»â¿. *)
- Definition mconverge (m : T) :=
- forall n, forall i {HLe : n <= i}, m = n = (σ i).
-
-End Chains.
-
-(* Again, this is not fully unbundled - "compl" is a computational component *)
-Class cmetric T `{mT : metric T} :=
- { compl : forall σ {σc : cchain σ}, T;
- conv_cauchy : forall σ {σc : cchain σ}, mconverge σ (compl σ)}.
-
-Notation "'mkCMetr' C" := (Build_cmetric _ _ _ C _) (at level 10).
-
-(*(** Completion assigns to each Cauchy chain an element of M, such that the chain
-converges to that element, i.e. it assigns it an actual limit. *)
-Class Completion M `{mM : metric M} := mcompl : forall (σ : chain M) (σc : cchain σ), M.
-Arguments mcompl {M e eqM D mM Completion} σ {σc}.
-
-Class cmetric M `{mM : metric M} {cM : Completion M} :=
- conv_cauchy : forall σ {σc : cchain σ}, mconverge σ (mcompl σ).
-*)
-
-Section ChainCompl.
- Context `{cT : cmetric T} (σ Ï : chain T) {σc : cchain σ} {Ïc : cchain Ï}.
-
- Lemma umet_complete_extn n (HEq : σ n = n = Ï n) :
- compl σ = n = compl Ï.
- Proof.
- assert (Hm:=conv_cauchy σ n n). assert (Hk:=conv_cauchy Ï n n).
- rewrite ->Hm, Hk; first (by apply HEq); reflexivity.
- Qed.
-
- Lemma umet_complete_ext :
- (forall i, σ i = i = Ï i) -> compl σ == compl Ï.
- Proof.
- intros HEq; rewrite <- dist_refl; intros n; apply umet_complete_extn.
- rewrite ->HEq. reflexivity.
- Qed.
-
- Lemma umet_complete_const m : compl (fun _ => m) == m.
- Proof.
- symmetry; rewrite <- dist_refl; intros n.
- assert (Hk:=conv_cauchy (fun _ => m) n). rewrite Hk; eauto || reflexivity.
- Qed.
-
- (** Limits don't depend on prefixes of sequences. *)
- Lemma cut_complete_eq n :
- compl σ == compl (cutn σ n).
- Proof.
- rewrite <- dist_refl; intros m; assert (Hk:=conv_cauchy σ m).
- assert (Hj:=conv_cauchy (cutn σ n) m); simpl in *.
- unfold cutn in *; rewrite ->Hj, Hk; [reflexivity | | apply le_max_l]; clear Hk Hj.
- apply _.
- Qed.
-
-End ChainCompl.
-
-(** Morphisms of metric spaces — non-expansive functions. *)
-Record metric_morphism T U `{mT : metric T} `{mU : metric U} :=
- mkUMorph
- { met_morph :> T -=> U;
- met_morph_nonexp n : Proper (dist n ==> dist n) met_morph}.
-
-Arguments mkUMorph [T U] {eqT mT eqT0 mU} _ _.
-Arguments met_morph [T U] {eqT mT eqT0 mU} !_ /.
-Arguments met_morph_nonexp {_ _} {_ _ _ _} _ {_} {_ _} _.
-Infix "-n>" := metric_morphism (at level 45, right associativity).
-
-(*Global Instance metric_morphism_proper T U `{mT : metric T} `{mU : metric U} n (f: T -n> U):
- Proper (dist n ==> dist n) f.
-Proof.
- now eapply met_morph_nonexp.
-Qed.*)
-
-Lemma dist_equiv T U `{mT : metric T} `{mU : metric U} (f: T -> U)
- (NEXP : forall n, Proper (dist n ==> dist n) f):
- Proper (equiv ==> equiv) f.
-Proof.
- intros x y Heq.
- eapply dist_refl. intros n.
- eapply NEXP. rewrite Heq. reflexivity.
-Qed.
-
-
-Program Definition mkNMorph T U `{mT : metric T} `{mU : metric U} (f: T -> U)
- (NEXP : forall n, Proper (dist n ==> dist n) f) :=
- mkUMorph s[(f)] _.
-Next Obligation.
- now eapply dist_equiv.
-Qed.
-Arguments mkNMorph [T U eqT mT eqT0 mU] _ _.
-Notation "'n[(' f ')]'" := (mkNMorph f _).
-
-Instance subrel_dist `{mT : metric T} n : subrelation equiv (dist n).
-Proof.
- intros x y HEq; revert n; rewrite dist_refl; assumption.
-Qed.
-
-Section MMInst.
- Context `{mT : metric T} `{mU : metric U}.
-
- Global Program Instance nonexp_type : Setoid (T -n> U) :=
- mkType (fun f g => met_morph f == g).
- Next Obligation.
- split.
- + intros f x; reflexivity.
- + intros f g HS x; symmetry; apply HS.
- + intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
- Qed.
-
- Global Program Instance nonexp_metric : metric (T -n> U) :=
- mkMetr (fun n f g => forall x, f x = n = g x).
- Next Obligation.
- intros f1 f2 EQf g1 g2 EQg; split; intros EQfg x; [symmetry in EQf, EQg |];
- rewrite ->(EQf x), (EQg x); apply EQfg.
- Qed.
- Next Obligation.
- fold equiv.
- split; [intros HEq t | intros HEq n].
- - rewrite <- dist_refl; intros n; apply HEq.
- - intros t; revert n; rewrite dist_refl; apply HEq.
- Qed.
- Next Obligation.
- intros f g HS x; symmetry; apply HS.
- Qed.
- Next Obligation.
- intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
- Qed.
- Next Obligation.
- eauto using mono_dist.
- Qed.
- Next Obligation.
- apply dist_bound.
- Qed.
-
-End MMInst.
-
-(** The next ones just seem to be "lemmas" stating that metric morphisms and morphisms preserve suitable equalities. *)
-Instance mmorph_proper n `{mT : metric T} `{mU : metric U} :
- Proper (dist n ==> dist n ==> dist n) (met_morph (T := T) (U := U)).
-Proof.
- intros f g HEq x y HEq'; etransitivity; [apply HEq | apply g, HEq'].
-Qed.
-
-Definition distS `{eqT : Setoid T} `{mU : metric U} n (f g : T -=> U) :=
- forall x, f x = n = g x.
-
-Instance mmorph_properS n `{mT : metric T} `{mU : metric U} :
- Proper (distS n ==> equiv ==> dist n) (morph (T:=T) (U:=U)).
-Proof.
- intros f g HEq x y HEq'; rewrite HEq'; apply HEq.
-Qed.
-
-Instance mmorph_inherit `{mT : metric T} `{mU : metric U} :
- Proper (equiv ==> equiv) (met_morph (T := T) (U := U)).
-Proof. intros f g HEq; apply HEq. Qed.
-
-Instance mmorph_extend `{mT : metric T} `{mU : metric U} n :
- Proper (dist n ==> distS n) (met_morph (T := T) (U := U)).
-Proof. intros f g HEq x; rewrite (HEq x); reflexivity. Qed.
-
-Instance morph_proper' n `{mT : metric T} `{mU : metric U} (f : T -n> U) :
- Proper (dist n ==> dist n) f.
-Proof. apply met_morph_nonexp. Qed.
-
-Ltac resp_dist := intros n; resp_set.
-
-Section MCont.
- Context `{cT : cmetric T} `{cU : cmetric U} `{cV : cmetric V}.
-
- (** Definition of contractive functions. This works since the spaces are bisected. *)
- Class contractive (f : T -> U) := contr n : Proper (dist n ==> dist (S n)) f.
-
- Program Definition contractive_nonexp (f: T -> U) (fC: contractive f): T -n> U :=
- n[(f)].
- Next Obligation.
- intros t u EQ. eapply dist_mono, fC. assumption.
- Qed.
-
-
- (** Image of a Cauchy chain by a non-expansive function is another Cauchy sequence. *)
- Definition liftc (f : T -> U) (σ : chain T) : chain U := fun i => f (σ i).
- Arguments liftc f σ i / .
- Global Instance liftc_cauchy (f : T -n> U) (σ : chain T) {σc : cchain σ} :
- cchain (liftc f σ).
- Proof.
- intros n i j HLei HLej; simpl.
- rewrite (chain_cauchy σ); reflexivity || assumption.
- Qed.
-
- (** The same as before, only for two-argument functions. *)
- Definition binaryLimit (f : T -n> U -n> V) (σ : chain T) (Ï : chain U) : chain V :=
- fun i => f (σ i) (Ï i).
- Arguments binaryLimit f σ Ï i / .
- Global Instance binLim_cauchy (f : T -n> U -n> V) (σ : chain T) (Ï : chain U) {σc : cchain σ} {Ïc : cchain Ï} : cchain (binaryLimit f σ Ï).
- Proof.
- intros n i j HLei HLej; simpl.
- rewrite ->(chain_cauchy σ), (chain_cauchy Ï); reflexivity || assumption.
- Qed.
-
- (** Non-expansive functions preserve limits, i.e. are continuous. *)
- Lemma nonexp_continuous (f : T -n> U) (σ : chain T) (σc : cchain σ) :
- f (compl σ) == compl (liftc f σ).
- Proof.
- rewrite <- dist_refl; intros n; assert (B:=conv_cauchy σ n n).
- assert (A:=conv_cauchy (liftc f σ) n n). simpl in *.
- rewrite ->B, A; reflexivity.
- Qed.
-
- Local Obligation Tactic := intros; resp_set || program_simpl.
-
- (** Composition of non-expansive maps is non-expansive. *)
- Program Definition umcomp (f : U -n> V) (g : T -n> U) : T -n> V :=
- n[(f << g)].
-
- Program Definition lift2m (f : T -=> U -=> V) p q : (T -n> U -n> V) :=
- mkUMorph s[(fun x => mkUMorph (f x) (p x))] q.
-
-End MCont.
-
-Infix "<M<" := umcomp (at level 35).
-
-Section MSwap.
- Context `{cT : cmetric T} `{cU : cmetric U} `{cV : cmetric V}.
-
- Local Obligation Tactic := intros; apply _ || resp_set || eauto with typeclass_instances.
-
- Program Definition Mswap (f: T -n> U -n> V): U -n> T -n> V :=
- n[(fun u => n[(fun t => f t u)])].
-
-End MSwap.
-
-Section MCompP.
- Context `{cT : cmetric T} `{cU : cmetric U} `{cV : cmetric V} `{cW : cmetric W}.
-
- (** Composition preserves distances. *)
- Global Instance ndist_umcomp n :
- Proper (dist n (T := U -n> V) ==> dist n ==> dist n) umcomp.
- Proof. intros f f' HEq g g' HEq' x; simpl; rewrite ->HEq, HEq'; reflexivity. Qed.
-
- Lemma lift_comp (f : U -n> V) (g : T -n> U) (σ : chain T) {σc : cchain σ} :
- compl (liftc f (liftc g σ)) == compl (liftc (f <M< g) σ).
- Proof.
- apply umet_complete_ext; try apply _; intros i; reflexivity.
- Qed.
-
- Lemma mcomp_assoc (f : V -n> W) (g : U -n> V) (h : T -n> U) :
- f <M< (g <M< h) == (f <M< g) <M< h.
- Proof. intros x; reflexivity. Qed.
-
- Local Obligation Tactic := intros; resp_set || program_simpl.
-
- (** Composition as a _non-expansive_ morphism itself. This then shows that the
- category of bisected spaces is enriched in itself. *)
- Program Definition comp : (U -n> V) -n> (T -n> U) -n> T -n> V :=
- lift2m (lift2s (fun f g => f <M< g) _ _) _ _.
-
- Program Definition umid : T -n> T := n[(mid _)].
-
- Program Definition umconst x : T -n> U := n[(mconst x)].
-
- Global Program Instance umconst_contractive m : contractive (umconst m).
-
- Program Definition precomp_ne (f : T -n> U) : (U -n> V) -n> (T -n> V) :=
- n[(fun g => g <M< f)].
-
- Program Definition postcomp_ne (f : T -n> U) : (V -n> T) -n> (V -n> U) :=
- n[(fun g => f <M< g)].
-
-End MCompP.
-
-Arguments umid T {eqT mT}.
-
-Section Halving.
- Context {T: Type} `{cmT : cmetric T}.
-
- CoInductive halve := halved: T -> halve.
- Definition unhalved (h: halve) := match h with halved t => t end.
-
- Definition dist_halve n :=
- match n with
- | O => fun _ _ => True
- | S n => fun h1 h2 => match h1, h2 with halved t1, halved t2 => dist n t1 t2 end
- end.
-
- Global Program Instance halve_ty : Setoid halve :=
- mkType (fun h1 h2 => match h1, h2 with halved t1, halved t2 => t1 == t2 end).
- Next Obligation.
- split; repeat intro;
- repeat (match goal with [ x : halve |- _ ] => destruct x end).
- - reflexivity.
- - symmetry; assumption.
- - etransitivity; eassumption.
- Qed.
-
- Global Instance unhalve_proper : Proper (equiv ==> equiv) unhalved.
- Proof.
- repeat intro. repeat (match goal with [ x : halve |- _ ] => destruct x end).
- simpl in *. assumption.
- Qed.
-
- Global Program Instance halve_metr : metric halve := mkMetr dist_halve.
- Next Obligation.
- destruct n; [now resp_set | repeat intro ];
- repeat (match goal with [ x : halve |- _ ] => destruct x end).
- simpl. simpl in *. rewrite ->H, H0. reflexivity.
- Qed.
- Next Obligation.
- split; intros HEq.
- - repeat (match goal with [ x : halve |- _ ] => destruct x end).
- simpl. apply dist_refl; intros n; apply (HEq (S n)).
- - intros [| n]; [exact I |]. simpl.
- repeat (match goal with [ x : halve |- _ ] => destruct x end).
- revert n; apply dist_refl, HEq.
- Qed.
- Next Obligation.
- intros t1 t2 HEq; destruct n; [exact I |].
- repeat (match goal with [ x : halve |- _ ] => destruct x end). simpl in *.
- symmetry; apply HEq.
- Qed.
- Next Obligation.
- intros t1 t2 t3 HEq12 HEq23; destruct n; [exact I |].
- repeat (match goal with [ x : halve |- _ ] => destruct x end). simpl in *.
- etransitivity; [apply HEq12 | apply HEq23].
- Qed.
- Next Obligation.
- destruct n; [exact I | ].
- repeat (match goal with [ x : halve |- _ ] => destruct x end). simpl in *.
- apply dist_mono, H.
- Qed.
-
- Instance halve_chain (σ : chain halve) {σc : cchain σ} : cchain (fun n => unhalved (σ (S n))).
- Proof.
- unfold cchain; intros.
- apply le_n_S in HLei. apply le_n_S in HLej.
- specialize (chain_cauchy _ σc (S n) (S i) (S j)). simpl. intros Hcauchy.
- destruct (σ (S i)), (σ (S j)). assumption.
- Qed.
-
- Definition compl_halve (σ : chain halve) (σc : cchain σ) : halve :=
- halved (compl (fun n => unhalved (σ (S n))) (σc := halve_chain σ)).
-
- Program Definition halve_cm : cmetric halve := mkCMetr compl_halve.
- Next Obligation.
- intros [| n]; [intros; exact I |].
- assert (HCon:=conv_cauchy _ (σc := halve_chain σ) n).
- intros [| i] HLe; [inversion HLe |]. unfold compl_halve.
- apply le_S_n in HLe.
- specialize (HCon i _). simpl in HCon. destruct (σ (S i)). simpl. assumption.
- Qed.
-
- Global Instance halve_eq n: Proper (dist (S n) ==> dist n) unhalved.
- Proof.
- repeat intro. repeat (match goal with [ x : halve |- _ ] => destruct x end). simpl. assumption.
- Qed.
-End Halving.
-Arguments halve : clear implicits.
-Ltac unhalve := repeat match goal with
- | x: halve _ |- _ => destruct x as [x]
- | H: halved _ == halved _ |- _ => simpl in H
- | H: halved _ = _ = halved _ |- _ => simpl in H
- end.
-
-
-(** Single element space and the distance on it. *)
-Program Instance unit_metric : metric unit :=
- mkMetr (fun _ _ _ => True).
-Next Obligation. destruct x, y. simpl. tauto. Qed.
-
-(** The unit space is complete. *)
-Program Instance unit_cmetric : cmetric unit :=
- mkCMetr (fun _ _ => tt).
-Next Obligation.
- intros n; intros k HLe; destruct (σ k); reflexivity.
-Qed.
-
-Section Iteration.
- Context `{mT : metric T}.
-
- (** Iteration of a non-expansive function again gives a non-expansive function. *)
- Program Definition itern n (f : T -n> T) : T -n> T :=
- n[(fun x => iter_nat n _ f x)].
- Next Obligation.
- induction n; simpl.
- - intros x y EQ. assumption.
- - resp_set.
- Qed.
-
- (** If a function is contractive then after sufficiently many iterations it
- maps all elements closer than 2â»â¿. *)
- Lemma bounded_contractive_n f {HC : contractive f} n m x y (HLe : n <= m) :
- iter_nat m _ f x = n = iter_nat m _ f y.
- Proof.
- revert m x y HLe; induction n; intros; [apply dist_bound |].
- destruct m; [inversion HLe |]; simpl; apply HC, IHn; omega.
- Qed.
-
- Global Instance cfix f {HC : contractive f} x : cchain (fun n => iter_nat n _ f x).
- Proof.
- unfold cchain; intros.
- cutrewrite (i = n + (i - n)); [rewrite -> nat_iter_plus | omega].
- cutrewrite (j = n + (j - n)); [rewrite -> nat_iter_plus | omega].
- apply bounded_contractive_n; [assumption | auto].
- Qed.
-
-End Iteration.
-
-Section Fixpoints.
- Context `{cT : cmetric T}.
-
- (** A fixed point of a contractive f is the limit of the iterations of the
- function. This seemingly depends on the starting point x. *)
- Definition fixp f {HC : contractive f} x := compl (fun n => iter_nat n _ f x).
-
- (** Stating that the proposed fixed point is in fact a fixed point. *)
- Lemma fixp_eq f x {HC : contractive f} : fixp f x == f (fixp f x).
- Proof.
- pose (f' := contractive_nonexp _ HC).
- change (fixp f' x == f' (fixp f' x)).
- rewrite <- dist_refl; intros n; unfold fixp.
- assert (Hm:=conv_cauchy (fun n => iter_nat n _ f' x) n).
- rewrite ->(Hm (S n)), (Hm n) at 1 by omega. simpl. reflexivity.
- Qed.
-
- Lemma fixp_iter f x i {HC : contractive f} : fixp f x == iter_nat i _ f (fixp f x).
- Proof.
- pose (f' := contractive_nonexp _ HC).
- change (fixp f' x == iter_nat i _ f' (fixp f' x)).
- induction i; [reflexivity |].
- etransitivity; [eapply fixp_eq|].
- rewrite ->IHi at 1. reflexivity.
- Qed.
-
- (** Fixed points are unique, i.e. the fixp does not depend on the starting point of the iteration. *)
- Lemma fixp_unique f x y {HC : contractive f} : fixp f x == fixp f y.
- Proof.
- rewrite <- dist_refl; intros n; unfold fixp.
- assert (Hmx:=conv_cauchy (fun n => iter_nat n _ f x) n).
- assert (Hmy:=conv_cauchy (fun n => iter_nat n _ f y) n).
- rewrite ->(Hmx n), Hmy;
- [ rewrite ->bounded_contractive_n | ..]; reflexivity || apply _.
- Qed.
-
- (** This lemma states that fixp is non-expansive in f. *)
- Lemma fixp_ne (f f' : T -n> T) {HC : contractive f} (HC' : contractive f') x x' n (HEq : f = n = f') :
- fixp f x = n = fixp f' x'.
- Proof.
- rewrite ->fixp_unique with (x := x') (y := x).
- clear x'; unfold fixp; assert (Hm:=conv_cauchy (fun n => iter_nat n _ f x) n).
- assert (Hk:=conv_cauchy (fun n => iter_nat n _ f' x) n).
- rewrite ->(Hm n), (Hk n); try apply _; [].
- clear Hm Hk. induction n; simpl; [reflexivity |].
- etransitivity.
- - eapply HC, IHn. by eapply dist_mono.
- - rewrite ->HEq. reflexivity.
- Qed.
-
- (** From the non-expansiveness it also follows that fixp preserves equality of f. *)
- Lemma fixp_equiv (f f' : T -n> T) {HC : contractive f} (HC' : contractive f') x x' (HEq : f == f') :
- fixp f x == fixp f' x'.
- Proof.
- rewrite <- dist_refl; intros n; apply fixp_ne.
- rewrite HEq; reflexivity.
- Qed.
-
- (** The above properties should be enough to reason about fixpoints, so we make the definition opaque *)
- Global Opaque fixp.
-
-End Fixpoints.
-
-Section ChainApps.
- Context `{cT : cmetric T} `{cU : cmetric U} (σ : chain (T -n> U)) {σc : cchain σ}.
-
- (** A cauchy chain applied to an element gives another Cauchy chain. *)
- Global Instance chain_app x : cchain (fun i => σ i x).
- Proof. unfold cchain; intros; rewrite (chain_cauchy σ); reflexivity || assumption. Qed.
-
- Instance nonexp_lub n : Proper (dist n ==> dist n) (fun x => compl (fun i => σ i x)).
- Proof.
- intros x y HEq; assert (Hmx:=conv_cauchy (fun i => σ i x) n n).
- assert (Hmy:=conv_cauchy (fun i => σ i y) n n).
- rewrite ->Hmx, Hmy; simpl; [rewrite HEq; reflexivity | ..]; auto using le_max_r, le_max_l.
- Qed.
-
- (** Given a Cauchy chain of functions we get a non-expansive function by
- taking limits starting at different points. Used to show that the hom-set is a
- complete metric space. *)
- Program Definition fun_lub : T -n> U :=
- n[(fun x => compl (fun i => σ i x))].
-
-End ChainApps.
-
-Section NonexpCMetric.
- Context `{cT : cmetric T} `{cU : cmetric U}.
-
- (** The set of non-expansive morphisms between two complete metric spaces is again a complete metric space. *)
- Global Program Instance nonexp_cmetric : cmetric (T -n> U) :=
- mkCMetr fun_lub.
- Next Obligation.
- intros n; intros m HLe x.
- assert (Hk:=conv_cauchy (fun i => σ i x) n).
- rewrite ->(Hk m), (chain_cauchy σ); [reflexivity |..]; apply _.
- Qed.
-
-End NonexpCMetric.
-
-(** Product of two complete metric spaces. *)
-Section MetricProducts.
- Context `{cT : cmetric T} `{cU : cmetric U} `{cV : cmetric V}.
-
- Local Obligation Tactic := intros; apply _ || resp_set || program_simpl.
-
- Definition prod_dist n (p1 p2 : U * V) :=
- fst p1 = n = fst p2 /\ snd p1 = n = snd p2.
- Global Arguments prod_dist n p1 p2 /.
-
- Global Program Instance prod_metric : metric (U * V) := mkMetr prod_dist.
- Next Obligation.
- intros [a1 b1] [a2 b2] [Ha Hb] [a3 b3] [a4 b4] [Ha' Hb']; simpl in *.
- rewrite ->Ha, Hb, Ha', Hb'; reflexivity.
- Qed.
- Next Obligation.
- split; intros HEq.
- + split; rewrite <- dist_refl; intros n; destruct (HEq n); assumption.
- + intros n; split; revert n; rewrite dist_refl; destruct HEq; assumption.
- Qed.
- Next Obligation.
- intros [a1 b1] [a2 b2] [Ha Hb]; split; symmetry; assumption.
- Qed.
- Next Obligation.
- intros [a1 b1] [a2 b2] [a3 b3] [Ha12 Hb12] [Ha23 Hb23]; split; etransitivity; eassumption.
- Qed.
- Next Obligation.
- destruct H; split; eapply mono_dist; try eassumption; auto.
- Qed.
- Next Obligation.
- split; apply dist_bound.
- Qed.
-
- Global Instance prod_proper_n n : Proper (dist n ==> dist n ==> dist n) (@pair U V).
- Proof. intros a a' Ha b b' Hb; split; assumption. Qed.
-
- Global Instance mfst_proper_n n : Proper (dist n ==> dist n) (@fst U V).
- Proof. intros [a1 b1] [a2 b2] [Ha Hb]; assumption. Qed.
-
- Global Instance msnd_proper_n n : Proper (dist n ==> dist n) (@snd U V).
- Proof. intros [a1 b1] [a2 b2] [Ha Hb]; assumption. Qed.
-
- Definition Mfst : U * V -n> U := n[(mfst)].
- Definition Msnd : U * V -n> V := n[(msnd)].
-
- Program Definition Mprod (f : T -n> U) (g : T -n> V) : T -n> U * V :=
- n[(mprod f g)].
- Next Obligation.
- intros x y HEq; simpl; rewrite HEq; split; reflexivity.
- Qed.
-
- Lemma Mprod_fst f g : Mfst <M< Mprod f g == f.
- Proof. intros x; reflexivity. Qed.
-
- Lemma Mprod_snd f g : Msnd <M< Mprod f g == g.
- Proof. intros x; reflexivity. Qed.
-
- Lemma Mprod_unique (f : T -n> U) (g : T -n> V) (h : T -n> U * V) :
- Mfst <M< h == f -> Msnd <M< h == g -> h == Mprod f g.
- Proof. intros HL HR; apply (mprod_unique HL HR). Qed.
-
- (** Product of complete spaces is again a complete space. *)
- Definition prod_compl (σ : chain (U * V)) (σc : cchain σ) :=
- (compl (liftc Mfst σ), compl (liftc Msnd σ)).
- Arguments prod_compl σ σc /.
-
- Global Program Instance prod_cmetric : cmetric (U * V) :=
- mkCMetr prod_compl.
- Next Obligation.
- intros n; assert (Hfst:=conv_cauchy (liftc Mfst σ) n).
- assert (Hsnd:=conv_cauchy (liftc Msnd σ) n).
- intros k HLe; split; simpl in *;
- [apply Hfst | apply Hsnd]; eauto using le_max_l, le_max_r, le_trans.
- Qed.
-
-End MetricProducts.
-
-Section MetricProductMap.
- Context `{pcT : metric T} `{pcU : metric U} `{pcV : metric V} `{pcW : metric W}.
-
- Definition Mprod_map (f: T -n> U) (g: V -n> W): (T * V) -n> (U * W) :=
- Mprod (f <M< Mfst) (g <M< Msnd).
-
- Global Instance Mprod_map_resp: Proper (equiv ==> equiv ==> equiv) Mprod_map.
- Proof.
- move=>f1 f2 EQf g1 g2 EQg [x1 x2]. simpl. now rewrite ->EQf, EQg.
- Qed.
- Global Instance Mprod_map_nonexp n: Proper (dist n ==> dist n ==> dist n) Mprod_map.
- Proof.
- move=>f1 f2 EQf g1 g2 EQg [x1 x2]. simpl. now rewrite ->EQf, EQg.
- Qed.
-
-End MetricProductMap.
-
-
-
-Section ComplSetup.
- Context `{cT : cmetric T} `{cU : cmetric U} (σ : chain T) (Ï : chain U) {σc : cchain σ} {Ïc : cchain Ï}.
-
- Definition chain_pair n := (σ n, Ï n).
- Global Instance cchain_pair : cchain chain_pair.
- Proof. split; simpl; eapply chain_cauchy; assumption. Qed.
-
- (** The limit in the product is computed pointwise, i.e. the limit is the pair
- of limits computed in original spaces. *)
- Lemma pair_limit : compl (chain_pair) == (compl σ, compl Ï).
- Proof. split; simpl; apply umet_complete_ext; intros i; reflexivity. Qed.
-
-End ComplSetup.
-
-(** The subspace defined by P is chain complete. *)
-Class LimitPreserving `{cT : cmetric T} (P : T -> Prop) :=
- lim_pres : forall (σ : chain T) (σc : cchain σ), (forall i, P (σ i)) -> P (compl σ).
-
-(** The set of contractive functions is complete in the set of non-expansive ones. *)
-Instance contractive_complete `{cT : cmetric T} `{cU : cmetric U} :
- LimitPreserving (fun f : T -n> U => contractive f).
-Proof.
- intros σ σc HC n x y HEq; assert (Hm:=conv_cauchy σ (S n)).
- rewrite ->(Hm (S n)); [apply HC |]; trivial.
-Qed.
-
-
-Section OptM.
- Context `{mT : metric T}.
-
- Definition option_dist n (x y : option T) :=
- match x, y with
- | Some x, Some y => x = n = y
- | None, None => True
- | _, _ => match n with O => True | _ => False end
- end.
-
- Global Program Instance option_metric : metric (option T) :=
- mkMetr option_dist.
- Next Obligation.
- destruct n as [| n]; intros [x |] [y |] EQxy [u |] [v |] EQuv; simpl in *; try (contradiction || reflexivity); [|].
- - rewrite EQxy EQuv. reflexivity.
- - rewrite EQxy EQuv. reflexivity.
- Qed.
- Next Obligation.
- split; intros HEq.
- - destruct x; destruct y; try (contradiction (HEq 1) || reflexivity); [].
- unfold equiv; simpl; rewrite <- dist_refl; intros n.
- specialize (HEq (S n)); eapply mono_dist, HEq; auto.
- - destruct x; destruct y; try (contradiction HEq || reflexivity); simpl in *.
- rewrite dist_refl; assumption.
- Qed.
- Next Obligation.
- destruct n as [| n]; intros [x |] [y |] HS; try (contradiction HS || reflexivity);
- simpl; symmetry; assumption.
- Qed.
- Next Obligation.
- revert n; intros [| n] [x |] [y |] [z |] Hxy Hyz; try (contradiction || reflexivity || exact:dist_bound); simpl; [].
- etransitivity; [apply Hxy | apply Hyz].
- Qed.
- Next Obligation.
- destruct n as [n |]; destruct x as [x |]; destruct y as [y |]; try (contradiction H || reflexivity);
- simpl; eapply mono_dist, H; auto.
- Qed.
- Next Obligation.
- destruct x, y; try exact I. exact:dist_bound.
- Qed.
-
- Lemma option_dist_Some x y n:
- Some x = n = Some y <-> x = n = y.
- Proof.
- reflexivity.
- Qed.
-
-End OptM.
-
-(** Subspaces. *)
-Section Submetric.
- Context `{mT : metric T} {P : T -> Prop}.
- Local Obligation Tactic := intros; apply _ || resp_set || program_simpl.
-
- Definition subset_Dist n (x y : {e : T | P e}) := proj1_sig x = n = proj1_sig y.
- Global Arguments subset_Dist n x y /.
-
- Global Program Instance sub_metric : metric {e : T | P e} :=
- mkMetr subset_Dist.
- Next Obligation.
- intros [x Hx] [y Hy] EQxy [u Hu] [v Hv] EQuv; unfold equiv in EQxy, EQuv; simpl in *.
- rewrite ->EQxy, EQuv; reflexivity.
- Qed.
- Next Obligation.
- simpl. apply dist_refl.
- Qed.
- Next Obligation.
- intros [x Hx] [y Hy] [z Hz] Hxy Hyz; simpl in *; etransitivity; eassumption.
- Qed.
- Next Obligation.
- eapply mono_dist, H; auto.
- Qed.
- Next Obligation.
- apply dist_bound.
- Qed.
-
- Program Definition inclM : {e : T | P e} -n> T :=
- n[(mincl)].
- Next Obligation.
- move=>[t1 P1] [t2 P2]. simpl. tauto.
- Qed.
-
- Context {U} `{mU : metric U}.
-
- Program Definition inheritM (f : U -n> T) (HAll : forall n, P (f n)) :=
- n[(minherit f HAll)].
-
- Lemma forgetM_mono f g (HF : inclM <M< f == inclM <M< g) : f == g.
- Proof. apply mforget_mono, HF. Qed.
-
-End Submetric.
-
-Section SubCMetric.
- Context `{cT : cmetric T} {P : T -> Prop} {C : LimitPreserving P}.
-
- (** If a space defined by P is complete (assumption [ccomplete P]) then it
- already contains the limits of its Cauchy chains. *)
- Lemma subchainlubP (σ : chain {x : T | P x}) {σc : cchain σ} :
- P (compl (liftc inclM σ)).
- Proof. apply C; intros i; unfold liftc; destruct (σ i); simpl; assumption. Qed.
-
- Definition sub_compl (σ : chain {x : T | P x}) {σc : cchain σ} :=
- exist P (compl (liftc inclM σ)) (subchainlubP σ).
- Global Program Instance sub_cmetric : cmetric {x : T | P x} :=
- mkCMetr sub_compl.
- Next Obligation.
- intros n; simpl; assert (Hm:=conv_cauchy (liftc inclM σ) n).
- intros k HLe; apply (Hm _ HLe).
- Qed.
-
-End SubCMetric.
-
-Section Exponentials.
- Context `{mT : metric T} `{mU : metric U} `{mV : metric V}.
- Local Obligation Tactic := intros; apply _ || resp_set || program_simpl.
-
- Program Definition uncurry (f : T -n> U -n> V) : (T * U -n> V) :=
- n[(fun p => f (fst p) (snd p))].
- Next Obligation.
- intros [a1 b1] [a2 b2] [Ha Hb]; simpl in *.
- rewrite ->Ha, Hb; reflexivity.
- Qed.
-
- Program Definition curryM (f : T * U -n> V) : T -n> U -n> V := lift2m (mcurry f) _ _.
-
- Context `{mW : metric W}.
-
- Definition prodM_map (f : T -n> U) (g : V -n> W) := Mprod (f <M< Mfst) (g <M< Msnd).
-
- Program Definition evalM : (T -n> U) * T -n> U :=
- n[(meval << mprod_map s[(met_morph (U := U))] (mid _))].
- Next Obligation.
- intros f g HEq; simpl; rewrite ->!HEq at 1; reflexivity.
- Qed.
-
-End Exponentials.
-
-Section ExponentialProps.
- Context `{mT : metric T} `{mU : metric U} `{mV : metric V}.
-
- Lemma curryMCom (f : T * U -n> V) : f == evalM <M< prodM_map (curryM f) (umid _).
- Proof. intros [a b]; reflexivity. Qed.
-
- Lemma curryM_unique (f : T * U -n> V) g (HEq : f == evalM <M< prodM_map g (umid _)) :
- g == curryM f.
- Proof. intros a b; simpl; rewrite HEq; reflexivity. Qed.
-
-End ExponentialProps.
-
-Lemma nonexp_cont2 `{cT : cmetric T} `{cU : cmetric U} `{cV : cmetric V} (f : T -n> U -n> V) (σ : chain T) (Ï : chain U) {σc : cchain σ} {Ïc : cchain Ï} :
- f (compl σ) (compl Ï) == compl (binaryLimit f σ Ï).
-Proof.
- assert (HT := nonexp_continuous (uncurry f) (chain_pair σ Ï) _).
- rewrite ->pair_limit in HT at 1; simpl in HT; rewrite HT; apply umet_complete_ext; intros i; clear HT.
- reflexivity.
-Qed.
-
-(** Discrete spaces are proper metric spaces (discrete meaning that the distance
- is 1 if elements are diffent and 0 for equal elements. Equality here is
- propositional Coq equality. *)
-Section DiscreteMetric.
- Context {T : Type} {T_type : Setoid T}.
-
- Definition discreteDist n (x y : T) :=
- match n with
- O => True
- | _ => x == y
- end.
- Global Arguments discreteDist n x y / .
-
- Program Instance discreteMetric : metric T := mkMetr discreteDist.
- Next Obligation.
- intros x y Heq x' y' Heq'. split; (destruct n as [|n]; [reflexivity|simpl]).
- - intros Heqx. rewrite <-Heq, <-Heq'. assumption.
- - intros Heqy. rewrite ->Heq, Heq'. assumption.
- Qed.
- Next Obligation.
- split; intros Heq.
- - now apply (Heq 1).
- - intros [|n]; tauto.
- Qed.
- Next Obligation.
- destruct n as [| n]; intros x y HS; simpl in *; [| symmetry]; tauto.
- Qed.
- Next Obligation.
- destruct n as [| n]; intros x y z Hxy Hyz; simpl in *; [| etransitivity]; eauto.
- Qed.
- Next Obligation.
- destruct n; tauto.
- Qed.
-
- Definition discreteCompl (σ : chain T) {σc : cchain σ} := σ 1.
-
- Program Instance discreteCMetric : cmetric T := mkCMetr discreteCompl.
- Next Obligation.
- intros n; simpl; intros [| i] HLe; [now inversion HLe |].
- destruct n as [| n]; [exact I |]. unfold discreteCompl.
- change (σ 1 = 1 = σ (S i)).
- eapply σc; omega.
- Qed.
-
- (** Every predicate is complete on the discrete metric space *)
- Global Instance discreteLP (P : T -> Prop): LimitPreserving P | 5. (* just to be safe, give this a low priority. *)
- Proof.
- repeat intro. simpl. unfold discreteCompl. by apply: H.
- Qed.
-
-End DiscreteMetric.
-
-Tactic Notation "cchain_eq" constr(σ) "at" constr(P1) constr(P2) "lvl:" constr(L) :=
- let le1 := fresh in
- let le2 := fresh in
- assert (le1: L <= P1) by omega; assert (le2: L <= P2) by omega;
- match goal with
- | [ σc: cchain σ |- _ ] => move/(_ _ _ _ le1 le2):(σc)
- end; clear le1 le2.
-
-Tactic Notation "cchain_eleq" constr(σ) "at" constr(P1) constr(P2) "lvl:" constr(L) :=
- let eq := fresh in
- cchain_eq σ at P1 P2 lvl:L =>eq;
- match goal with
- | [ H : _ = σ P1 |- _ ] => rewrite <-H in eq
- | [ H : σ P1 = _ |- _ ] => rewrite ->H in eq
- end;
- match goal with
- | [ H : _ = σ P2 |- _ ] => rewrite <-H in eq
- | [ H : σ P2 = _ |- _ ] => rewrite ->H in eq
- end;
- move:eq.
-
-Tactic Notation "cchain_discr" constr(σ) constr(P) "at" integer_list(pos) "as" simple_intropattern(pat) "deqn:" ident(EQ) :=
- (generalize (@eq_refl _ (σ P)) as EQ; pattern (σ P) at pos;
- destruct (σ P) as pat; move => EQ);
- last (exfalso; match goal with
- | [ H : _ = σ 1 |- _ ] => let EQ2 := fresh in
- cchain_eleq σ at 1 (P) lvl:1=>EQ2; eapply EQ2; omega
- end).
-
-Section Option.
- Context `{cT : cmetric T}.
-
- Program Definition unSome (σ : chain (option T)) {σc : cchain σ} (HNE : σ 1 <> None) : chain T :=
- fun i => match σ (S i) with
- | None => False_rect _ _
- | Some v => v
- end.
- Next Obligation.
- destruct (σ 1) as [v |] eqn:EQ; cchain_eleq σ at 1 (S i) lvl:1.
- - simpl. tauto.
- - move=>_. contradiction HNE; reflexivity.
- Qed.
-
- Instance unSome_c (σ : chain (option T)) {σc : cchain σ} HNE : cchain (unSome σ HNE).
- Proof.
- intros [| k] n m HLE1 HLE2; [apply dist_bound |]; unfold unSome.
- ddes (σ (S n)) at 1 3 as [v|] deqn:EQn.
- - ddes (σ (S m)) at 1 3 as [v'|] deqn:EQm.
- + specialize (σc (S k) (S n) (S m)); rewrite <- EQm, <- EQn in σc.
- apply σc; auto with arith.
- + exfalso; specialize (σc 1 1 (S m)); rewrite <- EQm in σc.
- destruct (σ 1) as [v' |]; [contradiction σc; auto with arith | contradiction HNE; reflexivity].
- - exfalso; specialize (σc 1 1 (S n)); rewrite <- EQn in σc.
- destruct (σ 1) as [v |]; [contradiction σc; auto with arith | contradiction HNE; reflexivity].
- Qed.
-
- Program Definition option_compl (σ : chain (option T)) {σc : cchain σ} :=
- match σ 1 with
- | None => None
- | Some v => Some (compl (unSome σ _))
- end.
-
- Global Program Instance option_cmt : cmetric (option T) := mkCMetr option_compl.
- Next Obligation.
- intros [| n]; [intros; apply dist_bound | unfold option_compl].
- generalize (@eq_refl _ (σ 1)) as EQ1; pattern (σ 1) at 1 3; destruct (σ 1) as [v |]; intros.
- - assert (HT := conv_cauchy (unSome σ (option_compl_obligation_1 _ _ _ EQ1)) (S n)).
- destruct (σ i) as [vi |] eqn: EQi; [unfold dist; simpl; rewrite ->(HT i) by eauto with arith | exfalso].
- + unfold unSome; generalize (@eq_refl _ (σ (S i))); pattern (σ (S i)) at 1 3.
- destruct (σ (S i)) as [vsi |]; intros EQsi; clear HT; [| exfalso].
- * assert (HT : S n <= i) by eauto with arith.
- specialize (σc (S n) (S i) i); rewrite ->EQi, <- EQsi in σc.
- apply σc; auto with arith.
- * specialize (σc 1 1 (S i)); rewrite <- EQ1, <- EQsi in σc.
- apply σc; auto with arith.
- + clear HT; specialize (σc 1 1 i); rewrite <- EQ1, EQi in σc.
- apply σc; auto with arith.
- rewrite <- HLe; auto with arith.
- - intros.
- destruct (σ i) as [vi |] eqn: EQi; [| reflexivity].
- specialize (σc 1 1 i); rewrite <- EQ1, EQi in σc.
- apply σc; omega.
- Qed.
-
-End Option.
-
-Section Lift.
- Context {T : Type}.
- Local Open Scope type.
- Context (f : T -> T -> T) `{cmT : cmetric T}
- {fequiv : Proper (equiv ==> equiv ==> equiv) f}
- {fdist : forall n, Proper (dist n ==> dist n ==> dist n) f}
- {U} `{cmU : cmetric U} (P : U -n> T) (Q : U -n> T).
-
- Local Obligation Tactic := intros; resp_set.
-
- Program Definition lift_bin : U -n> T :=
- n[(fun u => f (P u) (Q u))].
-
-End Lift.
-
diff --git a/lib/ModuRes/MetricRec.v b/lib/ModuRes/MetricRec.v
deleted file mode 100644
index 9023b272ed764fcd4837e7ecf83ee985af462482..0000000000000000000000000000000000000000
--- a/lib/ModuRes/MetricRec.v
+++ /dev/null
@@ -1,663 +0,0 @@
-Require Import MetricCore CatBasics.
-Require Import Arith Omega.
-
-(** A category enriched in complete bisected metric spaces and with a terminal object. *)
-
-Class BC_morph T := tmorph : T -> T -> cmtyp.
-Notation "u -t> v" := (tmorph u v) (at level 45, right associativity) : cat_scope.
-Delimit Scope cat_scope with cat.
-Open Scope cat_scope.
-Class BC_term T := tto : T.
-Class BC_terminal T {TA : BC_morph T} {TT : BC_term T} := tto_terminal t : t -t> tto.
-Class BC_comp T {TA : BC_morph T} :=
- tcomp t0 t1 t2 : (t1 -t> t2) -n> (t0 -t> t1) -n> (t0 -t> t2).
-Class BC_id T {TA : BC_morph T} := tid t : t -t> t.
-
-Arguments tcomp {T TA BC_comp t0 t1 t2}.
-
-Notation "f ∘ g" := (tcomp f g) (at level 40, left associativity) : cat_scope.
-Notation "1" := tto : cat_scope.
-Notation "! X" := (tto_terminal X) (at level 35) : cat_scope.
-
-Class BaseCat T {TA : BC_morph T} {TO : BC_term T} {TT : BC_terminal T} {TC : BC_comp T} {TI : BC_id T} :=
- { tcomp_assoc {t0 t1 t2 t3} (f : t2 -t> t3) (g : t1 -t> t2) (h : t0 -t> t1) :
- f ∘ (g ∘ h) == (f ∘ g) ∘ h;
- tid_left {t0 t1} (f : t0 -t> t1) : tid _ ∘ f == f;
- tid_right {t0 t1} (f : t0 -t> t1) : f ∘ tid _ == f;
- tto_term_unique : forall {t} (f g : t -t> 1), f == g}.
-
-Section Definitions.
- Context {M} `{BaseCat M}.
-
- (** A functor F : Cᵒᵖ × C → C. Since the categories are enriched in metric
- spaces, the functor is also required to be enriched, meaning that the morphism
- part is actually a morphism of metric spaces, in this case meaning that it is
- a non-expansive function. *)
- Class BiFMap (F : M -> M -> M) :=
- fmorph : forall {m0 m1 m2 m3}, (m1 -t> m0) * (m2 -t> m3) -n> (F m0 m2 -t> F m1 m3).
- Class BiFunctor F {FM : BiFMap F} := mkFunctor
- { fmorph_comp : forall m0 m1 m2 m3 m4 m5 (f : m4 -t> m1) (g : m3 -t> m5) (h : m1 -t> m0) (k : m2 -t> m3),
- fmorph (f, g) ∘ fmorph (h, k) == fmorph (h ∘ f, g ∘ k);
- fmorph_id : forall m0 m1, fmorph (tid m0, tid m1) == tid _}.
-
- Definition retract {m0 m1} (f : m0 -t> m1) (g : m1 -t> m0) := g ∘ f == tid _.
-
- (** A Cauchy tower. See paper on M-categories for precise definition. *)
- Record Tower := mkTower
- { tow_objs : nat -> M;
- tow_morphs : forall i, tow_objs (S i) -t> tow_objs i;
- tow_morphsI : forall i, tow_objs i -t> tow_objs (S i);
- tow_retract : forall i, retract (tow_morphsI i) (tow_morphs i);
- tow_limitD : forall n i, n <= i -> tow_morphsI i ∘ tow_morphs i = n = tid _}.
-
- (** A cone to a Cauchy tower. *)
- Record Cone (T : Tower) := mkBaseCone
- { cone_t :> M;
- cone_m : forall i, cone_t -t> (tow_objs T i);
- cone_m_com : forall i, tow_morphs T i ∘ cone_m (S i) == cone_m i}.
-
- (** A cocone to a Cauchy tower. *)
- Record CoCone (T : Tower) := mkBaseCoCone
- { cocone_t :> M;
- cocone_m : forall i, tow_objs T i -t> cocone_t;
- cocone_m_com : forall i, cocone_m (S i) ∘ tow_morphsI T i == cocone_m i}.
-
- (** Limit of a Cauchy tower, i.e. a terminal cone in the category of cones to the chosen tower. *)
- Record Limit (T : Tower) := mkBaseLimit
- { lim_cone :> Cone T;
- lim_exists : forall C : Cone T, cone_t _ C -t> lim_cone;
- lim_com : forall (C : Cone T) n, cone_m _ C n == cone_m _ lim_cone n ∘ lim_exists C;
- lim_unique : forall (C : Cone T) (h : cone_t _ C -t> lim_cone)
- (HEq : forall n, cone_m _ C n == cone_m _ lim_cone n ∘ h), h == lim_exists C}.
-
- (** A colimit of a Cauchy tower, i.e. an initial cocone in the category of cocones to the chosen tower. *)
- Record CoLimit (T : Tower) := mkBaseColimit
- { colim_cocone :> CoCone T;
- colim_exists : forall (C : CoCone T), cocone_t _ colim_cocone -t> C;
- colim_com : forall (C : CoCone T) n, cocone_m _ C n == colim_exists C ∘ cocone_m _ colim_cocone n;
- colim_unique : forall (C : CoCone T) (h : cocone_t _ colim_cocone -t> C)
- (HEq : forall n, cocone_m _ C n == h ∘ cocone_m _ colim_cocone n), h == colim_exists C}.
-
-End Definitions.
-
-Module Type MCat.
- Parameter M : Type.
- Parameter MArr : BC_morph M.
- Parameter MTermO : BC_term M.
- Parameter MTermA : BC_terminal M.
- Parameter MComp : BC_comp M.
- Parameter MId : BC_id M.
- Parameter Cat : BaseCat M.
-
- (** An M-category in addition to being enriched in cbult and having a terminal
- object also has to have limits of all Cauchy towers. Hence the additional
- assumption for the following section. *)
- Parameter AllLimits : forall T : Tower, Limit T.
-End MCat.
-
-Module Type InputType(Cat : MCat).
- Import Cat.
-
- (** We assume we have a bifunctor and a map from the terminal object into
- F(1, 1) (1 being the terminal object). This is used to start the
- construction of the Cauchy tower. *)
- Parameter F : M -> M -> M.
- Parameter FArr : BiFMap F.
- Parameter FFun : BiFunctor F.
- Parameter tmorph_ne : 1 -t> (F 1 1).
-
- (** In addition, we assume the given functor is locally contractive. *)
- Parameter F_contractive : forall {m0 m1 m2 m3 : M}, contractive (@fmorph _ _ F _ m0 m1 m2 m3).
-End InputType.
-
-Module Type SolutionType(Cat : MCat)(M_cat : InputType(Cat)).
- Import Cat.
- Import M_cat.
-
- (** The solution of the recursive domain equation. We are not
- interested in the exact definitions of any of the following,
- hence defining them as opaque. *)
- Axiom DInfO : M.
-
- Axiom Fold : F DInfO DInfO -t> DInfO.
- Axiom Unfold : DInfO -t> (F DInfO DInfO).
-
- Axiom FU_id : Fold ∘ Unfold == tid DInfO.
- Axiom UF_id : Unfold ∘ Fold == tid (F DInfO DInfO).
-
- (** If [ı : DInf → F(DInf, DInf)] is the above isomorphism then
- [Δ = e ↦ ı ; F(e, e) ; ıâ»Â¹]. This function is contractive.
- *)
- Parameter (Δ : (DInfO -t> DInfO) -n> (DInfO -t> DInfO)).
-
- Axiom Δ_contra : contractive Δ.
-End SolutionType.
-
-Module Solution(Cat : MCat)(M_cat : InputType(Cat)) : SolutionType(Cat)(M_cat).
- Import Cat.
- Import M_cat.
-
- Section RecursiveDomains.
- (** An image by a bifunctor of a retract pair is a retract pair, i.e. if f and g form a retract, meaning g ∘ f = id, then
- F(f, g), F(g, f) also forms a retract pair. *)
- Lemma BiFuncRtoR {m0 m1} (f : m0 -t> m1) (g : m1 -t> m0) (HR : retract f g) :
- retract (fmorph (g, f)) (fmorph (f, g)).
- Proof.
- unfold retract in *; rewrite fmorph_comp, HR; apply fmorph_id.
- Qed.
-
- (** Iteration of a bifunctor starting from the terminal object.
- F_0 = 1, F_{n+1} = F(F_n, F_n). This is used to construct the limiting cone. *)
- Fixpoint Diter n :=
- match n with
- | O => 1
- | S n => F (Diter n) (Diter n)
- end.
-
- (** Defining the injection projection pairs between F_n and F_{n+1} defined above.
- f_0 = tmorph_ne, g_0 = unique map into 1, f_{n+1} = F(g_n, f_n) and g_{n+1} = F(f_n, g_n). *)
- Fixpoint Injection n : Diter n -t> Diter (S n) :=
- match n with
- | O => tmorph_ne
- | S n => fmorph (Projection n, Injection n)
- end
- with Projection n : Diter (S n) -t> Diter n :=
- match n with
- | O => ! _
- | S n => fmorph (Injection n, Projection n)
- end.
-
- (** All of the above defined at each stage define a retract pair. *)
- Lemma retract_IP : forall n, retract (Injection n) (Projection n).
- Proof.
- induction n; [apply tto_term_unique |].
- unfold retract in *; simpl; rewrite fmorph_comp, IHn; apply fmorph_id.
- Qed.
-
- (** Composing in the other direction, i.e. f_n ∘ g_n gives a decreasing
- sequence. This shows that for the maps defined above (f_n-s and g_n-s) the composition
- f_n ∘ g_n forms a non-increasing sequence. *)
- Lemma IP_nonexp i j n (Hij : i <= j) (HReti : (Injection i ∘ Projection i) = n = tid _) :
- Injection j ∘ Projection j = n = tid _.
- Proof.
- induction Hij; [assumption | simpl].
- rewrite fmorph_comp, IHHij, fmorph_id; reflexivity.
- Qed.
-
- (** Using that additional assumption, we can show that the
- projection/injection pairs defined above form a Cauchy tower. *)
- Program Definition DTower : Tower := mkTower Diter Projection Injection _ _.
- Next Obligation. apply retract_IP. Qed.
- Next Obligation.
- revert i H; induction n; intros; [apply dist_bound |].
- destruct i; [inversion H | apply Le.le_S_n, IHn in H; clear IHn].
- simpl; rewrite fmorph_comp, <- fmorph_id; apply F_contractive.
- split; assumption.
- Qed.
-
- (** Now we use the assumption that the category in question has limits of
- all Cauchy towers, to get the proposed solution to our fixed point equation, DInf. *)
- Definition DInf := AllLimits DTower.
-
- (** Construction of various cones and cocones. The exact Cauchy tower is irrelevant, so it is a parameter. Later, DTower in the section will be instantiated by the above defined DTower. *)
- Section Tower.
- Variable DTower : Tower.
-
- (** This is just extending the projections and injections that work for
- one step, i.e. from n to n+1 or vice versa to more more steps. *)
- Fixpoint Projection_nm m n : tow_objs DTower (n + m) -t> tow_objs DTower m :=
- match n with
- | O => tid _
- | S n => Projection_nm m n ∘ tow_morphs DTower _
- end.
-
- Fixpoint Injection_nm m n : tow_objs DTower m -t> tow_objs DTower (n + m) :=
- match n with
- | O => tid _
- | S n => tow_morphsI DTower _ ∘ Injection_nm m n
- end.
-
- Definition DIter_coerce {n m} (EQ : n = m) : tow_objs DTower n -t> tow_objs DTower m.
- Proof. rewrite EQ; apply tid. Defined.
-
- Lemma lt_plus_minus {n m} (HLt : n < m) : m = m - n + n.
- Proof. omega. Qed.
-
- (** Using projections and injections we can go from object at n to object at m for any n, m. *)
- Definition t_nm n m : tow_objs DTower n -t> tow_objs DTower m :=
- match lt_eq_lt_dec n m with
- | inleft (left ee) => DIter_coerce (eq_sym (lt_plus_minus ee)) ∘ Injection_nm n (m - n)
- | inleft (right ee) => DIter_coerce ee
- | inright ee => Projection_nm m (n - m) ∘ DIter_coerce (lt_plus_minus ee)
- end.
-
- (** Coercions do not depend on the proofs of equality. *)
- Lemma DIter_coerce_simpl : forall n (Eq : n = n), DIter_coerce Eq = tid _.
- Proof.
- intros n EQ; unfold DIter_coerce, eq_rect_r; rewrite <- D.eq_rect_eq; auto.
- Qed.
-
- (** And is transitive. *)
- Lemma DIter_coerce_comp x y z (Eq1 : x = y) (Eq2 : y = z) :
- DIter_coerce Eq2 ∘ DIter_coerce Eq1 == DIter_coerce (trans_equal Eq1 Eq2).
- Proof.
- generalize Eq1; rewrite Eq1; clear x Eq1; intros Eq1.
- generalize Eq2; rewrite <- Eq2; clear z Eq2; intros Eq2.
- rewrite !DIter_coerce_simpl; apply tid_right.
- Qed.
-
- (** If n = m then the m'th component of the Cauchy tower is the same as if
- we compose the n'th with coercions. This really says that coercions are
- identities and that they are only needed to satisy the
- typechecker. Semantically, they are identites. *)
- Lemma tow_morphs_coerce m n (HEq : n = m) : tow_morphs DTower m ==
- DIter_coerce HEq ∘ tow_morphs DTower n ∘ DIter_coerce (eq_sym (eq_S _ _ HEq)).
- Proof. subst; rewrite !DIter_coerce_simpl, tid_right, tid_left; reflexivity. Qed.
-
- Lemma tow_morphsI_coerce m n (HEq : n = m) : tow_morphsI DTower m ==
- DIter_coerce (eq_S _ _ HEq) ∘ tow_morphsI DTower n ∘ DIter_coerce (eq_sym HEq).
- Proof. subst; rewrite !DIter_coerce_simpl, tid_left, tid_right; reflexivity. Qed.
-
- (** Projection (g) from m + (S k) to m is the same as the projection from
- S m + k to S k followed by another g, the element of Cauchy tower. Coerce
- is there to make the types work. *)
- Lemma Proj_left_comp : forall k m, Projection_nm m (S k) ==
- tow_morphs DTower m ∘ Projection_nm (S m) k ∘ DIter_coerce (plus_n_Sm _ _).
- Proof.
- induction k; intros; simpl in *.
- + rewrite DIter_coerce_simpl, tid_left, !tid_right; reflexivity.
- + rewrite IHk at 1. rewrite <- 4!tcomp_assoc. clear IHk.
- do 2 (apply equiv_morph; [reflexivity |]).
- rewrite (tow_morphs_coerce _ _ (plus_n_Sm _ _)).
- rewrite <- tcomp_assoc, DIter_coerce_comp.
- rewrite DIter_coerce_simpl, tid_right; reflexivity.
- Qed.
-
- (** The same as previous one, but for injections (i.e. f's). *)
- Lemma Inj_right_comp : forall k m, Injection_nm m (S k) ==
- DIter_coerce (sym_eq (plus_n_Sm k m)) ∘ Injection_nm (S m) k ∘ tow_morphsI DTower m.
- Proof.
- induction k; intros; simpl in *.
- + rewrite DIter_coerce_simpl, !tid_right, tid_left; reflexivity.
- + rewrite (IHk m), 2!tcomp_assoc; clear IHk.
- rewrite (tow_morphsI_coerce _ _ (plus_n_Sm _ _)).
- rewrite 3!tcomp_assoc, DIter_coerce_comp.
- rewrite DIter_coerce_simpl, tid_left; reflexivity.
- Qed.
-
- Lemma Injection_nm_coerce : forall m k n (HEq : k + n = m + n),
- Injection_nm n m == DIter_coerce HEq ∘ Injection_nm n k.
- Proof.
- induction m; intros.
- + destruct k; [| contradict HEq; omega]; simpl in *.
- rewrite DIter_coerce_simpl, tid_left; reflexivity.
- + destruct k; [contradict HEq; omega |].
- assert (HT : k + n = m + n) by omega.
- simpl; rewrite (IHm _ _ HT) at 1; clear IHm.
- rewrite 2!tcomp_assoc. apply equiv_morph; [| reflexivity].
- simpl in HEq; generalize HT HEq; rewrite HT; clear HEq HT; intros HEq HT.
- rewrite !DIter_coerce_simpl, tid_left, tid_right; reflexivity.
- Qed.
-
- Lemma Projection_nm_coerce : forall m k n (HEq : m + n = k + n),
- Projection_nm n m == Projection_nm n k ∘ DIter_coerce HEq.
- Proof.
- induction m; intros.
- + destruct k; [| contradict HEq; omega]; simpl in *.
- rewrite DIter_coerce_simpl, tid_left; reflexivity.
- + destruct k; [contradict HEq; omega |].
- assert (HT : m + n = k + n) by omega.
- simpl; rewrite (IHm _ _ HT) at 1; clear IHm.
- rewrite <- 2!tcomp_assoc. apply equiv_morph; [reflexivity |].
- simpl in HEq; generalize HT HEq; rewrite HT; clear HEq HT; intros HEq HT.
- rewrite !DIter_coerce_simpl, tid_left, tid_right; reflexivity.
- Qed.
-
- (** This lemma states that for each n, the morphisms t_nm n form a cone
- from F_n to {F_i}_'s together with g's. *)
- Lemma t_nmProjection n m : t_nm n m == tow_morphs DTower m ∘ t_nm n (S m).
- Proof.
- unfold t_nm; destruct (lt_eq_lt_dec n m) as [ [HLt | HEq] | HGt].
- + destruct (lt_eq_lt_dec n (S m)) as [ [HLtS | HC ] | HC]; try (contradict HC; omega).
- assert (HEq' : S (m - n) + n = S m - n + n) by omega.
- rewrite (Injection_nm_coerce _ _ _ HEq').
- simpl; rewrite 3!tcomp_assoc.
- apply equiv_morph; [| reflexivity].
- rewrite (tow_morphs_coerce _ _ (eq_sym (lt_plus_minus HLt))).
- do 2 rewrite <- tcomp_assoc with (f := DIter_coerce _ ∘ tow_morphs _ _).
- rewrite 2!DIter_coerce_comp.
- rewrite DIter_coerce_simpl, tid_right, <- tcomp_assoc, @tow_retract, tid_right; reflexivity.
- + destruct (lt_eq_lt_dec n (S m)) as [[HLtS | HC ] | HC]; try (contradict HC; omega).
- subst; assert (HEq : 1 + m = S m - m + m) by omega.
- rewrite (Injection_nm_coerce _ _ _ HEq); simpl.
- rewrite tid_right, (tcomp_assoc (DIter_coerce _)), DIter_coerce_comp.
- rewrite !DIter_coerce_simpl, tid_left, @tow_retract; reflexivity.
- + destruct (lt_eq_lt_dec n (S m)) as [[HC | HEq ] | HGtS]; try (contradict HC; omega).
- * subst; rewrite DIter_coerce_simpl, tid_right.
- assert (HEq : S m - m + m = 1 + m) by omega.
- rewrite (Projection_nm_coerce _ _ _ HEq); simpl.
- rewrite tid_left, <- tcomp_assoc, DIter_coerce_comp.
- rewrite DIter_coerce_simpl, tid_right; reflexivity.
- * assert (HEq : n - m + m = S (n - S m) + m) by omega.
- rewrite (Projection_nm_coerce _ _ _ HEq), Proj_left_comp, <- 4!tcomp_assoc.
- do 2 (apply equiv_morph; [reflexivity |]).
- rewrite 2!DIter_coerce_comp; remember (lt_plus_minus HGtS) as xx.
- rewrite (D.UIP _ _ _ xx); reflexivity.
- Qed.
-
- Lemma t_nn_ID: forall n, t_nm n n == tid _.
- Proof.
- intros n; unfold t_nm; destruct (lt_eq_lt_dec n n) as [[HC | HEq] | HC];
- (contradict HC; omega) || rewrite DIter_coerce_simpl; reflexivity.
- Qed.
-
- Lemma t_nmProjection2 n m (HLe : m <= n) : t_nm (S n) m == t_nm n m ∘ tow_morphs DTower n.
- Proof.
- remember (n - m) as k; revert n m HLe Heqk; induction k; intros.
- + assert (n = m) by omega; subst; simpl.
- rewrite t_nmProjection, !t_nn_ID, tid_left, tid_right; reflexivity.
- + destruct n; [discriminate |].
- rewrite (t_nmProjection (S (S n)) m), IHk, (t_nmProjection (S n) m); try omega.
- rewrite tcomp_assoc; reflexivity.
- Qed.
-
- (** This shows that for each m, λ k. t_nm k m form a cocone from F_i's with f's to F_m. *)
- Lemma t_nmEmbedding n m : t_nm n m == t_nm (S n) m ∘ tow_morphsI DTower n.
- Proof.
- unfold t_nm; destruct (lt_eq_lt_dec n m) as [[HLt | HEq] | HGt].
- + destruct (lt_eq_lt_dec (S n) m) as [[HLtS | HEq] | HC]; try (contradict HC; omega).
- * assert (HEq : S (m - S n) + n = m - n + n) by omega.
- rewrite (Injection_nm_coerce _ _ _ HEq), Inj_right_comp, 3!tcomp_assoc.
- do 2 rewrite <- tcomp_assoc with (g := (Injection_nm _ _)) (h := (tow_morphsI _ _)).
- apply equiv_morph; [| reflexivity].
- rewrite 2!DIter_coerce_comp; remember (Logic.eq_sym (lt_plus_minus HLtS)) as xx.
- rewrite (D.UIP _ _ _ xx); reflexivity.
- * subst; assert (HEq : 1 + n = S n - n + n) by omega.
- rewrite (Injection_nm_coerce _ _ _ HEq); simpl.
- rewrite tid_right, tcomp_assoc; apply equiv_morph; [| reflexivity].
- rewrite DIter_coerce_comp, !DIter_coerce_simpl; reflexivity.
- + destruct (lt_eq_lt_dec (S n) m) as [[HC | HC] | HGtS]; try (contradict HC; omega).
- subst; rewrite DIter_coerce_simpl; assert (HEq : S m - m + m = 1 + m) by omega.
- rewrite (Projection_nm_coerce _ _ _ HEq); simpl.
- rewrite tid_left, <- (tcomp_assoc (tow_morphs _ _)), DIter_coerce_comp.
- rewrite DIter_coerce_simpl, tid_right, @tow_retract; reflexivity.
- + destruct (lt_eq_lt_dec (S n) m) as [[HC | HC] | HGtS]; try (contradict HC; omega).
- assert (HEq : S n - m + m = S (n - m) + m) by omega.
- rewrite (Projection_nm_coerce _ _ _ HEq), <- (tcomp_assoc (Projection_nm _ _)),
- DIter_coerce_comp; simpl.
- rewrite <- 2!tcomp_assoc; apply equiv_morph; [reflexivity |].
- rewrite (tow_morphs_coerce _ _ (lt_plus_minus HGt)), <- 2!tcomp_assoc.
- rewrite (tcomp_assoc _ _ (tow_morphsI _ _)), DIter_coerce_comp.
- rewrite DIter_coerce_simpl, tid_left, tow_retract, tid_right; reflexivity.
- Qed.
-
- Lemma t_nmEmbedding2 n m (HLe : n <= m) : t_nm n (S m) == tow_morphsI DTower m ∘ t_nm n m.
- Proof.
- remember (m - n) as k; revert n m HLe Heqk; induction k; intros.
- + assert (m = n) by omega; subst; rewrite t_nmEmbedding, !t_nn_ID, tid_right, tid_left; reflexivity.
- + destruct m; [discriminate |].
- rewrite (t_nmEmbedding n (S (S m))), IHk, (t_nmEmbedding n (S m)); try omega.
- rewrite tcomp_assoc; reflexivity.
- Qed.
-
- (** [coneN n] is a cone from F_n to the diagram {Fáµ¢}áµ¢ with g's (projections). *)
- Program Definition coneN n : Cone DTower := mkBaseCone _ (tow_objs DTower n) (t_nm n) _.
- Next Obligation. symmetry; apply t_nmProjection. Qed.
-
- Lemma coneCom_l (C : Cone DTower) n i (HLe : i <= n) : cone_m _ C i == t_nm n i ∘ cone_m _ C n.
- Proof.
- remember (n - i) as m; revert n i HLe Heqm; induction m; intros.
- + assert (n = i) by omega; subst; rewrite t_nn_ID, tid_left; reflexivity.
- + destruct n; [discriminate |]; rewrite t_nmProjection, <- tcomp_assoc, <- IHm; try omega.
- symmetry; apply cone_m_com.
- Qed.
-
- Lemma coconeCom_l (C : CoCone DTower) n i (HLe : n <= i) : cocone_m _ C n == cocone_m _ C i ∘ t_nm n i.
- Proof.
- remember (i - n) as m; revert n i HLe Heqm; induction m; intros.
- + assert (n = i) by omega; subst; rewrite t_nn_ID, tid_right; reflexivity.
- + destruct i; [discriminate |]; rewrite t_nmEmbedding, tcomp_assoc, <- IHm; try omega.
- symmetry; apply cocone_m_com.
- Qed.
-
- Lemma cone_coconeP (C : Cone DTower) (CC : CoCone DTower) n k (HLe : n <= k) :
- cocone_m _ CC n ∘ cone_m _ C n = n = cocone_m _ CC k ∘ cone_m _ C k.
- Proof.
- induction k; intros; inversion HLe; subst; [reflexivity | reflexivity |]; clear HLe.
- rewrite IHk; [| assumption]; clear IHk.
- rewrite <- cone_m_com, <- cocone_m_com, tcomp_assoc, <- (tcomp_assoc (cocone_m _ _ _)).
- rewrite tow_limitD, tid_right; [reflexivity | assumption].
- Qed.
-
- Arguments cone_t [_ _ _ _ _] _.
- Arguments lim_cone [_ _ _ _ _] _.
- Arguments cocone_t [_ _ _ _ _] _.
- Arguments colim_cocone [_ _ _ _ _] _.
- (** Given a Cauchy tower and a cone C ad a cocone CC to it we get a Cauchy chain of morphisms
- from C to CC. This is used later to show the constructed limit is the solution. *)
- Definition chainPE (C : Cone DTower) (CC : CoCone DTower) : chain (cone_t C -t> cocone_t CC) :=
- fun n => cocone_m _ CC n ∘ cone_m _ C n.
- Lemma chainPE_cauchy (C : Cone DTower) (CC : CoCone DTower) : cchain (chainPE C CC).
- Proof.
- unfold cchain; intros.
- etransitivity; [| apply cone_coconeP; assumption].
- symmetry; apply cone_coconeP; assumption.
- Qed.
-
- End Tower.
-
- (** NOTE: DTower here is again the one defined by the iteration of a
- functor. In the section above it was a parameter with the same name. *)
-
- Definition α {T} := fun x => cone_t T (lim_cone _ x).
- Definition β {T} := fun x => cocone_t T (colim_cocone _ x).
- (** [coneN DTower n] defined above defines a cone from F_n to the tower (with projections).
- Since DInf is defined as a limit, we get a morphism into it from F_n *)
- Definition Embeddings n : (tow_objs DTower n) -t> (α DInf) := lim_exists _ DInf (coneN DTower n).
-
- (** Projections from the proposed solution to F_n's. Since DInf is defined
- as the limit of DTower, this is just one of the accompanying projections. *)
- Definition Projections n : α DInf -t> tow_objs DTower n := cone_m _ DInf n.
-
- Lemma coCom i : Embeddings (S i) ∘ Injection i == Embeddings i.
- Proof.
- unfold Embeddings; apply (lim_unique DTower (AllLimits DTower) (coneN DTower i)).
- intro n; simpl; rewrite tcomp_assoc, <- (lim_com _ (AllLimits DTower) (coneN DTower (S i))).
- simpl; rewrite t_nmEmbedding; reflexivity.
- Qed.
-
- (** The above defined embeddings also form a cocone to DInf *)
- Definition DCoCone : CoCone DTower := mkBaseCoCone _ (cone_t _ (AllLimits DTower)) Embeddings coCom.
-
- (** Embedding followed by a projection is always identity. This follows from
- the fact that we started with retractions in the Cauchy tower. *)
- Lemma retract_EP n : retract (Embeddings n) (Projections n).
- Proof.
- unfold retract, Projections, Embeddings.
- rewrite <- (lim_com _ (AllLimits DTower) (coneN DTower n) n); simpl; rewrite t_nn_ID; reflexivity.
- Qed.
-
- Lemma emp i j : Projections i ∘ Embeddings j == t_nm DTower j i.
- Proof.
- destruct (le_lt_dec i j) as [HLe | HLt].
- + unfold Projections; rewrite coneCom_l; [| eassumption].
- rewrite <- tcomp_assoc, retract_EP, tid_right; reflexivity.
- + assert (HT := coconeCom_l _ DCoCone); simpl in HT; rewrite (HT _ i); clear HT; [| omega].
- rewrite tcomp_assoc, retract_EP, tid_left; reflexivity.
- Qed.
-
- (** Given a cocone we get a Cauchy sequence of morphism from DInf to C. When
- instantiated with the cocone of embeddings (defined above) its limit will be
- the identity. *)
- Local Instance chainPEc (C : CoCone DTower) : cchain (chainPE _ (AllLimits DTower) C) := chainPE_cauchy _ _ _.
-
- Lemma EP_id : compl (chainPE _ (AllLimits DTower) DCoCone) == tid _.
- Proof.
- assert (Z : forall n, cone_m _ (AllLimits DTower) n == cone_m _ (AllLimits DTower) n ∘ tid _)
- by (intros; rewrite tid_right; reflexivity); apply lim_unique in Z; rewrite Z; clear Z.
- apply (lim_unique _ (AllLimits DTower) (AllLimits DTower)); intros n.
- rewrite nonexp_continuous, (cut_complete_eq _ n); simpl.
- etransitivity; [symmetry; apply umet_complete_const |]; apply umet_complete_ext; intros i.
- apply dist_refl; simpl; change (cone_m DTower (AllLimits DTower) n == cone_m DTower (AllLimits DTower) n ∘
- (Embeddings (n + i) ∘ cone_m DTower (AllLimits DTower) (n + i))); rewrite tcomp_assoc.
- rewrite emp, coneCom_l; [reflexivity | omega].
- Qed.
-
- (** Showing that DInf is also a colimit. The unique morphism from it to other cocones is given by limits
- of chainPEc's defined above. *)
- Program Definition DCoLimit : CoLimit DTower := mkBaseColimit _ DCoCone (fun C => compl (chainPE _ (AllLimits DTower) C)) _ _.
- Next Obligation.
- rewrite (cut_complete_eq _ n), <- dist_refl; intros m.
- assert (Hk:=conv_cauchy (cutn (chainPE _ (AllLimits DTower) C) n) m).
- specialize (Hk _ (le_n _)).
- assert (HT : forall m, Proper (dist m ==> dist m) (fun x : α DInf -t> cocone_t _ C => x ∘ Embeddings n))
- by (intros t e e' R; rewrite R; reflexivity).
- apply HT in Hk; clear HT. rewrite Hk; simpl morph.
- unfold cutn, chainPE.
- rewrite <- tcomp_assoc, emp.
- clear Hk. apply dist_refl. rewrite coconeCom_l; [reflexivity | omega].
- Qed.
- Next Obligation.
- rewrite <- (tid_right h), <- EP_id, nonexp_continuous; apply umet_complete_ext; intros i; simpl.
- apply dist_refl; unfold liftc, chainPE. rewrite tcomp_assoc, <- HEq; reflexivity.
- Qed.
-
- (** To show that DInf is a fixed point we define a cone and acocone to
- F(DInf, DInf) to later show that they are limits, therefore isomorphic to DInf. *)
- Program Definition ECoCone : CoCone DTower :=
- mkBaseCoCone _ (F (α DInf) (α DInf)) (fun i => fmorph (Projections i, Embeddings i) ∘ Injection i) _.
- Next Obligation.
- rewrite fmorph_comp, (cone_m_com _ (AllLimits DTower) i), (cocone_m_com _ DCoCone i); reflexivity.
- Qed.
-
- Program Definition FCone : Cone DTower :=
- mkBaseCone _ (F (α DInf) (α DInf)) (fun n => Projection n ∘ fmorph (Embeddings n, Projections n)) _.
- Next Obligation.
- apply equiv_morph; [reflexivity |].
- rewrite fmorph_comp, coCom, (cone_m_com _ (AllLimits DTower) i); reflexivity.
- Qed.
-
- (** Similar to chainPE, but this time a Cauchy chain from F(DInf, DInf). *)
- Local Instance chainFPE_c (C : CoCone DTower) : cchain (chainPE _ FCone C) := chainPE_cauchy _ _ _.
-
- (** F maps t_nm to t_(S n)(S m). Direct consequence of the way DTower is defined. *)
- Lemma morph_tnm n m : fmorph (t_nm DTower m n, t_nm DTower n m) == t_nm DTower (S n) (S m).
- Proof.
- destruct (le_lt_dec n m) as [HLe | HLt].
- + remember (m - n) as k; revert n m HLe Heqk; induction k; intros.
- * assert (m = n) by omega; subst; rewrite !t_nn_ID, fmorph_id; reflexivity.
- * destruct m; [discriminate |].
- rewrite t_nmProjection2, t_nmEmbedding2, <- fmorph_comp, IHk; try omega.
- rewrite (t_nmEmbedding2 _ _ (S m)); simpl; [reflexivity | omega].
- + assert (HLe : m <= n) by omega; clear HLt.
- remember (n - m) as k; revert n m HLe Heqk; induction k; intros.
- * assert (m = n) by omega; subst; rewrite !t_nn_ID, fmorph_id; reflexivity.
- * destruct n; [discriminate |].
- rewrite t_nmProjection2, t_nmEmbedding2, <- fmorph_comp, IHk; try omega.
- rewrite (t_nmProjection2 _ (S n)); [reflexivity | omega].
- Qed.
-
- (** The next two lemmas show that F(DInf, DInf) is in fact a colimit of the same diagram as DInf. *)
- Lemma EColCom (C : CoCone DTower) n :
- cocone_m _ C n == compl (chainPE _ FCone C) ∘ cocone_m _ ECoCone n.
- Proof.
- simpl morph; rewrite (cut_complete_eq _ n), <- dist_refl; intros m.
- assert (Hk:=conv_cauchy (cutn (chainPE _ FCone C) n) m).
- rewrite Hk by reflexivity. simpl morph; clear Hk. apply dist_refl.
- unfold chainPE, cutn; rewrite <- tcomp_assoc, coconeCom_l; [apply equiv_morph; [reflexivity |] | omega].
- rewrite t_nmProjection, t_nmEmbedding, <- morph_tnm; simpl.
- rewrite <- tcomp_assoc; apply equiv_morph; [reflexivity |].
- rewrite tcomp_assoc, fmorph_comp, 2!emp; reflexivity.
- Qed.
-
- Lemma CoLimitUnique (C : CoCone DTower) (h : cocone_t _ ECoCone -t> cocone_t _ C)
- (HEq : forall n, cocone_m _ C n == h ∘ cocone_m _ ECoCone n) :
- h == compl (chainPE _ FCone C).
- Proof.
- transitivity (h ∘ fmorph (compl (chainPE _ (AllLimits DTower) DCoCone), compl (chainPE _ (AllLimits DTower) DCoCone)));
- [rewrite !EP_id, fmorph_id, tid_right; reflexivity |].
- rewrite <- pair_limit, (nonexp_continuous fmorph).
- rewrite nonexp_continuous, (cut_complete_eq (chainPE _ FCone C) 1). apply umet_complete_ext; intros i.
- apply dist_refl; unfold liftc, chain_pair, chainPE, cutn; simpl.
- rewrite fmorph_comp, coCom, (cone_m_com _ (AllLimits DTower) i); simpl in *.
- specialize (HEq (S i)); simpl in HEq; rewrite fmorph_comp, coCom, (cone_m_com _ (AllLimits DTower) i) in HEq.
- rewrite HEq, <- tcomp_assoc, fmorph_comp; reflexivity.
- Qed.
-
- Definition ECoLimit := mkBaseColimit _ ECoCone (fun C => compl (chainPE _ FCone C)) EColCom CoLimitUnique.
-
- Definition DInfO : M := α DInf.
-
- (** Since DInf and F(DInf, DInf) are colimits of the same cocone, we have functions back and forth.
- The next two lemmas then state that they are inverses of each other. This is a general categorical fact. *)
- Definition Fold : F (α DInf) (α DInf) -t> α DInf := colim_exists _ ECoLimit DCoCone.
- Definition Unfold : α DInf -t> F (α DInf) (α DInf) := colim_exists _ DCoLimit ECoCone.
-
- Lemma FU_id : Fold ∘ Unfold == tid _.
- Proof.
- transitivity (colim_exists _ DCoLimit DCoLimit).
- + apply (colim_unique _ DCoLimit DCoCone); intros n; unfold Fold, Unfold; simpl.
- rewrite (nonexp_cont2 _ _ _).
- rewrite (umet_complete_ext _ (chainPE _ (AllLimits DTower) DCoCone)), EP_id, tid_left; [reflexivity | intros i; simpl].
- apply dist_refl; unfold binaryLimit, chainPE; simpl.
- rewrite 3!tcomp_assoc, <- (tcomp_assoc (Embeddings i ∘ Projection i)).
- simpl; rewrite fmorph_comp.
- rewrite !retract_EP, fmorph_id, tid_right, <- (tcomp_assoc (Embeddings i)).
- rewrite retract_IP, tid_right; reflexivity.
- + symmetry; apply (colim_unique _ DCoLimit DCoLimit); intros n; rewrite tid_left; reflexivity.
- Qed.
-
- Local Instance cced : cchain (chainPE _ FCone DCoCone).
- Proof.
- unfold cchain, chainPE; intros.
- etransitivity; [symmetry; apply (cone_coconeP _ FCone DCoCone); assumption
- | apply (cone_coconeP _ FCone DCoCone); assumption ].
- Qed.
-
- Lemma UF_id : Unfold ∘ Fold == tid _.
- transitivity (colim_exists _ ECoLimit ECoLimit).
- + apply (colim_unique _ ECoLimit ECoLimit); intros n; unfold Fold, Unfold; simpl.
- rewrite (nonexp_cont2 _ _ _).
- etransitivity; [symmetry; apply tid_left |].
- apply (morph_resp tcomp); unfold equiv; symmetry.
- rewrite <- fmorph_id, <- !EP_id, <- pair_limit, nonexp_continuous.
- rewrite (cut_complete_eq _ 1); apply umet_complete_ext; intros i; simpl.
- apply dist_refl; unfold chainPE, liftc, cutn, chain_pair, binaryLimit; simpl.
- replace (cone_m _ (AllLimits DTower) (S i)) with (Projections (S i)) by reflexivity.
- replace (cone_m _ (AllLimits DTower) i) with (Projections i) by reflexivity.
- rewrite !fmorph_comp, !coCom. rewrite !(cone_m_com _ (AllLimits DTower) i).
- rewrite <- tcomp_assoc, (tcomp_assoc (Projections (S i))).
- rewrite (retract_EP (S i)), tid_left, fmorph_comp; reflexivity.
- + symmetry; apply (colim_unique _ ECoLimit ECoLimit); intros n; rewrite tid_left; reflexivity.
- Qed.
-
- Local Obligation Tactic := intros; resp_set.
-
- (** If i : DInf → F(DInf, DInf) is the above isomorphism then Δ = e ↦ i ; F(e, e) ; iâ»Â¹.
- This function is contractive. This is called â–· in ð“¢ example or the iCAP model, but that's not a valid token in Coq. *)
- Program Definition Δ : (α DInf -t> α DInf) -n> (α DInf -t> α DInf) :=
- n[(fun e => Fold ∘ fmorph (e, e) ∘ Unfold)].
-
- Instance Δ_contra : contractive Δ.
- Proof.
- intros n f g HEq; simpl; rewrite F_contractive; [reflexivity |].
- rewrite HEq; reflexivity.
- Qed.
-
- (** The fixed point of Δ starting from identity is an identity. This is "minimal invariance" like statement. *)
- Lemma id_min : fixp Δ (tid _) == tid _.
- Proof.
- rewrite <- dist_refl; induction n; [apply dist_bound |].
- rewrite fixp_eq.
- (* Contractiveness does not expose its "Proper" bit, so can't rewrite directly. *)
- etransitivity; [apply Δ_contra, IHn |]; clear IHn.
- generalize (S n) as k; clear n; rewrite dist_refl.
- simpl; rewrite fmorph_id, tid_right.
- apply FU_id.
- Qed.
-
- End RecursiveDomains.
-
-End Solution.
-
-(* TODO, uniqueness of the solution. I.e., showing that it's a bifree algebra. *)
diff --git a/lib/ModuRes/PCBUltInst.v b/lib/ModuRes/PCBUltInst.v
deleted file mode 100644
index 61b27495097506114735e632f36bc5835f7ea801..0000000000000000000000000000000000000000
--- a/lib/ModuRes/PCBUltInst.v
+++ /dev/null
@@ -1,63 +0,0 @@
-(** This module provides the proof that PCBUlt, the category of
- pre-ordered, complete, bisected ultrametric spaces, forms an
- M-category. *)
-
-Require Import PreoMet.
-Require Import CatBasics MetricRec.
-
-Module PCBUlt <: MCat.
- Local Obligation Tactic := intros; resp_set || mono_resp || eauto with typeclass_instances.
-
- Definition M := pcmtyp.
- Instance MArr : BC_morph M := fun U V => pcmFromType (U -m> V).
- Program Instance MComp : BC_comp M := fun U V W => lift2m (lift2s pcomp _ _) _ _.
- Instance MId : BC_id M := fun T => pid T.
- Local Instance unit_preo : preoType unit := disc_preo unit.
- Local Instance unit_pcm : pcmType unit := disc_pcm unit.
- Instance MTermO : BC_term M := pcmFromType unit.
- Program Instance MTermA : BC_terminal M := fun U => m[(const tt)].
-
- Instance Cat : BaseCat M.
- Proof.
- split; intros; intros n; simpl; reflexivity || exact I. exact tt.
- Qed.
-
- Section Limits.
- Context (T : Tower).
-
- Definition guard := fun (σ : forall i, tow_objs T i) => forall n, tow_morphs T n (σ (S n)) == σ n.
- Instance lpg : LimitPreserving guard.
- Proof.
- intros σ σc HG n.
- rewrite !dep_chain_compl.
- rewrite nonexp_continuous; apply umet_complete_ext; intros k.
- simpl; apply dist_refl, HG.
- Qed.
-
- Program Definition lim_obj : pcmtyp := pcmFromType {σ : forall i, tow_objs T i | guard σ}.
-
- Definition lim_proj i : lim_obj -m> tow_objs T i := (pcmProjI i ∘ muincl)%pm.
-
- Program Definition lim_cone : Cone T := mkBaseCone T lim_obj lim_proj _.
- Next Obligation.
- intros [σ HG]; simpl; apply HG.
- Qed.
-
- Program Definition lim_map (C : Cone T) : (cone_t T C : pcmtyp) -m> (cone_t T lim_cone : pcmtyp) :=
- m[(fun m => exist _ (fun i => cone_m T C i m) _)].
- Next Obligation.
- intros n; simpl.
- assert (HT := cone_m_com T C n m); apply HT.
- Qed.
-
- Lemma AllLimits : Limit T.
- Proof.
- refine (mkBaseLimit T lim_cone lim_map _ _).
- + intros C n x; simpl; reflexivity.
- + intros C h HCom x n; simpl.
- specialize (HCom n x); simpl in HCom.
- symmetry; apply HCom.
- Qed.
-
- End Limits.
-End PCBUlt.
diff --git a/lib/ModuRes/Predom.v b/lib/ModuRes/Predom.v
deleted file mode 100644
index 70d38a7c4e8f85a429dc2a8232ffd3d1c49c9c2b..0000000000000000000000000000000000000000
--- a/lib/ModuRes/Predom.v
+++ /dev/null
@@ -1,411 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Export CSetoid.
-
-Generalizable Variables T U V W.
-
-Class preoType T {eqT : Setoid T} :=
- {pord : relation T;
- preoPO :> PreOrder pord;
- preoC :> Proper (equiv ==> equiv ==> impl) pord}.
-
-(** Rewriting under pord. *)
-Instance preoType_compat T `{pT : preoType T} : Proper (equiv ==> equiv ==> iff) pord.
-Proof.
- split; first by exact: preoC.
- symmetry in H, H0.
- exact: preoC.
-Qed.
-
-Arguments pord {_ _ _} !_ !_.
-Notation "'mkPOType' R" := (Build_preoType _ _ R _) (at level 10).
-Notation "s ⊑ t" := (pord s t) (at level 70, no associativity) : predom_scope.
-Delimit Scope predom_scope with pd.
-Local Open Scope predom_scope.
-
-(* Proof by reflexivity *)
-Lemma pordR {T : Type} `{eqT : preoType T} {a b : T} :
- a == b -> (a ⊑ b).
-Proof.
- intros Heq. rewrite Heq. reflexivity.
-Qed.
-
-Ltac mono_resp :=
- intros t1 t2 HSub; repeat (intros ?); rewrite -> ?HSub; simpl in *; rewrite -> ?HSub; repeat split; reflexivity.
-
-Section Monotone_Morphisms.
- Record monotone_morphism T U `{pT : preoType T} `{pU : preoType U} := mkMMorph
- { mono_morph :> T -=> U;
- mono_mono : Proper (pord ++> pord) mono_morph}.
-
-End Monotone_Morphisms.
-
-Global Arguments mkMMorph [T U] {_ pT _ pU} _ _.
-Arguments mono_morph [T U] {_ _ _ _} !_ /.
-Arguments mono_mono {_ _} {_ _ _ _} _ {_ _} _.
-
-Notation "T -m> U" := (monotone_morphism T U) (at level 45, right associativity) : predom_scope.
-
-Section MMorphProps1.
- Local Open Scope predom_scope.
- Context `{pT : preoType T} `{pU : preoType U} `{pV : preoType V} `{pW : preoType W}.
- Implicit Types (t : T) (f : T -m> U).
-
- (* PDS: It seems strange to have to repeat the point-wise equivalence yet again. *)
- Let mon_morph_eq f1 f2 : Prop := forall t, f1 t == f2 t.
- Global Instance equiv_mon_morph : Equivalence mon_morph_eq.
- Proof.
- split.
- - move=> f t. by reflexivity.
- - move=> f1 f2 EQf t. by symmetry.
- - move=> f1 f2 f3 EQ12 EQ23 t. by transitivity (f2 t).
- Qed.
- Global Instance mon_morph_type : Setoid (T -m> U) := mkType mon_morph_eq.
-
- Global Program Instance mon_morph_preoT : preoType (T -m> U) :=
- mkPOType (fun f g => forall x, f x ⊑ g x) _.
- Next Obligation.
- split.
- - intros f x; reflexivity.
- - intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
- Qed.
- Next Obligation.
- move=> f1 f2 EQf f'1 f'2 EQf' HLe t.
- by rewrite -(EQf t) -(EQf' t).
- Qed.
-
- Global Instance pord_mono :
- Proper (pord ==> pord ==> pord) (mono_morph (T:=T) (U:=U)).
- Proof.
- intros f g HSub x y HSub'; etransitivity; [apply HSub | apply g, HSub'].
- Qed.
-
- Program Definition mmcomp (f : U -m> V) (g : T -m> U) : T -m> V :=
- mkMMorph (f << g) _.
- Next Obligation.
- intros x y Hxy; now apply f, g.
- Qed.
-
-End MMorphProps1.
-
-Notation "f ∘ g" := (mmcomp f g) (at level 40, left associativity) : predom_scope.
-
-Section MMorphProps2.
- Local Open Scope predom_scope.
- Context `{pT : preoType T} `{pU : preoType U} `{pV : preoType V} `{pW : preoType W}.
-
- Global Instance pord_mmcomp :
- Proper (pord (T := T -m> U) ==> pord ==> pord) mmcomp.
- Proof.
- intros f1 f2 Hf g1 g2 Hg t; simpl; rewrite -> (Hf _); now apply mono_mono.
- Qed.
-
- Lemma mmcompAL (f: V -m> W) (g: U -m> V) (h: T -m> U) :
- f ∘ (g ∘ h) ⊑ f ∘ g ∘ h.
- Proof. intros x; reflexivity. Qed.
-
- Lemma mmcompAR (f: V -m> W) (g: U -m> V) (h: T -m> U) :
- f ∘ g ∘ h ⊑ f ∘ (g ∘ h).
- Proof. intros x; reflexivity. Qed.
-
- Program Definition lift2m (f : T -=> U -=> V) p q : T -m> U -m> V :=
- (mkMMorph (mkMorph (fun t : T => mkMMorph (f t) (p t)) _) q).
- Next Obligation.
- move=> t1 t2 EQt u /=. rewrite EQt; reflexivity.
- Qed.
-
-End MMorphProps2.
-
-Section MonotoneProducts.
- Local Open Scope predom_scope.
- Context `{pT : preoType T} `{pU : preoType U} `{pV : preoType V}.
-
- Definition prod_ord (p1 p2 : U * V) := (fst p1 ⊑ fst p2) /\ (snd p1 ⊑ snd p2).
-
- Global Program Instance preoType_prod : preoType (U * V) := mkPOType prod_ord _.
- Next Obligation.
- split.
- - intros [a b]; split; simpl; reflexivity.
- - intros [a1 b1] [a2 b2] [a3 b3] [Ha12 Hb12] [Ha13 Hb13]; split; simpl;
- etransitivity; eassumption.
- Qed.
- Next Obligation.
- move=> [u1 v1] [u2 v2] [/= EQu EQv] [u'1 v'1] [u'2 v'2] [/= EQu' EQv'] [/= LEu LEv]; split.
- - by rewrite -EQu -EQu'.
- - by rewrite -EQv -EQv'.
- Qed.
-
- Global Instance mprod_proper : Proper (pord ==> pord ==> pord) (@pair U V).
- Proof.
- intros a a' Ha b b' Hb; split; assumption.
- Qed.
-
- (** The next two are redundant, but speed up rewriting. *)
- Global Instance mprod_compat_fst : Proper (equiv ==> pord ==> pord) (@pair U V).
- Proof.
- move=> u1 u2 Ru v1 v2 Rv; split; last done.
- by rewrite Ru; reflexivity.
- Qed.
-
- Global Instance mprod_compat_snd : Proper (pord ==> equiv ==> pord) (@pair U V).
- Proof.
- move=> u1 u2 Ru v1 v2 Rv; split; first done.
- by rewrite Rv; reflexivity.
- Qed.
-
- Global Instance mmfst_proper : Proper (pord ==> pord) (@fst U V).
- Proof.
- intros [a1 b1] [a2 b2] [Ha Hb]; assumption.
- Qed.
-
- Global Instance mmsnd_proper : Proper (pord ==> pord) (@snd U V).
- Proof.
- intros [a1 b1] [a2 b2] [Ha Hb]; assumption.
- Qed.
-
- Local Obligation Tactic := intros; try mono_resp.
-
- Definition mfst : (U * V) -m> U := mkMMorph mfst _.
- Definition msnd : (U * V) -m> V := mkMMorph msnd _.
-
- Program Definition mprod (f: T -m> U) (g: T -m> V) : T -m> (U * V) :=
- mkMMorph (mprod f g) _.
- Next Obligation.
- move=> t1 t2 Ht; split; exact: mono_mono Ht.
- Qed.
-
- Lemma mprod_unique (f: T -m> U) (g: T -m> V) (h: T -m> U * V) :
- mfst ∘ h ⊑ f -> msnd ∘ h ⊑ g -> h ⊑ mprod f g.
- Proof.
- move=> HL HR x; split; [exact: HL | exact: HR].
- Qed.
-
-End MonotoneProducts.
-
-Section ProdTests.
- Local Open Scope predom_scope.
- Context `{pT : preoType T} `{pU : preoType U}.
- Implicit Types (t : T) (u : U).
-
- (*
- * Aside: The numbers count lines of
- *
- * Typeclasses eauto := debug.
- *
- * output before and after defining mprod_compat_{fst,snd}. (These
- * searches are worth speeding up. Iris uses pairs of resources.)
- *)
- Goal forall t1 t2 u, t1 == t2 -> (t1,u) ⊑ (t2,u).
- Proof. move=> t1 t2 u ->. reflexivity. Qed. (* ~950 -> ~50 *)
-
- Goal forall t u1 u2, u1 == u2 -> (t,u1) ⊑ (t,u2).
- Proof. move=> t u1 u2 ->. reflexivity. Qed. (* ~950 -> 50 *)
-
- Goal forall t1 t2 u1 u2, t1 == t2 -> u1 == u2 -> (t1,u1) ⊑ (t2,u2).
- Proof. move=> t1 t2 u1 u2 -> ->. reflexivity. Qed. (* ~4,700 -> ~120 *)
-End ProdTests.
-
-Global Arguments prod_ord {_ _ _ _ _ _} _ _ /.
-Notation "〈 f , g 〉" := (mprod f g) : predom_scope.
-
-
-Section Extras.
- Local Open Scope predom_scope.
- Local Obligation Tactic := intros; mono_resp || eauto.
- Context `{pT : preoType T} `{pU : preoType U} `{pV : preoType V} `{pW : preoType W}.
-
- Definition mprod_map (f : T -m> U) (g : V -m> W) := 〈f ∘ mfst, g ∘ msnd〉.
- Program Definition mid : T -m> T := mkMMorph (mid T) _.
- Program Definition mconst u : U -m> T := mkMMorph (mconst u) _.
-
-End Extras.
-
-Arguments mid T {_ _}.
-Notation "f × g" := (mprod_map f g) (at level 40, left associativity) : predom_scope.
-
-Section MonoExponentials.
- Local Open Scope predom_scope.
- Local Obligation Tactic := intros; mono_resp || eauto.
- Context `{pT : preoType T} `{pU : preoType U} `{pV : preoType V} `{pW : preoType W}.
-
- Program Definition muncurry (f : T -m> U -m> V) : T * U -m> V :=
- mkMMorph s[(fun p => f (fst p) (snd p))] _.
- Next Obligation.
- move=> [t1 u1] [t2 u2] [/= Ht ->].
- by eapply (morph_resp f).
- Qed.
- Next Obligation.
- move=> [t1 u1] [t2 u2] [/= Ht Hu].
- transitivity (f t2 u1).
- - exact: (mono_mono f Ht).
- - exact: (mono_mono (f t2) Hu).
- Qed.
-
- Program Definition mcurry (f : T * U -m> V) : T -m> U -m> V :=
- lift2m (mcurry f) _ _.
- Next Obligation.
- move=> u1 u2 Ru.
- apply: (mono_mono f).
- split; [by reflexivity | done].
- Qed.
- Next Obligation.
- move=> t1 t2 Rt u.
- apply: (mono_mono f).
- split; [done | by reflexivity].
- Qed.
-
- Program Definition meval : (T -m> U) * T -m> U :=
- mkMMorph s[(fun p => fst p (snd p))] _.
- Next Obligation.
- move=> [f1 t1] [f2 t2] [/= Rf Rt].
- by rewrite (Rf t1) Rt; reflexivity.
- Qed.
- Next Obligation.
- move=> [f1 t1] [f2 t2] [/= Rf Rt].
- transitivity (f2 t1); [exact: Rf | exact: mono_mono].
- Qed.
-
-End MonoExponentials.
-
-Section MonoExpProps.
- Local Open Scope predom_scope.
- Local Obligation Tactic := intros; mono_resp || eauto.
- Context `{pT : preoType T} `{pU : preoType U} `{pV : preoType V} `{pW : preoType W}.
-
- Lemma mcurry_comL (f : T * U -m> V) : f ⊑ meval ∘ (mcurry f × mid _).
- Proof. intros [a b]; reflexivity. Qed.
-
- Lemma mcurry_comR (f : T * U -m> V) : meval ∘ (mcurry f × mid _) ⊑ f.
- Proof. intros [a b]; reflexivity. Qed.
-
- Lemma mcurry_uniqeL (f : T * U -m> V) h :
- f ⊑ meval ∘ (h × mid _) -> mcurry f ⊑ h.
- Proof.
- move=> HEq a b; exact: HEq.
- Qed.
-
- Lemma mcurry_uniqeR (f : T * U -m> V) h :
- meval ∘ (h × mid _) ⊑ f -> h ⊑ mcurry f.
- Proof.
- move=> HEq a b; exact: (HEq (a,b)).
- Qed.
-
-End MonoExpProps.
-
-Section SubPredom.
- Local Open Scope predom_scope.
- Local Obligation Tactic := intros; mono_resp || eauto.
- Context `{eT : preoType T} {P : T -> Prop}.
-
- Definition subset_ord (x y : {t : T | P t}) := proj1_sig x ⊑ proj1_sig y.
- Arguments subset_ord _ _ /.
- Global Program Instance subset_preo : preoType {a : T | P a} := mkPOType subset_ord _.
- Next Obligation.
- split.
- - intros [x Hx]; red; simpl; reflexivity.
- - intros [x Hx] [y Hy] [z Hz] Hxy Hyz; red; simpl;
- etransitivity; [apply Hxy | apply Hyz].
- Qed.
- Next Obligation.
- move=> x1 x2 EQx y1 y2 EQy.
- by rewrite /subset_ord EQx EQy.
- Qed.
-
- Global Instance proj1sig_proper :
- Proper (pord (T := {t : T | P t}) ==> pord) (@proj1_sig T P).
- Proof. intros [x Hx] [y Hy] HEq; simpl; apply HEq. Qed.
-
- Program Definition mforget : {a : T | P a} -m> T :=
- mkMMorph mincl _.
-
- Context `{eU : preoType U}.
- Program Definition minherit (f : U -m> T) (HB : forall b, P (f b)) : U -m> {a : T | P a} :=
- mkMMorph (minherit f HB) _.
- Next Obligation.
- move=> u1 u2 Ru; exact: mono_mono.
- Qed.
-
- Lemma mforget_mono (f g : U -m> {a : T | P a}) : mforget ∘ f ⊑ mforget ∘ g -> f ⊑ g.
- Proof.
- intros HEq x; red; simpl; rewrite -> (HEq x); reflexivity.
- Qed.
-
-End SubPredom.
-
-
-Global Arguments subset_ord {_ _ _ _} _ _ /.
-
-(** Preorders on option types.
-
- Caution: this is *one* of the ways to define the order, and not necessarily the only useful.
- Thus, the instances are local, and should be declared w/ Existing Instance where needed. *)
-Section Option.
- Context `{pcV : preoType V}.
-
- (* The preorder on options where None is the bottom element. *)
- Section Bot.
-
- Definition option_pord_bot (o1 o2 : option V) :=
- match o1 with
- | None => True
- | Some v1 => match o2 with
- | None => False
- | Some v2 => pord v1 v2
- end
- end.
- Program Instance option_preo_bot : preoType (option V) := mkPOType option_pord_bot _.
- Next Obligation.
- split.
- - intros [v |]; simpl; [reflexivity | exact I].
- - intros [v1 |] [v2 |] [v3 |] Sub12 Sub23; simpl in *; try exact I || contradiction; [].
- etransitivity; eassumption.
- Qed.
- Next Obligation.
- move=> x1 x2 Rx y1 y2 Ry; move: Rx Ry.
- case: x1=>[x1|]; case: x2=>[x2|] //= Rx.
- case: y1=>[y1|]; case: y2=>[y2|] //= Ry; last done.
- by rewrite Rx Ry; reflexivity.
- Qed.
-
- End Bot.
-
- (* And the preorder, where None is a top element *)
- Section Top.
-
- Definition option_pord_top (o1 o2 : option V) :=
- match o2 with
- | None => True
- | Some v2 => match o1 with
- | None => False
- | Some v1 => pord v1 v2
- end
- end.
- Program Instance option_preo_top : preoType (option V) := mkPOType option_pord_top _.
- Next Obligation.
- split.
- - intros [v |]; simpl; [reflexivity | exact I].
- - intros [v1 |] [v2 |] [v3 |] Sub12 Sub23; simpl in *; try exact I || contradiction; [].
- etransitivity; eassumption.
- Qed.
- Next Obligation.
- move=> x1 x2 Rx y1 y2 Ry; move: Rx Ry.
- case: x1=>[x1|]; case: x2=>[x2|] //= Rx;
- case: y1=>[y1|]; case: y2=>[y2|] //= Ry; last done.
- rewrite Rx Ry; by reflexivity.
- Qed.
-
- End Top.
-
-End Option.
-
-
-Section ViewLemmas.
- Context {T} `{oT : preoType T}.
- Implicit Types (t : T).
- Local Open Scope predom_scope.
-
- Lemma prefl t : t ⊑ t.
- Proof. by reflexivity. Qed.
-
- Lemma ptrans {t1 t2 t3} (HL : t1 ⊑ t2) (HU : t2 ⊑ t3) : t1 ⊑ t3.
- Proof. by transitivity t2. Qed.
-End ViewLemmas.
diff --git a/lib/ModuRes/PreoMet.v b/lib/ModuRes/PreoMet.v
deleted file mode 100644
index 6609e2739e56cd5990f58608eeea10a6367d9f62..0000000000000000000000000000000000000000
--- a/lib/ModuRes/PreoMet.v
+++ /dev/null
@@ -1,603 +0,0 @@
-Require Import Ssreflect.ssreflect Omega.
-Require Export Predom MetricCore.
-
-Generalizable Variables T U V W X Y.
-
-Section PreCBUmet.
- Context (T : Type) `{cmT : cmetric T}.
-
- Definition respect_chain (le : relation T) :=
- forall (σ Ï : chain T) (σc : cchain σ) (Ïc : cchain Ï),
- (forall i, le (σ i) (Ï i)) -> le (compl σ) (compl Ï).
-
- Class pcmType {pTA : preoType T}: Prop :=
- { pcm_respC : respect_chain pord }.
-
-End PreCBUmet.
-
-
-Record monoMet_morphism T U `{pcmT : pcmType T} `{pcmU : pcmType U} := mkMUMorph
- { mu_morph :> T -n> U;
- mu_mono : Proper (pord ==> pord) mu_morph}.
-
-Arguments mkMUMorph [T U] {_ _ _ _ _ _ _ _ _ _} _ _.
-Arguments mu_morph [T U] {_ _ _ _ _ _ _ _ _ _} !_ /.
-Arguments mu_mono {_ _} {_ _ _ _ _ _ _ _ _ _} _ {_ _} _.
-
-Infix "-m>" := monoMet_morphism (at level 45, right associativity) : pumet_scope.
-Notation "'m[(' f ')]'" := (mkMUMorph n[(f)] _) : pumet_scope.
-Delimit Scope pumet_scope with pm.
-Open Scope pumet_scope.
-
-Section Morph_Props.
- Context `{pcmT : pcmType T} `{pcmU : pcmType U} `{pcmV : pcmType V}.
- Local Obligation Tactic := intros; apply _ || resp_set || program_simpl.
-
- Program Definition pcomp (f : U -m> V) (g : T -m> U) :=
- m[(f <M< g)].
- Next Obligation.
- intros x y HSub; apply mu_mono; now apply mu_mono.
- Qed.
-
- Program Definition pid := m[(umid _)].
-
-End Morph_Props.
-
-Section NonexpPCM.
- Context `{mT: metric T} `{eT: pcmType U}.
-
- Definition nonexp_ord (f1 f2: T -n> U): Prop :=
- forall x, (f1 x ⊑ f2 x)%pd.
-
- Global Program Instance preoType_nexp : preoType (T -n> U) := mkPOType nonexp_ord _.
- Next Obligation.
- split.
- - move=>f x. reflexivity.
- - move=>f g h Hfg Hgh x. etransitivity; [by eapply Hfg|by eapply Hgh].
- Qed.
- Next Obligation.
- move=>f1 f2 EQf g1 g2 EQg H x.
- rewrite -EQg -EQf. by eapply H.
- Qed.
-End NonexpPCM.
-
-
-Notation "f ∘ g" := (pcomp f g) (at level 40, left associativity) : pumet_scope.
-Arguments pid V {_ _ _ _ _}.
-
-Section PUMMorphProps1.
- Context `{pT : pcmType T} `{pU : pcmType U} `{pV : pcmType V} `{pW : pcmType W}.
- Local Obligation Tactic := intros; apply _ || resp_set || program_simpl.
-
- Definition PMEquiv (x y : T -m> U) := mu_morph x == mu_morph y.
-
- Global Instance PMEquivE: Equivalence PMEquiv.
- Proof.
- split.
- - intros f x; simpl; reflexivity.
- - intros f g Hfg x; simpl; symmetry; apply Hfg.
- - intros f g h Hfg Hgh x; simpl; etransitivity; [apply Hfg | apply Hgh].
- Qed.
-
- Global Program Instance PMtypeM : Setoid (T -m> U) := mkType PMEquiv.
-
- Definition PMDist n (f g : T -m> U) := (mu_morph f) = n = (mu_morph g).
-
- Global Program Instance PMMetric : metric (T -m> U) := mkMetr PMDist.
- Next Obligation.
- intros f g EQfg h i EQhi; split; intros EQ x; [symmetry in EQfg, EQhi |]; rewrite -> (EQfg x), (EQhi x); apply EQ.
- Qed.
- Next Obligation.
- split; [intros HEq t | intros HEq n].
- - rewrite <- dist_refl; intros n; apply HEq.
- - intros t; revert n; rewrite dist_refl; apply HEq.
- Qed.
- Next Obligation.
- intros f g HS x; symmetry; apply HS.
- Qed.
- Next Obligation.
- intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
- Qed.
- Next Obligation.
- intros t; simpl in *; eapply mono_dist; [| apply H]; omega.
- Qed.
- Next Obligation.
- intros t; apply dist_bound.
- Qed.
-
- Global Instance ccm (σ : chain (T -m> U)) {σc : cchain σ} : cchain (fun i => mu_morph (σ i)).
- Proof.
- unfold cchain; intros; apply σc; assumption.
- Qed.
-
- Definition PMpreo (f g: T -m> U) := (mu_morph f ⊑ mu_morph g)%pd.
-
- Global Instance PMpreo_is : PreOrder PMpreo.
- Proof.
- split.
- - intros f x; simpl. reflexivity.
- - intros f g h Hfg Hgh x. simpl; etransitivity; [apply Hfg | apply Hgh].
- Qed.
-
- Global Program Instance PMpreoT : preoType (T -m> U) :=
- mkPOType PMpreo _.
- Next Obligation.
- move=> f1 f2 Rf g1 g2 Rg H t.
- rewrite -(Rf t) -(Rg t).
- exact: H.
- Qed.
-
- Global Instance PM_proper (f : T -m> U) : Proper (pord ==> pord) f.
- Proof. apply mu_mono. Qed.
-
- Definition PMasMono (f : T -m> U) : (T -m> U)%pd :=
- mkMMorph (mu_morph f) _.
-
- Program Definition mu_morph_ne : (T -m> U) -n> (T -n> U) :=
- n[(mu_morph (U := U))].
- Next Obligation.
- intros x y HEq t; apply HEq.
- Qed.
-
- Program Definition PMCompl (σ : chain (T -m> U)) (σc : cchain σ) : T -m> U :=
- mkMUMorph (compl (liftc mu_morph_ne σ)) _.
- Next Obligation.
- intros x y HSub; simpl.
- eapply pcm_respC; [assumption |]; intros; simpl.
- rewrite -> HSub; reflexivity.
- Qed.
-
- Global Program Instance PMcmetric : cmetric (T -m> U) :=
- mkCMetr PMCompl.
- Next Obligation.
- apply (conv_cauchy (liftc mu_morph_ne σ)).
- Qed.
-
- Arguments PMEquiv _ _ /.
-
- Global Instance mon_morph_preoT : pcmType (T -m> U).
- Proof.
- clear; split.
- intros f g fc gc Hc x; simpl; eapply pcm_respC; try eassumption.
- intros n; apply Hc.
- Qed.
-
- Global Instance pord_pmu :
- Proper (pord ==> pord ==> pord) (mu_morph (T := T) (U := U)).
- Proof.
- intros f g HSub x y HSub'; etransitivity; [apply HSub | apply g, HSub'].
- Qed.
-
- Definition ordS (f g : T -=> U) := forall x, (f x ⊑ g x)%pd.
- Definition ordN (f g : T -n> U) := forall x, (f x ⊑ g x)%pd.
- Global Instance pord_extend_morph :
- Proper (ordN ==> ordS) (met_morph (T := T) (U := U)).
- Proof.
- intros f g HS; apply HS.
- Qed.
-
- Global Instance pord_extend_met :
- Proper (pord (T := T -m> U) ==> ordN) (mu_morph (U := U)).
- Proof.
- intros f g HS; apply HS.
- Qed.
-
- Global Instance pord_morph :
- Proper (ordS ==> equiv ==> pord) (morph (T:=T) (U:=U)).
- Proof.
- intros f g HS x y HS'; etransitivity; [apply HS |].
- eapply preoC; try assumption; [reflexivity | apply g; rewrite <- HS' |]; reflexivity.
- Qed.
-
- Global Instance pcm_equiv_inherit :
- Proper (equiv (A := T -m> U) ==> equiv (A := T -n> U)) (mu_morph (U := U)).
- Proof. intros f g HEq; apply HEq. Qed.
-
- Global Instance pcm_dist_inherit n :
- Proper (dist n (T := T -m> U) ==> dist n (T := T -n> U)) (mu_morph (U := U)).
- Proof. intros f g HEq; apply HEq. Qed.
-
-
-End PUMMorphProps1.
-
-(* Re-export the predom notation for pord in this scope *)
-Notation "x ⊑ y" := (pord x y) (at level 70, no associativity) : pumet_scope.
-
-Section CompProps.
- Context T U V `{pcmT : pcmType T} `{pcmU : pcmType U} `{pcmV : pcmType V}.
-
-(*
- Global Instance pord_equiv : Proper (equiv ==> equiv ==> iff) pord.
- Proof.
- intros a1 a2 EQa b1 b2 EQb; split; intros Sub; [symmetry in EQa, EQb |]; rewrite -> EQa, EQb; assumption.
- Qed.
-*)
-
- Global Instance pcomp_inherit :
- Proper (equiv (A := T -m> U) ==> equiv ==> equiv) pcomp.
- Proof.
- intros f f' Eqf g g' Eqg x; simpl; rewrite -> Eqf, Eqg; reflexivity.
- Qed.
-
- Global Instance pcomp_inherit_dist n :
- Proper (dist (T := T -m> U) n ==> dist n ==> dist n) pcomp.
- Proof.
- intros f f' Eqf g g' Eqg x; simpl; rewrite -> Eqf, Eqg; reflexivity.
- Qed.
-
- Context W `{pcmW : pcmType W}.
-
- Lemma pcomp_assoc (f : V -m> W) (g : U -m> V) (h : T -m> U) :
- f ∘ (g ∘ h) == (f ∘ g) ∘ h.
- Proof. intros x; reflexivity. Qed.
-
- Lemma pcomp_pid_right (f : T -m> U) :
- f ∘ (pid _) == f.
- Proof. intros x; reflexivity. Qed.
-
- Lemma pcomp_pid_left (f : T -m> U) :
- (pid _) ∘ f == f.
- Proof. intros x; reflexivity. Qed.
-
- Local Obligation Tactic := intros; resp_set || resp_dist || mono_resp || eauto.
-
- Program Definition precomp_mne (f : T -m> U) : (U -m> V) -m> (T -m> V) :=
- m[(fun g => g ∘ f)].
-
- Program Definition postcomp_mne (f : T -m> U) : (V -m> T) -m> (V -m> U) :=
- m[(fun g => f ∘ g)].
-
-End CompProps.
-
-Arguments precomp_mne {T U V _ _ _ _ _ _ _ _ _ _ _ _ _ _ _} f.
-Arguments postcomp_mne {T U V _ _ _ _ _ _ _ _ _ _ _ _ _ _ _} f.
-Notation "f â–¹" := (precomp_mne f) (at level 30) : pumet_scope.
-Notation "â—ƒ f" := (postcomp_mne f) (at level 30) : pumet_scope.
-
-Section PreCompProps.
- Context {T U V R: Type} `{pcmType T} `{pcmType U} `{pcmType V} `{pcmType R}.
-
- Lemma precomp_by_comp (f: T -m> U) (g: U -m> V) (h: T -m> V):
- g ∘ f == h ->
- (precomp_mne (V:=R) f) <M< (precomp_mne g) == h â–¹.
- Proof.
- intros Hcomp i. simpl morph. rewrite <-Hcomp. rewrite pcomp_assoc. reflexivity.
- Qed.
-
- Lemma precomp_by_id (f: T -m> T):
- f == (pid T) ->
- mu_morph (precomp_mne f) == (umid (T -m> R)).
- Proof.
- intros Hcomp i. simpl morph. rewrite Hcomp. intros x. reflexivity.
- Qed.
-
-End PreCompProps.
-
-
-Section MMorphProps2.
- Local Open Scope pumet_scope.
- Context `{pT : pcmType T} `{pU : pcmType U} `{pV : pcmType V} `{pW : pcmType W}.
-
- Global Instance pord_pcomp :
- Proper (pord (T := U -m> V) ==> pord ==> pord) pcomp.
- Proof.
- intros f f' HSubf g g' HSubg x; simpl; rewrite -> HSubf, HSubg; reflexivity.
- Qed.
-
- Lemma mmcompAL (f: V -m> W) (g: U -m> V) (h: T -m> U) :
- f ∘ (g ∘ h) ⊑ f ∘ g ∘ h.
- Proof. intros x; reflexivity. Qed.
-
- Lemma mmcompAR (f: V -m> W) (g: U -m> V) (h: T -m> U) :
- f ∘ g ∘ h ⊑ f ∘ (g ∘ h).
- Proof. intros x; reflexivity. Qed.
-
- Global Instance precomp_equiv : Proper (equiv (A := T -m> U) ==> equiv) precomp_mne.
- Proof. resp_set. Qed.
-
- Global Instance precomp_dist n : Proper (dist n (T := T -m> U) ==> dist n) precomp_mne.
- Proof. resp_set. Qed.
-
- Global Instance precomp_ord : Proper (pord ==> pord) precomp_mne.
- Proof. mono_resp. Qed.
-
- Global Instance postcomp_equiv : Proper (equiv (A := T -m> U) ==> equiv) postcomp_mne.
- Proof. resp_set. Qed.
-
- Global Instance postcomp_dist n : Proper (dist n (T := T -m> U) ==> dist n) postcomp_mne.
- Proof. resp_set. Qed.
-
- Global Instance postcomp_ord : Proper (pord ==> pord) postcomp_mne.
- Proof. mono_resp. Qed.
-
- Lemma ucomp_precomp (f : U -m> V) (g : T -m> U) :
- g ▹ ∘ f ▹ == precomp_mne (V := W) (f ∘ g).
- Proof.
- intros h; simpl morph; symmetry; apply pcomp_assoc.
- Qed.
-
- Lemma pid_precomp :
- precomp_mne (V := U) (pid T) == pid (T -m> U).
- Proof.
- intros f; simpl; apply pcomp_pid_right.
- Qed.
-
- Lemma ucomp_postcomp (f : T -m> U) (g : V -m> T) :
- ◃ f ∘ ◃ g == postcomp_mne (V := W) (f ∘ g).
- Proof.
- intros h; simpl; apply pcomp_assoc.
- Qed.
-
- Lemma pid_postcomp :
- postcomp_mne (V := T) (pid U) == pid (T -m> U).
- Proof.
- intros f; simpl; apply pcomp_pid_left.
- Qed.
-
-End MMorphProps2.
-
-Section MonotoneProducts.
- Local Open Scope pumet_scope.
- Context `{pcT : pcmType T} `{pcU : pcmType U} `{pcV : pcmType V}.
- Local Obligation Tactic := intros; apply _ || mono_resp || program_simpl.
-
- Global Instance pcmType_prod : pcmType (U * V).
- Proof.
- split.
- intros σ Ï Ïƒc Ïc HC; split; unfold liftc; eapply pcm_respC; try assumption; unfold liftc;
- intros i; rewrite -> HC; reflexivity.
- Qed.
-
-(* RJ These are already in Predom.v, right?
- Global Instance pcmprod_proper : Proper (pord ++> pord ++> pord) (@pair U V).
- Proof.
- intros a a' Ha b b' Hb; split; assumption.
- Qed.
-
- Global Instance pcmfst_proper : Proper (pord ++> pord) (@fst U V).
- Proof.
- intros [a1 b1] [a2 b2] [Ha Hb]; assumption.
- Qed.
-
- Global Instance pcmsnd_proper : Proper (pord ++> pord) (@snd U V).
- Proof.
- intros [a1 b1] [a2 b2] [Ha Hb]; assumption.
- Qed.
-*)
-
- Definition pcmfst : (U * V) -m> U := m[(Mfst)].
- Definition pcmsnd : (U * V) -m> V := m[(Msnd)].
-
- Program Definition pcmprod (f: T -m> U) (g: T -m> V) : T -m> (U * V) :=
- m[(Mprod f g)].
-
- Lemma pcmprod_unique (f: T -m> U) (g: T -m> V) (h: T -m> U * V) :
- pcmfst ∘ h == f -> pcmsnd ∘ h == g -> h == pcmprod f g.
- Proof.
- intros HL HR x; split; simpl; [rewrite <- HL | rewrite <- HR]; reflexivity.
- Qed.
-
-
-End MonotoneProducts.
-
-Notation "〈 f , g 〉" := (pcmprod f g) : pumet_scope.
-Notation "'Ï€â‚'" := pcmfst : pumet_scope.
-Notation "'π₂'" := pcmsnd : pumet_scope.
-
-Section Extras.
- Local Open Scope pumet_scope.
- Local Obligation Tactic := intros; apply _ || mono_resp || program_simpl.
- Context `{pT : pcmType T} `{pU : pcmType U} `{pV : pcmType V} `{pW : pcmType W}.
-
- Definition pcmprod_map (f : T -m> U) (g : V -m> W) := 〈f ∘ Ï€â‚, g ∘ π₂〉.
-
- Global Instance pcmprod_map_resp : Proper (equiv ==> equiv ==> equiv) pcmprod_map.
- Proof. intros f g H1 h j H2 [t1 v1]; simpl; now rewrite -> H1, H2. Qed.
-
- Global Instance pcmprod_map_nonexp n : Proper (dist n ==> dist n ==> dist n) pcmprod_map.
- Proof.
- intros f g H1 h j H2 [t1 v1]; split; simpl; [ rewrite H1 | rewrite H2]; reflexivity.
- Qed.
-
- Global Instance pcmprod_map_monic : Proper (pord ==> pord ==> pord) pcmprod_map.
- Proof.
- intros f g H1 h j H2 [t1 v1]; split; simpl; [ rewrite -> H1 | rewrite -> H2]; reflexivity.
- Qed.
-
- Program Definition pcmconst u : T -m> U := mkMUMorph (umconst u) _.
-
-End Extras.
-
-Section Instances.
- Local Open Scope pumet_scope.
- Local Obligation Tactic := intros; apply _ || mono_resp || program_simpl.
- Context `{pT : pcmType T} `{pU : pcmType U} `{pV : pcmType V} `{pW : pcmType W}.
-
- Lemma pcmprod_map_id : pcmprod_map (pid T) (pid U) == pid _.
- Proof. simpl. repeat intro; split; reflexivity. Qed.
-
- Context `{pX : pcmType Y} `{pY : pcmType X} {f : T -m> U} {g : V -m> W} {h : X -m> T} {j : Y -m> V}.
-
- Lemma pcmprod_map_comp :
- ((pcmprod_map f g) ∘ (pcmprod_map h j))%pm == (pcmprod_map (f ∘ h) (g ∘ j))%pm.
- Proof. intros [x y]; reflexivity. Qed.
-End Instances.
-
-Notation "f × g" := (pcmprod_map f g) (at level 40, left associativity) : pumet_scope.
-
-Section PCMExponentials.
- Local Open Scope pumet_scope.
- Local Obligation Tactic := intros; apply _ || mono_resp || program_simpl.
- Context `{pT : pcmType T} `{pU : pcmType U} `{pV : pcmType V} `{pW : pcmType W}.
-
- Program Definition um_bin_morph (f : T -m> U -m> V) : T -n> U -n> V :=
- lift2m (lift2s (fun a b => f a b) _ _) _ _.
-
- Program Definition pcmuncurry (f : T -m> U -m> V) : T * U -m> V :=
- m[(uncurry (um_bin_morph f))].
- Next Obligation.
- intros [a1 b1] [a2 b2] [HSa HSb]; simpl in *; now rewrite -> HSa, HSb.
- Qed.
-
- Program Definition lift2_pcm (f : T -n> U -n> V) p q : T -m> U -m> V :=
- mkMUMorph (mkUMorph (mkMorph (fun a => mkMUMorph (f a) (p a)) _) _) q.
-
- Program Definition mcurry (f : T * U -m> V) : T -m> U -m> V :=
- lift2_pcm (curryM f) _ _.
-
- Program Definition meval : (T -m> U) * T -m> U :=
- m[(evalM <M< prodM_map n[(mu_morph (U := U))] (umid _))].
- Next Obligation.
- intros [f a] [g b] [Sub1 Sub2]; simpl in *; rewrite -> Sub1, Sub2; reflexivity.
- Qed.
-
-End PCMExponentials.
-
-Section PCMExpProps.
- Local Open Scope pumet_scope.
- Context `{pT : pcmType T} `{pU : pcmType U} `{pV : pcmType V} `{pW : pcmType W}.
-
- Lemma pcmcurry_com (f : T * U -m> V) : f == meval ∘ (mcurry f × pid _).
- Proof. intros [a b]; reflexivity. Qed.
-
- Lemma mcurry_uniqe (f : T * U -m> V) h :
- f == meval ∘ (h × pid _) -> mcurry f == h.
- Proof. intros HEq a b; simpl; rewrite HEq; reflexivity. Qed.
-
-End PCMExpProps.
-
-Section SubPCM.
- Local Open Scope pumet_scope.
- Local Obligation Tactic := intros; apply _ || mono_resp || eauto.
- Context `{pcT : pcmType T} `{pcU : pcmType U} {P : T -> Prop} {C : LimitPreserving P}.
-
- Program Definition p1sNE :=
- n[(fun x : {a : T | P a} => proj1_sig x)].
- Next Obligation.
- move=>[t1 P1] [t2 P2] /=. tauto.
- Qed.
-
- Global Instance pcmType_sub : pcmType {a : T | P a}.
- Proof.
- split.
- intros σ Ï Ïƒc Ïc SUBc; simpl.
- eapply pcm_respC; [assumption |]; intros i; simpl; apply SUBc.
- Qed.
-
- Global Instance proj1sig_proper :
- Proper (pord (T := {t : T | P t}) ==> pord) (@proj1_sig T P).
- Proof. intros [x Hx] [y Hy] HEq; simpl; apply HEq. Qed.
-
- Definition muincl : {a : T | P a} -m> T := m[(inclM)].
-
- Program Definition muinherit (f : U -m> T) (HB : forall b, P (f b)) : U -m> {a : T | P a} :=
- m[(inheritM f HB)].
-
- Lemma muforget_mono (f g : U -m> {a : T | P a}) : muincl ∘ f ⊑ muincl ∘ g -> f ⊑ g.
- Proof.
- move=> HEq x; exact: HEq.
- Qed.
-
- Lemma muforget_mono' (f g : U -m> {a : T | P a}) : muincl ∘ f == muincl ∘ g -> f == g.
- Proof.
- move=> HEq x; exact: HEq.
- Qed.
-
-End SubPCM.
-
-
-(** Extending the pcbult's to option types.
-
- Caution: this is *one* of the ways to define the order, and not necessarily the only useful.
- Thus, the instances are local, and should be declared w/ Existing Instance where needed. *)
-Section Option.
- Context `{pcV : pcmType V}.
-
- (* The preorder on options where None is the bottom element. *)
- Section Bot.
-
- Existing Instance option_preo_bot.
-
- Instance option_pcm_bot : pcmType (option V).
- Proof.
- split.
- - intros σ Ï Ïƒc Ïc HS.
- unfold compl, option_cmt, option_compl at 1; simpl.
- generalize (@eq_refl _ (σ 1)); pattern (σ 1) at 1 3; destruct (σ 1) as [vs1 |]; intros; [| exact I].
- unfold option_compl; simpl.
- generalize (@eq_refl _ (Ï 1)); pattern (Ï 1) at 1 3; destruct (Ï 1) as [vr1 |]; intros; [| exfalso].
- { eapply pcm_respC; [assumption | intros].
- unfold unSome at 1; simpl.
- generalize (@eq_refl _ (σ (S i))); pattern (σ (S i)) at 1 3; destruct (σ (S i)) as [vsi |]; intros.
- + unfold unSome; simpl.
- generalize (@eq_refl _ (Ï (S i))); pattern (Ï (S i)) at 1 3; destruct (Ï (S i)) as [vri |]; intros.
- * specialize (HS (S i)); rewrite <- e1, <- e2 in HS; apply HS.
- * exfalso; specialize (Ïc 1 1 (S i)); rewrite <- e0, <- e2 in Ïc; apply Ïc; auto with arith.
- + exfalso; specialize (σc 1 1 (S i)); rewrite <- e, <- e1 in σc; apply σc; auto with arith.
- }
- specialize (HS 1); rewrite <- e0, <- e in HS; apply HS.
- Qed.
-
- End Bot.
-
- (* And the preorder, where None is a top element *)
- Section Top.
-
- Existing Instance option_preo_top.
-
- Instance option_pcm_top : pcmType (option V).
- Proof.
- split.
- - intros σ Ï Ïƒc Ïc HS.
- unfold compl, option_cmt, option_compl at 2; simpl.
- generalize (@eq_refl _ (Ï 1)); pattern (Ï 1) at 1 3; destruct (Ï 1) as [vr1 |]; intros; [| exact I].
- unfold option_compl; simpl.
- generalize (@eq_refl _ (σ 1)); pattern (σ 1) at 1 3; destruct (σ 1) as [vs1 |]; intros; [| exfalso].
- { unfold pord; simpl.
- eapply pcm_respC; [assumption | intros].
- unfold unSome at 1; simpl.
- generalize (@eq_refl _ (σ (S i))); pattern (σ (S i)) at 1 3; destruct (σ (S i)) as [vsi |]; intros.
- + unfold unSome; simpl.
- generalize (@eq_refl _ (Ï (S i))); pattern (Ï (S i)) at 1 3; destruct (Ï (S i)) as [vri |]; intros.
- * specialize (HS (S i)); rewrite <- e1, <- e2 in HS; apply HS.
- * exfalso; specialize (Ïc 1 1 (S i)); rewrite <- e, <- e2 in Ïc; apply Ïc; auto with arith.
- + exfalso; specialize (σc 1 1 (S i)); rewrite <- e0, <- e1 in σc; apply σc; auto with arith.
- }
- specialize (HS 1); rewrite <- e0, <- e in HS; apply HS.
- Qed.
-
- End Top.
-
-End Option.
-
-Section ExtOrdDiscrete.
- Context U `{cmU : cmetric U}.
-
- Program Instance disc_preo : preoType U := mkPOType equiv _.
- Next Obligation.
- split; apply _.
- Qed.
- Next Obligation.
- move=> x1 x2 Rx y1 y2 Ry.
- by rewrite Rx Ry.
- Qed.
-
- Instance disc_pcm : pcmType U.
- Proof.
- split; simpl.
- - intros σ Ï Ïƒc Ïc HS.
- apply umet_complete_ext=>i. rewrite HS. reflexivity.
- Qed.
-
-End ExtOrdDiscrete.
-
-Section ExtMetricDiscrete.
- Context T {eqtT : Setoid T} {preoT : preoType T}.
-
- Global Instance disc_metric_pcm : pcmType (mT:=discreteMetric) (cmT:=discreteCMetric) T.
- Proof.
- split. move=>σ Ï Ïƒc Ïc Hle.
- rewrite /compl /= /discreteCompl.
- by apply: Hle.
- Qed.
-End ExtMetricDiscrete.
diff --git a/lib/ModuRes/RA.v b/lib/ModuRes/RA.v
deleted file mode 100644
index 0feeb6208fe0f98d72f8e0f33f3ef808963b2b7f..0000000000000000000000000000000000000000
--- a/lib/ModuRes/RA.v
+++ /dev/null
@@ -1,675 +0,0 @@
-(** Resource algebras: Commutative monoids with a validity predicate. *)
-
-Require Import Ssreflect.ssreflect.
-Require Import Coq.Classes.RelationPairs.
-Require Import Bool.
-Require Import Predom.
-Require Import CSetoid.
-
-Set Bullet Behavior "Strict Subproofs".
-
-
-Section RADef.
- Context {T : Type} {eqT : Setoid T}.
-
- Class RA_unit := ra_unit : T -> T.
- Class RA_op := ra_op : T -> T -> T.
- Class RA_valid:= ra_valid : T -> Prop.
- Class RA {TU : RA_unit} {TOP : RA_op} {TV : RA_valid} :=
- mkRA {
- ra_op_proper :> Proper (equiv ==> equiv ==> equiv) ra_op;
- ra_op_assoc :> Associative ra_op;
- ra_op_comm :> Commutative ra_op;
- ra_op_unit {t} : ra_op (ra_unit t) t == t;
- ra_unit_proper :> Proper (equiv ==> equiv) ra_unit;
- ra_unit_mono t t' : { t'' | ra_unit (ra_op t t') == ra_op (ra_unit t) t''};
- ra_unit_idem t : ra_unit (ra_unit t) == ra_unit t;
- ra_valid_proper :> Proper (equiv ==> iff) ra_valid;
- ra_op_valid {t1 t2}: ra_valid (ra_op t1 t2) -> ra_valid t1
- }.
-End RADef.
-Section VIRADef.
- Context {T : Type}.
- Class VIRA `{RAT : RA T}: Prop :=
- mkVIRA {
- ra_inhab : T;
- ra_inhab_valid : ra_valid ra_inhab
- }.
-End VIRADef.
-
-Arguments RA_unit : clear implicits.
-Arguments RA_op : clear implicits.
-Arguments RA_valid : clear implicits.
-Arguments RA T {_ _ _ _}: clear implicits.
-Arguments VIRA T {_ _ _ _ _}: clear implicits.
-
-Delimit Scope ra_scope with ra.
-Local Open Scope predom_scope.
-Local Open Scope ra_scope.
-
-Notation "'1'" := (ra_unit) : ra_scope.
-Notation "p · q" := (ra_op p q) (at level 40, left associativity) : ra_scope.
-Notation "'↓' p" := (ra_valid p) (at level 48) : ra_scope.
-
-Class Cancellative T `{raT : RA T} : Prop :=
- ra_cancel : forall {t1 t2 t3 : T}, ↓t1 · t3 -> t1 · t2 == t1 · t3 -> t2 == t3.
-
-Section RA_FPU.
- Context {T} `{raT : RA T}.
- Implicit Types (t : T) (P : T -> Prop).
-
- (* Two judgments means we'll duplicate some work (e.g., for products). *)
- Definition RA_FPS t1 t2 := forall tf, ↓t1 · tf -> ↓t2 · tf.
- Definition RA_FPU t1 P := forall tf, ↓t1 · tf -> exists t2, P t2 /\ ↓t2 · tf.
-End RA_FPU.
-Notation "a ⇠b" := (RA_FPS a b) (at level 48, no associativity) : ra_scope.
-Notation "a 'â‡âˆˆ' B" := (RA_FPU a B) (at level 48, no associativity) : ra_scope.
-
-(* General RA lemmas *)
-Section RALemmas.
- Context {T} `{raT : RA T}.
-
- Implicit Types (t : T).
-
- Lemma ra_op_unit2 {t} : t · 1 t == t.
- Proof.
- rewrite comm. now eapply ra_op_unit.
- Qed.
-
- Lemma ra_unit_dup {t} : 1 t · 1 t == 1 t.
- Proof.
- now rewrite -{1}(ra_unit_idem t) ra_op_unit.
- Qed.
-
- Lemma ra_op_valid2 {t1 t2} : ↓ (t1 · t2) -> ↓ t2.
- Proof.
- rewrite comm. now eapply ra_op_valid.
- Qed.
-
- Lemma ra_op_invalid {t1 t2} : ~↓t1 -> ~↓(t1 · t2).
- Proof.
- intros Hinval Hval.
- apply Hinval.
- eapply ra_op_valid; now eauto.
- Qed.
-
- Lemma ra_op_invalid2 {t1 t2} : ~↓t2 -> ~↓(t1 · t2).
- Proof.
- rewrite comm. now eapply ra_op_invalid.
- Qed.
-
- Lemma ra_fps_fpu {t1 t2} (Hu : t1 ⇠t2) : t1 â‡âˆˆ (equiv t2).
- Proof. move=> f Hv; exists t2; split; [by reflexivity | exact: Hu]. Qed.
-
- Lemma ra_fpu_fps {t1 t2} (Hu : t1 â‡âˆˆ (equiv t2)) : t1 ⇠t2.
- Proof.
- move=>f Hv. destruct (Hu f Hv) as [t [Heq Hv']].
- by rewrite Heq.
- Qed.
-
- Lemma ra_fps_id {t :T} : t ⇠t.
- Proof. done. Qed.
-
- Lemma ra_fpu_id {t : T} {P : T -> Prop} (Ht : P t) : t â‡âˆˆ P.
- Proof. by move=> f Hv; exists t. Qed.
-
- Local Obligation Tactic := resp_set || eauto with typeclass_instances.
-
- Program Definition ra_op_s: T -=> T -=> T :=
- s[(fun t1 => s[(ra_op t1)])].
-End RALemmas.
-
-
-(** The usual algebraic order on RAs. *)
-Section Order.
- Context {T} `{raT : RA T}.
-
- Let ra_ord t1 t2 :=
- exists t, t · t1 == t2.
-
- Global Instance ra_ord_preo: PreOrder ra_ord.
- Proof.
- split.
- - intros r; exists (1 r); erewrite ra_op_unit by apply _; reflexivity.
- - intros z yz xyz [y Hyz] [x Hxyz]; exists (x · y).
- rewrite <- Hxyz, <- Hyz; symmetry; apply assoc.
- Qed.
-
- (* Do not infer this automatically: It often ends in an endless loop searching for the unit of a type which is,
- not at all, an RA. *)
- Global Program Instance pord_ra : preoType T | 5 := mkPOType ra_ord _.
- Next Obligation.
- move=> x1 x2 Rx y1 y2 Ry [t Ht].
- exists t; by rewrite -Rx -Ry.
- Qed.
-
- Global Instance ra_op_mono : Proper (pord ++> pord ++> pord) ra_op.
- Proof.
- intros x1 x2 [x EQx] y1 y2 [y EQy]. exists (x · y).
- rewrite <- assoc, (comm y), <- assoc, assoc, (comm y1), EQx, EQy; reflexivity.
- Qed.
-
- (* PDS: Are we actually searching for validity proofs? *)
- Global Instance ra_valid_ord : Proper (pord ==> flip impl) ra_valid.
- Proof. move=>t1 t2 [t' HEq]; rewrite -HEq; exact: ra_op_valid2. Qed.
-
- Lemma unit_min {r} : 1 r ⊑ r.
- Proof. exists r. exact: ra_op_unit2. Qed.
-
- Lemma ra_cancel_ord {HC : Cancellative T} {a b c : T} :
- ↓a · c -> a · b ⊑ a · c -> b ⊑ c.
- Proof.
- move=> /ra_cancel Hc [t HEq]; exists t.
- by apply: Hc; move: HEq; rewrite assoc -[t · _]comm -assoc.
- Qed.
-
- Global Instance ra_unit_proper_pord: Proper (pord ++> pord) ra_unit.
- Proof.
- move=>t1 t2 [t3 EQ]. destruct (ra_unit_mono t1 t3) as [t4 EQ'].
- exists t4. rewrite comm -EQ' -EQ comm. reflexivity.
- Qed.
-
-End Order.
-Arguments ra_op_mono {_ _ _ _ _ _} {_ _} _ {_ _} _.
-Arguments ra_valid_ord {_ _ _ _ _ _} {_ _} _ _.
-
-Section OrdTests.
- Context {S T} `{raS : RA S, raT : RA T}.
- Implicit Types (s : S) (t : T).
-
- Goal forall s1 s2 t, s1 == s2 -> (s1,t) ⊑ (s2,t).
- Proof. move=> s1 s2 t ->. reflexivity. Qed.
-End OrdTests.
-
-
-(* RAs with cartesian products of carriers. *)
-Section Pairs.
- Context {S T: Type}.
- Context `{raS : RA S, raT : RA T}.
-
- Global Instance ra_unit_prod : RA_unit (S * T) := fun st => (1 (fst st), 1 (snd st)).
- Global Instance ra_op_prod : RA_op (S * T) :=
- fun st1 st2 => (fst st1 · fst st2, snd st1 · snd st2).
- Arguments ra_op_prod !st1 !st2 /.
- Global Instance ra_valid_prod : RA_valid (S * T) :=
- fun st => ra_valid (fst st) /\ ra_valid (snd st).
- Arguments ra_valid_prod !st /.
- Global Instance ra_prod : RA (S * T).
- Proof.
- split.
- - intros [s1 t1] [s2 t2] [Heqs Heqt]. intros [s'1 t'1] [s'2 t'2] [Heqs' Heqt']. simpl in *.
- split; [rewrite -> Heqs, Heqs'|rewrite ->Heqt, Heqt']; reflexivity.
- - intros [s1 t1] [s2 t2] [s3 t3]. simpl; split; now rewrite assoc.
- - intros [s1 t1] [s2 t2]. simpl; split; now rewrite comm.
- - intros [s t]. simpl; split; now rewrite ra_op_unit.
- - move => [s1 t1] [s2 t2] [] /= EQs EQt.
- split; rewrite ?EQs ?EQt; reflexivity.
- - move => [s1 t1] [s2 t2] /=.
- destruct (ra_unit_mono s1 s2) as [s3 Hs], (ra_unit_mono t1 t2) as [t3 Ht].
- exists (s3,t3). simpl. rewrite Hs Ht. split; reflexivity.
- - intros [s t]. unfold ra_unit, ra_unit_prod. rewrite !(ra_unit_idem).
- reflexivity.
- - intros [s1 t1] [s2 t2] [Heqs Heqt]. unfold ra_valid; simpl in *.
- rewrite -> Heqs, Heqt. reflexivity.
- - intros [s1 t1] [s2 t2]. unfold ra_valid; simpl. intros [H1 H2]. split.
- + eapply ra_op_valid; now eauto.
- + eapply ra_op_valid; now eauto.
- Qed.
-
- Implicit Types (s : S) (t : T) (p : S * T).
-
- Lemma ra_op_prod_fst {p1 p2} :
- fst (p1 · p2) = fst p1 · fst p2.
- Proof.
- by move: p1=>[s1 t1]; move: p2=>[s2 t2]; reflexivity.
- Qed.
-
- Lemma ra_op_prod_snd {p1 p2} :
- snd (p1 · p2) = snd p1 · snd p2.
- Proof.
- by move: p1=>[s1 t1]; move: p2=>[s2 t2]; reflexivity.
- Qed.
-
- Lemma ra_prod_pord {p1 p2}:
- pord (preoType:=pord_ra) p1 p2 <-> (fst p1 ⊑ fst p2 /\ snd p1 ⊑ snd p2).
- Proof.
- move: p1=>[s1 t1]; move: p2=>[s2 t2]/=.
- split.
- - move=> [[s t] /= [Heqs Heqt]]. split; eexists; eassumption.
- - move=> [[s Heqs] [t Heqt]]. exists (s, t). simpl. tauto.
- Qed.
-
- Lemma ra_prod_valid {p} :
- ↓p <-> ↓fst p /\ ↓snd p.
- Proof. by move: p=>[s t]. Qed.
-
- Lemma ra_sep_prod {p1 p2} :
- ↓p1 · p2 -> ↓fst p1 · fst p2 /\ ↓snd p1 · snd p2.
- Proof. by move: p1 p2 => [s t] [s' t']. Qed.
-
- Lemma ra_fps_prod {s s' t t'} (Hs : s ⇠s') (Ht : t ⇠t') : (s,t) ⇠(s',t').
- Proof.
- move=> [fs ft] /ra_sep_prod [Hvs Hvt]; split; [exact: Hs Hvs | exact: Ht Hvt].
- Qed.
-
- Lemma ra_fps_fst {s s' t} (Hs : s ⇠s') : (s,t) ⇠(s',t).
- Proof. exact: ra_fps_prod Hs ra_fps_id. Qed.
-
- Lemma ra_fps_snd {s t t'} (Ht : t ⇠t') : (s,t) ⇠(s,t').
- Proof. exact: ra_fps_prod ra_fps_id Ht. Qed.
-
- Lemma ra_fpu_prod {s t PS PT} (Hs : s â‡âˆˆ PS) (Ht : t â‡âˆˆ PT) :
- (s,t) â‡âˆˆ fun p => PS(fst p) /\ PT(snd p).
- Proof.
- move=> [fs ft] /ra_sep_prod [Hvs Hvt].
- move/(_ _ Hvs): Hs=> [s' [HPS Hs']]; move/(_ _ Hvt): Ht=> [t' [HPT Ht']].
- by exists (s',t').
- Qed.
-
- Lemma ra_fpu_fst {s t PS} (Hs : s â‡âˆˆ PS) : (s,t) â‡âˆˆ fun p => PS(fst p) /\ t == snd p.
- Proof. exact: ra_fpu_prod Hs (ra_fpu_id (srefl t)). Qed.
-
- Lemma ra_fpu_snd {s t PT} (Ht : t â‡âˆˆ PT) : (s,t) â‡âˆˆ fun p => s == fst p /\ PT(snd p).
- Proof. exact: ra_fpu_prod (ra_fpu_id (srefl s)) Ht. Qed.
-
- Global Instance ra_can_prod {cS : Cancellative S} {cT : Cancellative T} :
- Cancellative (S * T).
- Proof.
- move=> [f f'] [a a'] [b b'] [Hv Hv'] [/= /(ra_cancel Hv)-> /(ra_cancel Hv')->].
- by split; reflexivity.
- Qed.
-
- (* THe RA order of the product is the same as the product of the RA orders *)
- Lemma ra_pord_iff_prod_pord {p1 p2}:
- pord (preoType:=pord_ra) p1 p2 <-> pord (preoType:=preoType_prod) p1 p2.
- Proof.
- rewrite ra_prod_pord /pord /=. reflexivity.
- Qed.
-End Pairs.
-Section PairVIRA.
- Context {S T: Type} `{viraS : VIRA S, viraT : VIRA T}.
-
- Global Instance vira_prod: VIRA (S * T).
- Proof.
- destruct viraS as [s HS], viraT as [t HT].
- exists (s, t).
- split; assumption.
- Qed.
-End PairVIRA.
-
-(* Thanks to multi-unit, we can have sums. But they are ugly... *)
-Section Sums.
- Context {S T: Type}.
- Context `{raS : RA S, raT : RA T}.
-
- Global Instance ra_unit_sum : RA_unit (option (S + T)) :=
- fun st => match st with
- | Some (inl s) => Some (inl (1 s))
- | Some (inr t) => Some (inr (1 t))
- | None => None
- end.
- Global Instance ra_op_sum : RA_op (option (S + T)) :=
- fun st1 st2 =>
- match st1, st2 with
- | Some (inl s1), Some (inl s2) => Some (inl (s1 · s2))
- | Some (inr t1), Some (inr t2) => Some (inr (t1 · t2))
- | _ , _ => None
- end.
- Global Instance ra_valid_sum : RA_valid (option (S + T)) :=
- fun st => match st with
- | Some (inl s) => ↓ s
- | Some (inr t) => ↓ t
- | None => False
- end.
- Definition ra_inl s: option (S + T) := Some (inl s).
- Definition ra_inr s: option (S + T) := Some (inr s).
- Global Instance ra_sum : RA (option (S + T)).
- Proof.
- split.
- - move=>[[s1|t1]|] [[s2|t2]|] /= EQ [[s3|t3]|] [[s4|t4]|] /= EQ'; try tauto.
- + rewrite EQ EQ'; reflexivity.
- + rewrite EQ EQ'; reflexivity.
- - move=>[[s1|t1]|] [[s2|t2]|] [[s3|t3]|] /=; try tauto; rewrite assoc; reflexivity.
- - move=>[[s1|t1]|] [[s2|t2]|] /=; try tauto; rewrite comm; reflexivity.
- - move=>[[s1|t1]|] /=; try tauto; apply ra_op_unit.
- - move=>[[s1|t1]|] [[s2|t2]|] /= EQ; try tauto; rewrite EQ; reflexivity.
- - move=>[[s1|t1]|] [[s2|t2]|] /=; try (eexists None; reflexivity).
- + destruct (ra_unit_mono s1 s2) as [s3 EQ]. eexists (ra_inl s3).
- simpl. assumption.
- + destruct (ra_unit_mono t1 t2) as [t3 EQ]. eexists (ra_inr t3).
- simpl. assumption.
- - move=>[[s1|t1]|] /=; rewrite /ra_unit /ra_unit_sum /=; try tauto; apply ra_unit_idem.
- - move=>[[s1|t1]|] [[s2|t2]|] /= EQ; try tauto; rewrite /ra_valid /ra_valid_sum /=; apply ra_valid_proper; assumption.
- - move=>[[s1|t1]|] [[s2|t2]|] /=; rewrite /ra_valid /ra_valid_sum /=; try tauto; apply ra_op_valid.
- Qed.
-
- (* This shows adequacy of our operation *)
- Global Instance ra_sum_cancel {cS : Cancellative S} {cT : Cancellative T} :
- Cancellative (option (S + T)).
- Proof.
- move=>[[s1|t1]|] [[s2|t2]|] [[s3|t3]|] /=; rewrite /ra_valid /ra_valid_sum /=; try tauto.
- + apply ra_cancel.
- + apply ra_cancel.
- Qed.
-
- Lemma ra_sum_inl s1 s2:
- ra_inl s1 · ra_inl s2 == ra_inl (s1 · s2).
- Proof. reflexivity. Qed.
-
- Lemma ra_sum_inr s1 s2:
- ra_inr s1 · ra_inr s2 == ra_inr (s1 · s2).
- Proof. reflexivity. Qed.
-End Sums.
-
-
-(** Morphisms between RAs. *)
-Section Morph.
- Context {T U} `{raT : RA T, raU : RA U}.
- Record RA_morphism :=
- mkRAMorph
- { ra_morph :> T -=> U;
- ra_morph_unit t : ra_morph (1 t) == 1 (ra_morph t);
- ra_morph_op {t t'} : ra_morph (t · t') == ra_morph t · ra_morph t';
- ra_morph_valid {t} : ↓t -> ↓ra_morph t }.
-End Morph.
-Arguments RA_morphism T U {eqT TU TOP TV eqU UU UOP UV} : rename.
-Infix "-ra>" := RA_morphism (at level 45, right associativity) : type_scope.
-Notation "'ra[(' f ')]'" := (mkRAMorph f _ _ _) (at level 0) : ra_scope.
-
-Section MorphEq.
- Context {T U} `{raT : RA T, raU : RA U}.
- Implicit Types (f : T -ra> U).
-
- (** Equality is pointwise. *)
- Definition ra_morph_eq f f' : Prop := forall t, f t == f' t.
- Global Instance ra_equiv_morph : Equivalence ra_morph_eq.
- Proof.
- split.
- - move=> f t. by reflexivity.
- - move=> f f' HEq t. by symmetry.
- - move=> f f' f'' HEq HEq' t. by transitivity (f' t).
- Qed.
- Global Instance ra_type_morph : Setoid (T -ra> U) := mkType ra_morph_eq.
-End MorphEq.
-
-Section Comp.
- Context {T U V} `{raT : RA T, raU : RA U, raV : RA V}.
- Implicit Types (f : T -ra> U) (g : U -ra> V).
-
- Program Definition racomp g f : T -ra> V :=
- ra[(g << f)].
- Next Obligation. rewrite (ra_morph_unit f) (ra_morph_unit g). by reflexivity. Qed.
- Next Obligation. rewrite (ra_morph_op f) (ra_morph_op g). by reflexivity. Qed.
- Next Obligation. apply: ra_morph_valid. exact: ra_morph_valid. Qed.
-End Comp.
-Infix "<RA<" := racomp (at level 35) : ra_scope.
-
-Section Id.
- Context {T} `{raT : RA T}.
-
- Program Definition raid : T -ra> T := ra[(mid T)].
- Next Obligation.
- reflexivity.
- Qed.
- Next Obligation.
- reflexivity.
- Qed.
-End Id.
-
-(* JOK : This doesn't work with multi units
-Section Const.
- Context {T U} `{raT : RA T, raU : RA U}.
-
- Program Definition raconst1 : T -ra> U := ra[(mconst 1)].
- Next Obligation. by reflexivity. Qed.
- Next Obligation. by rewrite ra_op_unit; reflexivity. Qed.
- Next Obligation. exact: ra_valid_unit. Qed.
-End Const.
-*)
-
-Section MorphLemmas.
- Context {T U V W} `{raT : RA T, raU : RA U, raV : RA V, raW : RA W}.
- Implicit Types (f : T -ra> U) (g : U -ra> V) (h : V -ra> W).
-
- (** Composition maps equal morphisms to equal morphisms. *)
- Global Instance equiv_racomp :
- Proper (equiv (A := U -ra> V) ==> equiv (A := T -ra> U) ==> equiv) racomp.
- Proof. move=> g g' Hg f f' Hf t. rewrite /= (Hf t) (Hg (f' t)). by reflexivity. Qed.
-
- (** Composition is associative, and raid is its identity. *)
- Lemma racomp_assoc f g h :
- h <RA< (g <RA< f) == (h <RA< g) <RA< f.
- Proof. move=> t. by reflexivity. Qed.
-
- Lemma racomp_idR f : f <RA< raid == f.
- Proof. move=> t. by reflexivity. Qed.
-
- Lemma racomp_idL f : raid <RA< f == f.
- Proof. move=> t. by reflexivity. Qed.
-
- (** RA-morphisms are monotone wrt ra_ord. *)
- Global Instance ra_morph_mono f : Proper (pord ==> pord) f.
- Proof.
- move=> t t' [t'' H]. exists (f t''). rewrite -ra_morph_op H. by reflexivity.
- Qed.
-End MorphLemmas.
-Arguments equiv_racomp {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} {_ _} _ {_ _} _ {_}.
-Arguments ra_morph_mono {_ _ _ _ _ _ _ _ _ _ _ _} _ {_ _} _.
-
-Section MorphProductLemmas.
- Context {S T: Type} `{raS : RA S, raT : RA T}.
- Context {U} `{raU : RA U}.
- Implicit Types (f : U -ra> S) (g : U -ra> T).
-
- Program Definition rafst : (S * T) -ra> S := ra[(mfst)].
- Next Obligation. by reflexivity. Qed.
- Next Obligation. by reflexivity. Qed.
- Next Obligation. by move: H => [H _]. Qed.
-
- Program Definition rasnd : (S * T) -ra> T := ra[(msnd)].
- Next Obligation. by reflexivity. Qed.
- Next Obligation. by reflexivity. Qed.
- Next Obligation. by move: H => [_ H]. Qed.
-
- Program Definition raprod f g : U -ra> (S * T) :=
- ra[(mprod f g)].
- Next Obligation. by split; exact: ra_morph_unit. Qed.
- Next Obligation. by split; exact: ra_morph_op. Qed.
- Next Obligation. by split; exact: ra_morph_valid. Qed.
-
- Lemma raprod_unique {f g} {h : U -ra> S * T}
- (HL : rafst <RA< h == f) (HR : rasnd <RA< h == g) :
- h == raprod f g.
- Proof. move=> u. split; [exact: HL | exact: HR]. Qed.
-End MorphProductLemmas.
-
-(* JOK: broken by multi units
-(** T -ra> U as a pointwise RA, if ·U total. *)
-(* PDS: This can likely be improved. *)
-Class RA_total (T : Type) {TOP : RA_op T} {TV : RA_valid T} :=
- ra_op_total : forall t t', ↓t -> ↓t' -> ↓(t · t').
-Section MorphRA.
- Context {T U} `{raT : RA T, raU : RA U} {totU : RA_total U}.
- Implicit Types (f : T -ra> U).
-
- Global Instance ra_unit_morph : RA_unit (T -ra> U) := raconst1.
-
- Global Program Instance ra_op_morph : RA_op (T -ra> U) :=
- fun f f' => ra[(s[(fun t => f t · f' t)])].
- Next Obligation. move=> t t' Heq. rewrite Heq. by reflexivity. Qed.
- Next Obligation. rewrite 2!ra_morph_unit ra_op_unit. by reflexivity. Qed.
- Next Obligation.
- rewrite 2!ra_morph_op -assoc [f t' · _]assoc [f t' · _]comm 3!assoc.
- by reflexivity.
- Qed.
- Next Obligation.
- move/(ra_morph_valid f): (H)=> Hf.
- move/(ra_morph_valid f'): H => Hf'.
- exact: ra_op_total.
- Qed.
-
- Global Instance ra_valid_morph : RA_valid (T -ra> U) :=
- fun f => True. (* The natural "fun f => forall t, ↓t -> ↓f t" restates ra_morph_valid.*)
-
- Global Instance ra_morph_ra : RA (T -ra> U).
- Proof.
- split.
- - move=> f f' Hf g g' Hg t /=. rewrite (Hf t) (Hg t). by reflexivity.
- - move=> f g h t /=. rewrite assoc. by reflexivity.
- - move=> f g t /=. rewrite comm. by reflexivity.
- - move=> f t/=. rewrite ra_op_unit. by reflexivity.
- - done.
- - done.
- - done.
- Qed.
-End MorphRA.
-
-Section MorphRALemmas.
- Context {T U V W} `{raT : RA T, raU : RA U, raV : RA V, raW : RA W}.
- Implicit Types (f : T -ra> U) (g : U -ra> V).
-
- Context {totV : RA_total V}.
- Context {totU : RA_total U}.
-
- (** Pre- and postcomposition as structure-preserving maps. *)
- Program Definition raprecomp f : (U -ra> V) -ra> (T -ra> V) :=
- ra[(s[(fun g => g <RA< f)])].
- Next Obligation. move=> g g' Hg t /=. rewrite (Hg (f t)). by reflexivity. Qed.
- Next Obligation. move=> t /=. by reflexivity. Qed.
- Next Obligation. move: t t' => g g' t. by reflexivity. Qed.
-
- Program Definition rapostcomp g : (T -ra> U) -ra> (T -ra> V) :=
- ra[(s[(fun f => g <RA< f)])].
- Next Obligation. move=> f f' Hf t /=. rewrite (Hf t). by reflexivity. Qed.
- Next Obligation. move=> t. exact: ra_morph_unit. Qed.
- Next Obligation. move: t t' => f f' t. exact: ra_morph_op. Qed.
-End MorphRALemmas.
-
-
-(** Sub-RAs.*)
-Class RA_sub {T} `{raT : RA T} {P : T -> Prop} : Prop :=
- mkRASub
- { ra_sub_unit : P 1;
- ra_sub_op {t t'} : P t -> P t' -> P (t · t') }.
-Arguments RA_sub {_ _ _ _ _ _} _.
-Arguments mkRASub {_ _ _ _ _ _ _} _ _.
-
-Section Subra.
- Context {T} `{subT : RA_sub T}.
-
- Let sub := { t : T | P t }.
-
- Global Instance ra_type_sub : Setoid sub := subset_type.
- Global Instance ra_unit_sub : RA_unit sub := exist P 1 ra_sub_unit.
- Global Program Instance ra_op_sub : RA_op sub := fun a b => `a · `b.
- Next Obligation. move: a b=> [a Ha] [b Hb]. by exact: ra_sub_op. Qed.
- Global Instance ra_valid_sub : RA_valid sub := fun a => ↓ (`a).
- Global Instance ra_sub : RA sub.
- Proof.
- split.
- - move=> a a' Ha b b' Hb. move: Ha Hb=>/=->->. by reflexivity.
- - move=> a b c. rewrite /= assoc. by reflexivity.
- - move=> a b. rewrite /= comm. by reflexivity.
- - move=> a. rewrite /= ra_op_unit. by reflexivity.
- - rewrite/ra_valid/ra_valid_sub. by move=> a a' ->.
- - rewrite/ra_valid/ra_valid_sub. exact: ra_valid_unit.
- - rewrite/ra_valid/ra_valid_sub. by move=> a b /ra_op_valid.
- Qed.
-
- (* The inclusion is an RA-morphism. *)
- Program Definition raincl : sub -ra> T := ra[(mincl)].
- Next Obligation.
- reflexivity.
- Qed.
- Next Obligation.
- reflexivity.
- Qed.
-
- (* The inclusion is monic. *)
- Context {U} `{raU : RA U}.
- Lemma raforget_mono {f g : U -ra> sub}
- (Heq : raincl <RA< f == raincl <RA< g) :
- f == g.
- Proof. move=> u. exact: Heq. Qed.
-
- (** If we have a morphism from U to T whose image is in the subset
- determined by P, then this morphism restricts to the one into
- the subset determined by P. *)
- Program Definition rainherit (f : U -ra> T) (HU : forall u, P (f u))
- : U -ra> sub := ra[(s[(minherit f HU)])].
- Next Obligation. exact: ra_morph_unit. Qed.
- Next Obligation. exact: ra_morph_op. Qed.
- Next Obligation. exact: ra_morph_valid. Qed.
-
- Lemma ra_sep_sub {a b : sub} : ↓a · b ->↓ `a · `b.
- Proof. done. Qed.
-
- Lemma ra_fps_sub {t t': T} (Ht : P t) (Hu : t ⇠t') (Ht' : P t') :
- (exist P t Ht) ⇠(exist P t' Ht').
- Proof. move=> f; exact: Hu. Qed.
-
- Lemma ra_fpu_sub {t : T} {B : T -> Prop}
- (Ht : P t) (Hu : t â‡âˆˆ B) (HT : forall t, B t -> P t) :
- (exist P t Ht) â‡âˆˆ (B ∘ (@proj1_sig T P))%prg.
- Proof.
- move=> [f Hf] /ra_sep_sub HSep. move/(_ _ HSep): Hu => [t' [HB Ht']].
- by exists (exist P t' (HT _ HB)).
- Qed.
-End Subra.
-Arguments ra_sub {_ _ _ _ _ _ _} _ : clear implicits.
-
-(** The image of an RA-morphism is a sub-RA. *)
-(* PDS: This is ad hoc. *)
-Section Image.
- Context {T U} `{raT : RA T, raU : RA U} (f : T -ra> U).
-
- Definition in_rng u := exists t, f t == u.
- Global Instance ra_sub_img : RA_sub in_rng.
- Proof.
- apply: mkRASub.
- - exists (1 : T). exact: ra_morph_unit.
- - move=> u u' [t Ht] [t' Ht']. exists (t · t').
- rewrite ra_morph_op Ht Ht'. by reflexivity.
- Qed.
- Definition raimg := ra_sub ra_sub_img.
- Program Definition raimginj : T -ra> {u | in_rng u} :=
- rainherit f _.
- Next Obligation. move: u=> t. by exists t; reflexivity. Qed.
-End Image.
-(*
- Let f : T -> U.
- Define image and pre-image as usual:
- f> : (T -> Prop) -> U -> Prop
- (f>P)u if ∃t. t=fu ∧ Pt
- f< : (U -> Prop) -> T -> Prop
- (f<Q)t if Q(ft)
-
- f induces FPU's (writing a ⇠B : M for a FPU in M):
- If ta â‡âˆˆ tB : T,
- then (f ta) â‡âˆˆ (f>tB) : U.
-
- If (f<{ua}) â‡âˆˆ (f<uB) : U,
- then (f<{ua}) â‡âˆˆ (f<uB) : T.
-*)
- *)
-
-
-
-(* Package an RA as a module type (for use with other modules). *)
-Module Type RA_T.
-
- Parameter res : Type.
- Declare Instance res_type : Setoid res.
- Declare Instance res_op : RA_op res.
- Declare Instance res_unit : RA_unit res.
- Declare Instance res_valid : RA_valid res.
- Declare Instance res_ra : RA res.
-
-End RA_T.
-
-Module Type VIRA_T.
-
- Include RA_T.
- Declare Instance res_vira : VIRA res.
-
-End VIRA_T.
diff --git a/lib/ModuRes/RAConstr.v b/lib/ModuRes/RAConstr.v
deleted file mode 100644
index 43b6fd4a40eb6d86968fd704566bc31357530d6d..0000000000000000000000000000000000000000
--- a/lib/ModuRes/RAConstr.v
+++ /dev/null
@@ -1,938 +0,0 @@
-Require Import Ssreflect.ssreflect Omega.
-Require Import CSetoid Predom RA DecEnsemble ModuRes.Relations.
-Require Import Coq.Logic.Eqdep_dec.
-
-Local Open Scope ra_scope.
-Local Open Scope predom_scope.
-
-Set Bullet Behavior "Strict Subproofs".
-
-(** These constructions are only for RA, so their equality is also defined locally. *)
- (* PDS: Huh? *)
-
-(** The exclusive RA. *)
-Section Exclusive.
- Context {T: Type} {eqT : Setoid T}.
-
- Inductive ex: Type :=
- | ex_own: T -> ex
- | ex_unit: ex
- | ex_bot: ex.
-
- Implicit Types (r s : ex) (t : T).
-
- Definition ex_eq r s: Prop :=
- match r, s with
- | ex_own t1, ex_own t2 => t1 == t2
- | ex_unit, ex_unit => True
- | ex_bot, ex_bot => True
- | _, _ => False
- end.
-
- Global Instance ra_equiv_ex : Equivalence ex_eq.
- Proof.
- split.
- - intros [t| |]; simpl; now auto.
- - intros [t1| |] [t2| |]; simpl; now auto.
- - intros [t1| |] [t2| |] [t3| |]; simpl; try now auto.
- + intros ? ?. etransitivity; eassumption.
- Qed.
-
- Global Program Instance ra_type_ex : Setoid ex :=
- mkType ex_eq.
-
- Global Instance ex_own_compat : Proper (equiv ==> equiv) ex_own.
- Proof. by move=> t1 t2 EQt. Qed.
-
- Global Instance ra_unit_ex : RA_unit _ := fun _ => ex_unit.
- Global Instance ra_op_ex : RA_op _ :=
- fun r s =>
- match r, s with
- | ex_own _, ex_unit => r
- | ex_unit, ex_own _ => s
- | ex_unit, ex_unit => ex_unit
- | _, _ => ex_bot
- end.
- Global Instance ra_valid_ex : RA_valid _ :=
- fun r => match r with
- | ex_bot => False
- | _ => True
- end.
-
- Global Instance ra_ex : RA ex.
- Proof.
- split.
- - intros [t1| |] [t2| |] Heqt [t'1| |] [t'2| |] Heqt'; simpl; now auto.
- - intros [s1| |] [s2| |] [s3| |]; reflexivity.
- - intros [s1| |] [s2| |]; reflexivity.
- - intros [s1| |]; reflexivity.
- - intros [t1| |] [t2| |] Heqt; unfold ra_valid; simpl in *; now auto.
- - intros t1 t2. exists ex_unit. reflexivity.
- - intros [t | |]; reflexivity.
- - intros [t1| |] [t2| |] Heqt; unfold ra_valid; simpl in *; now auto.
- - intros [t1| |] [t2| |]; unfold ra_valid; simpl; now auto.
- Qed.
-
- Lemma ra_sep_ex {t r} : ↓ex_own t · r -> r = 1 r.
- Proof. by case: r. Qed.
-
- Lemma ra_fps_ex_any t {r} (Hr : ↓r) : ex_own t ⇠r.
- Proof. by move=> f /ra_sep_ex ->; rewrite (ra_op_unit2 (t := r)). Qed.
-
- Lemma ra_fps_ex t t' : ex_own t ⇠ex_own t'.
- Proof. exact: ra_fps_ex_any. Qed.
-
- Global Instance ra_can_ex : Cancellative ex.
- Proof.
- case=>[t ||] a b Hv HEq.
- - by rewrite (ra_sep_ex Hv); move: Hv; rewrite -HEq=> /ra_sep_ex->; reflexivity.
- - by move: HEq; rewrite (ra_op_unit (t:=a)) (ra_op_unit (t:=b)).
- - by exfalso.
- Qed.
-
- Global Instance ra_vira_ex : VIRA ex.
- Proof.
- exists ex_unit. exact I.
- Qed.
-
- Lemma ex_own_le t r t':
- ex_own t ⊑ r -> r ⊑ ex_own t' ->
- t == t'.
- Proof.
- move=>[r1 Heq1] [r2 Heq2]. destruct r1, r2, r; simpl in *; try contradiction; [].
- rewrite Heq1 Heq2. reflexivity.
- Qed.
-
-End Exclusive.
-Arguments ex T : clear implicits.
-
-
-Section ExTests.
- Context {T : Type} {eqT : Setoid T}.
- Implicit Types (t : T).
-
- Goal forall t1 t2, t1 == t2 -> ex_own t1 == ex_own t2.
- Proof. move=> t1 t2 ->. reflexivity. Qed.
-
- Context {U} `{raU : RA U}.
- Implicit Types (u : U).
-
- Goal forall t1 t2 u, t1 == t2 -> (ex_own t1,u) ⊑ (ex_own t2,u).
- Proof. move=> t1 t2 u ->. reflexivity. Qed.
-
- Goal forall t u1 u2, u1 == u2 -> (ex_own t,u1) == (ex_own t,u2).
- Proof. move=> t u1 u2 ->. reflexivity. Qed.
-End ExTests.
-
-(** Adjoining a valid unit element onto an RA. *)
-Section AddUnit.
- Context {T : Type} `{raT : RA T}.
-
- Inductive ra_add_unit :=
- | au_inj of T
- | au_unit.
-
- Implicit Types (t : T) (r s : ra_add_unit).
-
- Let ra_au_eq r s : Prop :=
- match r, s with
- | au_inj t, au_inj t' => t == t'
- | au_unit, au_unit => True
- | _, _ => False
- end.
-
- Global Instance ra_equiv_au : Equivalence ra_au_eq.
- Proof.
- split; rewrite/ra_au_eq.
- - by move=>[] // t; reflexivity.
- - by move=>[] // t [] // t'; symmetry.
- - move=> [?|] [t2|] [?|] //; []; by transitivity t2.
- Qed.
-
- Global Instance ra_type_au : Setoid ra_add_unit := mkType ra_au_eq.
-
- Global Instance ra_au_compat : Proper (equiv ==> equiv) au_inj.
- Proof. by []. Qed.
-
- Global Instance ra_unit_au : RA_unit ra_add_unit :=
- fun r => if r is au_inj t then au_inj (1 t) else r.
-
- Global Instance ra_op_au : RA_op ra_add_unit := fun r s =>
- match r, s with
- | au_inj t, au_inj t' => au_inj (t · t')
- | au_unit, _ => s
- | _, au_unit => r
- end.
-
- Global Instance ra_valid_au : RA_valid ra_add_unit :=
- fun r => if r is au_inj t then ↓t else True.
-
- Global Instance ra_au : RA ra_add_unit.
- Proof.
- split.
- - move=> [t1|] [t'1|] /= EQ1 [t2|] [t'2|] /= EQ2 //; []. rewrite EQ1 EQ2. by reflexivity.
- - move=> [t1|] [t2|] [t3|] /=; try reflexivity; []. rewrite assoc. by reflexivity.
- - move=> [t1|] [t2|] /=; try reflexivity; []. rewrite comm. by reflexivity.
- - move=> [t|] //=; []. rewrite ra_op_unit. by reflexivity.
- - move=> [t1|] [t2|] /= EQt //=; []. exact: ra_unit_proper.
- - move=> [t1|] [t2|] /=; try (exists au_unit; by reflexivity).
- + case: (ra_unit_mono t1 t2) => [t3 Ht]. by exists (au_inj t3).
- + exists (au_inj (1 t2)). by reflexivity.
- - move=> [t1|] //=; []. exact: ra_unit_idem.
- - move=> [t1|] [t2|] /= EQt //; []. rewrite/ra_valid/ra_valid_au. exact: ra_valid_proper.
- - move=> [t1|] [t2|] /= EQt //; []. rewrite/ra_valid/ra_valid_au. exact: ra_op_valid.
- Qed.
-
- Lemma ra_unit_min_au r : au_unit ⊑ r.
- Proof. by exists r; case: r; reflexivity. Qed.
-
- Lemma ra_unit_auE t : 1 (au_inj t) = au_inj (1 t).
- Proof. by []. Qed.
-
- Lemma ra_valid_auE r : ↓r -> (exists t, r = au_inj t /\ ↓t) \/ r = au_unit.
- Proof.
- case: r; last by right. move=> t Hv. by left; exists t.
- Qed.
-
- Lemma ra_sep_au {t r} : ↓au_inj t · r -> if r is au_inj t' then ↓t · t' else ↓t.
- Proof. by case: r. Qed.
-
- Lemma ra_fpu_au {t P} (Hupd : t â‡âˆˆ P) :
- au_inj t â‡âˆˆ (fun r => if r is au_inj t' then P t' else False).
- Proof.
- case=>[tf |].
- { move/ra_sep_au/(Hupd tf) => [t' [HP Hv]]. by exists (au_inj t'). }
- move/ra_sep_au; rewrite -(ra_op_unit2 (t:=t)) =>/(Hupd (1 t)) [t' [HP Hv]].
- exists (au_inj t'). split; first done.
- rewrite/ra_op/ra_op_au/ra_valid/ra_valid_au. exact: ra_op_valid Hv.
- Qed.
-
- Lemma ra_fps_au {t t'} (Hstep : t ⇠t') : au_inj t ⇠au_inj t'.
- Proof.
- case=> [tf |] /ra_sep_au; first exact: Hstep.
- rewrite -(ra_op_unit2 (t:=t)). by move/Hstep/ra_op_valid.
- Qed.
-
-End AddUnit.
-Arguments ra_add_unit : clear implicits.
-
-(** The authoritative RA. *)
-Section Authoritative.
- Context {T} `{raT : RA T}.
-
- CoInductive auth := Auth of ex T * T.
-
- Implicit Types (x : ex T) (g t u : T) (r s : auth).
-
- Let auth_eq r s : Prop :=
- match r, s with
- | Auth p, Auth p' => p == p'
- end.
-
- Global Instance ra_equiv_auth : Equivalence auth_eq.
- Proof.
- split.
- - by move=> [p]; rewrite/auth_eq; reflexivity.
- - by move=> [p] [p']; rewrite/auth_eq; symmetry.
- - by move=> [p1] [p2] [p3]; rewrite/auth_eq; transitivity p2.
- Qed.
- Global Instance ra_type_auth : Setoid auth := mkType auth_eq.
-
- Section Compat.
- Variable R : relation (ex T * T).
-
- Let RA : relation auth := fun r1 r2 =>
- match r1, r2 with Auth p1, Auth p2 => R p1 p2 end.
-
- Global Instance auth_compat : Proper(R ==> RA) Auth.
- Proof. by move=> p1 p2 Rp. Qed.
- End Compat.
-
- Global Instance ra_unit_auth : RA_unit auth :=
- fun a => match a with
- | Auth (e,t) => Auth(ex_unit, 1 t)
- end.
-
- Global Instance ra_op_auth : RA_op auth := fun r s =>
- match r, s with Auth(x, t), Auth(x', t') => Auth(x·x', t·t') end.
-
- Global Instance ra_valid_auth : RA_valid auth := fun r =>
- match r with
- | Auth(ex_unit, t) => ↓t
- | Auth(ex_own g, t) => ↓g /\ ↓t /\ t ⊑ g
- | Auth(ex_bot, _) => False
- end.
-
- Global Instance ra_auth : RA auth.
- Proof.
- split.
- - move=> [[x1 t1]] [[x1' t1']] [/= Hx1 Ht1] [[x2 t2]] [[x2' t2']] [/= Hx2 Ht2].
- by rewrite Hx1 Ht1 Hx2 Ht2; split; reflexivity.
- - by move=> [[x1 t1]] [[x2 t2]] [[x3 t3]] /=; split; rewrite assoc; reflexivity.
- - by move=> [[x1 t1]] [[x2 t2]] /=; split; rewrite comm; reflexivity.
- - move=> [[s t]] /=. split; last (rewrite ra_op_unit; reflexivity).
- destruct s; reflexivity.
- - move => [[x1 t1]] [[x2 t2]]. by firstorder.
- - move => [[x1 t1]] [[x2 t2]].
- destruct (ra_unit_mono x1 x2) as [x3 Hx], (ra_unit_mono t1 t2) as [t3 Ht].
- exists (Auth (x3, t3)); split; assumption.
- - move=> [[x t]]. unfold ra_unit, ra_unit_auth. rewrite !ra_unit_idem.
- reflexivity.
- - move=> [[x t]] [[x' t']] [/= Hx Ht].
- rewrite/ra_valid/ra_valid_auth.
- move: Hx; case: x=>[g||]; case: x'=>[g'||] => //= Hg.
- + by rewrite Ht Hg.
- + by rewrite Ht.
- - move=> [[x t]] [[x' t']]. rewrite /ra_op/ra_op_auth/ra_valid/ra_valid_auth.
- case: x=>[g||]; case: x'=>[g'||] //=.
- + move=>[Hg [Htv [t'' Ht]]]; split; [done | split; [exact: ra_op_valid Htv |]].
- exists (t'' · t'); by rewrite -assoc [t' · _]comm.
- + move=>[_ [Htv _]]; exact: ra_op_valid Htv.
- + exact: ra_op_valid.
- Qed.
-
- Lemma ra_sep_auth {t u x u'} :
- ↓Auth(ex_own t, u) · Auth(x, u') -> ↓t /\ x == ex_unit /\ ↓u · u' /\ u · u' ⊑ t.
- Proof.
- case: x=>[g||]; [done | | done].
- rewrite {1}/ra_valid/ra_valid_auth {1}/ra_op/ra_op_auth.
- by move=> [Ht [HSep HLe]].
- Qed.
-
- Definition auth_side_cond t u t' (Pu': T -> Prop) : Prop :=
- ↓u -> forall tf, t · tf ⊑ u -> exists u', Pu' u' /\ t' · tf ⊑ u' /\ ↓u'.
-
- (* This is the strongest lemma for auth-FPU we found. Everything else will be derived from this. *)
- Lemma ra_fpu_auth_general {t u t' Pu'} {Pn': auth -> Prop} (SIDE : auth_side_cond t u t' Pu') :
- (forall u', Pu' u' -> Pn' (Auth(ex_own u', t'))) ->
- Auth(ex_own u, t) â‡âˆˆ Pn'.
- Proof.
- move=>HPn' [[xf tf]] /ra_sep_auth [Htu [Hxf [Htf HLe]]].
- move:(SIDE Htu _ HLe)=>{SIDE} [u' [HPu' [HLe' Hval]]].
- exists (Auth (ex_own u', t')). split; first now apply HPn'.
- rewrite/ra_valid/ra_valid_auth [Auth _ · _]/ra_op/ra_op_auth.
- move: Hxf; case: xf=>[g||] H; [done| clear H |done]. (* i.e., "rewrite Hxf" despite the match. *)
- rewrite {1}/ra_op/ra_op_ex.
- split; first done.
- split; last done.
- destruct HLe' as [w HEq].
- eapply ra_op_valid2. now erewrite HEq.
- Qed.
-
- (* The following two lemmas for FPU and FPS are good enough for everything we need, and they
- have a precondition that one can actually give some intuition to.
- auth_steps is slightly stronger than auth_side_cond: Think of "tf" below being
- both "tf" and the "w" hidden in ⊑ above. Then auth_side_cond allows changing
- "w" to anything else, whereas auth_steps enforces using the same "w". *)
- Definition auth_steps t u t' Pu' : Prop :=
- ↓u -> forall tf, t · tf == u -> exists u', Pu' u' /\ t' · tf == u' /\ ↓u'.
-
- Lemma ra_fpu_auth {t u t' Pu'} {Pn': auth -> Prop} (STEPS : auth_steps t u t' Pu') :
- (forall u', Pu' u' -> Pn' (Auth(ex_own u', t'))) ->
- Auth(ex_own u, t) â‡âˆˆ Pn'.
- Proof.
- apply ra_fpu_auth_general. move=>Hu tf [w HEq].
- specialize (STEPS Hu (tf · w)). move:STEPS. case.
- - rewrite -HEq (comm w) assoc. reflexivity.
- - move=>u' [HPu' [HEq' Hu']]. exists u'. split; first assumption. split; last assumption.
- exists w. rewrite -HEq' (comm w) assoc. reflexivity.
- Qed.
-
- Definition auth_step t u t' u' : Prop :=
- ↓u -> forall tf, t · tf == u -> t' · tf == u' /\ ↓u'.
-
- Lemma ra_fps_auth {t u t' u'} (STEP: auth_step t u t' u'):
- Auth(ex_own u, t) ⇠Auth(ex_own u', t').
- Proof.
- apply ra_fpu_fps. eapply (ra_fpu_auth (Pu':=equiv u') (t':=t')).
- - move=>Hu tf Heq. exists u'. split; first reflexivity. exact: STEP.
- - move=>u'' ->. reflexivity.
- Qed.
-
- (* Some derived forms of the lemma above. But really, when proving in Coq,
- using ra_fps_auth directly is the easiest way forward *)
- Lemma ra_fps_auth_canc {HC : Cancellative T} t {u t'} (Hu' : ↓t' · u) :
- Auth(ex_own(t · u), t) ⇠Auth(ex_own(t' · u), t').
- Proof.
- apply: ra_fps_auth.
- move=> Hu tf HLe.
- split; last done.
- move: Hu. move/ra_cancel. move/(_ _ HLe)=>->. reflexivity.
- Qed.
-
- Definition ra_local_action (act : T -=> T) : Prop :=
- forall t tf, ↓act t -> ↓t · tf -> act(t · tf) == (act t) · tf.
-
- Lemma ra_op_local t: ra_local_action (ra_op_s t).
- Proof.
- move=>t' tf Hact Hcomp. simpl. rewrite assoc. reflexivity.
- Qed.
-
- Lemma ra_fps_auth_local {act t u} (HL : ra_local_action act) (Hu' : ↓act t · u) :
- Auth(ex_own(t · u), t) ⇠Auth(ex_own(act t · u), act t).
- Proof.
- eapply ra_fps_auth.
- move=>Hval tf HEq. split; last assumption.
- transitivity (act (t · u)).
- - rewrite -HEq. symmetry. eapply HL.
- + eapply ra_op_valid. eassumption.
- + rewrite HEq. assumption.
- - eapply HL; last assumption.
- eapply ra_op_valid. eassumption.
- Qed.
-End Authoritative.
-Arguments auth : clear implicits.
-(*
-Notation "• g" := (Auth (ex_own g,1)) (at level 48) : ra_scope.
-Notation "∘ t" := (Auth (1,t)) (at level 48) : ra_scope.
-*)
-
-Section AuthTests.
- Context {T : Type} `{raT : RA T}.
- Implicit Types (x : ex T) (t : T).
-
- Goal forall x t1 t2, t1 == t2 -> Auth(x,t1) == Auth(x,t2).
- Proof. move=> x t1 t2 EQt. rewrite EQt. reflexivity. Qed.
-
- Goal forall x1 x2 t, x1 == x2 -> Auth(x1,t) == Auth(x2,t).
- Proof. move=> x1 x2 t EQx. rewrite EQx. reflexivity. Qed.
-End AuthTests.
-
-
-Section DecAgreement.
- Context T (eq_dec : DecEq T).
- Local Open Scope ra_scope.
-
- Inductive ra_dagree : Type :=
- | dag_bottom
- | dag_inj (t : T).
-
- Global Instance ra_unit_dagree : RA_unit ra_dagree :=
- fun x => x.
- Global Instance ra_valid_dag : RA_valid _ :=
- fun x => match x with dag_bottom => False | _ => True end.
- Global Instance ra_op_dag : RA_op _ :=
- fun x y => match x, y with
- | dag_inj t1, dag_inj t2 =>
- if dec_eq t1 t2 is left _ then dag_inj t1 else dag_bottom
- | _ , _ => dag_bottom
- end.
-
- Definition ra_eq_dag (x y: ra_dagree): Prop :=
- match x,y with
- | dag_inj t1, dag_inj t2 => t1 = t2
- | x, y => x = y
- end.
-
-
- Global Instance ra_equivalence_agree : Equivalence ra_eq_dag.
- Proof.
- split; intro; intros; destruct x; try (destruct y; try destruct z); simpl; try reflexivity;
- simpl in *; try inversion H; try inversion H0; try rewrite <- H; try rewrite <- H0; try firstorder.
- Qed.
- Global Instance ra_type_dagree : Setoid ra_dagree := mkType ra_eq_dag.
- Global Instance res_dagree : RA ra_dagree.
- Proof.
- split; repeat intro.
- - repeat (match goal with [ x : ra_dagree |- _ ] => destruct x end);
- simpl in *; try discriminate || reflexivity || assumption; [].
- unfold ra_op, ra_op_dag.
- destruct (dec_eq t2 t0), (dec_eq t1 t); simpl; auto; exfalso; apply n; congruence.
- - repeat (match goal with [ x : ra_dagree |- _ ] => destruct x end);
- simpl in *; try discriminate || reflexivity || assumption;
- compute; try destruct (eq_dec _ _); try reflexivity; [].
- destruct (eq_dec t0 t), (eq_dec t1 t0), (eq_dec t1 t); simpl; auto; exfalso; apply n; congruence.
- - destruct t1, t2; try reflexivity; compute; destruct (eq_dec t0 t), (eq_dec t t0);
- try reflexivity; auto; try contradiction; symmetry in e; contradiction.
- - destruct t; try reflexivity; []. rewrite/ra_unit/ra_op/=. by rewrite DecEq_refl.
- - destruct x, y; simpl; firstorder; now inversion H.
- - case Ht: t => [| t1]; [by exists (1 t'); case: t' |].
- case Ht': t' => [| t2]; rewrite/ra_unit/ra_op/=.
- + by exists dag_bottom.
- + case: (dec_eq t1 t2); [|by exists dag_bottom]. exists (dag_inj t1).
- by rewrite DecEq_refl.
- - destruct t; reflexivity.
- - destruct x, y; simpl; firstorder; now inversion H.
- - destruct t1, t2; try contradiction; now constructor.
- Qed.
-
- Lemma ra_sep_dag_gen {t r} : ↓dag_inj t · r -> r = dag_inj t.
- Proof.
- case: r; [done |] => t' Hv; f_equal; move: Hv.
- by rewrite/ra_op/=; case: (dec_eq t t').
- Qed.
-
- Lemma ra_sep_dag {t t'} : ↓dag_inj t · dag_inj t' -> t = t'.
- Proof. by move/ra_sep_dag_gen => [ ->]. Qed.
-
-End DecAgreement.
-
-Section STS.
- Context {S T: Type}. (* the types of states and tokens. We ignore their Setoids. *)
- Local Instance STS_States_discrete : Setoid S := discreteType.
- Definition Toks := DecEnsemble T.
- Context (step: relation S) (tok: S -> Toks).
-
- Local Open Scope de_scope.
-
- Definition tokstep: relation (S * Toks) :=
- fun st1 st2 => match st1, st2 with
- | (s1, t1), (s2, t2) => step s1 s2 /\ (tok s1) # t1 /\ (tok s2) # t2 /\
- (tok s1) ∪ t1 == (tok s2) ∪ t2
- end.
-
- Local Instance tokstep_equiv: Proper (equiv ==> equiv ==> equiv) tokstep.
- Proof.
- move=>[s11 t11] [s12 t12] /= [EQs1 EQt1] [s21 t21] [s22 t22] [EQs2 EQt2]. unfold tokstep.
- simpl in *.
- hnf in EQs2. hnf in EQs1. subst.
- rewrite EQt1 EQt2. reflexivity.
- Qed.
-
- Definition toksteps := refl_trans_closure tokstep.
-
- Lemma toksteps_toks t1 s1 t2 s2:
- tok s1 # t1 ->
- toksteps (s1, t1) (s2, t2) ->
- tok s2 # t2 /\ (tok s1) ∪ t1 == (tok s2) ∪ t2.
- Proof.
- move=>Hdisj Hsteps. remember (s1, t1) as st1. remember (s2, t2) as st2.
- revert s1 t1 s2 t2 Hdisj Heqst1 Heqst2. induction Hsteps; intros; subst.
- - destruct H as [EQs EQt]. simpl in *. hnf in EQs. subst s2. rewrite EQt -EQt. now split.
- - destruct Ï2 as [s3 t3]. destruct H as [_ [Htok1 [Htok2 Hpres]]].
- move:IHHsteps. move/(_ _ _ _ _ Htok2 eq_refl). move/(_ s2 t2 eq_refl)=>[Htok3 Hpres'].
- split; first assumption.
- etransitivity; eassumption.
- Qed.
-
- Definition tframestep t: relation S :=
- fun s1 s2 => step s1 s2 /\ tok s1 # t /\ tok s2 # t.
-
- Local Instance tframestep_equiv: Proper (equiv ==> equiv ==> equiv ==> equiv) tframestep.
- Proof.
- move=>t1 t2 EQt s11 s12 EQs1 s21 s22 EQs2.
- rewrite /tframestep EQs1 EQs2 EQt. reflexivity.
- Qed.
-
-(* Local Instance tframestep_equiv_t t: Proper (equiv ==> equiv ==> equiv) (tframestep t).
- Proof.
- eapply tframestep_equiv. reflexivity.
- Qed.*)
-
- Definition tframesteps t := refl_trans_closure (tframestep t).
-
- Lemma tframesteps_toks t s1 s2:
- tok s1 # t ->
- tframesteps t s1 s2 ->
- tok s2 # t.
- Proof.
- move=>Htok Hstep. revert Htok. induction Hstep.
- - rewrite H. tauto.
- - destruct H as [_ Htoks]. tauto.
- Qed.
-
- Local Instance tframesteps_equiv: Proper (equiv ==> equiv) tframesteps.
- Proof.
- move=>t1 t2 EQt. rewrite /tframesteps.
- eapply refl_trans_closure_r_equiv.
- move=>s1 s2. now rewrite EQt.
- Qed.
-
- Lemma tokstep_framestep {s1 t1 s2 t2} tf:
- tf # (tok s1 ∪ t1) ->
- tokstep (s1, t1) (s2, t2) ->
- tframestep tf s1 s2.
- Proof.
- intros Hdisj (Hstep & Hdisj1 & Hdisj2 & Hpres).
- split; first assumption.
- split.
- - clear Hdisj2 Hpres. de_auto_eq.
- - clear Hdisj1. de_auto_eq.
- Qed.
-
- Lemma toksteps_framesteps {s1 t1 s2 t2} tf:
- tf # (tok s1 ∪ t1) ->
- toksteps (s1, t1) (s2, t2) ->
- tframesteps tf s1 s2.
- Proof.
- move=>Hdisj Hsteps. remember (s1, t1) as st1. remember (s2, t2) as st2.
- revert s1 t1 s2 t2 Hdisj Heqst1 Heqst2. induction Hsteps; intros.
- - subst. destruct H as [EQs _]. apply rt_refl. apply EQs.
- - subst. destruct Ï2 as [s3 t3]. eapply rt_step.
- + eapply tokstep_framestep; eassumption.
- + eapply IHHsteps; try reflexivity. destruct H as [_ [_ H]]. de_auto_eq.
- Qed.
-
- Lemma tframestep_smaller s1 s2 t1 t2:
- t1 ⊑ t2 ->
- tframestep t2 s1 s2 ->
- tframestep t1 s1 s2.
- Proof.
- intros Hle (Hstep & Hdisj1 & Hdisj2).
- split; split_conjs.
- - assumption.
- - clear Hdisj2. de_auto_eq.
- - clear Hdisj1. de_auto_eq.
- Qed.
-
- Lemma tframesteps_smaller s1 s2 t1 t2:
- t1 ⊑ t2 ->
- tframesteps t2 s1 s2 ->
- tframesteps t1 s1 s2.
- Proof.
- move=>Hle. induction 1.
- - now apply rt_refl.
- - eapply rt_step; last eassumption.
- eapply tframestep_smaller; eassumption.
- Qed.
-
- Definition upclosed (ss: S -> Prop) (t: Toks): Prop :=
- forall s1 s2, ss s1 -> tframesteps t s1 s2 -> ss s2.
-
- Lemma upclosed_bystep (ss: S -> Prop) t:
- (forall s1 s2, ss s1 -> tframestep t s1 s2 -> ss s2) ->
- upclosed ss t.
- Proof.
- move=>Hstep s1 s2 Hs1.
- induction 1.
- - rewrite -H. assumption.
- - eapply IHrefl_trans_closure, Hstep.
- + eassumption.
- + assumption.
- Qed.
-
- Definition upclose (ss: S -> Prop) (t: Toks): S -> Prop :=
- fun s' => exists s, ss s /\ tframesteps t s s'.
-
- Local Instance upclose_equiv: Proper (equiv ==> equiv ==> equiv) upclose.
- Proof.
- move=>ss1 ss2 EQss t1 t2 EQt s.
- split; intros [s' [Hs' Hstep]]; (exists s'; split; first now apply EQss).
- - eapply tframesteps_equiv; last eassumption.
- now symmetry.
- - eapply tframesteps_equiv; last eassumption.
- assumption.
- Qed.
-
- Lemma upclose_upclosed ss t:
- upclosed (upclose ss t) t.
- Proof.
- move=>s1 s2 [s1' [Hs1 Hsteps1]] Hsteps2.
- exists s1'. split; first assumption.
- eapply rt_trans; try (now apply _); eassumption.
- Qed.
-
- Lemma upclose_incl (ss: S -> Prop) t:
- forall s, ss s -> upclose ss t s.
- Proof.
- move=>s H. exists s. split; first assumption.
- apply rt_refl. reflexivity.
- Qed.
-
- Lemma upclose_noop (ss: S -> Prop) t (Hadisj: forall s, ss s -> tok s # t):
- upclosed ss t ->
- upclose ss t == ss.
- Proof.
- move=>Hclosed s. split.
- - move=>[s' [Hs' Hstep]].
- eapply Hclosed; eassumption.
- - eapply upclose_incl.
- Qed.
-
- CoInductive STSMon :=
- | STSEl: forall (ss: S -> Prop) (t: Toks) (v: Prop), upclosed ss t -> (forall s, ss s -> tok s # t) -> STSMon.
-
- Definition STS_ss (el: STSMon) :=
- let (ss, _, _, _, _) := el in ss.
-
- Definition STS_t (el: STSMon) :=
- let (_, t, _, _, _) := el in t.
-
- Local Ltac sts_destr := repeat (match goal with [ x : STSMon |- _ ] => destruct x end).
-
- Definition STS_eq: relation STSMon :=
- fun el1 el2 => match el1, el2 with
- | STSEl ss1 t1 v1 _ _, STSEl ss2 t2 v2 _ _ => ss1 == ss2 /\ t1 == t2 /\ v1 == v2
- end.
-
- Global Instance STS_equiv: Equivalence STS_eq.
- Proof.
- split.
- - intros ?. sts_destr; simpl. split_conjs; reflexivity.
- - intros ? ?. sts_destr; simpl. intros [EQs ?].
- split_conjs; now symmetry.
- - intros ? ? ?. sts_destr; simpl. intros [EQs1 [EQt1 EQv1]] [EQs2 [EQt2 EQv2]].
- split_conjs; try (etransitivity; eassumption).
- Qed.
-
- Global Instance STS_Type: Setoid STSMon := mkType STS_eq.
-
- Global Instance STS_valid: RA_valid STSMon :=
- fun el => let (ss, _, v, _, _) := el in v /\ (exists s, ss s).
-
- Program Definition STS_upclose (ss: S -> Prop) (t: Toks): STSMon :=
- let ss' := (fun s' => ss s' /\ tok s' # t) in
- STSEl (upclose ss' t) t True _ _.
- Next Obligation.
- apply upclose_upclosed.
- Qed.
- Next Obligation.
- destruct H as [s' [[Hss Htok]] _].
- eapply tframesteps_toks; eassumption.
- Qed.
-
- Definition STS_upclose1 s t := STS_upclose (fun s' => s' = s) t.
-
- Program Definition STS_upclose_notok (ss: S -> Prop): STSMon :=
- STSEl (upclose ss de_emp) de_emp True _ _.
- Next Obligation.
- apply upclose_upclosed.
- Qed.
- Next Obligation.
- rewrite de_emp_isect. reflexivity.
- Qed.
-
- Lemma STS_upclose_notok_eq ss:
- STS_upclose_notok ss == STS_upclose ss de_emp.
- Proof.
- split; last (split; reflexivity).
- eapply upclose_equiv; last reflexivity.
- move=>s. split; last tauto.
- move=>H. split; first eassumption.
- de_auto_eq.
- Qed.
-
- Definition STS_upclose1_notok (s: S): STSMon := STS_upclose_notok (fun s' => s' = s).
-
- Global Instance STS_unit: RA_unit STSMon :=
- fun el => let (ss, t, v, uc, d) := el in STS_upclose_notok ss.
-
- Global Program Instance STS_op: RA_op STSMon :=
- fun el1 el2 => match el1, el2 with
- | STSEl ss1 t1 v1 uc1 d1, STSEl ss2 t2 v2 uc2 d2 =>
- STSEl (fun s => ss1 s /\ ss2 s)
- (t1 ∪ t2) (v1 /\ v2 /\ t1 # t2) _ _
- end.
- Next Obligation.
- apply upclosed_bystep.
- move=>s1 s2 [Hss1 Hss2] Hstep.
- assert(Hss1': ss1 s2).
- { eapply uc1; first eassumption.
- eapply rt_onestep, tframestep_smaller, Hstep.
- de_auto_eq. }
- assert(Hss2': ss2 s2).
- { eapply uc2; first eassumption.
- eapply rt_onestep, tframestep_smaller, Hstep.
- de_auto_eq. }
- split_conjs; assumption.
- Qed.
- Next Obligation.
- specialize (d1 _ H). specialize (d2 _ H0). de_auto_eq.
- Qed.
-
- Global Instance STS_RA: RA STSMon.
- Proof.
- split.
- - intros el1 el2. sts_destr. intros [EQs1 [EQt1 EQv1]] el3 el4. sts_destr. intros [EQs3 [EQt3 EQv3]]. split; last split.
- + move=>s. simpl. rewrite (EQs1 s) (EQs3 s). reflexivity.
- + now rewrite EQt1 EQt3.
- + now rewrite EQt1 EQt3 EQv1 EQv3.
- - intros el1 el2 el3. sts_destr. split; last (split; first (now rewrite assoc)); last first.
- { split; intros H; split_conjs; try tauto; de_auto_eq. }
- intro s. split; intros [Hin1 Hin2]; tauto.
- - intros el1 el2. sts_destr. split; last (split; first (now rewrite comm)).
- + intro s. split; tauto.
- + rewrite comm. split; tauto.
- - move=>t. sts_destr. split; last (split; first now rewrite comm de_emp_union); last first.
- { split=>H; first tauto. split_conjs; try tauto; de_auto_eq. }
- move=>s. split=>Hss; first tauto.
- split_conjs.
- + exists s. split; first assumption. now apply rt_refl.
- + assumption.
- - move=>el1 el2. sts_destr. move =>[EQs [EQt EQv]]. split; last (split; reflexivity).
- rewrite EQs. reflexivity.
- - move=>t t'. exists (1 (t · t')). sts_destr. split; last (split; first now rewrite de_emp_union); last first.
- { split=>H; last tauto. split_conjs; try tauto; de_auto_eq. }
- move=>s. split.
- + intros [s' H]. split_conjs.
- * exists s'. tauto.
- * exists s'. tauto.
- + intros [_ [s'' [[Hs' Hs''] Hsteps'']]].
- exists s''. tauto.
- - move=>t. sts_destr. simpl. split; last (split; reflexivity).
- apply upclose_noop; last exact: upclose_upclosed.
- move=>s _. de_auto_eq.
- - apply proper_sym_impl_iff; try (now apply _). move=>el1 el2. sts_destr. move =>[EQs [EQt EQv]] [Hv [s Hinh]].
- split; first now apply EQv. exists s. now apply EQs.
- - move=>t1 t2. sts_destr. move=>[Hv [s Hinh]].
- split; first tauto.
- exists s. tauto.
- Qed.
-
- Lemma sts_pord st1 st2:
- ↓st2 ->
- (st1 ⊑ st2 <-> (↓st1 /\ STS_t st1 ⊑ STS_t st2 /\ STS_ss st2 == (fun s => STS_ss st1 s /\ upclose (STS_ss st2) (STS_t st2 \ STS_t st1) s))).
- Proof.
- move=>Hval. destruct st1 as [ss1 t1 v1 u1 d1], st2 as [ss2 t2 v2 u2 d2]. split.
- - move=>[[ss3 t3 v3 u3 d3] Heq]. split_conjs; simpl; last (destruct Heq as [Heq_ss [Heq_t Heq_v]]=>s; split).
- + eapply ra_op_valid2. erewrite Heq. assumption.
- + destruct Heq. de_auto_eq.
- + move=>Hss2. split; first now apply Heq_ss.
- exists s. split; first assumption. now apply rt_refl.
- + move=>[Hss1 [s' [Hss2 Hsteps]]]. apply Heq_ss. split; last assumption.
- eapply (u3 s'); first (now eapply Heq_ss). eapply tframesteps_smaller; last eassumption.
- destruct Hval as [Hval _]. apply Heq_v in Hval. de_auto_eq.
- - destruct Hval as [Hval Hinh]. simpl.
- move=>[[Hval' Hinh'] [Htincl Hseq]].
- exists (STS_upclose ss2 (t2 \ t1)). split; last split; last first.
- + split; first tauto. move=>_. split_conjs; try tauto. de_auto_eq.
- + de_auto_eq.
- + move=>s. split; last first.
- { move=>Hss2. split; last now apply Hseq.
- exists s. split_conjs; first assumption.
- - specialize (d2 _ Hss2). de_auto_eq.
- - apply rt_refl. reflexivity. }
- move=>[[s' [[Hss2 Htok] Hstep]] Hss1].
- apply Hseq. split; first assumption. exists s'. split; assumption.
- Qed.
-
- (* Now we become authoritative *)
- Definition STSauth := auth STSMon.
- Definition STSAuth := (@Auth STSMon).
-
- Lemma sts_fupd st_a st_l s t s' t'
- (Hstart: STS_ss st_a s /\ t = STS_t st_l) (* we start somewhere in st_a, with the tokens from st_l *) :
- toksteps (s, t) (s', t') ->
- STSAuth (ex_own st_a, st_l) â‡âˆˆ (fun n => exists st_an, STS_ss st_an s' /\ n == STSAuth (ex_own st_an, STS_upclose1 s' t')).
- Proof.
- destruct Hstart as [Hs Ht]. move=>Hsteps.
- eapply (ra_fpu_auth (Pu':=fun st_an => STS_ss st_an s') (t':=STS_upclose1 s' t')); last first.
- { move=>u' Hu'. exists u'. split; assumption || reflexivity. }
- move=>Hval tf HEq.
- assert (Hatoks: t ⊑ STS_t st_a).
- { sts_destr. destruct HEq as [_ [Htoks _]]. subst t. simpl. clear -Htoks. de_auto_eq. }
- assert (Hastoks: tok s # STS_t st_a).
- { clear -Hatoks Hs. destruct st_a as [? ? ? ? a_d]. simpl. eapply a_d; eassumption. }
- assert (Hsteptoks: tok s' # t' /\ tok s ∪ t == tok s' ∪ t').
- { apply toksteps_toks; last assumption. de_auto_eq. }
- assert (Htf: ↓tf).
- { eapply ra_op_valid2. erewrite HEq. assumption. }
- destruct tf as [tf_ss tf_t tf_v tf_u tf_d].
- assert (Htf_ss: tf_ss s).
- { sts_destr. destruct HEq as [Heq_ss _]. eapply Heq_ss. eexact Hs. }
- assert (Hdisj_tf: tf_t # tok s ∪ t).
- { move:(tf_d _ Htf_ss)=>Hdisj {Htf_ss}. rewrite <-HEq in Hval.
- clear -Hval Hdisj Ht. sts_destr. destruct Hval as [Hval _]. rewrite Ht /=. de_auto_eq. }
- assert (Htf_ss': tf_ss s').
- { eapply tf_u; first eexact Htf_ss.
- eapply toksteps_framesteps; eassumption. }
- exists (STS_upclose1 s' t' · (STSEl tf_ss tf_t tf_v tf_u tf_d)). split_conjs.
- - split; last assumption. exists s'. split; last now apply rt_refl.
- split; first reflexivity. tauto.
- - reflexivity.
- - split.
- + split; first done. split; first now apply Htf. de_auto_eq.
- + exists s'. split; last assumption. exists s'. split; last now apply rt_refl.
- split; first reflexivity. tauto.
- Qed.
-
-End STS.
-
-Section IndexedProduct.
- (* I is the index type (domain), S the type of the components (codomain) *)
- Context {I : Type} {eq_dec : DecEq I} {S : forall (i : I), Type}
- {tyS : forall i, Setoid (S i)}
- {uS : forall i, RA_unit (S i)}
- {opS : forall i, RA_op (S i)}
- {vS : forall i, RA_valid (S i)}
- {raS : forall i, RA (S i)}.
- Local Open Scope ra_scope.
-
- Definition ra_res_infprod := forall (i : I), S i.
-
- Implicit Type (i : I) (f g : ra_res_infprod).
-
- Definition ra_eq_infprod := fun f g => forall i, f i == g i.
- Global Instance ra_equiv_infprod : Equivalence ra_eq_infprod.
- Proof. split; repeat intro; [ | rewrite (H i) | rewrite -> (H i), (H0 i) ]; reflexivity. Qed.
-
- Global Instance ra_type_infprod : Setoid ra_res_infprod | 15 := mkType ra_eq_infprod. (* low priority, this is a fairly generic type... *)
- Global Instance ra_unit_infprod : RA_unit ra_res_infprod := fun t => fun i => 1 (t i).
- Global Instance ra_op_infprod : RA_op ra_res_infprod := fun f g i => f i · g i.
- Global Instance ra_valid_infprod : RA_valid ra_res_infprod := fun f => forall i, ↓ (f i).
- Global Instance ra_infprod : RA ra_res_infprod.
- Proof.
- split; repeat intro.
- - exact: ra_op_proper.
- - compute; now rewrite -> (assoc (T := S i) (t1 i) (t2 i) (t3 i)).
- - compute; now rewrite -> (comm (T :=S i) (t1 i) (t2 i)).
- - compute; now rewrite -> (ra_op_unit (RA := raS i) (t := t i)).
- - compute. rewrite (H i); reflexivity.
- - exists (fun i => proj1_sig (ra_unit_mono (t i) (t' i)))=>i.
- unfold ra_op, ra_op_infprod. move:(ra_unit_mono (t i) (t' i))=>[t'' Heq].
- etransitivity; last eapply Heq. reflexivity.
- - rewrite /ra_unit /ra_unit_infprod ra_unit_idem. reflexivity.
- - compute; intros; split; intros; by move/(_ i): H0; rewrite (H i).
- - eapply (ra_op_valid (RA := raS i)); now eauto.
- Qed.
-
- Definition ra_infprod_upd (f : ra_res_infprod) (i : I) (si : S i) : ra_res_infprod :=
- fun i' => if eq_dec i i' is left Heq then eq_rect _ _ si _ Heq else f i'.
-
- Lemma ra_infprod_upd_eq f i si : ra_infprod_upd f i si i = si.
- Proof.
- rewrite/ra_infprod_upd. case: (eq_dec i i); last done.
- move=> Heq. symmetry. apply: eq_rect_eq_dec. exact: eq_dec.
- Qed.
-
- Lemma ra_infprod_upd_neq {i i'} (Hneq : i <> i') f si : ra_infprod_upd f i si i' = f i'.
- Proof. rewrite/ra_infprod_upd. by case: (eq_dec i i'). Qed.
-
- Lemma ra_infprod_upd_valid {f i si g} (Hv : ↓f · g) (Hvi : ↓si · g i) : ↓ra_infprod_upd f i si · g.
- Proof.
- move=> i'; rewrite/ra_op/ra_op_infprod; case: (eq_dec i i') => [Heq | Hneq].
- - rewrite -Heq ra_infprod_upd_eq. exact: Hvi.
- - rewrite (ra_infprod_upd_neq Hneq). exact: Hv.
- Qed.
-
- Lemma ra_fpu_infprod {f i P} (Hi : f i â‡âˆˆ P) :
- f â‡âˆˆ (fun f' => exists si, P si /\ f' = ra_infprod_upd f i si).
- Proof.
- move=> g Hv; move/(_ (g i) (Hv i)): Hi => [si [Pi Hvi]].
- exists (ra_infprod_upd f i si). split; first by exists si. exact: ra_infprod_upd_valid.
- Qed.
-
- Lemma ra_fps_infprod {f i si} (Hi : f i ⇠si) : f ⇠ra_infprod_upd f i si.
- Proof.
- move=> g Hv i'; move/(_ i'): Hv. rewrite/ra_op/ra_op_infprod/=.
- case: (eq_dec i i') => [Heq | Hneq].
- - rewrite -Heq ra_infprod_upd_eq. exact: Hi.
- - by rewrite (ra_infprod_upd_neq Hneq).
- Qed.
-
-End IndexedProduct.
-Arguments ra_res_infprod : default implicits.
-
-
-Section HomogeneousProduct.
- (* I is the index type (domain), S the type of the components (codomain) *)
- Context {I : Type} {S : Type} `{RA S}.
-
- Global Instance ra_unit_homprod : RA_unit (forall (i : I), S) := ra_unit_infprod.
- Global Instance ra_op_homprod : RA_op (forall (i : I), S) := ra_op_infprod.
- Global Instance ra_valid_homprod : RA_valid (forall (i : I), S) := ra_valid_infprod.
- Global Instance ra_homprod : RA (forall (i : I), S).
- Proof.
- split; repeat intro.
- - now apply ra_op_proper.
- - now apply ra_op_assoc.
- - now apply ra_op_comm.
- - now apply ra_op_unit.
- - now apply ra_unit_proper.
- - destruct (ra_unit_mono t t') as [i Hi]. exists i. apply Hi.
- - now apply ra_unit_idem.
- - now apply ra_valid_proper.
- - eapply ra_op_valid. eapply H0.
- Qed.
-End HomogeneousProduct.
-
diff --git a/lib/ModuRes/Relations.v b/lib/ModuRes/Relations.v
deleted file mode 100644
index f5e8200fd5b540a8dfeabbddf4351a6c5e9d8974..0000000000000000000000000000000000000000
--- a/lib/ModuRes/Relations.v
+++ /dev/null
@@ -1,75 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Import CSetoid.
-
-(* Reflexive, transitive closure of relations *)
-Section ReflTransClosure.
- Context {T: Type} {eqT: Setoid T} (R: relation T).
- Context {R_proper: Proper (equiv ==> equiv ==> equiv) R}.
-
- Inductive refl_trans_closure : relation T :=
- | rt_refl Ï Ï' : equiv Ï Ï' -> refl_trans_closure Ï Ï'
- | rt_step Ï1 Ï2 Ï3 : R Ï1 Ï2 -> refl_trans_closure Ï2 Ï3 -> refl_trans_closure Ï1 Ï3.
-
- Global Instance refl_trans_closure_equiv: Proper (equiv ==> equiv ==> equiv) refl_trans_closure.
- Proof.
- apply proper_sym_impl_iff_2; try (now apply _).
- move=>r1 r2 EQr s1 s2 EQs H. revert r2 s2 EQr EQs. induction H; intros.
- - apply: rt_refl. by rewrite -EQr -EQs.
- - eapply rt_step.
- + rewrite -EQr; eassumption.
- + eapply IHrefl_trans_closure; eassumption || reflexivity.
- Qed.
-
- Lemma rt_trans Ï1 Ï2 Ï3 : refl_trans_closure Ï1 Ï2 -> refl_trans_closure Ï2 Ï3 -> refl_trans_closure Ï1 Ï3.
- Proof.
- revert Ï3. induction 1.
- - rewrite H. tauto.
- - move=>H'. eauto using refl_trans_closure.
- Qed.
-
- Lemma rt_onestep Ï1 Ï2: R Ï1 Ï2 -> refl_trans_closure Ï1 Ï2.
- Proof.
- move=>H.
- eapply rt_step; last eapply rt_refl.
- - eassumption.
- - reflexivity.
- Qed.
-
- Inductive n_closure : nat -> relation T :=
- | n_O Ï Ï' : Ï == Ï' -> n_closure O Ï Ï'
- | n_S Ï1 Ï2 Ï3 n
- (HS : R Ï1 Ï2)
- (HSN : n_closure n Ï2 Ï3) :
- n_closure (S n) Ï1 Ï3.
-
- Lemma refl_trans_n {Ï1 Ï2} :
- refl_trans_closure Ï1 Ï2 -> exists n, n_closure n Ï1 Ï2.
- Proof.
- induction 1.
- - eexists. eauto using n_closure.
- - destruct IHrefl_trans_closure as [n IH]. eexists. eauto using n_closure.
- Qed.
-
- Lemma n_refl_trans {n Ï1 Ï2}:
- n_closure n Ï1 Ï2 -> refl_trans_closure Ï1 Ï2.
- Proof.
- induction 1; now eauto using refl_trans_closure.
- Qed.
-End ReflTransClosure.
-
-Section ReflTransClosureProps.
- Context {T: Type} {eqT: Setoid T}.
-
- Global Instance refl_trans_closure_r_equiv: Proper (equiv ==> equiv) refl_trans_closure.
- Proof.
- assert(Himpl: forall R1 R2, R1 == R2 -> forall t1 t2, refl_trans_closure R1 t1 t2 -> refl_trans_closure R2 t1 t2).
- { move=>R1 R2 EQR t1 t2. induction 1.
- - apply rt_refl. assumption.
- - eapply rt_step.
- + eapply EQR. eassumption.
- + assumption.
- }
- move=>R1 R2 EQR t1 t2.
- split; apply Himpl; assumption || symmetry; assumption.
- Qed.
-End ReflTransClosureProps.
\ No newline at end of file
diff --git a/lib/ModuRes/SPred.v b/lib/ModuRes/SPred.v
deleted file mode 100644
index b0a3fd28d9d1dcb53b9d8c2ff5df239de6a2d3ef..0000000000000000000000000000000000000000
--- a/lib/ModuRes/SPred.v
+++ /dev/null
@@ -1,430 +0,0 @@
-Require Import Ssreflect.ssreflect Omega.
-Require Export PreoMet BI.
-
-Section Definitions.
- Program Definition dclosed (p : nat -> Prop) :=
- forall n m (HLe : m <= n), p n -> p m.
-
- Record SPred :=
- mkSPred {spred :> nat -> Prop;
- bpred : spred 0;
- dpred : dclosed spred }.
-
-End Definitions.
-Arguments dpred {s} {n m} _ _.
-Arguments mkSPred _ _ _.
-Notation "'p[(' f ')]'" := (mkSPred f _ _).
-
-Section Props.
- Program Definition sp_const P :=
- p[(fun n => match n return _ with
- | O => True
- | S _ => P end)].
- Next Obligation.
- move=>n m Hle. destruct m, n; simpl; tauto || inversion Hle.
- Qed.
-
- Definition sp_equiv (p q : SPred) := forall n, p n == q n.
-
- Global Instance sp_equiv_e: Equivalence sp_equiv.
- Proof.
- split.
- - intros p n; reflexivity.
- - intros p q Hpq n; symmetry; apply Hpq.
- - intros p q r Hpq Hqr n; etransitivity; [apply Hpq | apply Hqr].
- Qed.
-
- Global Program Instance sp_type : Setoid SPred := mkType sp_equiv.
-
- Definition sp_dist n (p q : SPred) :=
- forall m, m <= n -> (p m <-> q m).
-
- Global Program Instance sp_metric : metric SPred := mkMetr sp_dist.
- Next Obligation.
- intros p q Hpq r s Hrs; split; intros HD m HLt; [symmetry in Hpq, Hrs |];
- rewrite -> (Hpq m), (Hrs m); apply HD; assumption.
- Qed.
- Next Obligation.
- split; intros HEq.
- - intros n; apply (HEq (S n)); auto with arith.
- - intros _ m _; apply HEq.
- Qed.
- Next Obligation.
- intros p q Hpq m HLt; symmetry; apply Hpq, HLt.
- Qed.
- Next Obligation.
- intros p q r Hpq Hqr m HLt; etransitivity; [apply Hpq, HLt | apply Hqr, HLt].
- Qed.
- Next Obligation.
- intros m HLt; apply H; auto with arith.
- Qed.
- Next Obligation.
- intros m Hle. destruct m; last omega.
- split; intro; apply bpred.
- Qed.
-
- Lemma spredNE {P1 P2 : SPred} {n} (EQP : P1 = n = P2) : P1 n -> P2 n.
- Proof. by apply EQP. Qed.
-
- Program Definition sp_compl (σ : chain SPred) (σc : cchain σ) :=
- p[(fun n => σ n n)].
- Next Obligation.
- apply bpred.
- Qed.
- Next Obligation.
- intros n m HLt HSub.
- eapply (chain_cauchy σ σc m n); auto with arith; [].
- eapply dpred; eassumption.
- Qed.
-
- Global Program Instance sp_cmetric : cmetric SPred := mkCMetr sp_compl.
- Next Obligation.
- intros n; intros i HLe k HLt; simpl.
- eapply (chain_cauchy σ σc k); eauto with arith.
- Qed.
-
- Definition sp_ord (p q : SPred) := forall n, p n -> q n.
-
- Global Program Instance sp_preotype : preoType SPred := mkPOType sp_ord _.
- Next Obligation.
- split.
- + intros p n; tauto.
- + intros p q r Hpq Hqr n Hp; apply Hqr, Hpq, Hp.
- Qed.
- Next Obligation.
- move=> p1 p2 Rp q1 q2 Rq HLe n.
- rewrite -(Rp n) -(Rq n).
- exact: HLe.
- Qed.
-
- Global Instance sp_pcmetric : pcmType SPred.
- Proof.
- split.
- + intros σ Ï Ïƒc Ïc HSub n Hpc; simpl in *; apply HSub, Hpc.
- Qed.
-
- Global Instance spred_equiv : Proper (equiv ==> eq ==> iff) spred.
- Proof.
- add_morphism_tactic; intros R1 R2 EQR n; split; intros HH; apply EQR; assumption.
- Qed.
-
- Global Instance spred_pord : Proper (pord ++> le --> Basics.impl) spred.
- Proof.
- intros R1 R2 SubR n1 n2 Len HR1; eapply SubR, dpred; eassumption.
- Qed.
-
- Definition laterF (p : nat -> Prop) n :=
- match n with
- | O => True
- | S n => p n
- end.
- Program Definition later_sp (p : SPred) :=
- p[(laterF p)].
- Next Obligation.
- intros [| m] [| n] HLe; simpl; try tauto; [now inversion HLe |].
- intros HP; eapply dpred; [| eassumption]; auto with arith.
- Qed.
-
- Global Instance later_sp_equiv : Proper (equiv ==> equiv) later_sp.
- Proof.
- intros P Q EQPQ [| n]; simpl; [reflexivity | apply EQPQ].
- Qed.
-
- Global Instance later_sp_contractive: contractive later_sp.
- Proof.
- move=>n P Q EQ m Hle. split=>H; (destruct m as [|m]; first exact I); simpl in *; (eapply EQ; [omega|assumption]).
- Qed.
-
- Global Instance later_sp_dist n : Proper (dist n ==> dist n) later_sp.
- Proof.
- pose (lf := contractive_nonexp later_sp _).
- move=> ? ? ?.
- by apply: (met_morph_nonexp lf).
- Qed.
-
- Lemma equiv_spred_simpl U (R : relation U) (f : U -> SPred) {RS : Symmetric R}
- (HP : forall u1 u2 n, R u1 u2 -> f u1 n -> f u2 n) :
- Proper (R ==> equiv) f.
- Proof.
- split; intros HF;
- eapply HP; eassumption || symmetry; eassumption.
- Qed.
- Lemma dist_spred_simpl U (R : relation U) (f : U -> SPred) n {RS : Symmetric R}
- (HP : forall u1 u2 m (HLt : m <= n), R u1 u2 -> f u1 m -> f u2 m) :
- Proper (R ==> dist n) f.
- Proof.
- split; intros HF;
- eapply HP; eassumption || symmetry; eassumption.
- Qed.
-
- Lemma equiv_spred_simpl2 U V (RU : relation U) (RV : relation V) (f : U -> V -> SPred) {US : Symmetric RU} {VS : Symmetric RV}
- (HP : forall u1 u2 v1 v2 n, RU u1 u2 -> RV v1 v2 -> f u1 v1 n -> f u2 v2 n) :
- Proper (RU ==> RV ==> equiv) f.
- Proof.
- split; intros HF;
- eapply HP; eassumption || symmetry; eassumption.
- Qed.
- Lemma dist_spred_simpl2 U V (RU : relation U) (RV : relation V) (f : U -> V -> SPred) n {US : Symmetric RU} {VS : Symmetric RV}
- (HP : forall u1 u2 v1 v2 m (HLt : m <= n), RU u1 u2 -> RV v1 v2 -> f u1 v1 m -> f u2 v2 m) :
- Proper (RU ==> RV ==> dist n) f.
- Proof.
- split; intros HF;
- eapply HP; eassumption || symmetry; eassumption.
- Qed.
-
-End Props.
-
-Section SPredBI.
- Local Obligation Tactic := intros; eauto with typeclass_instances.
-
- (* Standard interpretations of propositional connectives. *)
- Global Program Instance top_sp : topBI SPred :=
- p[(fun _ => True)]. (* this behaves nicer than sp_c *)
- Next Obligation.
- repeat intro. exact I.
- Qed.
-
- Global Program Instance bot_sp : botBI SPred := sp_const False.
-
- Global Program Instance valid_sp : validBI SPred :=
- fun s => forall n, s n.
-
- Global Program Instance and_sp : andBI SPred :=
- fun P Q =>
- p[(fun n => P n /\ Q n)].
- Next Obligation.
- split; now apply bpred.
- Qed.
- Next Obligation.
- intros n m HLe; rewrite-> HLe; tauto.
- Qed.
- Global Program Instance or_sp : orBI SPred :=
- fun P Q =>
- p[(fun n => P n \/ Q n)].
- Next Obligation.
- left. now apply bpred.
- Qed.
- Next Obligation.
- intros n m HLe; rewrite-> HLe; tauto.
- Qed.
-
- Global Instance and_sp_equiv : Proper (equiv ==> equiv ==> equiv) and_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ n; simpl.
- rewrite-> EQP, EQQ; split; tauto.
- Qed.
- Global Instance and_sp_dist n : Proper (dist n ==> dist n ==> dist n) and_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ m HLt; simpl.
- split; intros; (split; [apply EQP | apply EQQ]; now auto with arith).
- Qed.
- Global Instance and_sp_ord : Proper (pord ==> pord ==> pord) and_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ n; simpl.
- rewrite-> EQP, EQQ; tauto.
- Qed.
-
- Global Instance or_sp_equiv : Proper (equiv ==> equiv ==> equiv) or_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ n; simpl.
- rewrite ->EQP, EQQ; hnf; tauto.
- Qed.
- Global Instance or_sp_dist n : Proper (dist n ==> dist n ==> dist n) or_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ m HLt; simpl.
- split; (intros [HP | HQ]; [left; apply EQP | right; apply EQQ]; now auto with arith).
- Qed.
- Global Instance or_sp_ord : Proper (pord ==> pord ==> pord) or_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ n; simpl.
- rewrite ->EQP, EQQ; tauto.
- Qed.
-
- Global Program Instance lattice_sp : Lattice SPred.
- Next Obligation.
- split; auto.
- Qed.
- Next Obligation.
- intros n _; exact I.
- Qed.
- Next Obligation.
- intros n HC; destruct n; last contradiction HC.
- apply bpred.
- Qed.
- Next Obligation.
- split.
- - intros HV n _. apply HV.
- - intros HV n. now apply HV.
- Qed.
- Next Obligation.
- move=>H. exact:(H 1).
- Qed.
- Next Obligation.
- intros n; simpl; tauto.
- Qed.
- Next Obligation.
- intros n [HP HQ]; assumption.
- Qed.
- Next Obligation.
- intros n [HP HQ]; assumption.
- Qed.
- Next Obligation.
- intros n HP; left; assumption.
- Qed.
- Next Obligation.
- intros n HQ; right; assumption.
- Qed.
- Next Obligation.
- intros n; simpl; tauto.
- Qed.
-
- Global Program Instance impl_sp : implBI SPred :=
- fun P Q =>
- p[(fun n => forall m, m <= n -> P m -> Q m)].
- Next Obligation.
- destruct m; last omega.
- apply bpred.
- Qed.
- Next Obligation.
- intros n m HLe HImp k HLe' HP.
- apply HImp; try (etransitivity; eassumption); assumption.
- Qed.
-
- (* BI connectives: Boring. We'd actually want just a Heyting Algebra for SPred, but whatever. *)
- Global Instance sc_sp : scBI SPred := and_sp.
- Global Instance si_sp : siBI SPred := impl_sp.
-
- (* For some reason tc inference gets confused otherwise *)
- Existing Instance sp_type.
-
- Global Instance impl_sp_dist n : Proper (dist n ==> dist n ==> dist n) impl_sp.
- Proof.
- intros P1 P2 EQP Q1 Q2 EQQ m HLt; simpl.
- split; intros; apply EQQ, H, EQP; now eauto with arith.
- Qed.
-
- Global Instance sc_sp_equiv : Proper (equiv ==> equiv ==> equiv) sc_sp := and_sp_equiv.
- Global Instance sc_sp_dist n : Proper (dist n ==> dist n ==> dist n) sc_sp := and_sp_dist n.
- Global Instance sc_sp_ord : Proper (pord ==> pord ==> pord) sc_sp := and_sp_ord.
-
- Global Instance si_sp_dist n : Proper (dist n ==> dist n ==> dist n) si_sp := impl_sp_dist n.
-
- (* Quantifiers. *)
- Global Program Instance all_sp : allBI SPred :=
- fun T eqT mT cmT R =>
- p[(fun n => forall t, R t n)].
- Next Obligation.
- apply bpred.
- Qed.
- Next Obligation.
- intros n m HLe HR t. rewrite-> HLe; apply HR.
- Qed.
-
- Definition xist_spF {T: Type} (R: T -> SPred) n :=
- match n with
- | O => True
- | S _ => exists t, R t n
- end.
- Global Program Instance xist_sp : xistBI SPred :=
- fun T eqT mT cmT R =>
- p[(xist_spF R)].
- Next Obligation.
- exact I.
- Qed.
- Next Obligation.
- intros n m HLe. destruct n.
- { destruct m; last omega. intro; exact I. }
- intros [t HR]. destruct m; first exact I.
- exists t; rewrite-> HLe; apply HR.
- Qed.
-
- Section Quantifiers.
- Context V `{cmV : cmetric V}.
-
- Existing Instance nonexp_type.
-
- Global Instance all_sp_dist n : Proper (dist (T := V -n> SPred) n ==> dist n) all.
- Proof.
- intros R1 R2 EQR m HLt; simpl.
- split; intros; apply EQR; now auto.
- Qed.
-
- Global Instance xist_sp_dist n : Proper (dist (T := V -n> SPred)n ==> dist n) xist.
- Proof.
- intros R1 R2 EQR m HLt; simpl.
- destruct m; first reflexivity.
- split; intros [t HR]; exists t; apply EQR; now auto.
- Qed.
-
- End Quantifiers.
-
- Global Program Instance cbi_sp : ComplBI SPred.
- Next Obligation.
- split; intros HH n.
- - intros HP m HLe HQ; apply HH; split; [rewrite-> HLe |]; assumption.
- - intros [HP HQ]; eapply HH; eassumption || reflexivity.
- Qed.
- Next Obligation.
- intros n; split; simpl; tauto.
- Qed.
- Next Obligation.
- split; intros HH n; simpl in *.
- - intros HP m HLe HQ. apply HH. split; last assumption. rewrite-> HLe. assumption.
- - intros [HP HQ]. eapply HH; try eassumption; omega.
- Qed.
- Next Obligation.
- split.
- - intros HH v n HP. apply HH; assumption.
- - intros HH v n HP. apply HH. assumption.
- Qed.
- Next Obligation.
- split.
- - intros HH n. destruct n; first (intro; exact: bpred).
- intros [u HP]; eapply HH; eassumption.
- - intros HH u n. destruct n; first (intro; exact: bpred).
- intros HP; apply HH; exists u; assumption.
- Qed.
-
-End SPredBI.
-
-Section SPredEq.
- Global Program Instance sp_eq : eqBI SPred :=
- fun U {eqU mU cmU u1 u2} => p[(fun n => u1 = n = u2)].
- Next Obligation.
- exact:dist_bound.
- Qed.
- Next Obligation.
- move=>n m Hle. simpl. eapply mono_dist. omega.
- Qed.
-
- Global Instance sp_eq_dist {U} `{pU : cmetric U} n: Proper (dist n ==> dist n ==> dist n) (@sp_eq U _ _ _).
- Proof.
- move=>u1 u2 EQu t1 t2 EQt m Hle. simpl. split=>EQ.
- - transitivity u1.
- { symmetry. eapply mono_dist; last eassumption. omega. }
- transitivity t1; first assumption.
- eapply mono_dist; last eassumption. omega.
- - transitivity u2.
- { eapply mono_dist; last eassumption. omega. }
- transitivity t2; first assumption.
- symmetry. eapply mono_dist; last eassumption. omega.
- Qed.
-
- Global Instance eqbi_sp : EqBI SPred.
- Proof.
- split; intros.
- - move=>u1 u2 EQu t1 t2 EQt n. simpl. rewrite ->EQu, EQt. reflexivity.
- - apply _.
- - move=>n. rewrite /= -/dist. split.
- + move=>EQ P m HLe HP.
- assert (P u1 = n = P u2) by now rewrite EQ. apply H; first omega. assumption.
- + move=>HP. pose(φ := n[(sp_eq _ _ _ _ u1)]). specialize (HP φ n (le_refl _)). eapply HP.
- simpl. reflexivity.
- Qed.
-
- Lemma sp_eq_iff U `{cmU: cmetric U} {u1 u2: U} n:
- ((intEq u1 u2):SPred) n <-> u1 = n = u2.
- Proof.
- reflexivity.
- Qed.
-End SPredEq.
diff --git a/lib/ModuRes/Util.v b/lib/ModuRes/Util.v
deleted file mode 100644
index 8de64a13952ab45723105f7db19844556e8ef027..0000000000000000000000000000000000000000
--- a/lib/ModuRes/Util.v
+++ /dev/null
@@ -1,73 +0,0 @@
-Require Import Ssreflect.ssreflect.
-Require Import Setoid SetoidClass.
-Require Import Eqdep_dec.
-
-Ltac find_rewrite1 t0 t1 := match goal with
- | H: t0 = t1 |- _ => rewrite-> H
- | H: t0 == t1 |- _ => rewrite-> H
- | H: t1 = t0 |- _ => rewrite<- H
- | H: t1 == t0 |- _ => rewrite<- H
- end.
-Ltac find_rewrite2 t0 t1 t2 := find_rewrite1 t0 t1; find_rewrite1 t1 t2.
-Ltac find_rewrite3 t0 t1 t2 t3 := find_rewrite2 t0 t1 t2; find_rewrite1 t2 t3.
-
-
-(* A tactic for dependant destruct. Essentially, the tactic allows you to declare which
- occurences of a term you want to be replaced by the destructed form. If you choose
- correctly, the result will be a well-typed term.
- Usually, you can obtain the list of indices as follows:
- * List the indices of occurences of T that are *outisde* of the return function
- of a dependant match.
- * Increrment every index by 2, and add 1 to the list
- The last step is necessary because ddes adds two more occurences of the term before doing
- the actual pattern-matching, of which you only want to replace the first. *)
-Tactic Notation "ddes" constr(T) "at" integer_list(pos) "as" simple_intropattern(pat) "deqn:" ident(EQ) :=
- (generalize (@eq_refl _ (T)) as EQ; pattern (T) at pos;
- destruct (T) as pat; move => EQ).
-
-Ltac split_conjs := repeat (match goal with [ |- _ /\ _ ] => split end).
-
-Lemma de_ft_eq: false = true <-> False.
-Proof.
- split; tauto || discriminate.
-Qed.
-Lemma de_tf_eq: true = false <-> False.
-Proof.
- split; tauto || discriminate.
-Qed.
-Lemma de_tt_eq: true = true <-> True.
-Proof.
- split; intros; tauto || reflexivity.
-Qed.
-Lemma de_ff_eq: false = false <-> True.
-Proof.
- split; intros; tauto || reflexivity.
-Qed.
-
-(* TODO RJ: Is this already defined somewhere? *)
-Class DecEq (T : Type) := dec_eq : forall (t1 t2: T), {t1 = t2} + {t1 <> t2}.
-
-Lemma DecEq_refl {T: Type} {eqT: DecEq T} t:
- dec_eq t t = left eq_refl.
-Proof.
- destruct (dec_eq t t) as [EQ|NEQ]; last (exfalso; now apply NEQ).
- f_equal. apply eq_proofs_unicity.
- move=>t1 t2. clear -eqT. destruct (dec_eq t1 t2); tauto.
-Qed.
-
-Global Instance DecEqBool: DecEq bool.
-Proof.
- move=>b1 b2. decide equality.
-Qed.
-
-Global Instance DecEqNat: DecEq nat.
-Proof.
- move=>n1 n2. decide equality.
-Qed.
-
-Ltac contradiction_eq := match goal with
- | [ H : ?i <> ?i |- _ ] => exfalso; now apply H
- end.
-
-(* Well-founded induction. *)
-Definition wf_nat_ind := well_founded_induction Wf_nat.lt_wf.
diff --git a/logic/upred.v b/logic/upred.v
new file mode 100644
index 0000000000000000000000000000000000000000..01f467cb0ee4c0e4abe110b5110a0f50cb376506
--- /dev/null
+++ b/logic/upred.v
@@ -0,0 +1,956 @@
+Require Export algebra.cmra.
+Local Hint Extern 1 (_ ≼ _) => etransitivity; [eassumption|].
+Local Hint Extern 1 (_ ≼ _) => etransitivity; [|eassumption].
+Local Hint Extern 10 (_ ≤ _) => omega.
+
+Record uPred (M : cmraT) : Type := IProp {
+ uPred_holds :> nat → M → Prop;
+ uPred_ne x1 x2 n : uPred_holds n x1 → x1 ={n}= x2 → uPred_holds n x2;
+ uPred_0 x : uPred_holds 0 x;
+ uPred_weaken x1 x2 n1 n2 :
+ uPred_holds n1 x1 → x1 ≼ x2 → n2 ≤ n1 → ✓{n2} x2 → uPred_holds n2 x2
+}.
+Arguments uPred_holds {_} _ _ _ : simpl never.
+Global Opaque uPred_holds.
+Local Transparent uPred_holds.
+Hint Resolve uPred_0.
+Add Printing Constructor uPred.
+Instance: Params (@uPred_holds) 3.
+
+Section cofe.
+ Context {M : cmraT}.
+ Instance uPred_equiv : Equiv (uPred M) := λ P Q, ∀ x n,
+ ✓{n} x → P n x ↔ Q n x.
+ Instance uPred_dist : Dist (uPred M) := λ n P Q, ∀ x n',
+ n' ≤ n → ✓{n'} x → P n' x ↔ Q n' x.
+ Program Instance uPred_compl : Compl (uPred M) := λ c,
+ {| uPred_holds n x := c n n x |}.
+ Next Obligation. by intros c x y n ??; simpl in *; apply uPred_ne with x. Qed.
+ Next Obligation. by intros c x; simpl. Qed.
+ Next Obligation.
+ intros c x1 x2 n1 n2 ????; simpl in *.
+ apply (chain_cauchy c n2 n1); eauto using uPred_weaken.
+ Qed.
+ Definition uPred_cofe_mixin : CofeMixin (uPred M).
+ Proof.
+ split.
+ * intros P Q; split; [by intros HPQ n x i ??; apply HPQ|].
+ intros HPQ x n ?; apply HPQ with n; auto.
+ * intros n; split.
+ + by intros P x i.
+ + by intros P Q HPQ x i ??; symmetry; apply HPQ.
+ + by intros P Q Q' HP HQ x i ??; transitivity (Q i x);[apply HP|apply HQ].
+ * intros n P Q HPQ x i ??; apply HPQ; auto.
+ * intros P Q x i; rewrite Nat.le_0_r=> ->; split; intros; apply uPred_0.
+ * by intros c n x i ??; apply (chain_cauchy c i n).
+ Qed.
+ Canonical Structure uPredC : cofeT := CofeT uPred_cofe_mixin.
+End cofe.
+Arguments uPredC : clear implicits.
+
+Instance uPred_ne' {M} (P : uPred M) n : Proper (dist n ==> iff) (P n).
+Proof. intros x1 x2 Hx; split; eauto using uPred_ne. Qed.
+Instance uPred_proper {M} (P : uPred M) n : Proper ((≡) ==> iff) (P n).
+Proof. by intros x1 x2 Hx; apply uPred_ne', equiv_dist. Qed.
+
+Lemma uPred_holds_ne {M} (P1 P2 : uPred M) n x :
+ P1 ={n}= P2 → ✓{n} x → P1 n x → P2 n x.
+Proof. intros HP ?; apply HP; auto. Qed.
+Lemma uPred_weaken' {M} (P : uPred M) x1 x2 n1 n2 :
+ x1 ≼ x2 → n2 ≤ n1 → ✓{n2} x2 → P n1 x1 → P n2 x2.
+Proof. eauto using uPred_weaken. Qed.
+
+(** functor *)
+Program Definition uPred_map {M1 M2 : cmraT} (f : M2 -n> M1)
+ `{!CMRAMonotone f} (P : uPred M1) :
+ uPred M2 := {| uPred_holds n x := P n (f x) |}.
+Next Obligation. by intros M1 M2 f ? P y1 y2 n ? Hy; rewrite /= -Hy. Qed.
+Next Obligation. intros M1 M2 f _ P x; apply uPred_0. Qed.
+Next Obligation.
+ naive_solver eauto using uPred_weaken, included_preserving, validN_preserving.
+Qed.
+Instance uPred_map_ne {M1 M2 : cmraT} (f : M2 -n> M1)
+ `{!CMRAMonotone f} :
+ Proper (dist n ==> dist n) (uPred_map f).
+Proof.
+ by intros n x1 x2 Hx y n'; split; apply Hx; auto using validN_preserving.
+Qed.
+Lemma uPred_map_id {M : cmraT} (P : uPred M): uPred_map cid P ≡ P.
+Proof. by intros x n ?. Qed.
+Lemma uPred_map_compose {M1 M2 M3 : cmraT} (f : M1 -n> M2) (g : M2 -n> M3)
+ `{!CMRAMonotone f} `{!CMRAMonotone g}
+ (P : uPred M3):
+ uPred_map (g ◎ f) P ≡ uPred_map f (uPred_map g P).
+Proof. by intros x n Hx. Qed.
+Lemma uPred_map_ext {M1 M2 : cmraT} (f g : M1 -n> M2)
+ `{!CMRAMonotone f} `{!CMRAMonotone g}:
+ (∀ x, f x ≡ g x) -> ∀ x, uPred_map f x ≡ uPred_map g x.
+Proof. move=> H x P n Hx /=. by rewrite /uPred_holds /= H. Qed.
+Definition uPredC_map {M1 M2 : cmraT} (f : M2 -n> M1) `{!CMRAMonotone f} :
+ uPredC M1 -n> uPredC M2 := CofeMor (uPred_map f : uPredC M1 → uPredC M2).
+Lemma upredC_map_ne {M1 M2 : cmraT} (f g : M2 -n> M1)
+ `{!CMRAMonotone f, !CMRAMonotone g} n :
+ f ={n}= g → uPredC_map f ={n}= uPredC_map g.
+Proof.
+ by intros Hfg P y n' ??;
+ rewrite /uPred_holds /= (dist_le _ _ _ _(Hfg y)); last lia.
+Qed.
+
+(** logical entailement *)
+Definition uPred_entails {M} (P Q : uPred M) := ∀ x n, ✓{n} x → P n x → Q n x.
+Hint Extern 0 (uPred_entails ?P ?P) => reflexivity.
+Instance uPred_entails_rewrite_relation M : RewriteRelation (@uPred_entails M).
+
+(** logical connectives *)
+Program Definition uPred_const {M} (φ : Prop) : uPred M :=
+ {| uPred_holds n x := match n return _ with 0 => True | _ => φ end |}.
+Solve Obligations with done.
+Next Obligation. intros M P x1 x2 [|n1] [|n2]; auto with lia. Qed.
+Instance uPred_inhabited M : Inhabited (uPred M) := populate (uPred_const True).
+
+Program Definition uPred_and {M} (P Q : uPred M) : uPred M :=
+ {| uPred_holds n x := P n x ∧ Q n x |}.
+Solve Obligations with naive_solver eauto 2 using uPred_ne, uPred_weaken.
+Program Definition uPred_or {M} (P Q : uPred M) : uPred M :=
+ {| uPred_holds n x := P n x ∨ Q n x |}.
+Solve Obligations with naive_solver eauto 2 using uPred_ne, uPred_weaken.
+Program Definition uPred_impl {M} (P Q : uPred M) : uPred M :=
+ {| uPred_holds n x := ∀ x' n',
+ x ≼ x' → n' ≤ n → ✓{n'} x' → P n' x' → Q n' x' |}.
+Next Obligation.
+ intros M P Q x1' x1 n1 HPQ Hx1 x2 n2 ????.
+ destruct (cmra_included_dist_l x1 x2 x1' n1) as (x2'&?&Hx2); auto.
+ assert (x2' ={n2}= x2) as Hx2' by (by apply dist_le with n1).
+ assert (✓{n2} x2') by (by rewrite Hx2'); rewrite -Hx2'.
+ eauto using uPred_weaken, uPred_ne.
+Qed.
+Next Obligation. intros M P Q x1 x2 [|n]; auto with lia. Qed.
+Next Obligation. naive_solver eauto 2 with lia. Qed.
+
+Program Definition uPred_forall {M A} (P : A → uPred M) : uPred M :=
+ {| uPred_holds n x := ∀ a, P a n x |}.
+Solve Obligations with naive_solver eauto 2 using uPred_ne, uPred_weaken.
+Program Definition uPred_exist {M A} (P : A → uPred M) : uPred M :=
+ {| uPred_holds n x :=
+ match n return _ with 0 => True | _ => ∃ a, P a n x end |}.
+Next Obligation. intros M A P x y [|n]; naive_solver eauto using uPred_ne. Qed.
+Next Obligation. done. Qed.
+Next Obligation.
+ intros M A P x y [|n] [|n']; naive_solver eauto 2 using uPred_weaken with lia.
+Qed.
+
+Program Definition uPred_eq {M} {A : cofeT} (a1 a2 : A) : uPred M :=
+ {| uPred_holds n x := a1 ={n}= a2 |}.
+Solve Obligations with naive_solver eauto 2 using (dist_le (A:=A)).
+
+Program Definition uPred_sep {M} (P Q : uPred M) : uPred M :=
+ {| uPred_holds n x := ∃ x1 x2, x ={n}= x1 ⋅ x2 ∧ P n x1 ∧ Q n x2 |}.
+Next Obligation.
+ by intros M P Q x y n (x1&x2&?&?&?) Hxy; exists x1, x2; rewrite -Hxy.
+Qed.
+Next Obligation. by intros M P Q x; exists x, x. Qed.
+Next Obligation.
+ intros M P Q x y n1 n2 (x1&x2&Hx&?&?) Hxy ??.
+ assert (∃ x2', y ={n2}= x1 ⋅ x2' ∧ x2 ≼ x2') as (x2'&Hy&?).
+ { destruct Hxy as [z Hy]; exists (x2 â‹… z); split; eauto using cmra_included_l.
+ apply dist_le with n1; auto. by rewrite (associative op) -Hx Hy. }
+ clear Hxy; cofe_subst y; exists x1, x2'; split_ands; [done| |].
+ * apply uPred_weaken with x1 n1; eauto using cmra_validN_op_l.
+ * apply uPred_weaken with x2 n1; eauto using cmra_validN_op_r.
+Qed.
+
+Program Definition uPred_wand {M} (P Q : uPred M) : uPred M :=
+ {| uPred_holds n x := ∀ x' n',
+ n' ≤ n → ✓{n'} (x ⋅ x') → P n' x' → Q n' (x ⋅ x') |}.
+Next Obligation.
+ intros M P Q x1 x2 n1 HPQ Hx x3 n2 ???; simpl in *.
+ rewrite -(dist_le _ _ _ _ Hx) //; apply HPQ; auto.
+ by rewrite (dist_le _ _ _ n2 Hx).
+Qed.
+Next Obligation. intros M P Q x1 x2 [|n]; auto with lia. Qed.
+Next Obligation.
+ intros M P Q x1 x2 n1 n2 HPQ ??? x3 n3 ???; simpl in *.
+ apply uPred_weaken with (x1 â‹… x3) n3;
+ eauto using cmra_validN_included, cmra_preserving_r.
+Qed.
+
+Program Definition uPred_later {M} (P : uPred M) : uPred M :=
+ {| uPred_holds n x := match n return _ with 0 => True | S n' => P n' x end |}.
+Next Obligation. intros M P ?? [|n]; eauto using uPred_ne,(dist_le (A:=M)). Qed.
+Next Obligation. done. Qed.
+Next Obligation.
+ intros M P x1 x2 [|n1] [|n2]; eauto using uPred_weaken, cmra_validN_S.
+Qed.
+Program Definition uPred_always {M} (P : uPred M) : uPred M :=
+ {| uPred_holds n x := P n (unit x) |}.
+Next Obligation. by intros M P x1 x2 n ? Hx; rewrite /= -Hx. Qed.
+Next Obligation. by intros; simpl. Qed.
+Next Obligation.
+ intros M P x1 x2 n1 n2 ????; eapply uPred_weaken with (unit x1) n1;
+ eauto using cmra_unit_preserving, cmra_unit_validN.
+Qed.
+
+Program Definition uPred_own {M : cmraT} (a : M) : uPred M :=
+ {| uPred_holds n x := a ≼{n} x |}.
+Next Obligation. by intros M a x1 x2 n [a' ?] Hx; exists a'; rewrite -Hx. Qed.
+Next Obligation. by intros M a x; exists x. Qed.
+Next Obligation.
+ intros M a x1 x n1 n2 [a' Hx1] [x2 Hx] ??.
+ exists (a' â‹… x2). by rewrite (associative op) -(dist_le _ _ _ _ Hx1) // Hx.
+Qed.
+Program Definition uPred_valid {M A : cmraT} (a : A) : uPred M :=
+ {| uPred_holds n x := ✓{n} a |}.
+Solve Obligations with naive_solver eauto 2 using cmra_validN_le, cmra_validN_0.
+
+Delimit Scope uPred_scope with I.
+Bind Scope uPred_scope with uPred.
+Arguments uPred_holds {_} _%I _ _.
+Arguments uPred_entails _ _%I _%I.
+Notation "P ⊑ Q" := (uPred_entails P%I Q%I) (at level 70) : C_scope.
+Notation "(⊑)" := uPred_entails (only parsing) : C_scope.
+Notation "■φ" := (uPred_const φ) (at level 20) : uPred_scope.
+Notation "'False'" := (uPred_const False) : uPred_scope.
+Notation "'True'" := (uPred_const True) : uPred_scope.
+Infix "∧" := uPred_and : uPred_scope.
+Notation "(∧)" := uPred_and (only parsing) : uPred_scope.
+Infix "∨" := uPred_or : uPred_scope.
+Notation "(∨)" := uPred_or (only parsing) : uPred_scope.
+Infix "→" := uPred_impl : uPred_scope.
+Infix "★" := uPred_sep (at level 80, right associativity) : uPred_scope.
+Notation "(★)" := uPred_sep (only parsing) : uPred_scope.
+Notation "P -★ Q" := (uPred_wand P Q)
+ (at level 90, Q at level 200, right associativity) : uPred_scope.
+Notation "∀ x .. y , P" :=
+ (uPred_forall (λ x, .. (uPred_forall (λ y, P)) ..)%I) : uPred_scope.
+Notation "∃ x .. y , P" :=
+ (uPred_exist (λ x, .. (uPred_exist (λ y, P)) ..)%I) : uPred_scope.
+Notation "â–· P" := (uPred_later P) (at level 20) : uPred_scope.
+Notation "â–¡ P" := (uPred_always P) (at level 20) : uPred_scope.
+Infix "≡" := uPred_eq : uPred_scope.
+Notation "✓" := uPred_valid (at level 1) : uPred_scope.
+
+Definition uPred_iff {M} (P Q : uPred M) : uPred M := ((P → Q) ∧ (Q → P))%I.
+Infix "↔" := uPred_iff : uPred_scope.
+
+Fixpoint uPred_big_and {M} (Ps : list (uPred M)) :=
+ match Ps with [] => True | P :: Ps => P ∧ uPred_big_and Ps end%I.
+Instance: Params (@uPred_big_and) 1.
+Notation "'Π∧' Ps" := (uPred_big_and Ps) (at level 20) : uPred_scope.
+Fixpoint uPred_big_sep {M} (Ps : list (uPred M)) :=
+ match Ps with [] => True | P :: Ps => P ★ uPred_big_sep Ps end%I.
+Instance: Params (@uPred_big_sep) 1.
+Notation "'Π★' Ps" := (uPred_big_sep Ps) (at level 20) : uPred_scope.
+
+Class TimelessP {M} (P : uPred M) := timelessP : ▷ P ⊑ (P ∨ ▷ False).
+Arguments timelessP {_} _ {_} _ _ _ _.
+Class AlwaysStable {M} (P : uPred M) := always_stable : P ⊑ □ P.
+Arguments always_stable {_} _ {_} _ _ _ _.
+
+Module uPred. Section uPred_logic.
+Context {M : cmraT}.
+Implicit Types φ : Prop.
+Implicit Types P Q : uPred M.
+Implicit Types Ps Qs : list (uPred M).
+Implicit Types A : Type.
+Notation "P ⊑ Q" := (@uPred_entails M P%I Q%I). (* Force implicit argument M *)
+Arguments uPred_holds {_} !_ _ _ /.
+
+Global Instance: PreOrder (@uPred_entails M).
+Proof. split. by intros P x i. by intros P Q Q' HP HQ x i ??; apply HQ, HP. Qed.
+Global Instance: AntiSymmetric (≡) (@uPred_entails M).
+Proof. intros P Q HPQ HQP; split; auto. Qed.
+Lemma equiv_spec P Q : P ≡ Q ↔ P ⊑ Q ∧ Q ⊑ P.
+Proof.
+ split; [|by intros [??]; apply (anti_symmetric (⊑))].
+ intros HPQ; split; intros x i; apply HPQ.
+Qed.
+Global Instance entails_proper :
+ Proper ((≡) ==> (≡) ==> iff) ((⊑) : relation (uPred M)).
+Proof.
+ move => P1 P2 /equiv_spec [HP1 HP2] Q1 Q2 /equiv_spec [HQ1 HQ2]; split; intros.
+ * by transitivity P1; [|transitivity Q1].
+ * by transitivity P2; [|transitivity Q2].
+Qed.
+
+(** Non-expansiveness and setoid morphisms *)
+Global Instance const_proper : Proper (iff ==> (≡)) (@uPred_const M).
+Proof. by intros φ1 φ2 Hφ ? [|n] ?; try apply Hφ. Qed.
+Global Instance and_ne n : Proper (dist n ==> dist n ==> dist n) (@uPred_and M).
+Proof.
+ intros P P' HP Q Q' HQ; split; intros [??]; split; by apply HP || by apply HQ.
+Qed.
+Global Instance and_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_and M) := ne_proper_2 _.
+Global Instance or_ne n : Proper (dist n ==> dist n ==> dist n) (@uPred_or M).
+Proof.
+ intros P P' HP Q Q' HQ; split; intros [?|?];
+ first [by left; apply HP | by right; apply HQ].
+Qed.
+Global Instance or_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_or M) := ne_proper_2 _.
+Global Instance impl_ne n :
+ Proper (dist n ==> dist n ==> dist n) (@uPred_impl M).
+Proof.
+ intros P P' HP Q Q' HQ; split; intros HPQ x' n'' ????; apply HQ,HPQ,HP; auto.
+Qed.
+Global Instance impl_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_impl M) := ne_proper_2 _.
+Global Instance sep_ne n : Proper (dist n ==> dist n ==> dist n) (@uPred_sep M).
+Proof.
+ intros P P' HP Q Q' HQ x n' ??; split; intros (x1&x2&?&?&?); cofe_subst x;
+ exists x1, x2; split_ands; try (apply HP || apply HQ);
+ eauto using cmra_validN_op_l, cmra_validN_op_r.
+Qed.
+Global Instance sep_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_sep M) := ne_proper_2 _.
+Global Instance wand_ne n :
+ Proper (dist n ==> dist n ==> dist n) (@uPred_wand M).
+Proof.
+ intros P P' HP Q Q' HQ x n' ??; split; intros HPQ x' n'' ???;
+ apply HQ, HPQ, HP; eauto using cmra_validN_op_r.
+Qed.
+Global Instance wand_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_wand M) := ne_proper_2 _.
+Global Instance eq_ne (A : cofeT) n :
+ Proper (dist n ==> dist n ==> dist n) (@uPred_eq M A).
+Proof.
+ intros x x' Hx y y' Hy z n'; split; intros; simpl in *.
+ * by rewrite -(dist_le _ _ _ _ Hx) -?(dist_le _ _ _ _ Hy); auto.
+ * by rewrite (dist_le _ _ _ _ Hx) ?(dist_le _ _ _ _ Hy); auto.
+Qed.
+Global Instance eq_proper (A : cofeT) :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_eq M A) := ne_proper_2 _.
+Global Instance forall_ne A :
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_forall M A).
+Proof. by intros n P1 P2 HP12 x n'; split; intros HP a; apply HP12. Qed.
+Global Instance forall_proper A :
+ Proper (pointwise_relation _ (≡) ==> (≡)) (@uPred_forall M A).
+Proof. by intros P1 P2 HP12 x n'; split; intros HP a; apply HP12. Qed.
+Global Instance exists_ne A :
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_exist M A).
+Proof.
+ by intros n P1 P2 HP x [|n']; [|split; intros [a ?]; exists a; apply HP].
+Qed.
+Global Instance exist_proper A :
+ Proper (pointwise_relation _ (≡) ==> (≡)) (@uPred_exist M A).
+Proof.
+ by intros P1 P2 HP x [|n']; [|split; intros [a ?]; exists a; apply HP].
+Qed.
+Global Instance later_contractive : Contractive (@uPred_later M).
+Proof.
+ intros n P Q HPQ x [|n'] ??; simpl; [done|].
+ apply HPQ; eauto using cmra_validN_S.
+Qed.
+Global Instance later_proper :
+ Proper ((≡) ==> (≡)) (@uPred_later M) := ne_proper _.
+Global Instance always_ne n: Proper (dist n ==> dist n) (@uPred_always M).
+Proof. intros P1 P2 HP x n'; split; apply HP; eauto using cmra_unit_validN. Qed.
+Global Instance always_proper :
+ Proper ((≡) ==> (≡)) (@uPred_always M) := ne_proper _.
+Global Instance own_ne n : Proper (dist n ==> dist n) (@uPred_own M).
+Proof.
+ by intros a1 a2 Ha x n'; split; intros [a' ?]; exists a'; simpl; first
+ [rewrite -(dist_le _ _ _ _ Ha); last lia
+ |rewrite (dist_le _ _ _ _ Ha); last lia].
+Qed.
+Global Instance own_proper : Proper ((≡) ==> (≡)) (@uPred_own M) := ne_proper _.
+Global Instance iff_ne n : Proper (dist n ==> dist n ==> dist n) (@uPred_iff M).
+Proof. unfold uPred_iff; solve_proper. Qed.
+Global Instance iff_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@uPred_iff M) := ne_proper_2 _.
+
+(** Introduction and elimination rules *)
+Lemma const_intro φ P : φ → P ⊑ ■φ.
+Proof. by intros ?? [|?]. Qed.
+Lemma const_elim φ Q R : Q ⊑ ■φ → (φ → Q ⊑ R) → Q ⊑ R.
+Proof.
+ intros HQP HQR x [|n] ??; first done.
+ apply HQR; first eapply (HQP _ (S n)); eauto.
+Qed.
+Lemma True_intro P : P ⊑ True.
+Proof. by apply const_intro. Qed.
+Lemma False_elim P : False ⊑ P.
+Proof. by intros x [|n] ?. Qed.
+Lemma and_elim_l P Q : (P ∧ Q) ⊑ P.
+Proof. by intros x n ? [??]. Qed.
+Lemma and_elim_r P Q : (P ∧ Q) ⊑ Q.
+Proof. by intros x n ? [??]. Qed.
+Lemma and_intro P Q R : P ⊑ Q → P ⊑ R → P ⊑ (Q ∧ R).
+Proof. intros HQ HR x n ??; split; auto. Qed.
+Lemma or_intro_l P Q : P ⊑ (P ∨ Q).
+Proof. intros x n ??; left; auto. Qed.
+Lemma or_intro_r P Q : Q ⊑ (P ∨ Q).
+Proof. intros x n ??; right; auto. Qed.
+Lemma or_elim P Q R : P ⊑ R → Q ⊑ R → (P ∨ Q) ⊑ R.
+Proof. intros HP HQ x n ? [?|?]. by apply HP. by apply HQ. Qed.
+Lemma impl_intro_r P Q R : (P ∧ Q) ⊑ R → P ⊑ (Q → R).
+Proof.
+ intros HQ x n ?? x' n' ????; apply HQ; naive_solver eauto using uPred_weaken.
+Qed.
+Lemma impl_elim P Q R : P ⊑ (Q → R) → P ⊑ Q → P ⊑ R.
+Proof. by intros HP HP' x n ??; apply HP with x n, HP'. Qed.
+Lemma forall_intro {A} P (Q : A → uPred M): (∀ a, P ⊑ Q a) → P ⊑ (∀ a, Q a).
+Proof. by intros HPQ x n ?? a; apply HPQ. Qed.
+Lemma forall_elim {A} {P : A → uPred M} a : (∀ a, P a) ⊑ P a.
+Proof. intros x n ? HP; apply HP. Qed.
+Lemma exist_intro {A} {P : A → uPred M} a : P a ⊑ (∃ a, P a).
+Proof. by intros x [|n] ??; [done|exists a]. Qed.
+Lemma exist_elim {A} (P : A → uPred M) Q : (∀ a, P a ⊑ Q) → (∃ a, P a) ⊑ Q.
+Proof. by intros HPQ x [|n] ?; [|intros [a ?]; apply HPQ with a]. Qed.
+Lemma eq_refl {A : cofeT} (a : A) P : P ⊑ (a ≡ a).
+Proof. by intros x n ??; simpl. Qed.
+Lemma eq_rewrite {A : cofeT} P (Q : A → uPred M)
+ `{HQ:∀ n, Proper (dist n ==> dist n) Q} a b : P ⊑ (a ≡ b) → P ⊑ Q a → P ⊑ Q b.
+Proof.
+ intros Hab Ha x n ??; apply HQ with n a; auto. by symmetry; apply Hab with x.
+Qed.
+Lemma eq_equiv `{Empty M, !CMRAIdentity M} {A : cofeT} (a b : A) :
+ True ⊑ (a ≡ b) → a ≡ b.
+Proof.
+ intros Hab; apply equiv_dist; intros n; apply Hab with ∅.
+ * apply cmra_valid_validN, cmra_empty_valid.
+ * by destruct n.
+Qed.
+Lemma iff_equiv P Q : True ⊑ (P ↔ Q) → P ≡ Q.
+Proof. by intros HPQ x [|n] ?; [|split; intros; apply HPQ with x (S n)]. Qed.
+
+(* Derived logical stuff *)
+Lemma and_elim_l' P Q R : P ⊑ R → (P ∧ Q) ⊑ R.
+Proof. by rewrite and_elim_l. Qed.
+Lemma and_elim_r' P Q R : Q ⊑ R → (P ∧ Q) ⊑ R.
+Proof. by rewrite and_elim_r. Qed.
+Lemma or_intro_l' P Q R : P ⊑ Q → P ⊑ (Q ∨ R).
+Proof. intros ->; apply or_intro_l. Qed.
+Lemma or_intro_r' P Q R : P ⊑ R → P ⊑ (Q ∨ R).
+Proof. intros ->; apply or_intro_r. Qed.
+Lemma exist_intro' {A} P (Q : A → uPred M) a : P ⊑ Q a → P ⊑ (∃ a, Q a).
+Proof. intros ->; apply exist_intro. Qed.
+
+Hint Resolve or_elim or_intro_l' or_intro_r'.
+Hint Resolve and_intro and_elim_l' and_elim_r'.
+Hint Immediate True_intro False_elim.
+
+Lemma impl_intro_l P Q R : (Q ∧ P) ⊑ R → P ⊑ (Q → R).
+Proof. intros HR; apply impl_intro_r; rewrite -HR; auto. Qed.
+Lemma impl_elim_l P Q : ((P → Q) ∧ P) ⊑ Q.
+Proof. apply impl_elim with P; auto. Qed.
+Lemma impl_elim_r P Q : (P ∧ (P → Q)) ⊑ Q.
+Proof. apply impl_elim with P; auto. Qed.
+Lemma impl_elim_l' P Q R : P ⊑ (Q → R) → (P ∧ Q) ⊑ R.
+Proof. intros; apply impl_elim with Q; auto. Qed.
+Lemma impl_elim_r' P Q R : Q ⊑ (P → R) → (P ∧ Q) ⊑ R.
+Proof. intros; apply impl_elim with P; auto. Qed.
+Lemma impl_entails P Q : True ⊑ (P → Q) → P ⊑ Q.
+Proof. intros HPQ; apply impl_elim with P; rewrite -?HPQ; auto. Qed.
+Lemma entails_impl P Q : (P ⊑ Q) → True ⊑ (P → Q).
+Proof. auto using impl_intro_l. Qed.
+
+Lemma const_intro_l φ Q R : φ → (■φ ∧ Q) ⊑ R → Q ⊑ R.
+Proof. intros ? <-; auto using const_intro. Qed.
+Lemma const_intro_r φ Q R : φ → (Q ∧ ■φ) ⊑ R → Q ⊑ R.
+Proof. intros ? <-; auto using const_intro. Qed.
+Lemma const_elim_l φ Q R : (φ → Q ⊑ R) → (■φ ∧ Q) ⊑ R.
+Proof. intros; apply const_elim with φ; eauto. Qed.
+Lemma const_elim_r φ Q R : (φ → Q ⊑ R) → (Q ∧ ■φ) ⊑ R.
+Proof. intros; apply const_elim with φ; eauto. Qed.
+Lemma const_equiv (φ : Prop) : φ → (■φ : uPred M)%I ≡ True%I.
+Proof. intros; apply (anti_symmetric _); auto using const_intro. Qed.
+Lemma equiv_eq {A : cofeT} P (a b : A) : a ≡ b → P ⊑ (a ≡ b).
+Proof. intros ->; apply eq_refl. Qed.
+Lemma eq_sym {A : cofeT} (a b : A) : (a ≡ b) ⊑ (b ≡ a).
+Proof.
+ refine (eq_rewrite _ (λ b, b ≡ a)%I a b _ _); auto using eq_refl.
+ intros n; solve_proper.
+Qed.
+
+Lemma const_mono φ1 φ2 : (φ1 → φ2) → ■φ1 ⊑ ■φ2.
+Proof. intros; apply const_elim with φ1; eauto using const_intro. Qed.
+Lemma and_mono P P' Q Q' : P ⊑ Q → P' ⊑ Q' → (P ∧ P') ⊑ (Q ∧ Q').
+Proof. auto. Qed.
+Lemma or_mono P P' Q Q' : P ⊑ Q → P' ⊑ Q' → (P ∨ P') ⊑ (Q ∨ Q').
+Proof. auto. Qed.
+Lemma impl_mono P P' Q Q' : Q ⊑ P → P' ⊑ Q' → (P → P') ⊑ (Q → Q').
+Proof.
+ intros HP HQ'; apply impl_intro_l; rewrite -HQ'.
+ apply impl_elim with P; eauto.
+Qed.
+Lemma forall_mono {A} (P Q : A → uPred M) :
+ (∀ a, P a ⊑ Q a) → (∀ a, P a) ⊑ (∀ a, Q a).
+Proof.
+ intros HP. apply forall_intro=> a; rewrite -(HP a); apply forall_elim.
+Qed.
+Lemma exist_mono {A} (P Q : A → uPred M) :
+ (∀ a, P a ⊑ Q a) → (∃ a, P a) ⊑ (∃ a, Q a).
+Proof. intros HP. apply exist_elim=> a; rewrite (HP a); apply exist_intro. Qed.
+Global Instance const_mono' : Proper (impl ==> (⊑)) (@uPred_const M).
+Proof. intros φ1 φ2; apply const_mono. Qed.
+Global Instance and_mono' : Proper ((⊑) ==> (⊑) ==> (⊑)) (@uPred_and M).
+Proof. by intros P P' HP Q Q' HQ; apply and_mono. Qed.
+Global Instance or_mono' : Proper ((⊑) ==> (⊑) ==> (⊑)) (@uPred_or M).
+Proof. by intros P P' HP Q Q' HQ; apply or_mono. Qed.
+Global Instance impl_mono' :
+ Proper (flip (⊑) ==> (⊑) ==> (⊑)) (@uPred_impl M).
+Proof. by intros P P' HP Q Q' HQ; apply impl_mono. Qed.
+Global Instance forall_mono' A :
+ Proper (pointwise_relation _ (⊑) ==> (⊑)) (@uPred_forall M A).
+Proof. intros P1 P2; apply forall_mono. Qed.
+Global Instance exist_mono' A :
+ Proper (pointwise_relation _ (⊑) ==> (⊑)) (@uPred_exist M A).
+Proof. intros P1 P2; apply exist_mono. Qed.
+
+Global Instance and_idem : Idempotent (≡) (@uPred_and M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance or_idem : Idempotent (≡) (@uPred_or M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance and_comm : Commutative (≡) (@uPred_and M).
+Proof. intros P Q; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance True_and : LeftId (≡) True%I (@uPred_and M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance and_True : RightId (≡) True%I (@uPred_and M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance False_and : LeftAbsorb (≡) False%I (@uPred_and M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance and_False : RightAbsorb (≡) False%I (@uPred_and M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance True_or : LeftAbsorb (≡) True%I (@uPred_or M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance or_True : RightAbsorb (≡) True%I (@uPred_or M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance False_or : LeftId (≡) False%I (@uPred_or M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance or_False : RightId (≡) False%I (@uPred_or M).
+Proof. intros P; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance and_assoc : Associative (≡) (@uPred_and M).
+Proof. intros P Q R; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance or_comm : Commutative (≡) (@uPred_or M).
+Proof. intros P Q; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance or_assoc : Associative (≡) (@uPred_or M).
+Proof. intros P Q R; apply (anti_symmetric (⊑)); auto. Qed.
+Global Instance True_impl : LeftId (≡) True%I (@uPred_impl M).
+Proof.
+ intros P; apply (anti_symmetric (⊑)).
+ * by rewrite -(left_id True%I uPred_and (_ → _)%I) impl_elim_r.
+ * by apply impl_intro_l; rewrite left_id.
+Qed.
+Lemma or_and_l P Q R : (P ∨ Q ∧ R)%I ≡ ((P ∨ Q) ∧ (P ∨ R))%I.
+Proof.
+ apply (anti_symmetric (⊑)); first auto.
+ do 2 (apply impl_elim_l', or_elim; apply impl_intro_l); auto.
+Qed.
+Lemma or_and_r P Q R : (P ∧ Q ∨ R)%I ≡ ((P ∨ R) ∧ (Q ∨ R))%I.
+Proof. by rewrite -!(commutative _ R) or_and_l. Qed.
+Lemma and_or_l P Q R : (P ∧ (Q ∨ R))%I ≡ (P ∧ Q ∨ P ∧ R)%I.
+Proof.
+ apply (anti_symmetric (⊑)); last auto.
+ apply impl_elim_r', or_elim; apply impl_intro_l; auto.
+Qed.
+Lemma and_or_r P Q R : ((P ∨ Q) ∧ R)%I ≡ (P ∧ R ∨ Q ∧ R)%I.
+Proof. by rewrite -!(commutative _ R) and_or_l. Qed.
+
+(* BI connectives *)
+Lemma sep_mono P P' Q Q' : P ⊑ Q → P' ⊑ Q' → (P ★ P') ⊑ (Q ★ Q').
+Proof.
+ intros HQ HQ' x n' ? (x1&x2&?&?&?); exists x1, x2; cofe_subst x;
+ eauto 7 using cmra_validN_op_l, cmra_validN_op_r.
+Qed.
+Global Instance True_sep : LeftId (≡) True%I (@uPred_sep M).
+Proof.
+ intros P x n Hvalid; split.
+ * intros (x1&x2&?&_&?); cofe_subst; eauto using uPred_weaken, cmra_included_r.
+ * by destruct n as [|n]; [|intros ?; exists (unit x), x; rewrite cmra_unit_l].
+Qed.
+Global Instance sep_commutative : Commutative (≡) (@uPred_sep M).
+Proof.
+ by intros P Q x n ?; split;
+ intros (x1&x2&?&?&?); exists x2, x1; rewrite (commutative op).
+Qed.
+Global Instance sep_associative : Associative (≡) (@uPred_sep M).
+Proof.
+ intros P Q R x n ?; split.
+ * intros (x1&x2&Hx&?&y1&y2&Hy&?&?); exists (x1 â‹… y1), y2; split_ands; auto.
+ + by rewrite -(associative op) -Hy -Hx.
+ + by exists x1, y1.
+ * intros (x1&x2&Hx&(y1&y2&Hy&?&?)&?); exists y1, (y2 â‹… x2); split_ands; auto.
+ + by rewrite (associative op) -Hy -Hx.
+ + by exists y2, x2.
+Qed.
+Lemma wand_intro_r P Q R : (P ★ Q) ⊑ R → P ⊑ (Q -★ R).
+Proof.
+ intros HPQR x n ?? x' n' ???; apply HPQR; auto.
+ exists x, x'; split_ands; auto.
+ eapply uPred_weaken with x n; eauto using cmra_validN_op_l.
+Qed.
+Lemma wand_elim_l P Q : ((P -★ Q) ★ P) ⊑ Q.
+Proof. by intros x n ? (x1&x2&Hx&HPQ&?); cofe_subst; apply HPQ. Qed.
+Lemma sep_or_l_1 P Q R : (P ★ (Q ∨ R)) ⊑ (P ★ Q ∨ P ★ R).
+Proof. by intros x n ? (x1&x2&Hx&?&[?|?]); [left|right]; exists x1, x2. Qed.
+Lemma sep_exist_l_1 {A} P (Q : A → uPred M) : (P ★ ∃ b, Q b) ⊑ (∃ b, P ★ Q b).
+Proof. by intros x [|n] ?; [done|intros (x1&x2&?&?&[a ?]); exists a,x1,x2]. Qed.
+
+(* Derived BI Stuff *)
+Hint Resolve sep_mono.
+Global Instance sep_mono' : Proper ((⊑) ==> (⊑) ==> (⊑)) (@uPred_sep M).
+Proof. by intros P P' HP Q Q' HQ; apply sep_mono. Qed.
+Lemma wand_mono P P' Q Q' : Q ⊑ P → P' ⊑ Q' → (P -★ P') ⊑ (Q -★ Q').
+Proof. intros HP HQ; apply wand_intro_r; rewrite HP -HQ; apply wand_elim_l. Qed.
+Global Instance wand_mono' : Proper (flip (⊑) ==> (⊑) ==> (⊑)) (@uPred_wand M).
+Proof. by intros P P' HP Q Q' HQ; apply wand_mono. Qed.
+
+Global Instance sep_True : RightId (≡) True%I (@uPred_sep M).
+Proof. by intros P; rewrite (commutative _) (left_id _ _). Qed.
+Lemma sep_elim_l P Q : (P ★ Q) ⊑ P.
+Proof. by rewrite (True_intro Q) (right_id _ _). Qed.
+Lemma sep_elim_r P Q : (P ★ Q) ⊑ Q.
+Proof. by rewrite (commutative (★))%I; apply sep_elim_l. Qed.
+Lemma sep_elim_l' P Q R : P ⊑ R → (P ★ Q) ⊑ R.
+Proof. intros ->; apply sep_elim_l. Qed.
+Lemma sep_elim_r' P Q R : Q ⊑ R → (P ★ Q) ⊑ R.
+Proof. intros ->; apply sep_elim_r. Qed.
+Hint Resolve sep_elim_l' sep_elim_r'.
+Lemma sep_intro_True_l P Q R : True ⊑ P → R ⊑ Q → R ⊑ (P ★ Q).
+Proof. by intros; rewrite -(left_id True%I uPred_sep R); apply sep_mono. Qed.
+Lemma sep_intro_True_r P Q R : R ⊑ P → True ⊑ Q → R ⊑ (P ★ Q).
+Proof. by intros; rewrite -(right_id True%I uPred_sep R); apply sep_mono. Qed.
+Lemma wand_intro_l P Q R : (Q ★ P) ⊑ R → P ⊑ (Q -★ R).
+Proof. rewrite (commutative _); apply wand_intro_r. Qed.
+Lemma wand_elim_r P Q : (P ★ (P -★ Q)) ⊑ Q.
+Proof. rewrite (commutative _ P); apply wand_elim_l. Qed.
+Lemma wand_elim_l' P Q R : P ⊑ (Q -★ R) → (P ★ Q) ⊑ R.
+Proof. intros ->; apply wand_elim_l. Qed.
+Lemma wand_elim_r' P Q R : Q ⊑ (P -★ R) → (P ★ Q) ⊑ R.
+Proof. intros ->; apply wand_elim_r. Qed.
+Lemma sep_and P Q : (P ★ Q) ⊑ (P ∧ Q).
+Proof. auto. Qed.
+Lemma impl_wand P Q : (P → Q) ⊑ (P -★ Q).
+Proof. apply wand_intro_r, impl_elim with P; auto. Qed.
+
+Global Instance sep_False : LeftAbsorb (≡) False%I (@uPred_sep M).
+Proof. intros P; apply (anti_symmetric _); auto. Qed.
+Global Instance False_sep : RightAbsorb (≡) False%I (@uPred_sep M).
+Proof. intros P; apply (anti_symmetric _); auto. Qed.
+
+Lemma sep_and_l P Q R : (P ★ (Q ∧ R)) ⊑ ((P ★ Q) ∧ (P ★ R)).
+Proof. auto. Qed.
+Lemma sep_and_r P Q R : ((P ∧ Q) ★ R) ⊑ ((P ★ R) ∧ (Q ★ R)).
+Proof. auto. Qed.
+Lemma sep_or_l P Q R : (P ★ (Q ∨ R))%I ≡ ((P ★ Q) ∨ (P ★ R))%I.
+Proof. apply (anti_symmetric (⊑)); eauto 10 using sep_or_l_1. Qed.
+Lemma sep_or_r P Q R : ((P ∨ Q) ★ R)%I ≡ ((P ★ R) ∨ (Q ★ R))%I.
+Proof. by rewrite -!(commutative _ R) sep_or_l. Qed.
+Lemma sep_exist_l {A} P (Q : A → uPred M) : (P ★ ∃ a, Q a)%I ≡ (∃ a, P ★ Q a)%I.
+Proof.
+ intros; apply (anti_symmetric (⊑)); eauto using sep_exist_l_1.
+ apply exist_elim=> a; apply sep_mono; auto using exist_intro.
+Qed.
+Lemma sep_exist_r {A} (P: A → uPred M) Q: ((∃ a, P a) ★ Q)%I ≡ (∃ a, P a ★ Q)%I.
+Proof. setoid_rewrite (commutative _ _ Q); apply sep_exist_l. Qed.
+Lemma sep_forall_l {A} P (Q : A → uPred M) : (P ★ ∀ a, Q a) ⊑ (∀ a, P ★ Q a).
+Proof. by apply forall_intro=> a; rewrite forall_elim. Qed.
+Lemma sep_forall_r {A} (P : A → uPred M) Q : ((∀ a, P a) ★ Q) ⊑ (∀ a, P a ★ Q).
+Proof. by apply forall_intro=> a; rewrite forall_elim. Qed.
+
+(* Later *)
+Lemma later_mono P Q : P ⊑ Q → ▷ P ⊑ ▷ Q.
+Proof. intros HP x [|n] ??; [done|apply HP; eauto using cmra_validN_S]. Qed.
+Lemma later_intro P : P ⊑ ▷ P.
+Proof.
+ intros x [|n] ??; simpl in *; [done|].
+ apply uPred_weaken with x (S n); eauto using cmra_validN_S.
+Qed.
+Lemma löb P : (▷ P → P) ⊑ P.
+Proof.
+ intros x n ? HP; induction n as [|n IH]; [by apply HP|].
+ apply HP, IH, uPred_weaken with x (S n); eauto using cmra_validN_S.
+Qed.
+Lemma later_and P Q : (▷ (P ∧ Q))%I ≡ (▷ P ∧ ▷ Q)%I.
+Proof. by intros x [|n]; split. Qed.
+Lemma later_or P Q : (▷ (P ∨ Q))%I ≡ (▷ P ∨ ▷ Q)%I.
+Proof. intros x [|n]; simpl; tauto. Qed.
+Lemma later_forall {A} (P : A → uPred M) : (▷ ∀ a, P a)%I ≡ (∀ a, ▷ P a)%I.
+Proof. by intros x [|n]. Qed.
+Lemma later_exist {A} (P : A → uPred M) : (∃ a, ▷ P a) ⊑ (▷ ∃ a, P a).
+Proof. by intros x [|[|n]]. Qed.
+Lemma later_exist' `{Inhabited A} (P : A → uPred M) :
+ (▷ ∃ a, P a)%I ≡ (∃ a, ▷ P a)%I.
+Proof. intros x [|[|n]]; split; done || by exists inhabitant; simpl. Qed.
+Lemma later_sep P Q : (▷ (P ★ Q))%I ≡ (▷ P ★ ▷ Q)%I.
+Proof.
+ intros x n ?; split.
+ * destruct n as [|n]; simpl; [by exists x, x|intros (x1&x2&Hx&?&?)].
+ destruct (cmra_extend_op n x x1 x2)
+ as ([y1 y2]&Hx'&Hy1&Hy2); eauto using cmra_validN_S; simpl in *.
+ exists y1, y2; split; [by rewrite Hx'|by rewrite Hy1 Hy2].
+ * destruct n as [|n]; simpl; [done|intros (x1&x2&Hx&?&?)].
+ exists x1, x2; eauto using dist_S.
+Qed.
+
+(* Later derived *)
+Global Instance later_mono' : Proper ((⊑) ==> (⊑)) (@uPred_later M).
+Proof. intros P Q; apply later_mono. Qed.
+Lemma later_impl P Q : ▷ (P → Q) ⊑ (▷ P → ▷ Q).
+Proof.
+ apply impl_intro_l; rewrite -later_and.
+ apply later_mono, impl_elim with P; auto.
+Qed.
+Lemma later_wand P Q : ▷ (P -★ Q) ⊑ (▷ P -★ ▷ Q).
+Proof. apply wand_intro_r;rewrite -later_sep; apply later_mono,wand_elim_l. Qed.
+Lemma löb_all_1 {A} (P Q : A → uPred M) :
+ (∀ a, (▷(∀ b, P b → Q b) ∧ P a) ⊑ Q a) → ∀ a, P a ⊑ Q a.
+Proof.
+ intros Hlöb a. apply impl_entails. transitivity (∀ a, P a → Q a)%I; last first.
+ { by rewrite (forall_elim a). } clear a.
+ etransitivity; last by eapply löb.
+ apply impl_intro_l, forall_intro=>a. rewrite right_id. by apply impl_intro_r.
+Qed.
+
+(* Always *)
+Lemma always_const φ : (□ ■φ : uPred M)%I ≡ (■φ)%I.
+Proof. done. Qed.
+Lemma always_elim P : □ P ⊑ P.
+Proof.
+ intros x n ??; apply uPred_weaken with (unit x) n;
+ eauto using cmra_included_unit.
+Qed.
+Lemma always_intro P Q : □ P ⊑ Q → □ P ⊑ □ Q.
+Proof.
+ intros HPQ x n ??; apply HPQ; simpl in *; auto using cmra_unit_validN.
+ by rewrite cmra_unit_idempotent.
+Qed.
+Lemma always_and P Q : (□ (P ∧ Q))%I ≡ (□ P ∧ □ Q)%I.
+Proof. done. Qed.
+Lemma always_or P Q : (□ (P ∨ Q))%I ≡ (□ P ∨ □ Q)%I.
+Proof. done. Qed.
+Lemma always_forall {A} (P : A → uPred M) : (□ ∀ a, P a)%I ≡ (∀ a, □ P a)%I.
+Proof. done. Qed.
+Lemma always_exist {A} (P : A → uPred M) : (□ ∃ a, P a)%I ≡ (∃ a, □ P a)%I.
+Proof. done. Qed.
+Lemma always_and_sep_1 P Q : □ (P ∧ Q) ⊑ □ (P ★ Q).
+Proof.
+ intros x n ? [??]; exists (unit x), (unit x); rewrite cmra_unit_unit; auto.
+Qed.
+Lemma always_and_sep_l_1 P Q : (□ P ∧ Q) ⊑ (□ P ★ Q).
+Proof.
+ intros x n ? [??]; exists (unit x), x; simpl in *.
+ by rewrite cmra_unit_l cmra_unit_idempotent.
+Qed.
+Lemma always_later P : (□ ▷ P)%I ≡ (▷ □ P)%I.
+Proof. done. Qed.
+
+(* Always derived *)
+Lemma always_mono P Q : P ⊑ Q → □ P ⊑ □ Q.
+Proof. intros. apply always_intro. by rewrite always_elim. Qed.
+Hint Resolve always_mono.
+Global Instance always_mono' : Proper ((⊑) ==> (⊑)) (@uPred_always M).
+Proof. intros P Q; apply always_mono. Qed.
+Lemma always_impl P Q : □ (P → Q) ⊑ (□ P → □ Q).
+Proof.
+ apply impl_intro_l; rewrite -always_and.
+ apply always_mono, impl_elim with P; auto.
+Qed.
+Lemma always_eq {A:cofeT} (a b : A) : (□ (a ≡ b))%I ≡ (a ≡ b : uPred M)%I.
+Proof.
+ apply (anti_symmetric (⊑)); auto using always_elim.
+ refine (eq_rewrite _ (λ b, □ (a ≡ b))%I a b _ _); auto.
+ { intros n; solve_proper. }
+ rewrite -(eq_refl _ True) always_const; auto.
+Qed.
+Lemma always_and_sep P Q : (□ (P ∧ Q))%I ≡ (□ (P ★ Q))%I.
+Proof. apply (anti_symmetric (⊑)); auto using always_and_sep_1. Qed.
+Lemma always_and_sep_l P Q : (□ P ∧ Q)%I ≡ (□ P ★ Q)%I.
+Proof. apply (anti_symmetric (⊑)); auto using always_and_sep_l_1. Qed.
+Lemma always_and_sep_r P Q : (P ∧ □ Q)%I ≡ (P ★ □ Q)%I.
+Proof. by rewrite !(commutative _ P) always_and_sep_l. Qed.
+Lemma always_sep P Q : (□ (P ★ Q))%I ≡ (□ P ★ □ Q)%I.
+Proof. by rewrite -always_and_sep -always_and_sep_l always_and. Qed.
+Lemma always_wand P Q : □ (P -★ Q) ⊑ (□ P -★ □ Q).
+Proof. by apply wand_intro_r; rewrite -always_sep wand_elim_l. Qed.
+Lemma always_sep_dup P : (□ P)%I ≡ (□ P ★ □ P)%I.
+Proof. by rewrite -always_sep -always_and_sep (idempotent _). Qed.
+Lemma always_wand_impl P Q : (□ (P -★ Q))%I ≡ (□ (P → Q))%I.
+Proof.
+ apply (anti_symmetric (⊑)); [|by rewrite -impl_wand].
+ apply always_intro, impl_intro_r.
+ by rewrite always_and_sep_l always_elim wand_elim_l.
+Qed.
+Lemma always_entails_l P Q : (P ⊑ □ Q) → P ⊑ (□ Q ★ P).
+Proof. intros; rewrite -always_and_sep_l; auto. Qed.
+Lemma always_entails_r P Q : (P ⊑ □ Q) → P ⊑ (P ★ □ Q).
+Proof. intros; rewrite -always_and_sep_r; auto. Qed.
+
+(* Own *)
+Lemma own_op (a1 a2 : M) :
+ uPred_own (a1 ⋅ a2) ≡ (uPred_own a1 ★ uPred_own a2)%I.
+Proof.
+ intros x n ?; split.
+ * intros [z ?]; exists a1, (a2 â‹… z); split; [by rewrite (associative op)|].
+ split. by exists (unit a1); rewrite cmra_unit_r. by exists z.
+ * intros (y1&y2&Hx&[z1 Hy1]&[z2 Hy2]); exists (z1 â‹… z2).
+ by rewrite (associative op _ z1) -(commutative op z1) (associative op z1)
+ -(associative op _ a2) (commutative op z1) -Hy1 -Hy2.
+Qed.
+Lemma always_own_unit (a : M) : (□ uPred_own (unit a))%I ≡ uPred_own (unit a).
+Proof.
+ intros x n; split; [by apply always_elim|intros [a' Hx]]; simpl.
+ rewrite -(cmra_unit_idempotent a) Hx.
+ apply cmra_unit_preservingN, cmra_includedN_l.
+Qed.
+Lemma always_own (a : M) : unit a ≡ a → (□ uPred_own a)%I ≡ uPred_own a.
+Proof. by intros <-; rewrite always_own_unit. Qed.
+Lemma own_empty `{Empty M, !CMRAIdentity M} : True ⊑ uPred_own ∅.
+Proof. intros x [|n] ??; [done|]. by exists x; rewrite (left_id _ _). Qed.
+Lemma own_valid (a : M) : uPred_own a ⊑ (✓ a).
+Proof. move => x n Hv [a' ?]; cofe_subst; eauto using cmra_validN_op_l. Qed.
+Lemma valid_intro {A : cmraT} (a : A) : ✓ a → True ⊑ (✓ a).
+Proof. by intros ? x n ? _; simpl; apply cmra_valid_validN. Qed.
+Lemma valid_elim {A : cmraT} (a : A) : ¬ ✓{1} a → (✓ a) ⊑ False.
+Proof.
+ intros Ha x [|n] ??; [|apply Ha, cmra_validN_le with (S n)]; auto with lia.
+Qed.
+Lemma valid_mono {A B : cmraT} (a : A) (b : B) :
+ (∀ n, ✓{n} a → ✓{n} b) → (✓ a) ⊑ (✓ b).
+Proof. by intros ? x n ?; simpl; auto. Qed.
+Lemma always_valid {A : cmraT} (a : A) : (□ (✓ a))%I ≡ (✓ a : uPred M)%I.
+Proof. done. Qed.
+Lemma own_invalid (a : M) : ¬ ✓{1} a → uPred_own a ⊑ False.
+Proof. by intros; rewrite own_valid valid_elim. Qed.
+
+(* Big ops *)
+Global Instance uPred_big_and_proper : Proper ((≡) ==> (≡)) (@uPred_big_and M).
+Proof. by induction 1 as [|P Q Ps Qs HPQ ? IH]; rewrite /= ?HPQ ?IH. Qed.
+Global Instance uPred_big_sep_proper : Proper ((≡) ==> (≡)) (@uPred_big_sep M).
+Proof. by induction 1 as [|P Q Ps Qs HPQ ? IH]; rewrite /= ?HPQ ?IH. Qed.
+Global Instance uPred_big_and_perm : Proper ((≡ₚ) ==> (≡)) (@uPred_big_and M).
+Proof.
+ induction 1 as [|P Ps Qs ? IH|P Q Ps|]; simpl; auto.
+ * by rewrite IH.
+ * by rewrite !(associative _) (commutative _ P).
+ * etransitivity; eauto.
+Qed.
+Global Instance uPred_big_sep_perm : Proper ((≡ₚ) ==> (≡)) (@uPred_big_sep M).
+Proof.
+ induction 1 as [|P Ps Qs ? IH|P Q Ps|]; simpl; auto.
+ * by rewrite IH.
+ * by rewrite !(associative _) (commutative _ P).
+ * etransitivity; eauto.
+Qed.
+Lemma uPred_big_and_app Ps Qs : (Π∧ (Ps ++ Qs))%I ≡ (Π∧ Ps ∧ Π∧ Qs)%I.
+Proof.
+ by induction Ps as [|P Ps IH];
+ rewrite /= ?(left_id _ _) -?(associative _) ?IH.
+Qed.
+Lemma uPred_big_sep_app Ps Qs : (Π★ (Ps ++ Qs))%I ≡ (Π★ Ps ★ Π★ Qs)%I.
+Proof.
+ by induction Ps as [|P Ps IH];
+ rewrite /= ?(left_id _ _) -?(associative _) ?IH.
+Qed.
+Lemma uPred_big_sep_and Ps : (Π★ Ps) ⊑ (Π∧ Ps).
+Proof. by induction Ps as [|P Ps IH]; simpl; auto. Qed.
+Lemma uPred_big_and_elem_of Ps P : P ∈ Ps → (Π∧ Ps) ⊑ P.
+Proof. induction 1; simpl; auto. Qed.
+Lemma uPred_big_sep_elem_of Ps P : P ∈ Ps → (Π★ Ps) ⊑ P.
+Proof. induction 1; simpl; auto. Qed.
+
+(* Timeless *)
+Lemma timelessP_spec P : TimelessP P ↔ ∀ x n, ✓{n} x → P 1 x → P n x.
+Proof.
+ split.
+ * intros HP x n ??; induction n as [|[|n]]; auto.
+ by destruct (HP x (S (S n))); auto using cmra_validN_S.
+ * move=> HP x [|[|n]] /=; auto; left.
+ apply HP, uPred_weaken with x (S n); eauto using cmra_validN_le.
+Qed.
+Global Instance const_timeless φ : TimelessP (■φ : uPred M)%I.
+Proof. by apply timelessP_spec=> x [|n]. Qed.
+Global Instance and_timeless P Q: TimelessP P → TimelessP Q → TimelessP (P ∧ Q).
+Proof. by intros ??; rewrite /TimelessP later_and or_and_r; apply and_mono. Qed.
+Global Instance or_timeless P Q : TimelessP P → TimelessP Q → TimelessP (P ∨ Q).
+Proof.
+ intros; rewrite /TimelessP later_or (timelessP P) (timelessP Q); eauto 10.
+Qed.
+Global Instance impl_timeless P Q : TimelessP Q → TimelessP (P → Q).
+Proof.
+ rewrite !timelessP_spec=> HP x [|n] ? HPQ x' [|n'] ????; auto.
+ apply HP, HPQ, uPred_weaken with x' (S n'); eauto using cmra_validN_le.
+Qed.
+Global Instance sep_timeless P Q: TimelessP P → TimelessP Q → TimelessP (P ★ Q).
+Proof.
+ intros; rewrite /TimelessP later_sep (timelessP P) (timelessP Q).
+ apply wand_elim_l', or_elim; apply wand_intro_r; auto.
+ apply wand_elim_r', or_elim; apply wand_intro_r; auto.
+ rewrite ?(commutative _ Q); auto.
+Qed.
+Global Instance wand_timeless P Q : TimelessP Q → TimelessP (P -★ Q).
+Proof.
+ rewrite !timelessP_spec=> HP x [|n] ? HPQ x' [|n'] ???; auto.
+ apply HP, HPQ, uPred_weaken with x' (S n');
+ eauto 3 using cmra_validN_le, cmra_validN_op_r.
+Qed.
+Global Instance forall_timeless {A} (P : A → uPred M) :
+ (∀ x, TimelessP (P x)) → TimelessP (∀ x, P x).
+Proof. by setoid_rewrite timelessP_spec=>HP x n ?? a; apply HP. Qed.
+Global Instance exist_timeless {A} (P : A → uPred M) :
+ (∀ x, TimelessP (P x)) → TimelessP (∃ x, P x).
+Proof.
+ by setoid_rewrite timelessP_spec=>HP x [|n] ?;
+ [|intros [a ?]; exists a; apply HP].
+Qed.
+Global Instance always_timeless P : TimelessP P → TimelessP (□ P).
+Proof.
+ intros ?; rewrite /TimelessP.
+ by rewrite -always_const -!always_later -always_or; apply always_mono.
+Qed.
+Global Instance eq_timeless {A : cofeT} (a b : A) :
+ Timeless a → TimelessP (a ≡ b : uPred M)%I.
+Proof. by intro; apply timelessP_spec=> x n ??; apply equiv_dist, timeless. Qed.
+Global Instance own_timeless (a : M) : Timeless a → TimelessP (uPred_own a).
+Proof.
+ intros ?; apply timelessP_spec=> x [|n] ?? //; apply cmra_included_includedN,
+ cmra_timeless_included_l; eauto using cmra_validN_le.
+Qed.
+
+(* Always stable *)
+Notation AS := AlwaysStable.
+Global Instance const_always_stable φ : AS (■φ : uPred M)%I.
+Proof. by rewrite /AlwaysStable always_const. Qed.
+Global Instance always_always_stable P : AS (â–¡ P).
+Proof. by intros; apply always_intro. Qed.
+Global Instance and_always_stable P Q: AS P → AS Q → AS (P ∧ Q).
+Proof. by intros; rewrite /AlwaysStable always_and; apply and_mono. Qed.
+Global Instance or_always_stable P Q : AS P → AS Q → AS (P ∨ Q).
+Proof. by intros; rewrite /AlwaysStable always_or; apply or_mono. Qed.
+Global Instance sep_always_stable P Q: AS P → AS Q → AS (P ★ Q).
+Proof. by intros; rewrite /AlwaysStable always_sep; apply sep_mono. Qed.
+Global Instance forall_always_stable {A} (P : A → uPred M) :
+ (∀ x, AS (P x)) → AS (∀ x, P x).
+Proof. by intros; rewrite /AlwaysStable always_forall; apply forall_mono. Qed.
+Global Instance exist_always_stable {A} (P : A → uPred M) :
+ (∀ x, AS (P x)) → AS (∃ x, P x).
+Proof. by intros; rewrite /AlwaysStable always_exist; apply exist_mono. Qed.
+Global Instance eq_always_stable {A : cofeT} (a b : A) : AS (a ≡ b : uPred M)%I.
+Proof. by intros; rewrite /AlwaysStable always_eq. Qed.
+Global Instance valid_always_stable {A : cmraT} (a : A) : AS (✓ a : uPred M)%I.
+Proof. by intros; rewrite /AlwaysStable always_valid. Qed.
+Global Instance later_always_stable P : AS P → AS (▷ P).
+Proof. by intros; rewrite /AlwaysStable always_later; apply later_mono. Qed.
+Global Instance own_unit_always_stable (a : M) : AS (uPred_own (unit a)).
+Proof. by rewrite /AlwaysStable always_own_unit. Qed.
+Global Instance default_always_stable {A} P (Q : A → uPred M) (mx : option A) :
+ AS P → (∀ x, AS (Q x)) → AS (default P mx Q).
+Proof. destruct mx; apply _. Qed.
+
+Lemma always_always P `{!AlwaysStable P} : (□ P)%I ≡ P.
+Proof. apply (anti_symmetric (⊑)); auto using always_elim. Qed.
+Lemma always_intro' P Q `{!AlwaysStable P} : P ⊑ Q → P ⊑ □ Q.
+Proof. rewrite -(always_always P); apply always_intro. Qed.
+Lemma always_and_sep_l' P Q `{!AlwaysStable P} : (P ∧ Q)%I ≡ (P ★ Q)%I.
+Proof. by rewrite -(always_always P) always_and_sep_l. Qed.
+Lemma always_and_sep_r' P Q `{!AlwaysStable Q} : (P ∧ Q)%I ≡ (P ★ Q)%I.
+Proof. by rewrite -(always_always Q) always_and_sep_r. Qed.
+Lemma always_sep_dup' P `{!AlwaysStable P} : P ≡ (P ★ P)%I.
+Proof. by rewrite -(always_always P) -always_sep_dup. Qed.
+Lemma always_entails_l' P Q `{!AlwaysStable Q} : (P ⊑ Q) → P ⊑ (Q ★ P).
+Proof. by rewrite -(always_always Q); apply always_entails_l. Qed.
+Lemma always_entails_r' P Q `{!AlwaysStable Q} : (P ⊑ Q) → P ⊑ (P ★ Q).
+Proof. by rewrite -(always_always Q); apply always_entails_r. Qed.
+
+End uPred_logic. End uPred.
diff --git a/prelude/base.v b/prelude/base.v
new file mode 100644
index 0000000000000000000000000000000000000000..ddbf6334f62fb0822ed76810cbc2ad1b008a8ba3
--- /dev/null
+++ b/prelude/base.v
@@ -0,0 +1,978 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects type class interfaces, notations, and general theorems
+that are used throughout the whole development. Most importantly it contains
+abstract interfaces for ordered structures, collections, and various other data
+structures. *)
+Global Generalizable All Variables.
+Global Set Automatic Coercions Import.
+Global Set Asymmetric Patterns.
+Require Export Morphisms RelationClasses List Bool Utf8 Program Setoid.
+Obligation Tactic := idtac.
+
+(** * General *)
+(** Zipping lists. *)
+Definition zip_with {A B C} (f : A → B → C) : list A → list B → list C :=
+ fix go l1 l2 :=
+ match l1, l2 with x1 :: l1, x2 :: l2 => f x1 x2 :: go l1 l2 | _ , _ => [] end.
+Notation zip := (zip_with pair).
+
+(** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully
+applied. *)
+Arguments id _ _ /.
+Arguments compose _ _ _ _ _ _ /.
+Arguments flip _ _ _ _ _ _ /.
+Arguments const _ _ _ _ /.
+Typeclasses Transparent id compose flip const.
+Instance: Params (@pair) 2.
+
+(** Change [True] and [False] into notations in order to enable overloading.
+We will use this in the file [assertions] to give [True] and [False] a
+different interpretation in [assert_scope] used for assertions of our axiomatic
+semantics. *)
+Notation "'True'" := True : type_scope.
+Notation "'False'" := False : type_scope.
+
+Notation curry := prod_curry.
+Notation uncurry := prod_uncurry.
+Definition curry3 {A B C D} (f : A → B → C → D) (p : A * B * C) : D :=
+ let '(a,b,c) := p in f a b c.
+Definition curry4 {A B C D E} (f : A → B → C → D → E) (p : A * B * C * D) : E :=
+ let '(a,b,c,d) := p in f a b c d.
+
+(** Throughout this development we use [C_scope] for all general purpose
+notations that do not belong to a more specific scope. *)
+Delimit Scope C_scope with C.
+Global Open Scope C_scope.
+
+(** Introduce some Haskell style like notations. *)
+Notation "(=)" := eq (only parsing) : C_scope.
+Notation "( x =)" := (eq x) (only parsing) : C_scope.
+Notation "(= x )" := (λ y, eq y x) (only parsing) : C_scope.
+Notation "(≠)" := (λ x y, x ≠y) (only parsing) : C_scope.
+Notation "( x ≠)" := (λ y, x ≠y) (only parsing) : C_scope.
+Notation "(≠x )" := (λ y, y ≠x) (only parsing) : C_scope.
+
+Hint Extern 0 (?x = ?x) => reflexivity.
+Hint Extern 100 (_ ≠_) => discriminate.
+
+Notation "(→)" := (λ A B, A → B) (only parsing) : C_scope.
+Notation "( A →)" := (λ B, A → B) (only parsing) : C_scope.
+Notation "(→ B )" := (λ A, A → B) (only parsing) : C_scope.
+
+Notation "t $ r" := (t r)
+ (at level 65, right associativity, only parsing) : C_scope.
+Notation "($)" := (λ f x, f x) (only parsing) : C_scope.
+Notation "($ x )" := (λ f, f x) (only parsing) : C_scope.
+
+Infix "∘" := compose : C_scope.
+Notation "(∘)" := compose (only parsing) : C_scope.
+Notation "( f ∘)" := (compose f) (only parsing) : C_scope.
+Notation "(∘ f )" := (λ g, compose g f) (only parsing) : C_scope.
+
+Notation "(∧)" := and (only parsing) : C_scope.
+Notation "( A ∧)" := (and A) (only parsing) : C_scope.
+Notation "(∧ B )" := (λ A, A ∧ B) (only parsing) : C_scope.
+
+Notation "(∨)" := or (only parsing) : C_scope.
+Notation "( A ∨)" := (or A) (only parsing) : C_scope.
+Notation "(∨ B )" := (λ A, A ∨ B) (only parsing) : C_scope.
+
+Notation "(↔)" := iff (only parsing) : C_scope.
+Notation "( A ↔)" := (iff A) (only parsing) : C_scope.
+Notation "(↔ B )" := (λ A, A ↔ B) (only parsing) : C_scope.
+
+Hint Extern 0 (_ ↔ _) => reflexivity.
+Hint Extern 0 (_ ↔ _) => symmetry; assumption.
+
+Notation "( x ,)" := (pair x) (only parsing) : C_scope.
+Notation "(, y )" := (λ x, (x,y)) (only parsing) : C_scope.
+
+Notation "p .1" := (fst p) (at level 10, format "p .1").
+Notation "p .2" := (snd p) (at level 10, format "p .2").
+
+Definition prod_map {A A' B B'} (f : A → A') (g : B → B')
+ (p : A * B) : A' * B' := (f (p.1), g (p.2)).
+Arguments prod_map {_ _ _ _} _ _ !_ /.
+Definition prod_zip {A A' A'' B B' B''} (f : A → A' → A'') (g : B → B' → B'')
+ (p : A * B) (q : A' * B') : A'' * B'' := (f (p.1) (q.1), g (p.2) (q.2)).
+Arguments prod_zip {_ _ _ _ _ _} _ _ !_ !_ /.
+
+(** Set convenient implicit arguments for [existT] and introduce notations. *)
+Arguments existT {_ _} _ _.
+Arguments proj1_sig {_ _} _.
+Notation "x ↾ p" := (exist _ x p) (at level 20) : C_scope.
+Notation "` x" := (proj1_sig x) (at level 10, format "` x") : C_scope.
+
+(** * Type classes *)
+(** ** Provable propositions *)
+(** This type class collects provable propositions. It is useful to constraint
+type classes by arbitrary propositions. *)
+Class PropHolds (P : Prop) := prop_holds: P.
+
+Hint Extern 0 (PropHolds _) => assumption : typeclass_instances.
+Instance: Proper (iff ==> iff) PropHolds.
+Proof. repeat intro; trivial. Qed.
+
+Ltac solve_propholds :=
+ match goal with
+ | |- PropHolds (?P) => apply _
+ | |- ?P => change (PropHolds P); apply _
+ end.
+
+(** ** Decidable propositions *)
+(** This type class by (Spitters/van der Weegen, 2011) collects decidable
+propositions. For example to declare a parameter expressing decidable equality
+on a type [A] we write [`{∀ x y : A, Decision (x = y)}] and use it by writing
+[decide (x = y)]. *)
+Class Decision (P : Prop) := decide : {P} + {¬P}.
+Arguments decide _ {_}.
+
+(** ** Inhabited types *)
+(** This type class collects types that are inhabited. *)
+Class Inhabited (A : Type) : Type := populate { inhabitant : A }.
+Arguments populate {_} _.
+
+Instance unit_inhabited: Inhabited unit := populate ().
+Instance list_inhabited {A} : Inhabited (list A) := populate [].
+Instance prod_inhabited {A B} (iA : Inhabited A)
+ (iB : Inhabited B) : Inhabited (A * B) :=
+ match iA, iB with populate x, populate y => populate (x,y) end.
+Instance sum_inhabited_l {A B} (iA : Inhabited A) : Inhabited (A + B) :=
+ match iA with populate x => populate (inl x) end.
+Instance sum_inhabited_r {A B} (iB : Inhabited A) : Inhabited (A + B) :=
+ match iB with populate y => populate (inl y) end.
+Instance option_inhabited {A} : Inhabited (option A) := populate None.
+
+(** ** Proof irrelevant types *)
+(** This type class collects types that are proof irrelevant. That means, all
+elements of the type are equal. We use this notion only used for propositions,
+but by universe polymorphism we can generalize it. *)
+Class ProofIrrel (A : Type) : Prop := proof_irrel (x y : A) : x = y.
+
+(** ** Setoid equality *)
+(** We define an operational type class for setoid equality. This is based on
+(Spitters/van der Weegen, 2011). *)
+Class Equiv A := equiv: relation A.
+Infix "≡" := equiv (at level 70, no associativity) : C_scope.
+Notation "(≡)" := equiv (only parsing) : C_scope.
+Notation "( X ≡)" := (equiv X) (only parsing) : C_scope.
+Notation "(≡ X )" := (λ Y, Y ≡ X) (only parsing) : C_scope.
+Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : C_scope.
+Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : C_scope.
+Notation "( X ≢)" := (λ Y, X ≢ Y) (only parsing) : C_scope.
+Notation "(≢ X )" := (λ Y, Y ≢ X) (only parsing) : C_scope.
+
+Class EquivE E A := equivE: E → relation A.
+Instance: Params (@equivE) 4.
+Notation "X ≡{ Γ } Y" := (equivE Γ X Y)
+ (at level 70, format "X ≡{ Γ } Y") : C_scope.
+Notation "(≡{ Γ } )" := (equivE Γ) (only parsing, Γ at level 1) : C_scope.
+Notation "X ≡{ Γ1 , Γ2 , .. , Γ3 } Y" :=
+ (equivE (pair .. (Γ1, Γ2) .. Γ3) X Y)
+ (at level 70, format "'[' X ≡{ Γ1 , Γ2 , .. , Γ3 } '/' Y ']'") : C_scope.
+Notation "(≡{ Γ1 , Γ2 , .. , Γ3 } )" := (equivE (pair .. (Γ1, Γ2) .. Γ3))
+ (only parsing, Γ1 at level 1) : C_scope.
+
+(** The type class [LeibnizEquiv] collects setoid equalities that coincide
+with Leibniz equality. We provide the tactic [fold_leibniz] to transform such
+setoid equalities into Leibniz equalities, and [unfold_leibniz] for the
+reverse. *)
+Class LeibnizEquiv A `{Equiv A} := leibniz_equiv x y : x ≡ y → x = y.
+Lemma leibniz_equiv_iff `{LeibnizEquiv A, !Reflexive (@equiv A _)} (x y : A) :
+ x ≡ y ↔ x = y.
+Proof. split. apply leibniz_equiv. intros ->; reflexivity. Qed.
+
+Ltac fold_leibniz := repeat
+ match goal with
+ | H : context [ @equiv ?A _ _ _ ] |- _ =>
+ setoid_rewrite (leibniz_equiv_iff (A:=A)) in H
+ | |- context [ @equiv ?A _ _ _ ] =>
+ setoid_rewrite (leibniz_equiv_iff (A:=A))
+ end.
+Ltac unfold_leibniz := repeat
+ match goal with
+ | H : context [ @eq ?A _ _ ] |- _ =>
+ setoid_rewrite <-(leibniz_equiv_iff (A:=A)) in H
+ | |- context [ @eq ?A _ _ ] =>
+ setoid_rewrite <-(leibniz_equiv_iff (A:=A))
+ end.
+
+Definition equivL {A} : Equiv A := (=).
+
+(** A [Params f n] instance forces the setoid rewriting mechanism not to
+rewrite in the first [n] arguments of the function [f]. We will declare such
+instances for all operational type classes in this development. *)
+Instance: Params (@equiv) 2.
+
+(** The following instance forces [setoid_replace] to use setoid equality
+(for types that have an [Equiv] instance) rather than the standard Leibniz
+equality. *)
+Instance equiv_default_relation `{Equiv A} : DefaultRelation (≡) | 3.
+Hint Extern 0 (?x ≡ ?y) => reflexivity.
+Hint Extern 0 (_ ≡ _) => symmetry; assumption.
+Hint Extern 0 (?x ≡{_} ?y) => reflexivity.
+Hint Extern 0 (_ ≡{_} _) => symmetry; assumption.
+
+(** ** Operations on collections *)
+(** We define operational type classes for the traditional operations and
+relations on collections: the empty collection [∅], the union [(∪)],
+intersection [(∩)], and difference [(∖)], the singleton [{[_]}], the subset
+[(⊆)] and element of [(∈)] relation, and disjointess [(⊥)]. *)
+Class Empty A := empty: A.
+Notation "∅" := empty : C_scope.
+
+Class Union A := union: A → A → A.
+Instance: Params (@union) 2.
+Infix "∪" := union (at level 50, left associativity) : C_scope.
+Notation "(∪)" := union (only parsing) : C_scope.
+Notation "( x ∪)" := (union x) (only parsing) : C_scope.
+Notation "(∪ x )" := (λ y, union y x) (only parsing) : C_scope.
+Infix "∪*" := (zip_with (∪)) (at level 50, left associativity) : C_scope.
+Notation "(∪*)" := (zip_with (∪)) (only parsing) : C_scope.
+Infix "∪**" := (zip_with (zip_with (∪)))
+ (at level 50, left associativity) : C_scope.
+Infix "∪*∪**" := (zip_with (prod_zip (∪) (∪*)))
+ (at level 50, left associativity) : C_scope.
+
+Definition union_list `{Empty A} `{Union A} : list A → A := fold_right (∪) ∅.
+Arguments union_list _ _ _ !_ /.
+Notation "⋃ l" := (union_list l) (at level 20, format "⋃ l") : C_scope.
+
+Class Intersection A := intersection: A → A → A.
+Instance: Params (@intersection) 2.
+Infix "∩" := intersection (at level 40) : C_scope.
+Notation "(∩)" := intersection (only parsing) : C_scope.
+Notation "( x ∩)" := (intersection x) (only parsing) : C_scope.
+Notation "(∩ x )" := (λ y, intersection y x) (only parsing) : C_scope.
+
+Class Difference A := difference: A → A → A.
+Instance: Params (@difference) 2.
+Infix "∖" := difference (at level 40) : C_scope.
+Notation "(∖)" := difference (only parsing) : C_scope.
+Notation "( x ∖)" := (difference x) (only parsing) : C_scope.
+Notation "(∖ x )" := (λ y, difference y x) (only parsing) : C_scope.
+Infix "∖*" := (zip_with (∖)) (at level 40, left associativity) : C_scope.
+Notation "(∖*)" := (zip_with (∖)) (only parsing) : C_scope.
+Infix "∖**" := (zip_with (zip_with (∖)))
+ (at level 40, left associativity) : C_scope.
+Infix "∖*∖**" := (zip_with (prod_zip (∖) (∖*)))
+ (at level 50, left associativity) : C_scope.
+
+Class Singleton A B := singleton: A → B.
+Instance: Params (@singleton) 3.
+Notation "{[ x ]}" := (singleton x) (at level 1) : C_scope.
+Notation "{[ x ; y ; .. ; z ]}" :=
+ (union .. (union (singleton x) (singleton y)) .. (singleton z))
+ (at level 1) : C_scope.
+Notation "{[ x , y ]}" := (singleton (x,y))
+ (at level 1, y at next level) : C_scope.
+Notation "{[ x , y , z ]}" := (singleton (x,y,z))
+ (at level 1, y at next level, z at next level) : C_scope.
+
+Class SubsetEq A := subseteq: relation A.
+Instance: Params (@subseteq) 2.
+Infix "⊆" := subseteq (at level 70) : C_scope.
+Notation "(⊆)" := subseteq (only parsing) : C_scope.
+Notation "( X ⊆ )" := (subseteq X) (only parsing) : C_scope.
+Notation "( ⊆ X )" := (λ Y, Y ⊆ X) (only parsing) : C_scope.
+Notation "X ⊈ Y" := (¬X ⊆ Y) (at level 70) : C_scope.
+Notation "(⊈)" := (λ X Y, X ⊈ Y) (only parsing) : C_scope.
+Notation "( X ⊈ )" := (λ Y, X ⊈ Y) (only parsing) : C_scope.
+Notation "( ⊈ X )" := (λ Y, Y ⊈ X) (only parsing) : C_scope.
+Infix "⊆*" := (Forall2 (⊆)) (at level 70) : C_scope.
+Notation "(⊆*)" := (Forall2 (⊆)) (only parsing) : C_scope.
+Infix "⊆**" := (Forall2 (⊆*)) (at level 70) : C_scope.
+Infix "⊆1*" := (Forall2 (λ p q, p.1 ⊆ q.1)) (at level 70) : C_scope.
+Infix "⊆2*" := (Forall2 (λ p q, p.2 ⊆ q.2)) (at level 70) : C_scope.
+Infix "⊆1**" := (Forall2 (λ p q, p.1 ⊆* q.1)) (at level 70) : C_scope.
+Infix "⊆2**" := (Forall2 (λ p q, p.2 ⊆* q.2)) (at level 70) : C_scope.
+
+Hint Extern 0 (_ ⊆ _) => reflexivity.
+Hint Extern 0 (_ ⊆* _) => reflexivity.
+Hint Extern 0 (_ ⊆** _) => reflexivity.
+
+Class SubsetEqE E A := subseteqE: E → relation A.
+Instance: Params (@subseteqE) 4.
+Notation "X ⊆{ Γ } Y" := (subseteqE Γ X Y)
+ (at level 70, format "X ⊆{ Γ } Y") : C_scope.
+Notation "(⊆{ Γ } )" := (subseteqE Γ) (only parsing, Γ at level 1) : C_scope.
+Notation "X ⊈{ Γ } Y" := (¬X ⊆{Γ} Y)
+ (at level 70, format "X ⊈{ Γ } Y") : C_scope.
+Notation "(⊈{ Γ } )" := (λ X Y, X ⊈{Γ} Y)
+ (only parsing, Γ at level 1) : C_scope.
+Notation "Xs ⊆{ Γ }* Ys" := (Forall2 (⊆{Γ}) Xs Ys)
+ (at level 70, format "Xs ⊆{ Γ }* Ys") : C_scope.
+Notation "(⊆{ Γ }* )" := (Forall2 (⊆{Γ}))
+ (only parsing, Γ at level 1) : C_scope.
+Notation "X ⊆{ Γ1 , Γ2 , .. , Γ3 } Y" :=
+ (subseteqE (pair .. (Γ1, Γ2) .. Γ3) X Y)
+ (at level 70, format "'[' X ⊆{ Γ1 , Γ2 , .. , Γ3 } '/' Y ']'") : C_scope.
+Notation "(⊆{ Γ1 , Γ2 , .. , Γ3 } )" := (subseteqE (pair .. (Γ1, Γ2) .. Γ3))
+ (only parsing, Γ1 at level 1) : C_scope.
+Notation "X ⊈{ Γ1 , Γ2 , .. , Γ3 } Y" := (¬X ⊆{pair .. (Γ1, Γ2) .. Γ3} Y)
+ (at level 70, format "X ⊈{ Γ1 , Γ2 , .. , Γ3 } Y") : C_scope.
+Notation "(⊈{ Γ1 , Γ2 , .. , Γ3 } )" := (λ X Y, X ⊈{pair .. (Γ1, Γ2) .. Γ3} Y)
+ (only parsing) : C_scope.
+Notation "Xs ⊆{ Γ1 , Γ2 , .. , Γ3 }* Ys" :=
+ (Forall2 (⊆{pair .. (Γ1, Γ2) .. Γ3}) Xs Ys)
+ (at level 70, format "Xs ⊆{ Γ1 , Γ2 , .. , Γ3 }* Ys") : C_scope.
+Notation "(⊆{ Γ1 , Γ2 , .. , Γ3 }* )" := (Forall2 (⊆{pair .. (Γ1, Γ2) .. Γ3}))
+ (only parsing, Γ1 at level 1) : C_scope.
+Hint Extern 0 (_ ⊆{_} _) => reflexivity.
+
+Definition strict {A} (R : relation A) : relation A := λ X Y, R X Y ∧ ¬R Y X.
+Instance: Params (@strict) 2.
+Infix "⊂" := (strict (⊆)) (at level 70) : C_scope.
+Notation "(⊂)" := (strict (⊆)) (only parsing) : C_scope.
+Notation "( X ⊂ )" := (strict (⊆) X) (only parsing) : C_scope.
+Notation "( ⊂ X )" := (λ Y, Y ⊂ X) (only parsing) : C_scope.
+Notation "X ⊄ Y" := (¬X ⊂ Y) (at level 70) : C_scope.
+Notation "(⊄)" := (λ X Y, X ⊄ Y) (only parsing) : C_scope.
+Notation "( X ⊄ )" := (λ Y, X ⊄ Y) (only parsing) : C_scope.
+Notation "( ⊄ X )" := (λ Y, Y ⊄ X) (only parsing) : C_scope.
+
+(** The class [Lexico A] is used for the lexicographic order on [A]. This order
+is used to create finite maps, finite sets, etc, and is typically different from
+the order [(⊆)]. *)
+Class Lexico A := lexico: relation A.
+
+Class ElemOf A B := elem_of: A → B → Prop.
+Instance: Params (@elem_of) 3.
+Infix "∈" := elem_of (at level 70) : C_scope.
+Notation "(∈)" := elem_of (only parsing) : C_scope.
+Notation "( x ∈)" := (elem_of x) (only parsing) : C_scope.
+Notation "(∈ X )" := (λ x, elem_of x X) (only parsing) : C_scope.
+Notation "x ∉ X" := (¬x ∈ X) (at level 80) : C_scope.
+Notation "(∉)" := (λ x X, x ∉ X) (only parsing) : C_scope.
+Notation "( x ∉)" := (λ X, x ∉ X) (only parsing) : C_scope.
+Notation "(∉ X )" := (λ x, x ∉ X) (only parsing) : C_scope.
+
+Class Disjoint A := disjoint : A → A → Prop.
+Instance: Params (@disjoint) 2.
+Infix "⊥" := disjoint (at level 70) : C_scope.
+Notation "(⊥)" := disjoint (only parsing) : C_scope.
+Notation "( X ⊥.)" := (disjoint X) (only parsing) : C_scope.
+Notation "(.⊥ X )" := (λ Y, Y ⊥ X) (only parsing) : C_scope.
+Infix "⊥*" := (Forall2 (⊥)) (at level 70) : C_scope.
+Notation "(⊥*)" := (Forall2 (⊥)) (only parsing) : C_scope.
+Infix "⊥**" := (Forall2 (⊥*)) (at level 70) : C_scope.
+Infix "⊥1*" := (Forall2 (λ p q, p.1 ⊥ q.1)) (at level 70) : C_scope.
+Infix "⊥2*" := (Forall2 (λ p q, p.2 ⊥ q.2)) (at level 70) : C_scope.
+Infix "⊥1**" := (Forall2 (λ p q, p.1 ⊥* q.1)) (at level 70) : C_scope.
+Infix "⊥2**" := (Forall2 (λ p q, p.2 ⊥* q.2)) (at level 70) : C_scope.
+Hint Extern 0 (_ ⊥ _) => symmetry; eassumption.
+Hint Extern 0 (_ ⊥* _) => symmetry; eassumption.
+
+Class DisjointE E A := disjointE : E → A → A → Prop.
+Instance: Params (@disjointE) 4.
+Notation "X ⊥{ Γ } Y" := (disjointE Γ X Y)
+ (at level 70, format "X ⊥{ Γ } Y") : C_scope.
+Notation "(⊥{ Γ } )" := (disjointE Γ) (only parsing, Γ at level 1) : C_scope.
+Notation "Xs ⊥{ Γ }* Ys" := (Forall2 (⊥{Γ}) Xs Ys)
+ (at level 70, format "Xs ⊥{ Γ }* Ys") : C_scope.
+Notation "(⊥{ Γ }* )" := (Forall2 (⊥{Γ}))
+ (only parsing, Γ at level 1) : C_scope.
+Notation "X ⊥{ Γ1 , Γ2 , .. , Γ3 } Y" := (disjoint (pair .. (Γ1, Γ2) .. Γ3) X Y)
+ (at level 70, format "X ⊥{ Γ1 , Γ2 , .. , Γ3 } Y") : C_scope.
+Notation "Xs ⊥{ Γ1 , Γ2 , .. , Γ3 }* Ys" :=
+ (Forall2 (disjoint (pair .. (Γ1, Γ2) .. Γ3)) Xs Ys)
+ (at level 70, format "Xs ⊥{ Γ1 , Γ2 , .. , Γ3 }* Ys") : C_scope.
+Hint Extern 0 (_ ⊥{_} _) => symmetry; eassumption.
+
+Class DisjointList A := disjoint_list : list A → Prop.
+Instance: Params (@disjoint_list) 2.
+Notation "⊥ Xs" := (disjoint_list Xs) (at level 20, format "⊥ Xs") : C_scope.
+
+Section disjoint_list.
+ Context `{Disjoint A, Union A, Empty A}.
+ Inductive disjoint_list_default : DisjointList A :=
+ | disjoint_nil_2 : ⊥ (@nil A)
+ | disjoint_cons_2 (X : A) (Xs : list A) : X ⊥ ⋃ Xs → ⊥ Xs → ⊥ (X :: Xs).
+ Global Existing Instance disjoint_list_default.
+
+ Lemma disjoint_list_nil : ⊥ @nil A ↔ True.
+ Proof. split; constructor. Qed.
+ Lemma disjoint_list_cons X Xs : ⊥ (X :: Xs) ↔ X ⊥ ⋃ Xs ∧ ⊥ Xs.
+ Proof. split. inversion_clear 1; auto. intros [??]. constructor; auto. Qed.
+End disjoint_list.
+
+Class Filter A B := filter: ∀ (P : A → Prop) `{∀ x, Decision (P x)}, B → B.
+
+(** ** Monadic operations *)
+(** We define operational type classes for the monadic operations bind, join
+and fmap. We use these type classes merely for convenient overloading of
+notations and do not formalize any theory on monads (we do not even define a
+class with the monad laws). *)
+Class MRet (M : Type → Type) := mret: ∀ {A}, A → M A.
+Arguments mret {_ _ _} _.
+Instance: Params (@mret) 3.
+Class MBind (M : Type → Type) := mbind : ∀ {A B}, (A → M B) → M A → M B.
+Arguments mbind {_ _ _ _} _ !_ /.
+Instance: Params (@mbind) 4.
+Class MJoin (M : Type → Type) := mjoin: ∀ {A}, M (M A) → M A.
+Arguments mjoin {_ _ _} !_ /.
+Instance: Params (@mjoin) 3.
+Class FMap (M : Type → Type) := fmap : ∀ {A B}, (A → B) → M A → M B.
+Arguments fmap {_ _ _ _} _ !_ /.
+Instance: Params (@fmap) 4.
+Class OMap (M : Type → Type) := omap: ∀ {A B}, (A → option B) → M A → M B.
+Arguments omap {_ _ _ _} _ !_ /.
+Instance: Params (@omap) 4.
+
+Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : C_scope.
+Notation "( m ≫=)" := (λ f, mbind f m) (only parsing) : C_scope.
+Notation "(≫= f )" := (mbind f) (only parsing) : C_scope.
+Notation "(≫=)" := (λ m f, mbind f m) (only parsing) : C_scope.
+
+Notation "x ↠y ; z" := (y ≫= (λ x : _, z))
+ (at level 65, only parsing, right associativity) : C_scope.
+Infix "<$>" := fmap (at level 60, right associativity) : C_scope.
+Notation "' ( x1 , x2 ) ↠y ; z" :=
+ (y ≫= (λ x : _, let ' (x1, x2) := x in z))
+ (at level 65, only parsing, right associativity) : C_scope.
+Notation "' ( x1 , x2 , x3 ) ↠y ; z" :=
+ (y ≫= (λ x : _, let ' (x1,x2,x3) := x in z))
+ (at level 65, only parsing, right associativity) : C_scope.
+Notation "' ( x1 , x2 , x3 , x4 ) ↠y ; z" :=
+ (y ≫= (λ x : _, let ' (x1,x2,x3,x4) := x in z))
+ (at level 65, only parsing, right associativity) : C_scope.
+Notation "' ( x1 , x2 , x3 , x4 , x5 ) ↠y ; z" :=
+ (y ≫= (λ x : _, let ' (x1,x2,x3,x4,x5) := x in z))
+ (at level 65, only parsing, right associativity) : C_scope.
+Notation "' ( x1 , x2 , x3 , x4 , x5 , x6 ) ↠y ; z" :=
+ (y ≫= (λ x : _, let ' (x1,x2,x3,x4,x5,x6) := x in z))
+ (at level 65, only parsing, right associativity) : C_scope.
+
+Notation "ps .*1" := (fmap (M:=list) fst ps)
+ (at level 10, format "ps .*1").
+Notation "ps .*2" := (fmap (M:=list) snd ps)
+ (at level 10, format "ps .*2").
+
+Class MGuard (M : Type → Type) :=
+ mguard: ∀ P {dec : Decision P} {A}, (P → M A) → M A.
+Arguments mguard _ _ _ !_ _ _ /.
+Notation "'guard' P ; o" := (mguard P (λ _, o))
+ (at level 65, only parsing, right associativity) : C_scope.
+Notation "'guard' P 'as' H ; o" := (mguard P (λ H, o))
+ (at level 65, only parsing, right associativity) : C_scope.
+
+(** ** Operations on maps *)
+(** In this section we define operational type classes for the operations
+on maps. In the file [fin_maps] we will axiomatize finite maps.
+The function look up [m !! k] should yield the element at key [k] in [m]. *)
+Class Lookup (K A M : Type) := lookup: K → M → option A.
+Instance: Params (@lookup) 4.
+Notation "m !! i" := (lookup i m) (at level 20) : C_scope.
+Notation "(!!)" := lookup (only parsing) : C_scope.
+Notation "( m !!)" := (λ i, m !! i) (only parsing) : C_scope.
+Notation "(!! i )" := (lookup i) (only parsing) : C_scope.
+Arguments lookup _ _ _ _ !_ !_ / : simpl nomatch.
+
+(** The singleton map *)
+Class SingletonM K A M := singletonM: K → A → M.
+Instance: Params (@singletonM) 5.
+Notation "{[ x ↦ y ]}" := (singletonM x y) (at level 1) : C_scope.
+
+(** The function insert [<[k:=a]>m] should update the element at key [k] with
+value [a] in [m]. *)
+Class Insert (K A M : Type) := insert: K → A → M → M.
+Instance: Params (@insert) 5.
+Notation "<[ k := a ]>" := (insert k a)
+ (at level 5, right associativity, format "<[ k := a ]>") : C_scope.
+Arguments insert _ _ _ _ !_ _ !_ / : simpl nomatch.
+
+(** The function delete [delete k m] should delete the value at key [k] in
+[m]. If the key [k] is not a member of [m], the original map should be
+returned. *)
+Class Delete (K M : Type) := delete: K → M → M.
+Instance: Params (@delete) 4.
+Arguments delete _ _ _ !_ !_ / : simpl nomatch.
+
+(** The function [alter f k m] should update the value at key [k] using the
+function [f], which is called with the original value. *)
+Class Alter (K A M : Type) := alter: (A → A) → K → M → M.
+Instance: Params (@alter) 5.
+Arguments alter {_ _ _ _} _ !_ !_ / : simpl nomatch.
+
+(** The function [alter f k m] should update the value at key [k] using the
+function [f], which is called with the original value at key [k] or [None]
+if [k] is not a member of [m]. The value at [k] should be deleted if [f]
+yields [None]. *)
+Class PartialAlter (K A M : Type) :=
+ partial_alter: (option A → option A) → K → M → M.
+Instance: Params (@partial_alter) 4.
+Arguments partial_alter _ _ _ _ _ !_ !_ / : simpl nomatch.
+
+(** The function [dom C m] should yield the domain of [m]. That is a finite
+collection of type [C] that contains the keys that are a member of [m]. *)
+Class Dom (M C : Type) := dom: M → C.
+Instance: Params (@dom) 3.
+Arguments dom {_} _ {_} !_ / : simpl nomatch, clear implicits.
+
+(** The function [merge f m1 m2] should merge the maps [m1] and [m2] by
+constructing a new map whose value at key [k] is [f (m1 !! k) (m2 !! k)].*)
+Class Merge (M : Type → Type) :=
+ merge: ∀ {A B C}, (option A → option B → option C) → M A → M B → M C.
+Instance: Params (@merge) 4.
+Arguments merge _ _ _ _ _ _ !_ !_ / : simpl nomatch.
+
+(** The function [union_with f m1 m2] is supposed to yield the union of [m1]
+and [m2] using the function [f] to combine values of members that are in
+both [m1] and [m2]. *)
+Class UnionWith (A M : Type) :=
+ union_with: (A → A → option A) → M → M → M.
+Instance: Params (@union_with) 3.
+Arguments union_with {_ _ _} _ !_ !_ / : simpl nomatch.
+
+(** Similarly for intersection and difference. *)
+Class IntersectionWith (A M : Type) :=
+ intersection_with: (A → A → option A) → M → M → M.
+Instance: Params (@intersection_with) 3.
+Arguments intersection_with {_ _ _} _ !_ !_ / : simpl nomatch.
+
+Class DifferenceWith (A M : Type) :=
+ difference_with: (A → A → option A) → M → M → M.
+Instance: Params (@difference_with) 3.
+Arguments difference_with {_ _ _} _ !_ !_ / : simpl nomatch.
+
+Definition intersection_with_list `{IntersectionWith A M}
+ (f : A → A → option A) : M → list M → M := fold_right (intersection_with f).
+Arguments intersection_with_list _ _ _ _ _ !_ /.
+
+Class LookupE (E K A M : Type) := lookupE: E → K → M → option A.
+Instance: Params (@lookupE) 6.
+Notation "m !!{ Γ } i" := (lookupE Γ i m)
+ (at level 20, format "m !!{ Γ } i") : C_scope.
+Notation "(!!{ Γ } )" := (lookupE Γ) (only parsing, Γ at level 1) : C_scope.
+Arguments lookupE _ _ _ _ _ _ !_ !_ / : simpl nomatch.
+
+Class InsertE (E K A M : Type) := insertE: E → K → A → M → M.
+Instance: Params (@insertE) 6.
+Notation "<[ k := a ]{ Γ }>" := (insertE Γ k a)
+ (at level 5, right associativity, format "<[ k := a ]{ Γ }>") : C_scope.
+Arguments insertE _ _ _ _ _ _ !_ _ !_ / : simpl nomatch.
+
+(** ** Common properties *)
+(** These operational type classes allow us to refer to common mathematical
+properties in a generic way. For example, for injectivity of [(k ++)] it
+allows us to write [injective (k ++)] instead of [app_inv_head k]. *)
+Class Injective {A B} (R : relation A) (S : relation B) (f : A → B) : Prop :=
+ injective: ∀ x y, S (f x) (f y) → R x y.
+Class Injective2 {A B C} (R1 : relation A) (R2 : relation B)
+ (S : relation C) (f : A → B → C) : Prop :=
+ injective2: ∀ x1 x2 y1 y2, S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2.
+Class Cancel {A B} (S : relation B) (f : A → B) (g : B → A) : Prop :=
+ cancel: ∀ x, S (f (g x)) x.
+Class Surjective {A B} (R : relation B) (f : A → B) :=
+ surjective : ∀ y, ∃ x, R (f x) y.
+Class Idempotent {A} (R : relation A) (f : A → A → A) : Prop :=
+ idempotent: ∀ x, R (f x x) x.
+Class Commutative {A B} (R : relation A) (f : B → B → A) : Prop :=
+ commutative: ∀ x y, R (f x y) (f y x).
+Class LeftId {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ left_id: ∀ x, R (f i x) x.
+Class RightId {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ right_id: ∀ x, R (f x i) x.
+Class Associative {A} (R : relation A) (f : A → A → A) : Prop :=
+ associative: ∀ x y z, R (f x (f y z)) (f (f x y) z).
+Class LeftAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ left_absorb: ∀ x, R (f i x) i.
+Class RightAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ right_absorb: ∀ x, R (f x i) i.
+Class AntiSymmetric {A} (R S : relation A) : Prop :=
+ anti_symmetric: ∀ x y, S x y → S y x → R x y.
+Class Total {A} (R : relation A) := total x y : R x y ∨ R y x.
+Class Trichotomy {A} (R : relation A) :=
+ trichotomy : ∀ x y, R x y ∨ x = y ∨ R y x.
+Class TrichotomyT {A} (R : relation A) :=
+ trichotomyT : ∀ x y, {R x y} + {x = y} + {R y x}.
+
+Arguments irreflexivity {_} _ {_} _ _.
+Arguments injective {_ _ _ _} _ {_} _ _ _.
+Arguments injective2 {_ _ _ _ _ _} _ {_} _ _ _ _ _.
+Arguments cancel {_ _ _} _ _ {_} _.
+Arguments surjective {_ _ _} _ {_} _.
+Arguments idempotent {_ _} _ {_} _.
+Arguments commutative {_ _ _} _ {_} _ _.
+Arguments left_id {_ _} _ _ {_} _.
+Arguments right_id {_ _} _ _ {_} _.
+Arguments associative {_ _} _ {_} _ _ _.
+Arguments left_absorb {_ _} _ _ {_} _.
+Arguments right_absorb {_ _} _ _ {_} _.
+Arguments anti_symmetric {_ _} _ {_} _ _ _ _.
+Arguments total {_} _ {_} _ _.
+Arguments trichotomy {_} _ {_} _ _.
+Arguments trichotomyT {_} _ {_} _ _.
+
+Instance id_injective {A} : Injective (=) (=) (@id A).
+Proof. intros ??; auto. Qed.
+
+(** The following lemmas are specific versions of the projections of the above
+type classes for Leibniz equality. These lemmas allow us to enforce Coq not to
+use the setoid rewriting mechanism. *)
+Lemma idempotent_L {A} (f : A → A → A) `{!Idempotent (=) f} x : f x x = x.
+Proof. auto. Qed.
+Lemma commutative_L {A B} (f : B → B → A) `{!Commutative (=) f} x y :
+ f x y = f y x.
+Proof. auto. Qed.
+Lemma left_id_L {A} (i : A) (f : A → A → A) `{!LeftId (=) i f} x : f i x = x.
+Proof. auto. Qed.
+Lemma right_id_L {A} (i : A) (f : A → A → A) `{!RightId (=) i f} x : f x i = x.
+Proof. auto. Qed.
+Lemma associative_L {A} (f : A → A → A) `{!Associative (=) f} x y z :
+ f x (f y z) = f (f x y) z.
+Proof. auto. Qed.
+Lemma left_absorb_L {A} (i : A) (f : A → A → A) `{!LeftAbsorb (=) i f} x :
+ f i x = i.
+Proof. auto. Qed.
+Lemma right_absorb_L {A} (i : A) (f : A → A → A) `{!RightAbsorb (=) i f} x :
+ f x i = i.
+Proof. auto. Qed.
+
+(** ** Axiomatization of ordered structures *)
+(** The classes [PreOrder], [PartialOrder], and [TotalOrder] use an arbitrary
+relation [R] instead of [⊆] to support multiple orders on the same type. *)
+Class PartialOrder {A} (R : relation A) : Prop := {
+ partial_order_pre :> PreOrder R;
+ partial_order_anti_symmetric :> AntiSymmetric (=) R
+}.
+Class TotalOrder {A} (R : relation A) : Prop := {
+ total_order_partial :> PartialOrder R;
+ total_order_trichotomy :> Trichotomy (strict R)
+}.
+
+(** We do not use a setoid equality in the following interfaces to avoid the
+need for proofs that the relations and operations are proper. Instead, we
+define setoid equality generically [λ X Y, X ⊆ Y ∧ Y ⊆ X]. *)
+Class EmptySpec A `{Empty A, SubsetEq A} : Prop := subseteq_empty X : ∅ ⊆ X.
+Class JoinSemiLattice A `{SubsetEq A, Union A} : Prop := {
+ join_semi_lattice_pre :>> PreOrder (⊆);
+ union_subseteq_l X Y : X ⊆ X ∪ Y;
+ union_subseteq_r X Y : Y ⊆ X ∪ Y;
+ union_least X Y Z : X ⊆ Z → Y ⊆ Z → X ∪ Y ⊆ Z
+}.
+Class MeetSemiLattice A `{SubsetEq A, Intersection A} : Prop := {
+ meet_semi_lattice_pre :>> PreOrder (⊆);
+ intersection_subseteq_l X Y : X ∩ Y ⊆ X;
+ intersection_subseteq_r X Y : X ∩ Y ⊆ Y;
+ intersection_greatest X Y Z : Z ⊆ X → Z ⊆ Y → Z ⊆ X ∩ Y
+}.
+Class Lattice A `{SubsetEq A, Union A, Intersection A} : Prop := {
+ lattice_join :>> JoinSemiLattice A;
+ lattice_meet :>> MeetSemiLattice A;
+ lattice_distr X Y Z : (X ∪ Y) ∩ (X ∪ Z) ⊆ X ∪ (Y ∩ Z)
+}.
+
+(** ** Axiomatization of collections *)
+(** The class [SimpleCollection A C] axiomatizes a collection of type [C] with
+elements of type [A]. *)
+Instance: Params (@map) 3.
+Class SimpleCollection A C `{ElemOf A C,
+ Empty C, Singleton A C, Union C} : Prop := {
+ not_elem_of_empty (x : A) : x ∉ ∅;
+ elem_of_singleton (x y : A) : x ∈ {[ y ]} ↔ x = y;
+ elem_of_union X Y (x : A) : x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y
+}.
+Class Collection A C `{ElemOf A C, Empty C, Singleton A C,
+ Union C, Intersection C, Difference C} : Prop := {
+ collection_simple :>> SimpleCollection A C;
+ elem_of_intersection X Y (x : A) : x ∈ X ∩ Y ↔ x ∈ X ∧ x ∈ Y;
+ elem_of_difference X Y (x : A) : x ∈ X ∖ Y ↔ x ∈ X ∧ x ∉ Y
+}.
+Class CollectionOps A C `{ElemOf A C, Empty C, Singleton A C, Union C,
+ Intersection C, Difference C, IntersectionWith A C, Filter A C} : Prop := {
+ collection_ops :>> Collection A C;
+ elem_of_intersection_with (f : A → A → option A) X Y (x : A) :
+ x ∈ intersection_with f X Y ↔ ∃ x1 x2, x1 ∈ X ∧ x2 ∈ Y ∧ f x1 x2 = Some x;
+ elem_of_filter X P `{∀ x, Decision (P x)} x : x ∈ filter P X ↔ P x ∧ x ∈ X
+}.
+
+(** We axiomative a finite collection as a collection whose elements can be
+enumerated as a list. These elements, given by the [elements] function, may be
+in any order and should not contain duplicates. *)
+Class Elements A C := elements: C → list A.
+Instance: Params (@elements) 3.
+
+(** We redefine the standard library's [In] and [NoDup] using type classes. *)
+Inductive elem_of_list {A} : ElemOf A (list A) :=
+ | elem_of_list_here (x : A) l : x ∈ x :: l
+ | elem_of_list_further (x y : A) l : x ∈ l → x ∈ y :: l.
+Existing Instance elem_of_list.
+
+Inductive NoDup {A} : list A → Prop :=
+ | NoDup_nil_2 : NoDup []
+ | NoDup_cons_2 x l : x ∉ l → NoDup l → NoDup (x :: l).
+
+(** Decidability of equality of the carrier set is admissible, but we add it
+anyway so as to avoid cycles in type class search. *)
+Class FinCollection A C `{ElemOf A C, Empty C, Singleton A C,
+ Union C, Intersection C, Difference C,
+ Elements A C, ∀ x y : A, Decision (x = y)} : Prop := {
+ fin_collection :>> Collection A C;
+ elem_of_elements X x : x ∈ elements X ↔ x ∈ X;
+ NoDup_elements X : NoDup (elements X)
+}.
+Class Size C := size: C → nat.
+Arguments size {_ _} !_ / : simpl nomatch.
+Instance: Params (@size) 2.
+
+(** The class [Collection M] axiomatizes a type constructor [M] that can be
+used to construct a collection [M A] with elements of type [A]. The advantage
+of this class, compared to [Collection], is that it also axiomatizes the
+the monadic operations. The disadvantage, is that not many inhabits are
+possible (we will only provide an inhabitant using unordered lists without
+duplicates removed). More interesting implementations typically need
+decidability of equality, or a total order on the elements, which do not fit
+in a type constructor of type [Type → Type]. *)
+Class CollectionMonad M `{∀ A, ElemOf A (M A),
+ ∀ A, Empty (M A), ∀ A, Singleton A (M A), ∀ A, Union (M A),
+ !MBind M, !MRet M, !FMap M, !MJoin M} : Prop := {
+ collection_monad_simple A :> SimpleCollection A (M A);
+ elem_of_bind {A B} (f : A → M B) (X : M A) (x : B) :
+ x ∈ X ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ X;
+ elem_of_ret {A} (x y : A) : x ∈ mret y ↔ x = y;
+ elem_of_fmap {A B} (f : A → B) (X : M A) (x : B) :
+ x ∈ f <$> X ↔ ∃ y, x = f y ∧ y ∈ X;
+ elem_of_join {A} (X : M (M A)) (x : A) : x ∈ mjoin X ↔ ∃ Y, x ∈ Y ∧ Y ∈ X
+}.
+
+(** The function [fresh X] yields an element that is not contained in [X]. We
+will later prove that [fresh] is [Proper] with respect to the induced setoid
+equality on collections. *)
+Class Fresh A C := fresh: C → A.
+Instance: Params (@fresh) 3.
+Class FreshSpec A C `{ElemOf A C,
+ Empty C, Singleton A C, Union C, Fresh A C} : Prop := {
+ fresh_collection_simple :>> SimpleCollection A C;
+ fresh_proper_alt X Y : (∀ x, x ∈ X ↔ x ∈ Y) → fresh X = fresh Y;
+ is_fresh (X : C) : fresh X ∉ X
+}.
+
+(** * Booleans *)
+(** The following coercion allows us to use Booleans as propositions. *)
+Coercion Is_true : bool >-> Sortclass.
+Hint Unfold Is_true.
+Hint Immediate Is_true_eq_left.
+Hint Resolve orb_prop_intro andb_prop_intro.
+Notation "(&&)" := andb (only parsing).
+Notation "(||)" := orb (only parsing).
+Infix "&&*" := (zip_with (&&)) (at level 40).
+Infix "||*" := (zip_with (||)) (at level 50).
+
+Definition bool_le (β1 β2 : bool) : Prop := negb β1 || β2.
+Infix "=.>" := bool_le (at level 70).
+Infix "=.>*" := (Forall2 bool_le) (at level 70).
+Instance: PartialOrder bool_le.
+Proof. repeat split; repeat intros [|]; compute; tauto. Qed.
+
+Lemma andb_True b1 b2 : b1 && b2 ↔ b1 ∧ b2.
+Proof. destruct b1, b2; simpl; tauto. Qed.
+Lemma orb_True b1 b2 : b1 || b2 ↔ b1 ∨ b2.
+Proof. destruct b1, b2; simpl; tauto. Qed.
+Lemma negb_True b : negb b ↔ ¬b.
+Proof. destruct b; simpl; tauto. Qed.
+Lemma Is_true_false (b : bool) : b = false → ¬b.
+Proof. now intros -> ?. Qed.
+
+(** * Miscellaneous *)
+Class Half A := half: A → A.
+Notation "½" := half : C_scope.
+Notation "½*" := (fmap (M:=list) half) : C_scope.
+
+Lemma proj1_sig_inj {A} (P : A → Prop) x (Px : P x) y (Py : P y) :
+ x↾Px = y↾Py → x = y.
+Proof. injection 1; trivial. Qed.
+Lemma not_symmetry `{R : relation A, !Symmetric R} x y : ¬R x y → ¬R y x.
+Proof. intuition. Qed.
+Lemma symmetry_iff `(R : relation A) `{!Symmetric R} x y : R x y ↔ R y x.
+Proof. intuition. Qed.
+
+(** ** Pointwise relations *)
+(** These instances are in Coq trunk since revision 15455, but are not in Coq
+8.4 yet. *)
+Instance pointwise_reflexive {A} `{R : relation B} :
+ Reflexive R → Reflexive (pointwise_relation A R) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_symmetric {A} `{R : relation B} :
+ Symmetric R → Symmetric (pointwise_relation A R) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_transitive {A} `{R : relation B} :
+ Transitive R → Transitive (pointwise_relation A R) | 9.
+Proof. firstorder. Qed.
+
+(** ** Unit *)
+Instance unit_equiv : Equiv unit := λ _ _, True.
+Instance unit_equivalence : Equivalence (@equiv unit _).
+Proof. repeat split. Qed.
+
+(** ** Products *)
+Instance prod_map_injective {A A' B B'} (f : A → A') (g : B → B') :
+ Injective (=) (=) f → Injective (=) (=) g →
+ Injective (=) (=) (prod_map f g).
+Proof.
+ intros ?? [??] [??] ?; simpl in *; f_equal;
+ [apply (injective f)|apply (injective g)]; congruence.
+Qed.
+
+Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) :
+ relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2).
+Section prod_relation.
+ Context `{R1 : relation A, R2 : relation B}.
+ Global Instance:
+ Reflexive R1 → Reflexive R2 → Reflexive (prod_relation R1 R2).
+ Proof. firstorder eauto. Qed.
+ Global Instance:
+ Symmetric R1 → Symmetric R2 → Symmetric (prod_relation R1 R2).
+ Proof. firstorder eauto. Qed.
+ Global Instance:
+ Transitive R1 → Transitive R2 → Transitive (prod_relation R1 R2).
+ Proof. firstorder eauto. Qed.
+ Global Instance:
+ Equivalence R1 → Equivalence R2 → Equivalence (prod_relation R1 R2).
+ Proof. split; apply _. Qed.
+ Global Instance: Proper (R1 ==> R2 ==> prod_relation R1 R2) pair.
+ Proof. firstorder eauto. Qed.
+ Global Instance: Proper (prod_relation R1 R2 ==> R1) fst.
+ Proof. firstorder eauto. Qed.
+ Global Instance: Proper (prod_relation R1 R2 ==> R2) snd.
+ Proof. firstorder eauto. Qed.
+End prod_relation.
+
+Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) := prod_relation (≡) (≡).
+Instance pair_proper `{Equiv A, Equiv B} :
+ Proper ((≡) ==> (≡) ==> (≡)) (@pair A B) | 0 := _.
+Instance fst_proper `{Equiv A, Equiv B} :
+ Proper ((≡) ==> (≡)) (@fst A B) | 0 := _.
+Instance snd_proper `{Equiv A, Equiv B} :
+ Proper ((≡) ==> (≡)) (@snd A B) | 0 := _.
+Typeclasses Opaque prod_equiv.
+
+(** ** Other *)
+Lemma or_l P Q : ¬Q → P ∨ Q ↔ P.
+Proof. tauto. Qed.
+Lemma or_r P Q : ¬P → P ∨ Q ↔ Q.
+Proof. tauto. Qed.
+Lemma and_wlog_l (P Q : Prop) : (Q → P) → Q → (P ∧ Q).
+Proof. tauto. Qed.
+Lemma and_wlog_r (P Q : Prop) : P → (P → Q) → (P ∧ Q).
+Proof. tauto. Qed.
+Instance: ∀ A B (x : B), Commutative (=) (λ _ _ : A, x).
+Proof. red. trivial. Qed.
+Instance: ∀ A (x : A), Associative (=) (λ _ _ : A, x).
+Proof. red. trivial. Qed.
+Instance: ∀ A, Associative (=) (λ x _ : A, x).
+Proof. red. trivial. Qed.
+Instance: ∀ A, Associative (=) (λ _ x : A, x).
+Proof. red. trivial. Qed.
+Instance: ∀ A, Idempotent (=) (λ x _ : A, x).
+Proof. red. trivial. Qed.
+Instance: ∀ A, Idempotent (=) (λ _ x : A, x).
+Proof. red. trivial. Qed.
+
+Instance left_id_propholds {A} (R : relation A) i f :
+ LeftId R i f → ∀ x, PropHolds (R (f i x) x).
+Proof. red. trivial. Qed.
+Instance right_id_propholds {A} (R : relation A) i f :
+ RightId R i f → ∀ x, PropHolds (R (f x i) x).
+Proof. red. trivial. Qed.
+Instance left_absorb_propholds {A} (R : relation A) i f :
+ LeftAbsorb R i f → ∀ x, PropHolds (R (f i x) i).
+Proof. red. trivial. Qed.
+Instance right_absorb_propholds {A} (R : relation A) i f :
+ RightAbsorb R i f → ∀ x, PropHolds (R (f x i) i).
+Proof. red. trivial. Qed.
+Instance idem_propholds {A} (R : relation A) f :
+ Idempotent R f → ∀ x, PropHolds (R (f x x) x).
+Proof. red. trivial. Qed.
+
+Instance: ∀ `{R1 : relation A, R2 : relation B} (x : B),
+ Reflexive R2 → Proper (R1 ==> R2) (λ _, x).
+Proof. intros A R1 B R2 x ? y1 y2; reflexivity. Qed.
+Instance: @PreOrder A (=).
+Proof. split; repeat intro; congruence. Qed.
+Lemma injective_iff {A B} {R : relation A} {S : relation B} (f : A → B)
+ `{!Injective R S f} `{!Proper (R ==> S) f} x y : S (f x) (f y) ↔ R x y.
+Proof. firstorder. Qed.
+Instance: Injective (=) (=) (@inl A B).
+Proof. injection 1; auto. Qed.
+Instance: Injective (=) (=) (@inr A B).
+Proof. injection 1; auto. Qed.
+Instance: Injective2 (=) (=) (=) (@pair A B).
+Proof. injection 1; auto. Qed.
+Instance: ∀ `{Injective2 A B C R1 R2 R3 f} y, Injective R1 R3 (λ x, f x y).
+Proof. repeat intro; edestruct (injective2 f); eauto. Qed.
+Instance: ∀ `{Injective2 A B C R1 R2 R3 f} x, Injective R2 R3 (f x).
+Proof. repeat intro; edestruct (injective2 f); eauto. Qed.
+
+Lemma cancel_injective `{Cancel A B R1 f g}
+ `{!Equivalence R1} `{!Proper (R2 ==> R1) f} : Injective R1 R2 g.
+Proof.
+ intros x y E. rewrite <-(cancel f g x), <-(cancel f g y), E. reflexivity.
+Qed.
+Lemma cancel_surjective `{Cancel A B R1 f g} : Surjective R1 f.
+Proof. intros y. exists (g y). auto. Qed.
+
+Lemma impl_transitive (P Q R : Prop) : (P → Q) → (Q → R) → (P → R).
+Proof. tauto. Qed.
+Instance: Commutative (↔) (@eq A).
+Proof. red; intuition. Qed.
+Instance: Commutative (↔) (λ x y, @eq A y x).
+Proof. red; intuition. Qed.
+Instance: Commutative (↔) (↔).
+Proof. red; intuition. Qed.
+Instance: Commutative (↔) (∧).
+Proof. red; intuition. Qed.
+Instance: Associative (↔) (∧).
+Proof. red; intuition. Qed.
+Instance: Idempotent (↔) (∧).
+Proof. red; intuition. Qed.
+Instance: Commutative (↔) (∨).
+Proof. red; intuition. Qed.
+Instance: Associative (↔) (∨).
+Proof. red; intuition. Qed.
+Instance: Idempotent (↔) (∨).
+Proof. red; intuition. Qed.
+Instance: LeftId (↔) True (∧).
+Proof. red; intuition. Qed.
+Instance: RightId (↔) True (∧).
+Proof. red; intuition. Qed.
+Instance: LeftAbsorb (↔) False (∧).
+Proof. red; intuition. Qed.
+Instance: RightAbsorb (↔) False (∧).
+Proof. red; intuition. Qed.
+Instance: LeftId (↔) False (∨).
+Proof. red; intuition. Qed.
+Instance: RightId (↔) False (∨).
+Proof. red; intuition. Qed.
+Instance: LeftAbsorb (↔) True (∨).
+Proof. red; intuition. Qed.
+Instance: RightAbsorb (↔) True (∨).
+Proof. red; intuition. Qed.
+Instance: LeftId (↔) True impl.
+Proof. unfold impl. red; intuition. Qed.
+Instance: RightAbsorb (↔) True impl.
+Proof. unfold impl. red; intuition. Qed.
+Lemma not_injective `{Injective A B R R' f} x y : ¬R x y → ¬R' (f x) (f y).
+Proof. intuition. Qed.
+Instance injective_compose {A B C} R1 R2 R3 (f : A → B) (g : B → C) :
+ Injective R1 R2 f → Injective R2 R3 g → Injective R1 R3 (g ∘ f).
+Proof. red; intuition. Qed.
+Instance surjective_compose {A B C} R (f : A → B) (g : B → C) :
+ Surjective (=) f → Surjective R g → Surjective R (g ∘ f).
+Proof.
+ intros ?? x. unfold compose. destruct (surjective g x) as [y ?].
+ destruct (surjective f y) as [z ?]. exists z. congruence.
+Qed.
+
+Section sig_map.
+ Context `{P : A → Prop} `{Q : B → Prop} (f : A → B) (Hf : ∀ x, P x → Q (f x)).
+ Definition sig_map (x : sig P) : sig Q := f (`x) ↾ Hf _ (proj2_sig x).
+ Global Instance sig_map_injective:
+ (∀ x, ProofIrrel (P x)) → Injective (=) (=) f → Injective (=) (=) sig_map.
+ Proof.
+ intros ?? [x Hx] [y Hy]. injection 1. intros Hxy.
+ apply (injective f) in Hxy; subst. rewrite (proof_irrel _ Hy). auto.
+ Qed.
+End sig_map.
+Arguments sig_map _ _ _ _ _ _ !_ /.
diff --git a/prelude/bsets.v b/prelude/bsets.v
new file mode 100644
index 0000000000000000000000000000000000000000..87e1c50eaffba71dd7e8aa4ed35d953b7ad3d461
--- /dev/null
+++ b/prelude/bsets.v
@@ -0,0 +1,35 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file implements bsets as functions into Prop. *)
+Require Export prelude.prelude.
+
+Record bset (A : Type) : Type := mkBSet { bset_car : A → bool }.
+Arguments mkBSet {_} _.
+Arguments bset_car {_} _ _.
+Definition bset_all {A} : bset A := mkBSet (λ _, true).
+Instance bset_empty {A} : Empty (bset A) := mkBSet (λ _, false).
+Instance bset_singleton {A} `{∀ x y : A, Decision (x = y)} :
+ Singleton A (bset A) := λ x, mkBSet (λ y, bool_decide (y = x)).
+Instance bset_elem_of {A} : ElemOf A (bset A) := λ x X, bset_car X x.
+Instance bset_union {A} : Union (bset A) := λ X1 X2,
+ mkBSet (λ x, bset_car X1 x || bset_car X2 x).
+Instance bset_intersection {A} : Intersection (bset A) := λ X1 X2,
+ mkBSet (λ x, bset_car X1 x && bset_car X2 x).
+Instance bset_difference {A} : Difference (bset A) := λ X1 X2,
+ mkBSet (λ x, bset_car X1 x && negb (bset_car X2 x)).
+Instance bset_collection {A} `{∀ x y : A, Decision (x = y)} :
+ Collection A (bset A).
+Proof.
+ split; [split| |].
+ * by intros x ?.
+ * by intros x y; rewrite <-(bool_decide_spec (x = y)).
+ * split. apply orb_prop_elim. apply orb_prop_intro.
+ * split. apply andb_prop_elim. apply andb_prop_intro.
+ * intros X Y x; unfold elem_of, bset_elem_of; simpl.
+ destruct (bset_car X x), (bset_car Y x); simpl; tauto.
+Qed.
+Instance bset_elem_of_dec {A} x (X : bset A) : Decision (x ∈ X) := _.
+
+Typeclasses Opaque bset_elem_of.
+Global Opaque bset_empty bset_singleton bset_union
+ bset_intersection bset_difference.
diff --git a/prelude/co_pset.v b/prelude/co_pset.v
new file mode 100644
index 0000000000000000000000000000000000000000..55efb4f7851d7383c3e01b9d07969041ed42bfa1
--- /dev/null
+++ b/prelude/co_pset.v
@@ -0,0 +1,390 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files implements an efficient implementation of finite/cofinite sets
+of positive binary naturals [positive]. *)
+Require Export prelude.collections.
+Require Import prelude.pmap prelude.gmap prelude.mapset.
+Local Open Scope positive_scope.
+
+(** * The tree data structure *)
+Inductive coPset_raw :=
+ | coPLeaf : bool → coPset_raw
+ | coPNode : bool → coPset_raw → coPset_raw → coPset_raw.
+Instance coPset_raw_eq_dec (t1 t2 : coPset_raw) : Decision (t1 = t2).
+Proof. solve_decision. Defined.
+
+Fixpoint coPset_wf (t : coPset_raw) : bool :=
+ match t with
+ | coPLeaf _ => true
+ | coPNode true (coPLeaf true) (coPLeaf true) => false
+ | coPNode false (coPLeaf false) (coPLeaf false) => false
+ | coPNode b l r => coPset_wf l && coPset_wf r
+ end.
+Arguments coPset_wf !_ / : simpl nomatch.
+
+Lemma coPNode_wf_l b l r : coPset_wf (coPNode b l r) → coPset_wf l.
+Proof. destruct b, l as [[]|],r as [[]|]; simpl; rewrite ?andb_True; tauto. Qed.
+Lemma coPNode_wf_r b l r : coPset_wf (coPNode b l r) → coPset_wf r.
+Proof. destruct b, l as [[]|],r as [[]|]; simpl; rewrite ?andb_True; tauto. Qed.
+Local Hint Immediate coPNode_wf_l coPNode_wf_r.
+
+Definition coPNode' (b : bool) (l r : coPset_raw) : coPset_raw :=
+ match b, l, r with
+ | true, coPLeaf true, coPLeaf true => coPLeaf true
+ | false, coPLeaf false, coPLeaf false => coPLeaf false
+ | _, _, _ => coPNode b l r
+ end.
+Arguments coPNode' _ _ _ : simpl never.
+Lemma coPNode_wf b l r : coPset_wf l → coPset_wf r → coPset_wf (coPNode' b l r).
+Proof. destruct b, l as [[]|], r as [[]|]; simpl; auto. Qed.
+Hint Resolve coPNode_wf.
+
+Fixpoint coPset_elem_of_raw (p : positive) (t : coPset_raw) {struct t} : bool :=
+ match t, p with
+ | coPLeaf b, _ => b
+ | coPNode b l r, 1 => b
+ | coPNode _ l _, p~0 => coPset_elem_of_raw p l
+ | coPNode _ _ r, p~1 => coPset_elem_of_raw p r
+ end.
+Local Notation e_of := coPset_elem_of_raw.
+Arguments coPset_elem_of_raw _ !_ / : simpl nomatch.
+Lemma coPset_elem_of_node b l r p :
+ e_of p (coPNode' b l r) = e_of p (coPNode b l r).
+Proof. by destruct p, b, l as [[]|], r as [[]|]. Qed.
+
+Lemma coPLeaf_wf t b : (∀ p, e_of p t = b) → coPset_wf t → t = coPLeaf b.
+Proof.
+ induction t as [b'|b' l IHl r IHr]; intros Ht ?; [f_equal; apply (Ht 1)|].
+ assert (b' = b) by (apply (Ht 1)); subst.
+ assert (l = coPLeaf b) as -> by (apply IHl; try apply (λ p, Ht (p~0)); eauto).
+ assert (r = coPLeaf b) as -> by (apply IHr; try apply (λ p, Ht (p~1)); eauto).
+ by destruct b.
+Qed.
+Lemma coPset_eq t1 t2 :
+ (∀ p, e_of p t1 = e_of p t2) → coPset_wf t1 → coPset_wf t2 → t1 = t2.
+Proof.
+ revert t2.
+ induction t1 as [b1|b1 l1 IHl r1 IHr]; intros [b2|b2 l2 r2] Ht ??; simpl in *.
+ * f_equal; apply (Ht 1).
+ * by discriminate (coPLeaf_wf (coPNode b2 l2 r2) b1).
+ * by discriminate (coPLeaf_wf (coPNode b1 l1 r1) b2).
+ * f_equal; [apply (Ht 1)| |].
+ + apply IHl; try apply (λ x, Ht (x~0)); eauto.
+ + apply IHr; try apply (λ x, Ht (x~1)); eauto.
+Qed.
+
+Fixpoint coPset_singleton_raw (p : positive) : coPset_raw :=
+ match p with
+ | 1 => coPNode true (coPLeaf false) (coPLeaf false)
+ | p~0 => coPNode' false (coPset_singleton_raw p) (coPLeaf false)
+ | p~1 => coPNode' false (coPLeaf false) (coPset_singleton_raw p)
+ end.
+Instance coPset_union_raw : Union coPset_raw :=
+ fix go t1 t2 := let _ : Union _ := @go in
+ match t1, t2 with
+ | coPLeaf false, coPLeaf false => coPLeaf false
+ | _, coPLeaf true => coPLeaf true
+ | coPLeaf true, _ => coPLeaf true
+ | coPNode b l r, coPLeaf false => coPNode b l r
+ | coPLeaf false, coPNode b l r => coPNode b l r
+ | coPNode b1 l1 r1, coPNode b2 l2 r2 => coPNode' (b1||b2) (l1 ∪ l2) (r1 ∪ r2)
+ end.
+Local Arguments union _ _!_ !_ /.
+Instance coPset_intersection_raw : Intersection coPset_raw :=
+ fix go t1 t2 := let _ : Intersection _ := @go in
+ match t1, t2 with
+ | coPLeaf true, coPLeaf true => coPLeaf true
+ | _, coPLeaf false => coPLeaf false
+ | coPLeaf false, _ => coPLeaf false
+ | coPNode b l r, coPLeaf true => coPNode b l r
+ | coPLeaf true, coPNode b l r => coPNode b l r
+ | coPNode b1 l1 r1, coPNode b2 l2 r2 => coPNode' (b1&&b2) (l1 ∩ l2) (r1 ∩ r2)
+ end.
+Local Arguments intersection _ _!_ !_ /.
+Fixpoint coPset_opp_raw (t : coPset_raw) : coPset_raw :=
+ match t with
+ | coPLeaf b => coPLeaf (negb b)
+ | coPNode b l r => coPNode' (negb b) (coPset_opp_raw l) (coPset_opp_raw r)
+ end.
+
+Lemma coPset_singleton_wf p : coPset_wf (coPset_singleton_raw p).
+Proof. induction p; simpl; eauto. Qed.
+Lemma coPset_union_wf t1 t2 : coPset_wf t1 → coPset_wf t2 → coPset_wf (t1 ∪ t2).
+Proof. revert t2; induction t1 as [[]|[]]; intros [[]|[] ??]; simpl; eauto. Qed.
+Lemma coPset_intersection_wf t1 t2 :
+ coPset_wf t1 → coPset_wf t2 → coPset_wf (t1 ∩ t2).
+Proof. revert t2; induction t1 as [[]|[]]; intros [[]|[] ??]; simpl; eauto. Qed.
+Lemma coPset_opp_wf t : coPset_wf (coPset_opp_raw t).
+Proof. induction t as [[]|[]]; simpl; eauto. Qed.
+Lemma elem_to_Pset_singleton p q : e_of p (coPset_singleton_raw q) ↔ p = q.
+Proof.
+ split; [|by intros <-; induction p; simpl; rewrite ?coPset_elem_of_node].
+ by revert q; induction p; intros [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; intros; f_equal'; auto.
+Qed.
+Lemma elem_to_Pset_union t1 t2 p : e_of p (t1 ∪ t2) = e_of p t1 || e_of p t2.
+Proof.
+ by revert t2 p; induction t1 as [[]|[]]; intros [[]|[] ??] [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; simpl;
+ rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r.
+Qed.
+Lemma elem_to_Pset_intersection t1 t2 p :
+ e_of p (t1 ∩ t2) = e_of p t1 && e_of p t2.
+Proof.
+ by revert t2 p; induction t1 as [[]|[]]; intros [[]|[] ??] [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; simpl;
+ rewrite ?andb_true_l, ?andb_false_l, ?andb_true_r, ?andb_false_r.
+Qed.
+Lemma elem_to_Pset_opp t p : e_of p (coPset_opp_raw t) = negb (e_of p t).
+Proof.
+ by revert p; induction t as [[]|[]]; intros [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; simpl.
+Qed.
+
+(** * Packed together + set operations *)
+Definition coPset := { t | coPset_wf t }.
+
+Instance coPset_singleton : Singleton positive coPset := λ p,
+ coPset_singleton_raw p ↾ coPset_singleton_wf _.
+Instance coPset_elem_of : ElemOf positive coPset := λ p X, e_of p (`X).
+Instance coPset_empty : Empty coPset := coPLeaf false ↾ I.
+Definition coPset_all : coPset := coPLeaf true ↾ I.
+Instance coPset_union : Union coPset := λ X Y,
+ let (t1,Ht1) := X in let (t2,Ht2) := Y in
+ (t1 ∪ t2) ↾ coPset_union_wf _ _ Ht1 Ht2.
+Instance coPset_intersection : Intersection coPset := λ X Y,
+ let (t1,Ht1) := X in let (t2,Ht2) := Y in
+ (t1 ∩ t2) ↾ coPset_intersection_wf _ _ Ht1 Ht2.
+Instance coPset_difference : Difference coPset := λ X Y,
+ let (t1,Ht1) := X in let (t2,Ht2) := Y in
+ (t1 ∩ coPset_opp_raw t2) ↾ coPset_intersection_wf _ _ Ht1 (coPset_opp_wf _).
+
+Instance coPset_elem_of_dec (p : positive) (X : coPset) : Decision (p ∈ X) := _.
+Instance coPset_collection : Collection positive coPset.
+Proof.
+ split; [split| |].
+ * by intros ??.
+ * intros p q. apply elem_to_Pset_singleton.
+ * intros [t] [t'] p; unfold elem_of, coPset_elem_of, coPset_union; simpl.
+ by rewrite elem_to_Pset_union, orb_True.
+ * intros [t] [t'] p; unfold elem_of,coPset_elem_of,coPset_intersection; simpl.
+ by rewrite elem_to_Pset_intersection, andb_True.
+ * intros [t] [t'] p; unfold elem_of, coPset_elem_of, coPset_difference; simpl.
+ by rewrite elem_to_Pset_intersection,
+ elem_to_Pset_opp, andb_True, negb_True.
+Qed.
+Instance coPset_leibniz : LeibnizEquiv coPset.
+Proof.
+ intros X Y; rewrite elem_of_equiv; intros HXY.
+ apply (sig_eq_pi _), coPset_eq; try apply proj2_sig.
+ intros p; apply eq_bool_prop_intro, (HXY p).
+Qed.
+
+(** * Finite sets *)
+Fixpoint coPset_finite (t : coPset_raw) : bool :=
+ match t with
+ | coPLeaf b => negb b | coPNode b l r => coPset_finite l && coPset_finite r
+ end.
+Lemma coPset_finite_node b l r :
+ coPset_finite (coPNode' b l r) = coPset_finite l && coPset_finite r.
+Proof. by destruct b, l as [[]|], r as [[]|]. Qed.
+Lemma coPset_finite_spec X : set_finite X ↔ coPset_finite (`X).
+Proof.
+ destruct X as [t Ht].
+ unfold set_finite, elem_of at 1, coPset_elem_of; simpl; clear Ht; split.
+ * induction t as [b|b l IHl r IHr]; simpl.
+ { destruct b; simpl; [intros [l Hl]|done].
+ by apply (is_fresh (of_list l : Pset)), elem_of_of_list, Hl. }
+ intros [ll Hll]; rewrite andb_True; split.
+ + apply IHl; exists (omap (maybe (~0)) ll); intros i.
+ rewrite elem_of_list_omap; intros; exists (i~0); auto.
+ + apply IHr; exists (omap (maybe (~1)) ll); intros i.
+ rewrite elem_of_list_omap; intros; exists (i~1); auto.
+ * induction t as [b|b l IHl r IHr]; simpl; [by exists []; destruct b|].
+ rewrite andb_True; intros [??]; destruct IHl as [ll ?], IHr as [rl ?]; auto.
+ exists ([1] ++ ((~0) <$> ll) ++ ((~1) <$> rl))%list; intros [i|i|]; simpl;
+ rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap; naive_solver.
+Qed.
+Instance coPset_finite_dec (X : coPset) : Decision (set_finite X).
+Proof.
+ refine (cast_if (decide (coPset_finite (`X)))); by rewrite coPset_finite_spec.
+Defined.
+
+(** * Pick element from infitinite sets *)
+(* just depth-first search: using this to pick elements results in very
+unbalanced trees. *)
+Fixpoint coPpick_raw (t : coPset_raw) : option positive :=
+ match t with
+ | coPLeaf true | coPNode true _ _ => Some 1
+ | coPLeaf false => None
+ | coPNode false l r =>
+ match coPpick_raw l with
+ | Some i => Some (i~0) | None => (~1) <$> coPpick_raw r
+ end
+ end.
+Definition coPpick (X : coPset) : positive := from_option 1 (coPpick_raw (`X)).
+
+Lemma coPpick_raw_elem_of t i : coPpick_raw t = Some i → e_of i t.
+Proof.
+ revert i; induction t as [[]|[] l ? r]; intros i ?; simplify_equality'; auto.
+ destruct (coPpick_raw l); simplify_option_equality; auto.
+Qed.
+Lemma coPpick_raw_None t : coPpick_raw t = None → coPset_finite t.
+Proof.
+ induction t as [[]|[] l ? r]; intros i; simplify_equality'; auto.
+ destruct (coPpick_raw l); simplify_option_equality; auto.
+Qed.
+Lemma coPpick_elem_of X : ¬set_finite X → coPpick X ∈ X.
+Proof.
+ destruct X as [t ?]; unfold coPpick; destruct (coPpick_raw _) as [j|] eqn:?.
+ * by intros; apply coPpick_raw_elem_of.
+ * by intros []; apply coPset_finite_spec, coPpick_raw_None.
+Qed.
+
+(** * Conversion to psets *)
+Fixpoint to_Pset_raw (t : coPset_raw) : Pmap_raw () :=
+ match t with
+ | coPLeaf _ => PLeaf
+ | coPNode false l r => PNode' None (to_Pset_raw l) (to_Pset_raw r)
+ | coPNode true l r => PNode (Some ()) (to_Pset_raw l) (to_Pset_raw r)
+ end.
+Lemma to_Pset_wf t : coPset_wf t → Pmap_wf (to_Pset_raw t).
+Proof. induction t as [|[]]; simpl; eauto using PNode_wf. Qed.
+Definition to_Pset (X : coPset) : Pset :=
+ let (t,Ht) := X in Mapset (PMap (to_Pset_raw t) (to_Pset_wf _ Ht)).
+Lemma elem_of_to_Pset X i : set_finite X → i ∈ to_Pset X ↔ i ∈ X.
+Proof.
+ rewrite coPset_finite_spec; destruct X as [t Ht].
+ change (coPset_finite t → to_Pset_raw t !! i = Some () ↔ e_of i t).
+ clear Ht; revert i; induction t as [[]|[] l IHl r IHr]; intros [i|i|];
+ simpl; rewrite ?andb_True, ?PNode_lookup; naive_solver.
+Qed.
+
+(** * Conversion from psets *)
+Fixpoint of_Pset_raw (t : Pmap_raw ()) : coPset_raw :=
+ match t with
+ | PLeaf => coPLeaf false
+ | PNode None l r => coPNode false (of_Pset_raw l) (of_Pset_raw r)
+ | PNode (Some _) l r => coPNode true (of_Pset_raw l) (of_Pset_raw r)
+ end.
+Lemma of_Pset_wf t : Pmap_wf t → coPset_wf (of_Pset_raw t).
+Proof.
+ induction t as [|[] l IHl r IHr]; simpl; rewrite ?andb_True; auto.
+ * intros [??]; destruct l as [|[]], r as [|[]]; simpl in *; auto.
+ * destruct l as [|[]], r as [|[]]; simpl in *; rewrite ?andb_true_r;
+ rewrite ?andb_True; rewrite ?andb_True in IHl, IHr; intuition.
+Qed.
+Lemma elem_of_of_Pset_raw i t : e_of i (of_Pset_raw t) ↔ t !! i = Some ().
+Proof. by revert i; induction t as [|[[]|]]; intros []; simpl; auto; split. Qed.
+Lemma of_Pset_raw_finite t : coPset_finite (of_Pset_raw t).
+Proof. induction t as [|[[]|]]; simpl; rewrite ?andb_True; auto. Qed.
+
+Definition of_Pset (X : Pset) : coPset :=
+ let 'Mapset (PMap t Ht) := X in of_Pset_raw t ↾ of_Pset_wf _ Ht.
+Lemma elem_of_of_Pset X i : i ∈ of_Pset X ↔ i ∈ X.
+Proof. destruct X as [[t ?]]; apply elem_of_of_Pset_raw. Qed.
+Lemma of_Pset_finite X : set_finite (of_Pset X).
+Proof.
+ apply coPset_finite_spec; destruct X as [[t ?]]; apply of_Pset_raw_finite.
+Qed.
+
+(** * Conversion from gsets of positives *)
+Definition of_gset (X : gset positive) : coPset :=
+ let 'Mapset (GMap (PMap t Ht) _) := X in of_Pset_raw t ↾ of_Pset_wf _ Ht.
+Lemma elem_of_of_gset X i : i ∈ of_gset X ↔ i ∈ X.
+Proof. destruct X as [[[t ?]]]; apply elem_of_of_Pset_raw. Qed.
+Lemma of_gset_finite X : set_finite (of_gset X).
+Proof.
+ apply coPset_finite_spec; destruct X as [[[t ?]]]; apply of_Pset_raw_finite.
+Qed.
+
+(** * Domain of finite maps *)
+Instance Pmap_dom_coPset {A} : Dom (Pmap A) coPset := λ m, of_Pset (dom _ m).
+Instance Pmap_dom_coPset_spec: FinMapDom positive Pmap coPset.
+Proof.
+ split; try apply _; intros A m i; unfold dom, Pmap_dom_coPset.
+ by rewrite elem_of_of_Pset, elem_of_dom.
+Qed.
+Instance gmap_dom_coPset {A} : Dom (gmap positive A) coPset := λ m,
+ of_gset (dom _ m).
+Instance gmap_dom_coPset_spec: FinMapDom positive (gmap positive) coPset.
+Proof.
+ split; try apply _; intros A m i; unfold dom, gmap_dom_coPset.
+ by rewrite elem_of_of_gset, elem_of_dom.
+Qed.
+
+(** * Suffix sets *)
+Fixpoint coPset_suffixes_raw (p : positive) : coPset_raw :=
+ match p with
+ | 1 => coPLeaf true
+ | p~0 => coPNode' false (coPset_suffixes_raw p) (coPLeaf false)
+ | p~1 => coPNode' false (coPLeaf false) (coPset_suffixes_raw p)
+ end.
+Lemma coPset_suffixes_wf p : coPset_wf (coPset_suffixes_raw p).
+Proof. induction p; simpl; eauto. Qed.
+Definition coPset_suffixes (p : positive) : coPset :=
+ coPset_suffixes_raw p ↾ coPset_suffixes_wf _.
+Lemma elem_coPset_suffixes p q : p ∈ coPset_suffixes q ↔ ∃ q', p = q' ++ q.
+Proof.
+ unfold elem_of, coPset_elem_of; simpl; split.
+ * revert p; induction q; intros [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; naive_solver.
+ * by intros [q' ->]; induction q; simpl; rewrite ?coPset_elem_of_node.
+Qed.
+
+(** * Splitting of infinite sets *)
+Fixpoint coPset_l_raw (t : coPset_raw) : coPset_raw :=
+ match t with
+ | coPLeaf false => coPLeaf false
+ | coPLeaf true => coPNode true (coPLeaf true) (coPLeaf false)
+ | coPNode b l r => coPNode' b (coPset_l_raw l) (coPset_l_raw r)
+ end.
+Fixpoint coPset_r_raw (t : coPset_raw) : coPset_raw :=
+ match t with
+ | coPLeaf false => coPLeaf false
+ | coPLeaf true => coPNode false (coPLeaf false) (coPLeaf true)
+ | coPNode b l r => coPNode' false (coPset_r_raw l) (coPset_r_raw r)
+ end.
+
+Lemma coPset_l_wf t : coPset_wf (coPset_l_raw t).
+Proof. induction t as [[]|]; simpl; auto. Qed.
+Lemma coPset_r_wf t : coPset_wf (coPset_r_raw t).
+Proof. induction t as [[]|]; simpl; auto. Qed.
+Definition coPset_l (X : coPset) : coPset :=
+ let (t,Ht) := X in coPset_l_raw t ↾ coPset_l_wf _.
+Definition coPset_r (X : coPset) : coPset :=
+ let (t,Ht) := X in coPset_r_raw t ↾ coPset_r_wf _.
+
+Lemma coPset_lr_disjoint X : coPset_l X ∩ coPset_r X = ∅.
+Proof.
+ apply elem_of_equiv_empty_L; intros p; apply Is_true_false.
+ destruct X as [t Ht]; simpl; clear Ht; rewrite elem_to_Pset_intersection.
+ revert p; induction t as [[]|[]]; intros [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; simpl;
+ rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r; auto.
+Qed.
+Lemma coPset_lr_union X : coPset_l X ∪ coPset_r X = X.
+Proof.
+ apply elem_of_equiv_L; intros p; apply eq_bool_prop_elim.
+ destruct X as [t Ht]; simpl; clear Ht; rewrite elem_to_Pset_union.
+ revert p; induction t as [[]|[]]; intros [?|?|]; simpl;
+ rewrite ?coPset_elem_of_node; simpl;
+ rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r; auto.
+Qed.
+Lemma coPset_l_finite X : set_finite (coPset_l X) → set_finite X.
+Proof.
+ rewrite !coPset_finite_spec; destruct X as [t Ht]; simpl; clear Ht.
+ induction t as [[]|]; simpl; rewrite ?coPset_finite_node, ?andb_True; tauto.
+Qed.
+Lemma coPset_r_finite X : set_finite (coPset_r X) → set_finite X.
+Proof.
+ rewrite !coPset_finite_spec; destruct X as [t Ht]; simpl; clear Ht.
+ induction t as [[]|]; simpl; rewrite ?coPset_finite_node, ?andb_True; tauto.
+Qed.
+Lemma coPset_split X :
+ ¬set_finite X →
+ ∃ X1 X2, X = X1 ∪ X2 ∧ X1 ∩ X2 = ∅ ∧ ¬set_finite X1 ∧ ¬set_finite X2.
+Proof.
+ exists (coPset_l X), (coPset_r X); eauto 10 using coPset_lr_union,
+ coPset_lr_disjoint, coPset_l_finite, coPset_r_finite.
+Qed.
diff --git a/prelude/collections.v b/prelude/collections.v
new file mode 100644
index 0000000000000000000000000000000000000000..b34b5cdc32165f44049f1b0eb4b7fb0c510a129c
--- /dev/null
+++ b/prelude/collections.v
@@ -0,0 +1,628 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects definitions and theorems on collections. Most
+importantly, it implements some tactics to automatically solve goals involving
+collections. *)
+Require Export prelude.base prelude.tactics prelude.orders.
+
+Instance collection_subseteq `{ElemOf A C} : SubsetEq C := λ X Y,
+ ∀ x, x ∈ X → x ∈ Y.
+
+(** * Basic theorems *)
+Section simple_collection.
+ Context `{SimpleCollection A C}.
+ Implicit Types x y : A.
+ Implicit Types X Y : C.
+
+ Lemma elem_of_empty x : x ∈ ∅ ↔ False.
+ Proof. split. apply not_elem_of_empty. done. Qed.
+ Lemma elem_of_union_l x X Y : x ∈ X → x ∈ X ∪ Y.
+ Proof. intros. apply elem_of_union. auto. Qed.
+ Lemma elem_of_union_r x X Y : x ∈ Y → x ∈ X ∪ Y.
+ Proof. intros. apply elem_of_union. auto. Qed.
+ Global Instance: EmptySpec C.
+ Proof. firstorder auto. Qed.
+ Global Instance: JoinSemiLattice C.
+ Proof. firstorder auto. Qed.
+ Lemma elem_of_subseteq X Y : X ⊆ Y ↔ ∀ x, x ∈ X → x ∈ Y.
+ Proof. done. Qed.
+ Lemma elem_of_equiv X Y : X ≡ Y ↔ ∀ x, x ∈ X ↔ x ∈ Y.
+ Proof. firstorder. Qed.
+ Lemma elem_of_equiv_alt X Y :
+ X ≡ Y ↔ (∀ x, x ∈ X → x ∈ Y) ∧ (∀ x, x ∈ Y → x ∈ X).
+ Proof. firstorder. Qed.
+ Lemma elem_of_equiv_empty X : X ≡ ∅ ↔ ∀ x, x ∉ X.
+ Proof. firstorder. Qed.
+ Lemma collection_positive_l X Y : X ∪ Y ≡ ∅ → X ≡ ∅.
+ Proof.
+ rewrite !elem_of_equiv_empty. setoid_rewrite elem_of_union. naive_solver.
+ Qed.
+ Lemma collection_positive_l_alt X Y : X ≢ ∅ → X ∪ Y ≢ ∅.
+ Proof. eauto using collection_positive_l. Qed.
+ Lemma elem_of_singleton_1 x y : x ∈ {[y]} → x = y.
+ Proof. by rewrite elem_of_singleton. Qed.
+ Lemma elem_of_singleton_2 x y : x = y → x ∈ {[y]}.
+ Proof. by rewrite elem_of_singleton. Qed.
+ Lemma elem_of_subseteq_singleton x X : x ∈ X ↔ {[ x ]} ⊆ X.
+ Proof.
+ split.
+ * intros ??. rewrite elem_of_singleton. by intros ->.
+ * intros Ex. by apply (Ex x), elem_of_singleton.
+ Qed.
+ Global Instance singleton_proper : Proper ((=) ==> (≡)) (singleton (B:=C)).
+ Proof. by repeat intro; subst. Qed.
+ Global Instance elem_of_proper :
+ Proper ((=) ==> (≡) ==> iff) ((∈) : A → C → Prop) | 5.
+ Proof. intros ???; subst. firstorder. Qed.
+ Lemma elem_of_union_list Xs x : x ∈ ⋃ Xs ↔ ∃ X, X ∈ Xs ∧ x ∈ X.
+ Proof.
+ split.
+ * induction Xs; simpl; intros HXs; [by apply elem_of_empty in HXs|].
+ setoid_rewrite elem_of_cons. apply elem_of_union in HXs. naive_solver.
+ * intros [X []]. induction 1; simpl; [by apply elem_of_union_l |].
+ intros. apply elem_of_union_r; auto.
+ Qed.
+ Lemma non_empty_singleton x : ({[ x ]} : C) ≢ ∅.
+ Proof. intros [E _]. by apply (elem_of_empty x), E, elem_of_singleton. Qed.
+ Lemma not_elem_of_singleton x y : x ∉ {[ y ]} ↔ x ≠y.
+ Proof. by rewrite elem_of_singleton. Qed.
+ Lemma not_elem_of_union x X Y : x ∉ X ∪ Y ↔ x ∉ X ∧ x ∉ Y.
+ Proof. rewrite elem_of_union. tauto. Qed.
+
+ Section leibniz.
+ Context `{!LeibnizEquiv C}.
+ Lemma elem_of_equiv_L X Y : X = Y ↔ ∀ x, x ∈ X ↔ x ∈ Y.
+ Proof. unfold_leibniz. apply elem_of_equiv. Qed.
+ Lemma elem_of_equiv_alt_L X Y :
+ X = Y ↔ (∀ x, x ∈ X → x ∈ Y) ∧ (∀ x, x ∈ Y → x ∈ X).
+ Proof. unfold_leibniz. apply elem_of_equiv_alt. Qed.
+ Lemma elem_of_equiv_empty_L X : X = ∅ ↔ ∀ x, x ∉ X.
+ Proof. unfold_leibniz. apply elem_of_equiv_empty. Qed.
+ Lemma collection_positive_l_L X Y : X ∪ Y = ∅ → X = ∅.
+ Proof. unfold_leibniz. apply collection_positive_l. Qed.
+ Lemma collection_positive_l_alt_L X Y : X ≠∅ → X ∪ Y ≠∅.
+ Proof. unfold_leibniz. apply collection_positive_l_alt. Qed.
+ Lemma non_empty_singleton_L x : {[ x ]} ≠∅.
+ Proof. unfold_leibniz. apply non_empty_singleton. Qed.
+ End leibniz.
+
+ Section dec.
+ Context `{∀ X Y : C, Decision (X ⊆ Y)}.
+ Global Instance elem_of_dec_slow (x : A) (X : C) : Decision (x ∈ X) | 100.
+ Proof.
+ refine (cast_if (decide_rel (⊆) {[ x ]} X));
+ by rewrite elem_of_subseteq_singleton.
+ Defined.
+ End dec.
+End simple_collection.
+
+Definition of_option `{Singleton A C, Empty C} (x : option A) : C :=
+ match x with None => ∅ | Some a => {[ a ]} end.
+Fixpoint of_list `{Singleton A C, Empty C, Union C} (l : list A) : C :=
+ match l with [] => ∅ | x :: l => {[ x ]} ∪ of_list l end.
+
+Section of_option_list.
+ Context `{SimpleCollection A C}.
+ Lemma elem_of_of_option (x : A) o : x ∈ of_option o ↔ o = Some x.
+ Proof.
+ destruct o; simpl;
+ rewrite ?elem_of_empty, ?elem_of_singleton; naive_solver.
+ Qed.
+ Lemma elem_of_of_list (x : A) l : x ∈ of_list l ↔ x ∈ l.
+ Proof.
+ split.
+ * induction l; simpl; [by rewrite elem_of_empty|].
+ rewrite elem_of_union,elem_of_singleton; intros [->|?]; constructor; auto.
+ * induction 1; simpl; rewrite elem_of_union, elem_of_singleton; auto.
+ Qed.
+End of_option_list.
+
+Global Instance collection_guard `{CollectionMonad M} : MGuard M :=
+ λ P dec A x, match dec with left H => x H | _ => ∅ end.
+
+Section collection_monad_base.
+ Context `{CollectionMonad M}.
+ Lemma elem_of_guard `{Decision P} {A} (x : A) (X : M A) :
+ x ∈ guard P; X ↔ P ∧ x ∈ X.
+ Proof.
+ unfold mguard, collection_guard; simpl; case_match;
+ rewrite ?elem_of_empty; naive_solver.
+ Qed.
+ Lemma elem_of_guard_2 `{Decision P} {A} (x : A) (X : M A) :
+ P → x ∈ X → x ∈ guard P; X.
+ Proof. by rewrite elem_of_guard. Qed.
+ Lemma guard_empty `{Decision P} {A} (X : M A) : guard P; X ≡ ∅ ↔ ¬P ∨ X ≡ ∅.
+ Proof.
+ rewrite !elem_of_equiv_empty; setoid_rewrite elem_of_guard.
+ destruct (decide P); naive_solver.
+ Qed.
+ Lemma bind_empty {A B} (f : A → M B) X :
+ X ≫= f ≡ ∅ ↔ X ≡ ∅ ∨ ∀ x, x ∈ X → f x ≡ ∅.
+ Proof.
+ setoid_rewrite elem_of_equiv_empty; setoid_rewrite elem_of_bind.
+ naive_solver.
+ Qed.
+End collection_monad_base.
+
+(** * Tactics *)
+(** Given a hypothesis [H : _ ∈ _], the tactic [destruct_elem_of H] will
+recursively split [H] for [(∪)], [(∩)], [(∖)], [map], [∅], [{[_]}]. *)
+Tactic Notation "decompose_elem_of" hyp(H) :=
+ let rec go H :=
+ lazymatch type of H with
+ | _ ∈ ∅ => apply elem_of_empty in H; destruct H
+ | ?x ∈ {[ ?y ]} =>
+ apply elem_of_singleton in H; try first [subst y | subst x]
+ | ?x ∉ {[ ?y ]} =>
+ apply not_elem_of_singleton in H
+ | _ ∈ _ ∪ _ =>
+ apply elem_of_union in H; destruct H as [H|H]; [go H|go H]
+ | _ ∉ _ ∪ _ =>
+ let H1 := fresh H in let H2 := fresh H in apply not_elem_of_union in H;
+ destruct H as [H1 H2]; go H1; go H2
+ | _ ∈ _ ∩ _ =>
+ let H1 := fresh H in let H2 := fresh H in apply elem_of_intersection in H;
+ destruct H as [H1 H2]; go H1; go H2
+ | _ ∈ _ ∖ _ =>
+ let H1 := fresh H in let H2 := fresh H in apply elem_of_difference in H;
+ destruct H as [H1 H2]; go H1; go H2
+ | ?x ∈ _ <$> _ =>
+ apply elem_of_fmap in H; destruct H as [? [? H]]; try (subst x); go H
+ | _ ∈ _ ≫= _ =>
+ let H1 := fresh H in let H2 := fresh H in apply elem_of_bind in H;
+ destruct H as [? [H1 H2]]; go H1; go H2
+ | ?x ∈ mret ?y =>
+ apply elem_of_ret in H; try first [subst y | subst x]
+ | _ ∈ mjoin _ ≫= _ =>
+ let H1 := fresh H in let H2 := fresh H in apply elem_of_join in H;
+ destruct H as [? [H1 H2]]; go H1; go H2
+ | _ ∈ guard _; _ =>
+ let H1 := fresh H in let H2 := fresh H in apply elem_of_guard in H;
+ destruct H as [H1 H2]; go H2
+ | _ ∈ of_option _ => apply elem_of_of_option in H
+ | _ ∈ of_list _ => apply elem_of_of_list in H
+ | _ => idtac
+ end in go H.
+Tactic Notation "decompose_elem_of" :=
+ repeat_on_hyps (fun H => decompose_elem_of H).
+
+Ltac decompose_empty := repeat
+ match goal with
+ | H : ∅ ≡ ∅ |- _ => clear H
+ | H : ∅ = ∅ |- _ => clear H
+ | H : ∅ ≡ _ |- _ => symmetry in H
+ | H : ∅ = _ |- _ => symmetry in H
+ | H : _ ∪ _ ≡ ∅ |- _ => apply empty_union in H; destruct H
+ | H : _ ∪ _ ≢ ∅ |- _ => apply non_empty_union in H; destruct H
+ | H : {[ _ ]} ≡ ∅ |- _ => destruct (non_empty_singleton _ H)
+ | H : _ ∪ _ = ∅ |- _ => apply empty_union_L in H; destruct H
+ | H : _ ∪ _ ≠∅ |- _ => apply non_empty_union_L in H; destruct H
+ | H : {[ _ ]} = ∅ |- _ => destruct (non_empty_singleton_L _ H)
+ | H : guard _ ; _ ≡ ∅ |- _ => apply guard_empty in H; destruct H
+ end.
+
+(** The first pass of our collection tactic consists of eliminating all
+occurrences of [(∪)], [(∩)], [(∖)], [(<$>)], [∅], [{[_]}], [(≡)], and [(⊆)],
+by rewriting these into logically equivalent propositions. For example we
+rewrite [A → x ∈ X ∪ ∅] into [A → x ∈ X ∨ False]. *)
+Ltac unfold_elem_of :=
+ repeat_on_hyps (fun H =>
+ repeat match type of H with
+ | context [ _ ⊆ _ ] => setoid_rewrite elem_of_subseteq in H
+ | context [ _ ⊂ _ ] => setoid_rewrite subset_spec in H
+ | context [ _ ≡ ∅ ] => setoid_rewrite elem_of_equiv_empty in H
+ | context [ _ ≡ _ ] => setoid_rewrite elem_of_equiv_alt in H
+ | context [ _ = ∅ ] => setoid_rewrite elem_of_equiv_empty_L in H
+ | context [ _ = _ ] => setoid_rewrite elem_of_equiv_alt_L in H
+ | context [ _ ∈ ∅ ] => setoid_rewrite elem_of_empty in H
+ | context [ _ ∈ {[ _ ]} ] => setoid_rewrite elem_of_singleton in H
+ | context [ _ ∈ _ ∪ _ ] => setoid_rewrite elem_of_union in H
+ | context [ _ ∈ _ ∩ _ ] => setoid_rewrite elem_of_intersection in H
+ | context [ _ ∈ _ ∖ _ ] => setoid_rewrite elem_of_difference in H
+ | context [ _ ∈ _ <$> _ ] => setoid_rewrite elem_of_fmap in H
+ | context [ _ ∈ mret _ ] => setoid_rewrite elem_of_ret in H
+ | context [ _ ∈ _ ≫= _ ] => setoid_rewrite elem_of_bind in H
+ | context [ _ ∈ mjoin _ ] => setoid_rewrite elem_of_join in H
+ | context [ _ ∈ guard _; _ ] => setoid_rewrite elem_of_guard in H
+ | context [ _ ∈ of_option _ ] => setoid_rewrite elem_of_of_option in H
+ | context [ _ ∈ of_list _ ] => setoid_rewrite elem_of_of_list in H
+ end);
+ repeat match goal with
+ | |- context [ _ ⊆ _ ] => setoid_rewrite elem_of_subseteq
+ | |- context [ _ ⊂ _ ] => setoid_rewrite subset_spec
+ | |- context [ _ ≡ ∅ ] => setoid_rewrite elem_of_equiv_empty
+ | |- context [ _ ≡ _ ] => setoid_rewrite elem_of_equiv_alt
+ | |- context [ _ = ∅ ] => setoid_rewrite elem_of_equiv_empty_L
+ | |- context [ _ = _ ] => setoid_rewrite elem_of_equiv_alt_L
+ | |- context [ _ ∈ ∅ ] => setoid_rewrite elem_of_empty
+ | |- context [ _ ∈ {[ _ ]} ] => setoid_rewrite elem_of_singleton
+ | |- context [ _ ∈ _ ∪ _ ] => setoid_rewrite elem_of_union
+ | |- context [ _ ∈ _ ∩ _ ] => setoid_rewrite elem_of_intersection
+ | |- context [ _ ∈ _ ∖ _ ] => setoid_rewrite elem_of_difference
+ | |- context [ _ ∈ _ <$> _ ] => setoid_rewrite elem_of_fmap
+ | |- context [ _ ∈ mret _ ] => setoid_rewrite elem_of_ret
+ | |- context [ _ ∈ _ ≫= _ ] => setoid_rewrite elem_of_bind
+ | |- context [ _ ∈ mjoin _ ] => setoid_rewrite elem_of_join
+ | |- context [ _ ∈ guard _; _ ] => setoid_rewrite elem_of_guard
+ | |- context [ _ ∈ of_option _ ] => setoid_rewrite elem_of_of_option
+ | |- context [ _ ∈ of_list _ ] => setoid_rewrite elem_of_of_list
+ end.
+
+(** Since [firstorder] fails or loops on very small goals generated by
+[solve_elem_of] already. We use the [naive_solver] tactic as a substitute.
+This tactic either fails or proves the goal. *)
+Tactic Notation "solve_elem_of" tactic3(tac) :=
+ setoid_subst;
+ decompose_empty;
+ unfold_elem_of;
+ naive_solver tac.
+Tactic Notation "solve_elem_of" "-" hyp_list(Hs) "/" tactic3(tac) :=
+ clear Hs; solve_elem_of tac.
+Tactic Notation "solve_elem_of" "+" hyp_list(Hs) "/" tactic3(tac) :=
+ revert Hs; clear; solve_elem_of tac.
+Tactic Notation "solve_elem_of" := solve_elem_of eauto.
+Tactic Notation "solve_elem_of" "-" hyp_list(Hs) := clear Hs; solve_elem_of.
+Tactic Notation "solve_elem_of" "+" hyp_list(Hs) :=
+ revert Hs; clear; solve_elem_of.
+
+(** * More theorems *)
+Section collection.
+ Context `{Collection A C}.
+ Implicit Types X Y : C.
+
+ Global Instance: Lattice C.
+ Proof. split. apply _. firstorder auto. solve_elem_of. Qed.
+ Global Instance difference_proper :
+ Proper ((≡) ==> (≡) ==> (≡)) (@difference C _).
+ Proof.
+ intros X1 X2 HX Y1 Y2 HY; apply elem_of_equiv; intros x.
+ by rewrite !elem_of_difference, HX, HY.
+ Qed.
+ Lemma intersection_singletons x : ({[x]} : C) ∩ {[x]} ≡ {[x]}.
+ Proof. solve_elem_of. Qed.
+ Lemma difference_twice X Y : (X ∖ Y) ∖ Y ≡ X ∖ Y.
+ Proof. solve_elem_of. Qed.
+ Lemma subseteq_empty_difference X Y : X ⊆ Y → X ∖ Y ≡ ∅.
+ Proof. solve_elem_of. Qed.
+ Lemma difference_diag X : X ∖ X ≡ ∅.
+ Proof. solve_elem_of. Qed.
+ Lemma difference_union_distr_l X Y Z : (X ∪ Y) ∖ Z ≡ X ∖ Z ∪ Y ∖ Z.
+ Proof. solve_elem_of. Qed.
+ Lemma difference_union_distr_r X Y Z : Z ∖ (X ∪ Y) ≡ (Z ∖ X) ∩ (Z ∖ Y).
+ Proof. solve_elem_of. Qed.
+ Lemma difference_intersection_distr_l X Y Z : (X ∩ Y) ∖ Z ≡ X ∖ Z ∩ Y ∖ Z.
+ Proof. solve_elem_of. Qed.
+ Lemma disjoint_union_difference X Y : X ∩ Y ≡ ∅ → (X ∪ Y) ∖ X ≡ Y.
+ Proof. solve_elem_of. Qed.
+
+ Section leibniz.
+ Context `{!LeibnizEquiv C}.
+ Lemma intersection_singletons_L x : {[x]} ∩ {[x]} = {[x]}.
+ Proof. unfold_leibniz. apply intersection_singletons. Qed.
+ Lemma difference_twice_L X Y : (X ∖ Y) ∖ Y = X ∖ Y.
+ Proof. unfold_leibniz. apply difference_twice. Qed.
+ Lemma subseteq_empty_difference_L X Y : X ⊆ Y → X ∖ Y = ∅.
+ Proof. unfold_leibniz. apply subseteq_empty_difference. Qed.
+ Lemma difference_diag_L X : X ∖ X = ∅.
+ Proof. unfold_leibniz. apply difference_diag. Qed.
+ Lemma difference_union_distr_l_L X Y Z : (X ∪ Y) ∖ Z = X ∖ Z ∪ Y ∖ Z.
+ Proof. unfold_leibniz. apply difference_union_distr_l. Qed.
+ Lemma difference_union_distr_r_L X Y Z : Z ∖ (X ∪ Y) = (Z ∖ X) ∩ (Z ∖ Y).
+ Proof. unfold_leibniz. apply difference_union_distr_r. Qed.
+ Lemma difference_intersection_distr_l_L X Y Z :
+ (X ∩ Y) ∖ Z = X ∖ Z ∩ Y ∖ Z.
+ Proof. unfold_leibniz. apply difference_intersection_distr_l. Qed.
+ Lemma disjoint_union_difference_L X Y : X ∩ Y = ∅ → (X ∪ Y) ∖ X = Y.
+ Proof. unfold_leibniz. apply disjoint_union_difference. Qed.
+ End leibniz.
+
+ Section dec.
+ Context `{∀ (x : A) (X : C), Decision (x ∈ X)}.
+ Lemma not_elem_of_intersection x X Y : x ∉ X ∩ Y ↔ x ∉ X ∨ x ∉ Y.
+ Proof. rewrite elem_of_intersection. destruct (decide (x ∈ X)); tauto. Qed.
+ Lemma not_elem_of_difference x X Y : x ∉ X ∖ Y ↔ x ∉ X ∨ x ∈ Y.
+ Proof. rewrite elem_of_difference. destruct (decide (x ∈ Y)); tauto. Qed.
+ Lemma union_difference X Y : X ⊆ Y → Y ≡ X ∪ Y ∖ X.
+ Proof.
+ split; intros x; rewrite !elem_of_union, elem_of_difference; [|intuition].
+ destruct (decide (x ∈ X)); intuition.
+ Qed.
+ Lemma non_empty_difference X Y : X ⊂ Y → Y ∖ X ≢ ∅.
+ Proof.
+ intros [HXY1 HXY2] Hdiff. destruct HXY2. intros x.
+ destruct (decide (x ∈ X)); solve_elem_of.
+ Qed.
+ Lemma empty_difference_subseteq X Y : X ∖ Y ≡ ∅ → X ⊆ Y.
+ Proof. intros ? x ?; apply dec_stable; solve_elem_of. Qed.
+ Context `{!LeibnizEquiv C}.
+ Lemma union_difference_L X Y : X ⊆ Y → Y = X ∪ Y ∖ X.
+ Proof. unfold_leibniz. apply union_difference. Qed.
+ Lemma non_empty_difference_L X Y : X ⊂ Y → Y ∖ X ≠∅.
+ Proof. unfold_leibniz. apply non_empty_difference. Qed.
+ Lemma empty_difference_subseteq_L X Y : X ∖ Y = ∅ → X ⊆ Y.
+ Proof. unfold_leibniz. apply empty_difference_subseteq. Qed.
+ End dec.
+End collection.
+
+Section collection_ops.
+ Context `{CollectionOps A C}.
+
+ Lemma elem_of_intersection_with_list (f : A → A → option A) Xs Y x :
+ x ∈ intersection_with_list f Y Xs ↔ ∃ xs y,
+ Forall2 (∈) xs Xs ∧ y ∈ Y ∧ foldr (λ x, (≫= f x)) (Some y) xs = Some x.
+ Proof.
+ split.
+ * revert x. induction Xs; simpl; intros x HXs; [eexists [], x; intuition|].
+ rewrite elem_of_intersection_with in HXs; destruct HXs as (x1&x2&?&?&?).
+ destruct (IHXs x2) as (xs & y & hy & ? & ?); trivial.
+ eexists (x1 :: xs), y. intuition (simplify_option_equality; auto).
+ * intros (xs & y & Hxs & ? & Hx). revert x Hx.
+ induction Hxs; intros; simplify_option_equality; [done |].
+ rewrite elem_of_intersection_with. naive_solver.
+ Qed.
+
+ Lemma intersection_with_list_ind (P Q : A → Prop) f Xs Y :
+ (∀ y, y ∈ Y → P y) →
+ Forall (λ X, ∀ x, x ∈ X → Q x) Xs →
+ (∀ x y z, Q x → P y → f x y = Some z → P z) →
+ ∀ x, x ∈ intersection_with_list f Y Xs → P x.
+ Proof.
+ intros HY HXs Hf. induction Xs; simplify_option_equality; [done |].
+ intros x Hx. rewrite elem_of_intersection_with in Hx.
+ decompose_Forall. destruct Hx as (? & ? & ? & ? & ?). eauto.
+ Qed.
+End collection_ops.
+
+(** * Sets without duplicates up to an equivalence *)
+Section NoDup.
+ Context `{SimpleCollection A B} (R : relation A) `{!Equivalence R}.
+
+ Definition elem_of_upto (x : A) (X : B) := ∃ y, y ∈ X ∧ R x y.
+ Definition set_NoDup (X : B) := ∀ x y, x ∈ X → y ∈ X → R x y → x = y.
+
+ Global Instance: Proper ((≡) ==> iff) (elem_of_upto x).
+ Proof. intros ??? E. unfold elem_of_upto. by setoid_rewrite E. Qed.
+ Global Instance: Proper (R ==> (≡) ==> iff) elem_of_upto.
+ Proof.
+ intros ?? E1 ?? E2. split; intros [z [??]]; exists z.
+ * rewrite <-E1, <-E2; intuition.
+ * rewrite E1, E2; intuition.
+ Qed.
+ Global Instance: Proper ((≡) ==> iff) set_NoDup.
+ Proof. firstorder. Qed.
+
+ Lemma elem_of_upto_elem_of x X : x ∈ X → elem_of_upto x X.
+ Proof. unfold elem_of_upto. solve_elem_of. Qed.
+ Lemma elem_of_upto_empty x : ¬elem_of_upto x ∅.
+ Proof. unfold elem_of_upto. solve_elem_of. Qed.
+ Lemma elem_of_upto_singleton x y : elem_of_upto x {[ y ]} ↔ R x y.
+ Proof. unfold elem_of_upto. solve_elem_of. Qed.
+
+ Lemma elem_of_upto_union X Y x :
+ elem_of_upto x (X ∪ Y) ↔ elem_of_upto x X ∨ elem_of_upto x Y.
+ Proof. unfold elem_of_upto. solve_elem_of. Qed.
+ Lemma not_elem_of_upto x X : ¬elem_of_upto x X → ∀ y, y ∈ X → ¬R x y.
+ Proof. unfold elem_of_upto. solve_elem_of. Qed.
+
+ Lemma set_NoDup_empty: set_NoDup ∅.
+ Proof. unfold set_NoDup. solve_elem_of. Qed.
+ Lemma set_NoDup_add x X :
+ ¬elem_of_upto x X → set_NoDup X → set_NoDup ({[ x ]} ∪ X).
+ Proof. unfold set_NoDup, elem_of_upto. solve_elem_of. Qed.
+ Lemma set_NoDup_inv_add x X :
+ x ∉ X → set_NoDup ({[ x ]} ∪ X) → ¬elem_of_upto x X.
+ Proof.
+ intros Hin Hnodup [y [??]].
+ rewrite (Hnodup x y) in Hin; solve_elem_of.
+ Qed.
+ Lemma set_NoDup_inv_union_l X Y : set_NoDup (X ∪ Y) → set_NoDup X.
+ Proof. unfold set_NoDup. solve_elem_of. Qed.
+ Lemma set_NoDup_inv_union_r X Y : set_NoDup (X ∪ Y) → set_NoDup Y.
+ Proof. unfold set_NoDup. solve_elem_of. Qed.
+End NoDup.
+
+(** * Quantifiers *)
+Section quantifiers.
+ Context `{SimpleCollection A B} (P : A → Prop).
+
+ Definition set_Forall X := ∀ x, x ∈ X → P x.
+ Definition set_Exists X := ∃ x, x ∈ X ∧ P x.
+
+ Lemma set_Forall_empty : set_Forall ∅.
+ Proof. unfold set_Forall. solve_elem_of. Qed.
+ Lemma set_Forall_singleton x : set_Forall {[ x ]} ↔ P x.
+ Proof. unfold set_Forall. solve_elem_of. Qed.
+ Lemma set_Forall_union X Y : set_Forall X → set_Forall Y → set_Forall (X ∪ Y).
+ Proof. unfold set_Forall. solve_elem_of. Qed.
+ Lemma set_Forall_union_inv_1 X Y : set_Forall (X ∪ Y) → set_Forall X.
+ Proof. unfold set_Forall. solve_elem_of. Qed.
+ Lemma set_Forall_union_inv_2 X Y : set_Forall (X ∪ Y) → set_Forall Y.
+ Proof. unfold set_Forall. solve_elem_of. Qed.
+
+ Lemma set_Exists_empty : ¬set_Exists ∅.
+ Proof. unfold set_Exists. solve_elem_of. Qed.
+ Lemma set_Exists_singleton x : set_Exists {[ x ]} ↔ P x.
+ Proof. unfold set_Exists. solve_elem_of. Qed.
+ Lemma set_Exists_union_1 X Y : set_Exists X → set_Exists (X ∪ Y).
+ Proof. unfold set_Exists. solve_elem_of. Qed.
+ Lemma set_Exists_union_2 X Y : set_Exists Y → set_Exists (X ∪ Y).
+ Proof. unfold set_Exists. solve_elem_of. Qed.
+ Lemma set_Exists_union_inv X Y :
+ set_Exists (X ∪ Y) → set_Exists X ∨ set_Exists Y.
+ Proof. unfold set_Exists. solve_elem_of. Qed.
+End quantifiers.
+
+Section more_quantifiers.
+ Context `{SimpleCollection A B}.
+
+ Lemma set_Forall_weaken (P Q : A → Prop) (Hweaken : ∀ x, P x → Q x) X :
+ set_Forall P X → set_Forall Q X.
+ Proof. unfold set_Forall. naive_solver. Qed.
+ Lemma set_Exists_weaken (P Q : A → Prop) (Hweaken : ∀ x, P x → Q x) X :
+ set_Exists P X → set_Exists Q X.
+ Proof. unfold set_Exists. naive_solver. Qed.
+End more_quantifiers.
+
+(** * Fresh elements *)
+(** We collect some properties on the [fresh] operation. In particular we
+generalize [fresh] to generate lists of fresh elements. *)
+Fixpoint fresh_list `{Fresh A C, Union C, Singleton A C}
+ (n : nat) (X : C) : list A :=
+ match n with
+ | 0 => []
+ | S n => let x := fresh X in x :: fresh_list n ({[ x ]} ∪ X)
+ end.
+Inductive Forall_fresh `{ElemOf A C} (X : C) : list A → Prop :=
+ | Forall_fresh_nil : Forall_fresh X []
+ | Forall_fresh_cons x xs :
+ x ∉ xs → x ∉ X → Forall_fresh X xs → Forall_fresh X (x :: xs).
+
+Section fresh.
+ Context `{FreshSpec A C}.
+ Implicit Types X Y : C.
+
+ Global Instance fresh_proper: Proper ((≡) ==> (=)) (fresh (C:=C)).
+ Proof. intros ???. by apply fresh_proper_alt, elem_of_equiv. Qed.
+ Global Instance fresh_list_proper:
+ Proper ((=) ==> (≡) ==> (=)) (fresh_list (C:=C)).
+ Proof.
+ intros ? n ->. induction n as [|n IH]; intros ?? E; f_equal'; [by rewrite E|].
+ apply IH. by rewrite E.
+ Qed.
+
+ Lemma Forall_fresh_NoDup X xs : Forall_fresh X xs → NoDup xs.
+ Proof. induction 1; by constructor. Qed.
+ Lemma Forall_fresh_elem_of X xs x : Forall_fresh X xs → x ∈ xs → x ∉ X.
+ Proof.
+ intros HX; revert x; rewrite <-Forall_forall.
+ by induction HX; constructor.
+ Qed.
+ Lemma Forall_fresh_alt X xs :
+ Forall_fresh X xs ↔ NoDup xs ∧ ∀ x, x ∈ xs → x ∉ X.
+ Proof.
+ split; eauto using Forall_fresh_NoDup, Forall_fresh_elem_of.
+ rewrite <-Forall_forall.
+ intros [Hxs Hxs']. induction Hxs; decompose_Forall_hyps; constructor; auto.
+ Qed.
+ Lemma Forall_fresh_subseteq X Y xs :
+ Forall_fresh X xs → Y ⊆ X → Forall_fresh Y xs.
+ Proof. rewrite !Forall_fresh_alt; solve_elem_of. Qed.
+
+ Lemma fresh_list_length n X : length (fresh_list n X) = n.
+ Proof. revert X. induction n; simpl; auto. Qed.
+ Lemma fresh_list_is_fresh n X x : x ∈ fresh_list n X → x ∉ X.
+ Proof.
+ revert X. induction n as [|n IH]; intros X; simpl;[by rewrite elem_of_nil|].
+ rewrite elem_of_cons; intros [->| Hin]; [apply is_fresh|].
+ apply IH in Hin; solve_elem_of.
+ Qed.
+ Lemma NoDup_fresh_list n X : NoDup (fresh_list n X).
+ Proof.
+ revert X. induction n; simpl; constructor; auto.
+ intros Hin; apply fresh_list_is_fresh in Hin; solve_elem_of.
+ Qed.
+ Lemma Forall_fresh_list X n : Forall_fresh X (fresh_list n X).
+ Proof.
+ rewrite Forall_fresh_alt; eauto using NoDup_fresh_list, fresh_list_is_fresh.
+ Qed.
+End fresh.
+
+(** * Properties of implementations of collections that form a monad *)
+Section collection_monad.
+ Context `{CollectionMonad M}.
+
+ Global Instance collection_fmap_proper {A B} :
+ Proper (pointwise_relation _ (=) ==> (≡) ==> (≡)) (@fmap M _ A B).
+ Proof. intros f g ? X Y [??]; split; solve_elem_of. Qed.
+ Global Instance collection_bind_proper {A B} :
+ Proper (((=) ==> (≡)) ==> (≡) ==> (≡)) (@mbind M _ A B).
+ Proof. unfold respectful; intros f g Hfg X Y [??]; split; solve_elem_of. Qed.
+ Global Instance collection_join_proper {A} :
+ Proper ((≡) ==> (≡)) (@mjoin M _ A).
+ Proof. intros X Y [??]; split; solve_elem_of. Qed.
+
+ Lemma collection_bind_singleton {A B} (f : A → M B) x : {[ x ]} ≫= f ≡ f x.
+ Proof. solve_elem_of. Qed.
+ Lemma collection_guard_True {A} `{Decision P} (X : M A) : P → guard P; X ≡ X.
+ Proof. solve_elem_of. Qed.
+ Lemma collection_fmap_compose {A B C} (f : A → B) (g : B → C) (X : M A) :
+ g ∘ f <$> X ≡ g <$> (f <$> X).
+ Proof. solve_elem_of. Qed.
+ Lemma elem_of_fmap_1 {A B} (f : A → B) (X : M A) (y : B) :
+ y ∈ f <$> X → ∃ x, y = f x ∧ x ∈ X.
+ Proof. solve_elem_of. Qed.
+ Lemma elem_of_fmap_2 {A B} (f : A → B) (X : M A) (x : A) :
+ x ∈ X → f x ∈ f <$> X.
+ Proof. solve_elem_of. Qed.
+ Lemma elem_of_fmap_2_alt {A B} (f : A → B) (X : M A) (x : A) (y : B) :
+ x ∈ X → y = f x → y ∈ f <$> X.
+ Proof. solve_elem_of. Qed.
+
+ Lemma elem_of_mapM {A B} (f : A → M B) l k :
+ l ∈ mapM f k ↔ Forall2 (λ x y, x ∈ f y) l k.
+ Proof.
+ split.
+ * revert l. induction k; solve_elem_of.
+ * induction 1; solve_elem_of.
+ Qed.
+ Lemma collection_mapM_length {A B} (f : A → M B) l k :
+ l ∈ mapM f k → length l = length k.
+ Proof. revert l; induction k; solve_elem_of. Qed.
+ Lemma elem_of_mapM_fmap {A B} (f : A → B) (g : B → M A) l k :
+ Forall (λ x, ∀ y, y ∈ g x → f y = x) l → k ∈ mapM g l → fmap f k = l.
+ Proof.
+ intros Hl. revert k. induction Hl; simpl; intros;
+ decompose_elem_of; f_equal'; auto.
+ Qed.
+ Lemma elem_of_mapM_Forall {A B} (f : A → M B) (P : B → Prop) l k :
+ l ∈ mapM f k → Forall (λ x, ∀ y, y ∈ f x → P y) k → Forall P l.
+ Proof. rewrite elem_of_mapM. apply Forall2_Forall_l. Qed.
+ Lemma elem_of_mapM_Forall2_l {A B C} (f : A → M B) (P: B → C → Prop) l1 l2 k :
+ l1 ∈ mapM f k → Forall2 (λ x y, ∀ z, z ∈ f x → P z y) k l2 →
+ Forall2 P l1 l2.
+ Proof.
+ rewrite elem_of_mapM. intros Hl1. revert l2.
+ induction Hl1; inversion_clear 1; constructor; auto.
+ Qed.
+End collection_monad.
+
+(** Finite collections *)
+Definition set_finite `{ElemOf A B} (X : B) := ∃ l : list A, ∀ x, x ∈ X → x ∈ l.
+
+Section finite.
+ Context `{SimpleCollection A B}.
+ Global Instance set_finite_subseteq :
+ Proper (flip (⊆) ==> impl) (@set_finite A B _).
+ Proof. intros X Y HX [l Hl]; exists l; solve_elem_of. Qed.
+ Global Instance set_finite_proper : Proper ((≡) ==> iff) (@set_finite A B _).
+ Proof. by intros X Y [??]; split; apply set_finite_subseteq. Qed.
+ Lemma empty_finite : set_finite ∅.
+ Proof. by exists []; intros ?; rewrite elem_of_empty. Qed.
+ Lemma singleton_finite (x : A) : set_finite {[ x ]}.
+ Proof. exists [x]; intros y ->%elem_of_singleton; left. Qed.
+ Lemma union_finite X Y : set_finite X → set_finite Y → set_finite (X ∪ Y).
+ Proof.
+ intros [lX ?] [lY ?]; exists (lX ++ lY); intros x.
+ rewrite elem_of_union, elem_of_app; naive_solver.
+ Qed.
+ Lemma union_finite_inv_l X Y : set_finite (X ∪ Y) → set_finite X.
+ Proof. intros [l ?]; exists l; solve_elem_of. Qed.
+ Lemma union_finite_inv_r X Y : set_finite (X ∪ Y) → set_finite Y.
+ Proof. intros [l ?]; exists l; solve_elem_of. Qed.
+End finite.
+
+Section more_finite.
+ Context `{Collection A B}.
+ Lemma intersection_finite_l X Y : set_finite X → set_finite (X ∩ Y).
+ Proof. intros [l ?]; exists l; intros x [??]%elem_of_intersection; auto. Qed.
+ Lemma intersection_finite_r X Y : set_finite Y → set_finite (X ∩ Y).
+ Proof. intros [l ?]; exists l; intros x [??]%elem_of_intersection; auto. Qed.
+ Lemma difference_finite X Y : set_finite X → set_finite (X ∖ Y).
+ Proof. intros [l ?]; exists l; intros x [??]%elem_of_difference; auto. Qed.
+ Lemma difference_finite_inv X Y `{∀ x, Decision (x ∈ Y)} :
+ set_finite Y → set_finite (X ∖ Y) → set_finite X.
+ Proof.
+ intros [l ?] [k ?]; exists (l ++ k).
+ intros x ?; destruct (decide (x ∈ Y)); rewrite elem_of_app; solve_elem_of.
+ Qed.
+End more_finite.
diff --git a/prelude/countable.v b/prelude/countable.v
new file mode 100644
index 0000000000000000000000000000000000000000..ab860ddf677228e3cf49060c021ffab5fa1e61db
--- /dev/null
+++ b/prelude/countable.v
@@ -0,0 +1,245 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Export prelude.list.
+Local Open Scope positive.
+
+Class Countable A `{∀ x y : A, Decision (x = y)} := {
+ encode : A → positive;
+ decode : positive → option A;
+ decode_encode x : decode (encode x) = Some x
+}.
+Arguments encode : simpl never.
+Arguments decode : simpl never.
+
+Definition encode_nat `{Countable A} (x : A) : nat :=
+ pred (Pos.to_nat (encode x)).
+Definition decode_nat `{Countable A} (i : nat) : option A :=
+ decode (Pos.of_nat (S i)).
+Instance encode_injective `{Countable A} : Injective (=) (=) encode.
+Proof.
+ intros x y Hxy; apply (injective Some).
+ by rewrite <-(decode_encode x), Hxy, decode_encode.
+Qed.
+Instance encode_nat_injective `{Countable A} : Injective (=) (=) encode_nat.
+Proof. unfold encode_nat; intros x y Hxy; apply (injective encode); lia. Qed.
+Lemma decode_encode_nat `{Countable A} x : decode_nat (encode_nat x) = Some x.
+Proof.
+ pose proof (Pos2Nat.is_pos (encode x)).
+ unfold decode_nat, encode_nat. rewrite Nat.succ_pred by lia.
+ by rewrite Pos2Nat.id, decode_encode.
+Qed.
+
+(** * Choice principles *)
+Section choice.
+ Context `{Countable A} (P : A → Prop) `{∀ x, Decision (P x)}.
+
+ Inductive choose_step: relation positive :=
+ | choose_step_None {p} : decode p = None → choose_step (Psucc p) p
+ | choose_step_Some {p x} :
+ decode p = Some x → ¬P x → choose_step (Psucc p) p.
+ Lemma choose_step_acc : (∃ x, P x) → Acc choose_step 1%positive.
+ Proof.
+ intros [x Hx]. cut (∀ i p,
+ i ≤ encode x → 1 + encode x = p + i → Acc choose_step p).
+ { intros help. by apply (help (encode x)). }
+ induction i as [|i IH] using Pos.peano_ind; intros p ??.
+ { constructor. intros j. assert (p = encode x) by lia; subst.
+ inversion 1 as [? Hd|?? Hd]; subst;
+ rewrite decode_encode in Hd; congruence. }
+ constructor. intros j.
+ inversion 1 as [? Hd|? y Hd]; subst; auto with lia.
+ Qed.
+ Fixpoint choose_go {i} (acc : Acc choose_step i) : A :=
+ match Some_dec (decode i) with
+ | inleft (x↾Hx) =>
+ match decide (P x) with
+ | left _ => x | right H => choose_go (Acc_inv acc (choose_step_Some Hx H))
+ end
+ | inright H => choose_go (Acc_inv acc (choose_step_None H))
+ end.
+ Fixpoint choose_go_correct {i} (acc : Acc choose_step i) : P (choose_go acc).
+ Proof. destruct acc; simpl. repeat case_match; auto. Qed.
+ Fixpoint choose_go_pi {i} (acc1 acc2 : Acc choose_step i) :
+ choose_go acc1 = choose_go acc2.
+ Proof. destruct acc1, acc2; simpl; repeat case_match; auto. Qed.
+
+ Definition choose (H: ∃ x, P x) : A := choose_go (choose_step_acc H).
+ Definition choose_correct (H: ∃ x, P x) : P (choose H) := choose_go_correct _.
+ Definition choose_pi (H1 H2 : ∃ x, P x) :
+ choose H1 = choose H2 := choose_go_pi _ _.
+ Definition choice (HA : ∃ x, P x) : { x | P x } := _↾choose_correct HA.
+End choice.
+
+Lemma surjective_cancel `{Countable A} `{∀ x y : B, Decision (x = y)}
+ (f : A → B) `{!Surjective (=) f} : { g : B → A & Cancel (=) f g }.
+Proof.
+ exists (λ y, choose (λ x, f x = y) (surjective f y)).
+ intros y. by rewrite (choose_correct (λ x, f x = y) (surjective f y)).
+Qed.
+
+(** * Instances *)
+(** ** Option *)
+Program Instance option_countable `{Countable A} : Countable (option A) := {|
+ encode o := match o with None => 1 | Some x => Pos.succ (encode x) end;
+ decode p := if decide (p = 1) then Some None else Some <$> decode (Pos.pred p)
+|}.
+Next Obligation.
+ intros ??? [x|]; simpl; repeat case_decide; auto with lia.
+ by rewrite Pos.pred_succ, decode_encode.
+Qed.
+
+(** ** Sums *)
+Program Instance sum_countable `{Countable A} `{Countable B} :
+ Countable (A + B)%type := {|
+ encode xy :=
+ match xy with inl x => (encode x)~0 | inr y => (encode y)~1 end;
+ decode p :=
+ match p with
+ | 1 => None | p~0 => inl <$> decode p | p~1 => inr <$> decode p
+ end
+ |}.
+Next Obligation. by intros ?????? [x|y]; simpl; rewrite decode_encode. Qed.
+
+(** ** Products *)
+Fixpoint prod_encode_fst (p : positive) : positive :=
+ match p with
+ | 1 => 1
+ | p~0 => (prod_encode_fst p)~0~0
+ | p~1 => (prod_encode_fst p)~0~1
+ end.
+Fixpoint prod_encode_snd (p : positive) : positive :=
+ match p with
+ | 1 => 1~0
+ | p~0 => (prod_encode_snd p)~0~0
+ | p~1 => (prod_encode_snd p)~1~0
+ end.
+Fixpoint prod_encode (p q : positive) : positive :=
+ match p, q with
+ | 1, 1 => 1~1
+ | p~0, 1 => (prod_encode_fst p)~1~0
+ | p~1, 1 => (prod_encode_fst p)~1~1
+ | 1, q~0 => (prod_encode_snd q)~0~1
+ | 1, q~1 => (prod_encode_snd q)~1~1
+ | p~0, q~0 => (prod_encode p q)~0~0
+ | p~0, q~1 => (prod_encode p q)~1~0
+ | p~1, q~0 => (prod_encode p q)~0~1
+ | p~1, q~1 => (prod_encode p q)~1~1
+ end.
+Fixpoint prod_decode_fst (p : positive) : option positive :=
+ match p with
+ | p~0~0 => (~0) <$> prod_decode_fst p
+ | p~0~1 => Some match prod_decode_fst p with Some q => q~1 | _ => 1 end
+ | p~1~0 => (~0) <$> prod_decode_fst p
+ | p~1~1 => Some match prod_decode_fst p with Some q => q~1 | _ => 1 end
+ | 1~0 => None
+ | 1~1 => Some 1
+ | 1 => Some 1
+ end.
+Fixpoint prod_decode_snd (p : positive) : option positive :=
+ match p with
+ | p~0~0 => (~0) <$> prod_decode_snd p
+ | p~0~1 => (~0) <$> prod_decode_snd p
+ | p~1~0 => Some match prod_decode_snd p with Some q => q~1 | _ => 1 end
+ | p~1~1 => Some match prod_decode_snd p with Some q => q~1 | _ => 1 end
+ | 1~0 => Some 1
+ | 1~1 => Some 1
+ | 1 => None
+ end.
+
+Lemma prod_decode_encode_fst p q : prod_decode_fst (prod_encode p q) = Some p.
+Proof.
+ assert (∀ p, prod_decode_fst (prod_encode_fst p) = Some p).
+ { intros p'. by induction p'; simplify_option_equality. }
+ assert (∀ p, prod_decode_fst (prod_encode_snd p) = None).
+ { intros p'. by induction p'; simplify_option_equality. }
+ revert q. by induction p; intros [?|?|]; simplify_option_equality.
+Qed.
+Lemma prod_decode_encode_snd p q : prod_decode_snd (prod_encode p q) = Some q.
+Proof.
+ assert (∀ p, prod_decode_snd (prod_encode_snd p) = Some p).
+ { intros p'. by induction p'; simplify_option_equality. }
+ assert (∀ p, prod_decode_snd (prod_encode_fst p) = None).
+ { intros p'. by induction p'; simplify_option_equality. }
+ revert q. by induction p; intros [?|?|]; simplify_option_equality.
+Qed.
+Program Instance prod_countable `{Countable A} `{Countable B} :
+ Countable (A * B)%type := {|
+ encode xy := prod_encode (encode (xy.1)) (encode (xy.2));
+ decode p :=
+ x ↠prod_decode_fst p ≫= decode;
+ y ↠prod_decode_snd p ≫= decode; Some (x, y)
+ |}.
+Next Obligation.
+ intros ?????? [x y]; simpl.
+ rewrite prod_decode_encode_fst, prod_decode_encode_snd; simpl.
+ by rewrite !decode_encode.
+Qed.
+
+(** ** Lists *)
+(* Lists are encoded as 1 separated sequences of 0s corresponding to the unary
+representation of the elements. *)
+Fixpoint list_encode `{Countable A} (acc : positive) (l : list A) : positive :=
+ match l with
+ | [] => acc
+ | x :: l => list_encode (Nat.iter (encode_nat x) (~0) (acc~1)) l
+ end.
+Fixpoint list_decode `{Countable A} (acc : list A)
+ (n : nat) (p : positive) : option (list A) :=
+ match p with
+ | 1 => Some acc
+ | p~0 => list_decode acc (S n) p
+ | p~1 => x ↠decode_nat n; list_decode (x :: acc) O p
+ end.
+Lemma x0_iter_x1 n acc : Nat.iter n (~0) acc~1 = acc ++ Nat.iter n (~0) 3.
+Proof. by induction n; f_equal'. Qed.
+Lemma list_encode_app' `{Countable A} (l1 l2 : list A) acc :
+ list_encode acc (l1 ++ l2) = list_encode acc l1 ++ list_encode 1 l2.
+Proof.
+ revert acc; induction l1; simpl; auto.
+ induction l2 as [|x l IH]; intros acc; simpl; [by rewrite ?(left_id_L _ _)|].
+ by rewrite !(IH (Nat.iter _ _ _)), (associative_L _), x0_iter_x1.
+Qed.
+Program Instance list_countable `{Countable A} : Countable (list A) :=
+ {| encode := list_encode 1; decode := list_decode [] 0 |}.
+Next Obligation.
+ intros A ??; simpl.
+ assert (∀ m acc n p, list_decode acc n (Nat.iter m (~0) p)
+ = list_decode acc (n + m) p) as decode_iter.
+ { induction m as [|m IH]; intros acc n p; simpl; [by rewrite Nat.add_0_r|].
+ by rewrite IH, Nat.add_succ_r. }
+ cut (∀ l acc, list_decode acc 0 (list_encode 1 l) = Some (l ++ acc))%list.
+ { by intros help l; rewrite help, (right_id_L _ _). }
+ induction l as [|x l IH] using @rev_ind; intros acc; [done|].
+ rewrite list_encode_app'; simpl; rewrite <-x0_iter_x1, decode_iter; simpl.
+ by rewrite decode_encode_nat; simpl; rewrite IH, <-(associative_L _).
+Qed.
+Lemma list_encode_app `{Countable A} (l1 l2 : list A) :
+ encode (l1 ++ l2)%list = encode l1 ++ encode l2.
+Proof. apply list_encode_app'. Qed.
+Lemma list_encode_cons `{Countable A} x (l : list A) :
+ encode (x :: l) = Nat.iter (encode_nat x) (~0) 3 ++ encode l.
+Proof. apply (list_encode_app' [_]). Qed.
+Lemma list_encode_suffix `{Countable A} (l k : list A) :
+ l `suffix_of` k → ∃ q, encode k = q ++ encode l.
+Proof. intros [l' ->]; exists (encode l'); apply list_encode_app. Qed.
+
+(** ** Numbers *)
+Instance pos_countable : Countable positive :=
+ {| encode := id; decode := Some; decode_encode x := eq_refl |}.
+Program Instance N_countable : Countable N := {|
+ encode x := match x with N0 => 1 | Npos p => Pos.succ p end;
+ decode p := if decide (p = 1) then Some 0%N else Some (Npos (Pos.pred p))
+|}.
+Next Obligation.
+ by intros [|p];simpl;[|rewrite decide_False,Pos.pred_succ by (by destruct p)].
+Qed.
+Program Instance Z_countable : Countable Z := {|
+ encode x := match x with Z0 => 1 | Zpos p => p~0 | Zneg p => p~1 end;
+ decode p := Some match p with 1 => Z0 | p~0 => Zpos p | p~1 => Zneg p end
+|}.
+Next Obligation. by intros [|p|p]. Qed.
+Program Instance nat_countable : Countable nat :=
+ {| encode x := encode (N.of_nat x); decode p := N.to_nat <$> decode p |}.
+Next Obligation.
+ by intros x; lazy beta; rewrite decode_encode; csimpl; rewrite Nat2N.id.
+Qed.
diff --git a/prelude/decidable.v b/prelude/decidable.v
new file mode 100644
index 0000000000000000000000000000000000000000..184372c8bf37317d0d2e82ca40da4ae3a3ed1f6c
--- /dev/null
+++ b/prelude/decidable.v
@@ -0,0 +1,197 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects theorems, definitions, tactics, related to propositions
+with a decidable equality. Such propositions are collected by the [Decision]
+type class. *)
+Require Export prelude.proof_irrel.
+
+Hint Extern 200 (Decision _) => progress (lazy beta) : typeclass_instances.
+
+Lemma dec_stable `{Decision P} : ¬¬P → P.
+Proof. firstorder. Qed.
+
+Lemma Is_true_reflect (b : bool) : reflect b b.
+Proof. destruct b. by left. right. intros []. Qed.
+Instance: Injective (=) (↔) Is_true.
+Proof. intros [] []; simpl; intuition. Qed.
+
+(** We introduce [decide_rel] to avoid inefficienct computation due to eager
+evaluation of propositions by [vm_compute]. This inefficiency occurs if
+[(x = y) := (f x = f y)] as [decide (x = y)] evaluates to [decide (f x = f y)]
+which then might lead to evaluation of [f x] and [f y]. Using [decide_rel]
+we hide [f] under a lambda abstraction to avoid this unnecessary evaluation. *)
+Definition decide_rel {A B} (R : A → B → Prop) {dec : ∀ x y, Decision (R x y)}
+ (x : A) (y : B) : Decision (R x y) := dec x y.
+Lemma decide_rel_correct {A B} (R : A → B → Prop) `{∀ x y, Decision (R x y)}
+ (x : A) (y : B) : decide_rel R x y = decide (R x y).
+Proof. done. Qed.
+
+Lemma decide_True {A} `{Decision P} (x y : A) :
+ P → (if decide P then x else y) = x.
+Proof. by destruct (decide P). Qed.
+Lemma decide_False {A} `{Decision P} (x y : A) :
+ ¬P → (if decide P then x else y) = y.
+Proof. by destruct (decide P). Qed.
+Lemma decide_iff {A} P Q `{Decision P, Decision Q} (x y : A) :
+ (P ↔ Q) → (if decide P then x else y) = (if decide Q then x else y).
+Proof. intros [??]. destruct (decide P), (decide Q); intuition. Qed.
+
+(** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the
+components is double negated, it will try to remove the double negation. *)
+Tactic Notation "destruct_decide" constr(dec) "as" ident(H) :=
+ destruct dec as [H|H];
+ try match type of H with
+ | ¬¬_ => apply dec_stable in H
+ end.
+Tactic Notation "destruct_decide" constr(dec) :=
+ let H := fresh in destruct_decide dec as H.
+
+(** The tactic [case_decide] performs case analysis on an arbitrary occurrence
+of [decide] or [decide_rel] in the conclusion or hypotheses. *)
+Tactic Notation "case_decide" "as" ident(Hd) :=
+ match goal with
+ | H : context [@decide ?P ?dec] |- _ =>
+ destruct_decide (@decide P dec) as Hd
+ | H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ =>
+ destruct_decide (@decide_rel _ _ R x y dec) as Hd
+ | |- context [@decide ?P ?dec] =>
+ destruct_decide (@decide P dec) as Hd
+ | |- context [@decide_rel _ _ ?R ?x ?y ?dec] =>
+ destruct_decide (@decide_rel _ _ R x y dec) as Hd
+ end.
+Tactic Notation "case_decide" :=
+ let H := fresh in case_decide as H.
+
+(** The tactic [solve_decision] uses Coq's [decide equality] tactic together
+with instance resolution to automatically generate decision procedures. *)
+Ltac solve_trivial_decision :=
+ match goal with
+ | |- Decision (?P) => apply _
+ | |- sumbool ?P (¬?P) => change (Decision P); apply _
+ end.
+Ltac solve_decision := intros; first
+ [ solve_trivial_decision
+ | unfold Decision; decide equality; solve_trivial_decision ].
+
+(** The following combinators are useful to create Decision proofs in
+combination with the [refine] tactic. *)
+Notation swap_if S := (match S with left H => right H | right H => left H end).
+Notation cast_if S := (if S then left _ else right _).
+Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _).
+Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _).
+Notation cast_if_and4 S1 S2 S3 S4 :=
+ (if S1 then cast_if_and3 S2 S3 S4 else right _).
+Notation cast_if_and5 S1 S2 S3 S4 S5 :=
+ (if S1 then cast_if_and4 S2 S3 S4 S5 else right _).
+Notation cast_if_and6 S1 S2 S3 S4 S5 S6 :=
+ (if S1 then cast_if_and5 S2 S3 S4 S5 S6 else right _).
+Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2).
+Notation cast_if_or3 S1 S2 S3 := (if S1 then left _ else cast_if_or S2 S3).
+Notation cast_if_not_or S1 S2 := (if S1 then cast_if S2 else left _).
+Notation cast_if_not S := (if S then right _ else left _).
+
+(** We can convert decidable propositions to booleans. *)
+Definition bool_decide (P : Prop) {dec : Decision P} : bool :=
+ if dec then true else false.
+
+Lemma bool_decide_reflect P `{dec : Decision P} : reflect P (bool_decide P).
+Proof. unfold bool_decide. destruct dec. by left. by right. Qed.
+
+Tactic Notation "case_bool_decide" "as" ident (Hd) :=
+ match goal with
+ | H : context [@bool_decide ?P ?dec] |- _ =>
+ destruct_decide (@bool_decide_reflect P dec) as Hd
+ | |- context [@bool_decide ?P ?dec] =>
+ destruct_decide (@bool_decide_reflect P dec) as Hd
+ end.
+Tactic Notation "case_bool_decide" :=
+ let H := fresh in case_bool_decide as H.
+
+Lemma bool_decide_spec (P : Prop) {dec : Decision P} : bool_decide P ↔ P.
+Proof. unfold bool_decide. by destruct dec. Qed.
+Lemma bool_decide_unpack (P : Prop) {dec : Decision P} : bool_decide P → P.
+Proof. by rewrite bool_decide_spec. Qed.
+Lemma bool_decide_pack (P : Prop) {dec : Decision P} : P → bool_decide P.
+Proof. by rewrite bool_decide_spec. Qed.
+Lemma bool_decide_true (P : Prop) `{Decision P} : P → bool_decide P = true.
+Proof. by case_bool_decide. Qed.
+Lemma bool_decide_false (P : Prop) `{Decision P} : ¬P → bool_decide P = false.
+Proof. by case_bool_decide. Qed.
+Lemma bool_decide_iff (P Q : Prop) `{Decision P, Decision Q} :
+ (P ↔ Q) → bool_decide P = bool_decide Q.
+Proof. repeat case_bool_decide; tauto. Qed.
+
+(** * Decidable Sigma types *)
+(** Leibniz equality on Sigma types requires the equipped proofs to be
+equal as Coq does not support proof irrelevance. For decidable we
+propositions we define the type [dsig P] whose Leibniz equality is proof
+irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. *)
+Definition dsig `(P : A → Prop) `{∀ x : A, Decision (P x)} :=
+ { x | bool_decide (P x) }.
+
+Definition proj2_dsig `{∀ x : A, Decision (P x)} (x : dsig P) : P (`x) :=
+ bool_decide_unpack _ (proj2_sig x).
+Definition dexist `{∀ x : A, Decision (P x)} (x : A) (p : P x) : dsig P :=
+ x↾bool_decide_pack _ p.
+Lemma dsig_eq `(P : A → Prop) `{∀ x, Decision (P x)}
+ (x y : dsig P) : x = y ↔ `x = `y.
+Proof. apply (sig_eq_pi _). Qed.
+Lemma dexists_proj1 `(P : A → Prop) `{∀ x, Decision (P x)} (x : dsig P) p :
+ dexist (`x) p = x.
+Proof. by apply dsig_eq. Qed.
+
+(** * Instances of Decision *)
+(** Instances of [Decision] for operators of propositional logic. *)
+Instance True_dec: Decision True := left I.
+Instance False_dec: Decision False := right (False_rect False).
+Instance Is_true_dec b : Decision (Is_true b).
+Proof. destruct b; apply _. Defined.
+
+Section prop_dec.
+ Context `(P_dec : Decision P) `(Q_dec : Decision Q).
+
+ Global Instance not_dec: Decision (¬P).
+ Proof. refine (cast_if_not P_dec); intuition. Defined.
+ Global Instance and_dec: Decision (P ∧ Q).
+ Proof. refine (cast_if_and P_dec Q_dec); intuition. Defined.
+ Global Instance or_dec: Decision (P ∨ Q).
+ Proof. refine (cast_if_or P_dec Q_dec); intuition. Defined.
+ Global Instance impl_dec: Decision (P → Q).
+ Proof. refine (if P_dec then cast_if Q_dec else left _); intuition. Defined.
+End prop_dec.
+Instance iff_dec `(P_dec : Decision P) `(Q_dec : Decision Q) :
+ Decision (P ↔ Q) := and_dec _ _.
+
+(** Instances of [Decision] for common data types. *)
+Instance bool_eq_dec (x y : bool) : Decision (x = y).
+Proof. solve_decision. Defined.
+Instance unit_eq_dec (x y : unit) : Decision (x = y).
+Proof. solve_decision. Defined.
+Instance prod_eq_dec `(A_dec : ∀ x y : A, Decision (x = y))
+ `(B_dec : ∀ x y : B, Decision (x = y)) (x y : A * B) : Decision (x = y).
+Proof. solve_decision. Defined.
+Instance sum_eq_dec `(A_dec : ∀ x y : A, Decision (x = y))
+ `(B_dec : ∀ x y : B, Decision (x = y)) (x y : A + B) : Decision (x = y).
+Proof. solve_decision. Defined.
+
+Instance curry_dec `(P_dec : ∀ (x : A) (y : B), Decision (P x y)) p :
+ Decision (curry P p) :=
+ match p as p return Decision (curry P p) with
+ | (x,y) => P_dec x y
+ end.
+Instance uncurry_dec `(P_dec : ∀ (p : A * B), Decision (P p)) x y :
+ Decision (uncurry P x y) := P_dec (x,y).
+
+Instance sig_eq_dec `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
+ `{∀ x y : A, Decision (x = y)} (x y : sig P) : Decision (x = y).
+Proof. refine (cast_if (decide (`x = `y))); by rewrite sig_eq_pi. Defined.
+
+(** Some laws for decidable propositions *)
+Lemma not_and_l {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
+Proof. destruct (decide P); tauto. Qed.
+Lemma not_and_r {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
+Proof. destruct (decide Q); tauto. Qed.
+Lemma not_and_l_alt {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ (¬Q ∧ P).
+Proof. destruct (decide P); tauto. Qed.
+Lemma not_and_r_alt {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ (¬P ∧ Q) ∨ ¬Q.
+Proof. destruct (decide Q); tauto. Qed.
diff --git a/prelude/error.v b/prelude/error.v
new file mode 100644
index 0000000000000000000000000000000000000000..0eb6c33f51b4baaf128cacc1fb15a47c210c6fd3
--- /dev/null
+++ b/prelude/error.v
@@ -0,0 +1,135 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Export prelude.list.
+
+Definition error (S E A : Type) : Type := S → E + (A * S).
+
+Definition error_eval {S E A} (x : error S E A) (s : S) : E + A :=
+ match x s with inl e => inl e | inr (a,_) => inr a end.
+
+Instance error_ret {S E} : MRet (error S E) := λ A x s, inr (x,s).
+Instance error_bind {S E} : MBind (error S E) := λ A B f x s,
+ match x s with
+ | inr (a,s') => f a s'
+ | inl e => inl e
+ end.
+Instance error_fmap {S E} : FMap (error S E) := λ A B f x s,
+ match x s with
+ | inr (a,s') => inr (f a,s')
+ | inl e => inl e
+ end.
+Definition fail {S E A} (e : E) : error S E A := λ s, inl e.
+
+Definition modify {S E} (f : S → S) : error S E () := λ s, inr ((), f s).
+Definition gets {S E A} (f : S → A) : error S E A := λ s, inr (f s, s).
+
+Definition error_guard {E} P {dec : Decision P} {S A}
+ (e : E) (f : P → error S E A) : error S E A :=
+ match decide P with left H => f H | right _ => fail e end.
+Notation "'guard' P 'with' e ; o" := (error_guard P e (λ _, o))
+ (at level 65, only parsing, right associativity) : C_scope.
+Definition error_of_option {S A E} (x : option A) (e : E) : error S E A :=
+ match x with Some a => mret a | None => fail e end.
+
+Lemma error_bind_ret {S E A B} (f : A → error S E B) s s'' x b :
+ (x ≫= f) s = mret b s'' ↔ ∃ a s', x s = mret a s' ∧ f a s' = mret b s''.
+Proof. compute; destruct (x s) as [|[??]]; naive_solver. Qed.
+Lemma error_fmap_ret {S E A B} (f : A → B) s s' (x : error S E A) b :
+ (f <$> x) s = mret b s' ↔ ∃ a, x s = mret a s' ∧ b = f a.
+Proof. compute; destruct (x s) as [|[??]]; naive_solver. Qed.
+Lemma error_of_option_ret {S E A} (s s' : S) (o : option A) (e : E) a :
+ error_of_option o e s = mret a s' ↔ o = Some a ∧ s = s'.
+Proof. compute; destruct o; naive_solver. Qed.
+Lemma error_guard_ret {S E A} `{dec : Decision P} s s' (x : error S E A) e a :
+ (guard P with e ; x) s = mret a s' ↔ P ∧ x s = mret a s'.
+Proof. compute; destruct dec; naive_solver. Qed.
+Lemma error_fmap_bind {S E A B C} (f : A → B) (g : B → error S E C) x s :
+ ((f <$> x) ≫= g) s = (x ≫= g ∘ f) s.
+Proof. by compute; destruct (x s) as [|[??]]. Qed.
+
+Lemma error_associative {S E A B C} (f : A → error S E B) (g : B → error S E C) x s :
+ ((x ≫= f) ≫= g) s = (a ↠x; f a ≫= g) s.
+Proof. by compute; destruct (x s) as [|[??]]. Qed.
+Lemma error_of_option_bind {S E A B} (f : A → option B) o e :
+ error_of_option (S := S) (E:=E) (o ≫= f) e
+ = a ↠error_of_option o e; error_of_option (f a) e.
+Proof. by destruct o. Qed.
+
+Lemma error_gets_spec {S E A} (g : S → A) s : gets (E:=E) g s = mret (g s) s.
+Proof. done. Qed.
+Lemma error_modify_spec {S E} (g : S → S) s : modify (E:=E) g s = mret () (g s).
+Proof. done. Qed.
+Lemma error_left_gets {S E A B} (g : S → A) (f : A → error S E B) s :
+ (gets (E:=E) g ≫= f) s = f (g s) s.
+Proof. done. Qed.
+Lemma error_left_modify {S E B} (g : S → S) (f : unit → error S E B) s :
+ (modify (E:=E) g ≫= f) s = f () (g s).
+Proof. done. Qed.
+Lemma error_left_id {S E A B} (a : A) (f : A → error S E B) :
+ (mret a ≫= f) = f a.
+Proof. done. Qed.
+
+Ltac generalize_errors :=
+ csimpl;
+ let gen_error e :=
+ try (is_var e; fail 1); generalize e;
+ let x := fresh "err" in intros x in
+ repeat match goal with
+ | |- appcontext[ fail ?e ] => gen_error e
+ | |- appcontext[ error_guard _ ?e ] => gen_error e
+ | |- appcontext[ error_of_option _ ?e ] => gen_error e
+ end.
+Tactic Notation "simplify_error_equality" :=
+ repeat match goal with
+ | H : context [ gets _ _ _ ] |- _ => rewrite error_gets_spec in H
+ | H : context [ modify _ _ _ ] |- _ => rewrite error_modify_spec in H
+ | H : (mret (M:=error _ _) _ ≫= _) _ = _ |- _ => rewrite error_left_id in H
+ | H : (gets _ ≫= _) _ = _ |- _ => rewrite error_left_gets in H
+ | H : (modify _ ≫= _) _ = _ |- _ => rewrite error_left_modify in H
+ | H : error_guard _ _ _ _ = _ |- _ => apply error_guard_ret in H; destruct H
+ | _ => progress simplify_equality'
+ | H : error_of_option _ _ _ = _ |- _ =>
+ apply error_of_option_ret in H; destruct H
+ | H : mbind (M:=error _ _) _ _ _ = _ |- _ =>
+ apply error_bind_ret in H; destruct H as (?&?&?&?)
+ | H : fmap (M:=error _ _) _ _ _ = _ |- _ =>
+ apply error_fmap_ret in H; destruct H as (?&?&?)
+ | H : mbind (M:=option) _ _ = _ |- _ =>
+ apply bind_Some in H; destruct H as (?&?&?)
+ | H : fmap (M:=option) _ _ = _ |- _ =>
+ apply fmap_Some in H; destruct H as (?&?&?)
+ | H : maybe _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : maybe2 _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : maybe3 _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : maybe4 _ ?x = Some _ |- _ => is_var x; destruct x
+ | _ => progress case_decide
+ end.
+
+Tactic Notation "error_proceed" :=
+ repeat match goal with
+ | H : context [ gets _ _ ] |- _ => rewrite error_gets_spec in H
+ | H : context [ modify _ _ ] |- _ => rewrite error_modify_spec in H
+ | H : context [ error_of_option _ _ ] |- _ => rewrite error_of_option_bind in H
+ | H : (mret (M:= _ _) _ ≫= _) _ = _ |- _ => rewrite error_left_id in H
+ | H : (gets _ ≫= _) _ = _ |- _ => rewrite error_left_gets in H
+ | H : (modify _ ≫= _) _ = _ |- _ => rewrite error_left_modify in H
+ | H : ((_ <$> _) ≫= _) _ = _ |- _ => rewrite error_fmap_bind in H
+ | H : ((_ ≫= _) ≫= _) _ = _ |- _ => rewrite error_associative in H
+ | H : (error_guard _ _ _) _ = _ |- _ =>
+ let H' := fresh in apply error_guard_ret in H; destruct H as [H' H]
+ | _ => progress simplify_equality'
+ | H : maybe _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : maybe2 _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : maybe3 _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : maybe4 _ ?x = Some _ |- _ => is_var x; destruct x
+ end.
+Tactic Notation "error_proceed"
+ simple_intropattern(a) "as" simple_intropattern(s) :=
+ error_proceed;
+ lazymatch goal with
+ | H : (error_of_option ?o _ ≫= _) _ = _ |- _ => destruct o as [a|] eqn:?
+ | H : error_of_option ?o _ _ = _ |- _ => destruct o as [a|] eqn:?
+ | H : (_ ≫= _) _ = _ |- _ => apply error_bind_ret in H; destruct H as (a&s&?&H)
+ | H : (_ <$> _) _ = _ |- _ => apply error_fmap_ret in H; destruct H as (a&?&?)
+ end;
+ error_proceed.
diff --git a/prelude/fin_collections.v b/prelude/fin_collections.v
new file mode 100644
index 0000000000000000000000000000000000000000..2f7a573d0ed171de1a6fcfe86a5c92cb5ccf5b1d
--- /dev/null
+++ b/prelude/fin_collections.v
@@ -0,0 +1,172 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects definitions and theorems on finite collections. Most
+importantly, it implements a fold and size function and some useful induction
+principles on finite collections . *)
+Require Import Permutation prelude.relations prelude.listset.
+Require Export prelude.numbers prelude.collections.
+
+Instance collection_size `{Elements A C} : Size C := length ∘ elements.
+Definition collection_fold `{Elements A C} {B}
+ (f : A → B → B) (b : B) : C → B := foldr f b ∘ elements.
+
+Section fin_collection.
+Context `{FinCollection A C}.
+Implicit Types X Y : C.
+
+Lemma fin_collection_finite X : set_finite X.
+Proof. by exists (elements X); intros; rewrite elem_of_elements. Qed.
+Global Instance elements_proper: Proper ((≡) ==> (≡ₚ)) (elements (C:=C)).
+Proof.
+ intros ?? E. apply NoDup_Permutation.
+ * apply NoDup_elements.
+ * apply NoDup_elements.
+ * intros. by rewrite !elem_of_elements, E.
+Qed.
+Global Instance collection_size_proper: Proper ((≡) ==> (=)) (@size C _).
+Proof. intros ?? E. apply Permutation_length. by rewrite E. Qed.
+Lemma size_empty : size (∅ : C) = 0.
+Proof.
+ unfold size, collection_size. simpl.
+ rewrite (elem_of_nil_inv (elements ∅)); [done|intro].
+ rewrite elem_of_elements, elem_of_empty; auto.
+Qed.
+Lemma size_empty_inv (X : C) : size X = 0 → X ≡ ∅.
+Proof.
+ intros; apply equiv_empty; intros x; rewrite <-elem_of_elements.
+ by rewrite (nil_length_inv (elements X)), ?elem_of_nil.
+Qed.
+Lemma size_empty_iff (X : C) : size X = 0 ↔ X ≡ ∅.
+Proof. split. apply size_empty_inv. by intros ->; rewrite size_empty. Qed.
+Lemma size_non_empty_iff (X : C) : size X ≠0 ↔ X ≢ ∅.
+Proof. by rewrite size_empty_iff. Qed.
+Lemma size_singleton (x : A) : size {[ x ]} = 1.
+Proof.
+ change (length (elements {[ x ]}) = length [x]).
+ apply Permutation_length, NoDup_Permutation.
+ * apply NoDup_elements.
+ * apply NoDup_singleton.
+ * intros y.
+ by rewrite elem_of_elements, elem_of_singleton, elem_of_list_singleton.
+Qed.
+Lemma size_singleton_inv X x y : size X = 1 → x ∈ X → y ∈ X → x = y.
+Proof.
+ unfold size, collection_size. simpl. rewrite <-!elem_of_elements.
+ generalize (elements X). intros [|? l]; intro; simplify_equality'.
+ rewrite (nil_length_inv l), !elem_of_list_singleton by done; congruence.
+Qed.
+Lemma collection_choose_or_empty X : (∃ x, x ∈ X) ∨ X ≡ ∅.
+Proof.
+ destruct (elements X) as [|x l] eqn:HX; [right|left].
+ * apply equiv_empty; intros x. by rewrite <-elem_of_elements, HX, elem_of_nil.
+ * exists x. rewrite <-elem_of_elements, HX. by left.
+Qed.
+Lemma collection_choose X : X ≢ ∅ → ∃ x, x ∈ X.
+Proof. intros. by destruct (collection_choose_or_empty X). Qed.
+Lemma collection_choose_L `{!LeibnizEquiv C} X : X ≠∅ → ∃ x, x ∈ X.
+Proof. unfold_leibniz. apply collection_choose. Qed.
+Lemma size_pos_elem_of X : 0 < size X → ∃ x, x ∈ X.
+Proof.
+ intros Hsz. destruct (collection_choose_or_empty X) as [|HX]; [done|].
+ contradict Hsz. rewrite HX, size_empty; lia.
+Qed.
+Lemma size_1_elem_of X : size X = 1 → ∃ x, X ≡ {[ x ]}.
+Proof.
+ intros E. destruct (size_pos_elem_of X); auto with lia.
+ exists x. apply elem_of_equiv. split.
+ * rewrite elem_of_singleton. eauto using size_singleton_inv.
+ * solve_elem_of.
+Qed.
+Lemma size_union X Y : X ∩ Y ≡ ∅ → size (X ∪ Y) = size X + size Y.
+Proof.
+ intros [E _]. unfold size, collection_size. simpl. rewrite <-app_length.
+ apply Permutation_length, NoDup_Permutation.
+ * apply NoDup_elements.
+ * apply NoDup_app; repeat split; try apply NoDup_elements.
+ intros x; rewrite !elem_of_elements; solve_elem_of.
+ * intros. by rewrite elem_of_app, !elem_of_elements, elem_of_union.
+Qed.
+Instance elem_of_dec_slow (x : A) (X : C) : Decision (x ∈ X) | 100.
+Proof.
+ refine (cast_if (decide_rel (∈) x (elements X)));
+ by rewrite <-(elem_of_elements _).
+Defined.
+Global Program Instance collection_subseteq_dec_slow (X Y : C) :
+ Decision (X ⊆ Y) | 100 :=
+ match decide_rel (=) (size (X ∖ Y)) 0 return _ with
+ | left _ => left _ | right _ => right _
+ end.
+Next Obligation.
+ intros X Y E1 x ?; apply dec_stable; intro. destruct (proj1(elem_of_empty x)).
+ apply (size_empty_inv _ E1). by rewrite elem_of_difference.
+Qed.
+Next Obligation.
+ intros X Y E1 E2; destruct E1. apply size_empty_iff, equiv_empty. intros x.
+ rewrite elem_of_difference. intros [E3 ?]. by apply E2 in E3.
+Qed.
+Lemma size_union_alt X Y : size (X ∪ Y) = size X + size (Y ∖ X).
+Proof.
+ rewrite <-size_union by solve_elem_of.
+ setoid_replace (Y ∖ X) with ((Y ∪ X) ∖ X) by solve_elem_of.
+ rewrite <-union_difference, (commutative (∪)); solve_elem_of.
+Qed.
+Lemma subseteq_size X Y : X ⊆ Y → size X ≤ size Y.
+Proof. intros. rewrite (union_difference X Y), size_union_alt by done. lia. Qed.
+Lemma subset_size X Y : X ⊂ Y → size X < size Y.
+Proof.
+ intros. rewrite (union_difference X Y) by solve_elem_of.
+ rewrite size_union_alt, difference_twice.
+ cut (size (Y ∖ X) ≠0); [lia |].
+ by apply size_non_empty_iff, non_empty_difference.
+Qed.
+Lemma collection_wf : wf (strict (@subseteq C _)).
+Proof. apply (wf_projected (<) size); auto using subset_size, lt_wf. Qed.
+Lemma collection_ind (P : C → Prop) :
+ Proper ((≡) ==> iff) P →
+ P ∅ → (∀ x X, x ∉ X → P X → P ({[ x ]} ∪ X)) → ∀ X, P X.
+Proof.
+ intros ? Hemp Hadd. apply well_founded_induction with (⊂).
+ { apply collection_wf. }
+ intros X IH. destruct (collection_choose_or_empty X) as [[x ?]|HX].
+ * rewrite (union_difference {[ x ]} X) by solve_elem_of.
+ apply Hadd. solve_elem_of. apply IH; solve_elem_of.
+ * by rewrite HX.
+Qed.
+Lemma collection_fold_ind {B} (P : B → C → Prop) (f : A → B → B) (b : B) :
+ Proper ((=) ==> (≡) ==> iff) P →
+ P b ∅ → (∀ x X r, x ∉ X → P r X → P (f x r) ({[ x ]} ∪ X)) →
+ ∀ X, P (collection_fold f b X) X.
+Proof.
+ intros ? Hemp Hadd.
+ cut (∀ l, NoDup l → ∀ X, (∀ x, x ∈ X ↔ x ∈ l) → P (foldr f b l) X).
+ { intros help ?. apply help; [apply NoDup_elements|].
+ symmetry. apply elem_of_elements. }
+ induction 1 as [|x l ?? IH]; simpl.
+ * intros X HX. setoid_rewrite elem_of_nil in HX.
+ rewrite equiv_empty. done. solve_elem_of.
+ * intros X HX. setoid_rewrite elem_of_cons in HX.
+ rewrite (union_difference {[ x ]} X) by solve_elem_of.
+ apply Hadd. solve_elem_of. apply IH. solve_elem_of.
+Qed.
+Lemma collection_fold_proper {B} (R : relation B) `{!Equivalence R}
+ (f : A → B → B) (b : B) `{!Proper ((=) ==> R ==> R) f}
+ (Hf : ∀ a1 a2 b, R (f a1 (f a2 b)) (f a2 (f a1 b))) :
+ Proper ((≡) ==> R) (collection_fold f b : C → B).
+Proof. intros ?? E. apply (foldr_permutation R f b); auto. by rewrite E. Qed.
+Global Instance set_Forall_dec `(P : A → Prop)
+ `{∀ x, Decision (P x)} X : Decision (set_Forall P X) | 100.
+Proof.
+ refine (cast_if (decide (Forall P (elements X))));
+ abstract (unfold set_Forall; setoid_rewrite <-elem_of_elements;
+ by rewrite <-Forall_forall).
+Defined.
+Global Instance set_Exists_dec `(P : A → Prop) `{∀ x, Decision (P x)} X :
+ Decision (set_Exists P X) | 100.
+Proof.
+ refine (cast_if (decide (Exists P (elements X))));
+ abstract (unfold set_Exists; setoid_rewrite <-elem_of_elements;
+ by rewrite <-Exists_exists).
+Defined.
+Global Instance rel_elem_of_dec `{∀ x y, Decision (R x y)} x X :
+ Decision (elem_of_upto R x X) | 100 := decide (set_Exists (R x) X).
+End fin_collection.
diff --git a/prelude/fin_map_dom.v b/prelude/fin_map_dom.v
new file mode 100644
index 0000000000000000000000000000000000000000..7c4e76974aeb81104a670882203b2ecaef846b60
--- /dev/null
+++ b/prelude/fin_map_dom.v
@@ -0,0 +1,139 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file provides an axiomatization of the domain function of finite
+maps. We provide such an axiomatization, instead of implementing the domain
+function in a generic way, to allow more efficient implementations. *)
+Require Export prelude.collections prelude.fin_maps.
+
+Class FinMapDom K M D `{FMap M,
+ ∀ A, Lookup K A (M A), ∀ A, Empty (M A), ∀ A, PartialAlter K A (M A),
+ OMap M, Merge M, ∀ A, FinMapToList K A (M A), ∀ i j : K, Decision (i = j),
+ ∀ A, Dom (M A) D, ElemOf K D, Empty D, Singleton K D,
+ Union D, Intersection D, Difference D} := {
+ finmap_dom_map :>> FinMap K M;
+ finmap_dom_collection :>> Collection K D;
+ elem_of_dom {A} (m : M A) i : i ∈ dom D m ↔ is_Some (m !! i)
+}.
+
+Section fin_map_dom.
+Context `{FinMapDom K M D}.
+
+Lemma elem_of_dom_2 {A} (m : M A) i x : m !! i = Some x → i ∈ dom D m.
+Proof. rewrite elem_of_dom; eauto. Qed.
+Lemma not_elem_of_dom {A} (m : M A) i : i ∉ dom D m ↔ m !! i = None.
+Proof. by rewrite elem_of_dom, eq_None_not_Some. Qed.
+Lemma subseteq_dom {A} (m1 m2 : M A) : m1 ⊆ m2 → dom D m1 ⊆ dom D m2.
+Proof.
+ rewrite map_subseteq_spec.
+ intros ??. rewrite !elem_of_dom. inversion 1; eauto.
+Qed.
+Lemma subset_dom {A} (m1 m2 : M A) : m1 ⊂ m2 → dom D m1 ⊂ dom D m2.
+Proof.
+ intros [Hss1 Hss2]; split; [by apply subseteq_dom |].
+ contradict Hss2. rewrite map_subseteq_spec. intros i x Hi.
+ specialize (Hss2 i). rewrite !elem_of_dom in Hss2.
+ destruct Hss2; eauto. by simplify_map_equality.
+Qed.
+Lemma dom_empty {A} : dom D (@empty (M A) _) ≡ ∅.
+Proof.
+ split; intro; [|solve_elem_of].
+ rewrite elem_of_dom, lookup_empty. by inversion 1.
+Qed.
+Lemma dom_empty_inv {A} (m : M A) : dom D m ≡ ∅ → m = ∅.
+Proof.
+ intros E. apply map_empty. intros. apply not_elem_of_dom.
+ rewrite E. solve_elem_of.
+Qed.
+Lemma dom_alter {A} f (m : M A) i : dom D (alter f i m) ≡ dom D m.
+Proof.
+ apply elem_of_equiv; intros j; rewrite !elem_of_dom; unfold is_Some.
+ destruct (decide (i = j)); simplify_map_equality'; eauto.
+ destruct (m !! j); naive_solver.
+Qed.
+Lemma dom_insert {A} (m : M A) i x : dom D (<[i:=x]>m) ≡ {[ i ]} ∪ dom D m.
+Proof.
+ apply elem_of_equiv. intros j. rewrite elem_of_union, !elem_of_dom.
+ unfold is_Some. setoid_rewrite lookup_insert_Some.
+ destruct (decide (i = j)); solve_elem_of.
+Qed.
+Lemma dom_insert_subseteq {A} (m : M A) i x : dom D m ⊆ dom D (<[i:=x]>m).
+Proof. rewrite (dom_insert _). solve_elem_of. Qed.
+Lemma dom_insert_subseteq_compat_l {A} (m : M A) i x X :
+ X ⊆ dom D m → X ⊆ dom D (<[i:=x]>m).
+Proof. intros. transitivity (dom D m); eauto using dom_insert_subseteq. Qed.
+Lemma dom_singleton {A} (i : K) (x : A) : dom D {[i ↦ x]} ≡ {[ i ]}.
+Proof. rewrite <-insert_empty, dom_insert, dom_empty; solve_elem_of. Qed.
+Lemma dom_delete {A} (m : M A) i : dom D (delete i m) ≡ dom D m ∖ {[ i ]}.
+Proof.
+ apply elem_of_equiv. intros j. rewrite elem_of_difference, !elem_of_dom.
+ unfold is_Some. setoid_rewrite lookup_delete_Some. solve_elem_of.
+Qed.
+Lemma delete_partial_alter_dom {A} (m : M A) i f :
+ i ∉ dom D m → delete i (partial_alter f i m) = m.
+Proof. rewrite not_elem_of_dom. apply delete_partial_alter. Qed.
+Lemma delete_insert_dom {A} (m : M A) i x :
+ i ∉ dom D m → delete i (<[i:=x]>m) = m.
+Proof. rewrite not_elem_of_dom. apply delete_insert. Qed.
+Lemma map_disjoint_dom {A} (m1 m2 : M A) : m1 ⊥ₘ m2 ↔ dom D m1 ∩ dom D m2 ≡ ∅.
+Proof.
+ rewrite map_disjoint_spec, elem_of_equiv_empty.
+ setoid_rewrite elem_of_intersection.
+ setoid_rewrite elem_of_dom. unfold is_Some. naive_solver.
+Qed.
+Lemma map_disjoint_dom_1 {A} (m1 m2 : M A) : m1 ⊥ₘ m2 → dom D m1 ∩ dom D m2 ≡ ∅.
+Proof. apply map_disjoint_dom. Qed.
+Lemma map_disjoint_dom_2 {A} (m1 m2 : M A) : dom D m1 ∩ dom D m2 ≡ ∅ → m1 ⊥ₘ m2.
+Proof. apply map_disjoint_dom. Qed.
+Lemma dom_union {A} (m1 m2 : M A) : dom D (m1 ∪ m2) ≡ dom D m1 ∪ dom D m2.
+Proof.
+ apply elem_of_equiv. intros i. rewrite elem_of_union, !elem_of_dom.
+ unfold is_Some. setoid_rewrite lookup_union_Some_raw.
+ destruct (m1 !! i); naive_solver.
+Qed.
+Lemma dom_intersection {A} (m1 m2 : M A) :
+ dom D (m1 ∩ m2) ≡ dom D m1 ∩ dom D m2.
+Proof.
+ apply elem_of_equiv. intros i. rewrite elem_of_intersection, !elem_of_dom.
+ unfold is_Some. setoid_rewrite lookup_intersection_Some. naive_solver.
+Qed.
+Lemma dom_difference {A} (m1 m2 : M A) : dom D (m1 ∖ m2) ≡ dom D m1 ∖ dom D m2.
+Proof.
+ apply elem_of_equiv. intros i. rewrite elem_of_difference, !elem_of_dom.
+ unfold is_Some. setoid_rewrite lookup_difference_Some.
+ destruct (m2 !! i); naive_solver.
+Qed.
+Lemma dom_fmap {A B} (f : A → B) m : dom D (f <$> m) ≡ dom D m.
+Proof.
+ apply elem_of_equiv. intros i.
+ rewrite !elem_of_dom, lookup_fmap, <-!not_eq_None_Some.
+ destruct (m !! i); naive_solver.
+Qed.
+Lemma dom_finite {A} (m : M A) : set_finite (dom D m).
+Proof.
+ induction m using map_ind; rewrite ?dom_empty, ?dom_insert;
+ eauto using empty_finite, union_finite, singleton_finite.
+Qed.
+
+Context `{!LeibnizEquiv D}.
+Lemma dom_empty_L {A} : dom D (@empty (M A) _) = ∅.
+Proof. unfold_leibniz; apply dom_empty. Qed.
+Lemma dom_empty_inv_L {A} (m : M A) : dom D m = ∅ → m = ∅.
+Proof. by intros; apply dom_empty_inv; unfold_leibniz. Qed.
+Lemma dom_alter_L {A} f (m : M A) i : dom D (alter f i m) = dom D m.
+Proof. unfold_leibniz; apply dom_alter. Qed.
+Lemma dom_insert_L {A} (m : M A) i x : dom D (<[i:=x]>m) = {[ i ]} ∪ dom D m.
+Proof. unfold_leibniz; apply dom_insert. Qed.
+Lemma dom_singleton_L {A} (i : K) (x : A) : dom D {[i ↦ x]} = {[ i ]}.
+Proof. unfold_leibniz; apply dom_singleton. Qed.
+Lemma dom_delete_L {A} (m : M A) i : dom D (delete i m) = dom D m ∖ {[ i ]}.
+Proof. unfold_leibniz; apply dom_delete. Qed.
+Lemma dom_union_L {A} (m1 m2 : M A) : dom D (m1 ∪ m2) = dom D m1 ∪ dom D m2.
+Proof. unfold_leibniz; apply dom_union. Qed.
+Lemma dom_intersection_L {A} (m1 m2 : M A) :
+ dom D (m1 ∩ m2) = dom D m1 ∩ dom D m2.
+Proof. unfold_leibniz; apply dom_intersection. Qed.
+Lemma dom_difference_L {A} (m1 m2 : M A) : dom D (m1 ∖ m2) = dom D m1 ∖ dom D m2.
+Proof. unfold_leibniz; apply dom_difference. Qed.
+Lemma dom_fmap_L {A B} (f : A → B) m : dom D (f <$> m) = dom D m.
+Proof. unfold_leibniz; apply dom_fmap. Qed.
+End fin_map_dom.
diff --git a/prelude/fin_maps.v b/prelude/fin_maps.v
new file mode 100644
index 0000000000000000000000000000000000000000..09c65cdad1dafa8551775965b2daa890b07266d9
--- /dev/null
+++ b/prelude/fin_maps.v
@@ -0,0 +1,1573 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** Finite maps associate data to keys. This file defines an interface for
+finite maps and collects some theory on it. Most importantly, it proves useful
+induction principles for finite maps and implements the tactic
+[simplify_map_equality] to simplify goals involving finite maps. *)
+Require Import Permutation.
+Require Export prelude.relations prelude.vector prelude.orders.
+
+(** * Axiomatization of finite maps *)
+(** We require Leibniz equality to be extensional on finite maps. This of
+course limits the space of finite map implementations, but since we are mainly
+interested in finite maps with numbers as indexes, we do not consider this to
+be a serious limitation. The main application of finite maps is to implement
+the memory, where extensionality of Leibniz equality is very important for a
+convenient use in the assertions of our axiomatic semantics. *)
+
+(** Finiteness is axiomatized by requiring that each map can be translated
+to an association list. The translation to association lists is used to
+prove well founded recursion on finite maps. *)
+
+(** Finite map implementations are required to implement the [merge] function
+which enables us to give a generic implementation of [union_with],
+[intersection_with], and [difference_with]. *)
+
+Class FinMapToList K A M := map_to_list: M → list (K * A).
+
+Class FinMap K M `{FMap M, ∀ A, Lookup K A (M A), ∀ A, Empty (M A), ∀ A,
+ PartialAlter K A (M A), OMap M, Merge M, ∀ A, FinMapToList K A (M A),
+ ∀ i j : K, Decision (i = j)} := {
+ map_eq {A} (m1 m2 : M A) : (∀ i, m1 !! i = m2 !! i) → m1 = m2;
+ lookup_empty {A} i : (∅ : M A) !! i = None;
+ lookup_partial_alter {A} f (m : M A) i :
+ partial_alter f i m !! i = f (m !! i);
+ lookup_partial_alter_ne {A} f (m : M A) i j :
+ i ≠j → partial_alter f i m !! j = m !! j;
+ lookup_fmap {A B} (f : A → B) (m : M A) i : (f <$> m) !! i = f <$> m !! i;
+ NoDup_map_to_list {A} (m : M A) : NoDup (map_to_list m);
+ elem_of_map_to_list {A} (m : M A) i x :
+ (i,x) ∈ map_to_list m ↔ m !! i = Some x;
+ lookup_omap {A B} (f : A → option B) m i : omap f m !! i = m !! i ≫= f;
+ lookup_merge {A B C} (f : option A → option B → option C)
+ `{!PropHolds (f None None = None)} m1 m2 i :
+ merge f m1 m2 !! i = f (m1 !! i) (m2 !! i)
+}.
+
+(** * Derived operations *)
+(** All of the following functions are defined in a generic way for arbitrary
+finite map implementations. These generic implementations do not cause a
+significant performance loss to make including them in the finite map interface
+worthwhile. *)
+Instance map_insert `{PartialAlter K A M} : Insert K A M :=
+ λ i x, partial_alter (λ _, Some x) i.
+Instance map_alter `{PartialAlter K A M} : Alter K A M :=
+ λ f, partial_alter (fmap f).
+Instance map_delete `{PartialAlter K A M} : Delete K M :=
+ partial_alter (λ _, None).
+Instance map_singleton `{PartialAlter K A M, Empty M} :
+ SingletonM K A M := λ i x, <[i:=x]> ∅.
+
+Definition map_of_list `{Insert K A M, Empty M} : list (K * A) → M :=
+ fold_right (λ p, <[p.1:=p.2]>) ∅.
+Definition map_of_collection `{Elements K C, Insert K A M, Empty M}
+ (f : K → option A) (X : C) : M :=
+ map_of_list (omap (λ i, (i,) <$> f i) (elements X)).
+
+Instance map_union_with `{Merge M} {A} : UnionWith A (M A) :=
+ λ f, merge (union_with f).
+Instance map_intersection_with `{Merge M} {A} : IntersectionWith A (M A) :=
+ λ f, merge (intersection_with f).
+Instance map_difference_with `{Merge M} {A} : DifferenceWith A (M A) :=
+ λ f, merge (difference_with f).
+
+Instance map_equiv `{∀ A, Lookup K A (M A), Equiv A} : Equiv (M A) | 18 :=
+ λ m1 m2, ∀ i, m1 !! i ≡ m2 !! i.
+
+(** The relation [intersection_forall R] on finite maps describes that the
+relation [R] holds for each pair in the intersection. *)
+Definition map_Forall `{Lookup K A M} (P : K → A → Prop) : M → Prop :=
+ λ m, ∀ i x, m !! i = Some x → P i x.
+Definition map_relation `{∀ A, Lookup K A (M A)} {A B} (R : A → B → Prop)
+ (P : A → Prop) (Q : B → Prop) (m1 : M A) (m2 : M B) : Prop := ∀ i,
+ option_relation R P Q (m1 !! i) (m2 !! i).
+Definition map_included `{∀ A, Lookup K A (M A)} {A}
+ (R : relation A) : relation (M A) := map_relation R (λ _, False) (λ _, True).
+Definition map_disjoint `{∀ A, Lookup K A (M A)} {A} : relation (M A) :=
+ map_relation (λ _ _, False) (λ _, True) (λ _, True).
+Infix "⊥ₘ" := map_disjoint (at level 70) : C_scope.
+Hint Extern 0 (_ ⊥ₘ _) => symmetry; eassumption.
+Notation "( m ⊥ₘ.)" := (map_disjoint m) (only parsing) : C_scope.
+Notation "(.⊥ₘ m )" := (λ m2, m2 ⊥ₘ m) (only parsing) : C_scope.
+Instance map_subseteq `{∀ A, Lookup K A (M A)} {A} : SubsetEq (M A) :=
+ map_included (=).
+
+(** The union of two finite maps only has a meaningful definition for maps
+that are disjoint. However, as working with partial functions is inconvenient
+in Coq, we define the union as a total function. In case both finite maps
+have a value at the same index, we take the value of the first map. *)
+Instance map_union `{Merge M} {A} : Union (M A) := union_with (λ x _, Some x).
+Instance map_intersection `{Merge M} {A} : Intersection (M A) :=
+ intersection_with (λ x _, Some x).
+
+(** The difference operation removes all values from the first map whose
+index contains a value in the second map as well. *)
+Instance map_difference `{Merge M} {A} : Difference (M A) :=
+ difference_with (λ _ _, None).
+
+(** A stronger variant of map that allows the mapped function to use the index
+of the elements. Implemented by conversion to lists, so not very efficient. *)
+Definition map_imap `{∀ A, Insert K A (M A), ∀ A, Empty (M A),
+ ∀ A, FinMapToList K A (M A)} {A B} (f : K → A → option B) (m : M A) : M B :=
+ map_of_list (omap (λ ix, (fst ix,) <$> curry f ix) (map_to_list m)).
+
+(** * Theorems *)
+Section theorems.
+Context `{FinMap K M}.
+
+(** ** Setoids *)
+Section setoid.
+ Context `{Equiv A} `{!Equivalence ((≡) : relation A)}.
+ Global Instance map_equivalence : Equivalence ((≡) : relation (M A)).
+ Proof.
+ split.
+ * by intros m i.
+ * by intros m1 m2 ? i.
+ * by intros m1 m2 m3 ?? i; transitivity (m2 !! i).
+ Qed.
+ Global Instance lookup_proper (i : K) :
+ Proper ((≡) ==> (≡)) (lookup (M:=M A) i).
+ Proof. by intros m1 m2 Hm. Qed.
+ Global Instance partial_alter_proper :
+ Proper (((≡) ==> (≡)) ==> (=) ==> (≡) ==> (≡)) (partial_alter (M:=M A)).
+ Proof.
+ by intros f1 f2 Hf i ? <- m1 m2 Hm j; destruct (decide (i = j)) as [->|];
+ rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne by done;
+ try apply Hf; apply lookup_proper.
+ Qed.
+ Global Instance insert_proper (i : K) :
+ Proper ((≡) ==> (≡) ==> (≡)) (insert (M:=M A) i).
+ Proof. by intros ???; apply partial_alter_proper; [constructor|]. Qed.
+ Global Instance singleton_proper k :
+ Proper ((≡) ==> (≡)) (singletonM k : A → M A).
+ Proof. by intros ???; apply insert_proper. Qed.
+ Global Instance delete_proper (i : K) :
+ Proper ((≡) ==> (≡)) (delete (M:=M A) i).
+ Proof. by apply partial_alter_proper; [constructor|]. Qed.
+ Global Instance alter_proper :
+ Proper (((≡) ==> (≡)) ==> (=) ==> (≡) ==> (≡)) (alter (A:=A) (M:=M A)).
+ Proof.
+ intros ?? Hf; apply partial_alter_proper.
+ by destruct 1; constructor; apply Hf.
+ Qed.
+ Lemma merge_ext f g
+ `{!PropHolds (f None None = None), !PropHolds (g None None = None)} :
+ ((≡) ==> (≡) ==> (≡))%signature f g →
+ ((≡) ==> (≡) ==> (≡))%signature (merge (M:=M) f) (merge g).
+ Proof.
+ by intros Hf ?? Hm1 ?? Hm2 i; rewrite !lookup_merge by done; apply Hf.
+ Qed.
+ Global Instance union_with_proper :
+ Proper (((≡) ==> (≡) ==> (≡)) ==> (≡) ==> (≡) ==>(≡)) (union_with (M:=M A)).
+ Proof.
+ intros ?? Hf ?? Hm1 ?? Hm2 i; apply (merge_ext _ _); auto.
+ by do 2 destruct 1; first [apply Hf | constructor].
+ Qed.
+ Global Instance map_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (M A).
+ Proof.
+ intros m1 m2 Hm; apply map_eq; intros i.
+ by unfold_leibniz; apply lookup_proper.
+ Qed.
+ Lemma map_equiv_empty (m : M A) : m ≡ ∅ ↔ m = ∅.
+ Proof.
+ split; [intros Hm; apply map_eq; intros i|by intros ->].
+ by rewrite lookup_empty, <-equiv_None, Hm, lookup_empty.
+ Qed.
+ Lemma map_equiv_lookup (m1 m2 : M A) i x :
+ m1 ≡ m2 → m1 !! i = Some x → ∃ y, m2 !! i = Some y ∧ x ≡ y.
+ Proof.
+ intros Hm ?. destruct (equiv_Some (m1 !! i) (m2 !! i) x) as (y&?&?); eauto.
+ Qed.
+End setoid.
+
+(** ** General properties *)
+Lemma map_eq_iff {A} (m1 m2 : M A) : m1 = m2 ↔ ∀ i, m1 !! i = m2 !! i.
+Proof. split. by intros ->. apply map_eq. Qed.
+Lemma map_subseteq_spec {A} (m1 m2 : M A) :
+ m1 ⊆ m2 ↔ ∀ i x, m1 !! i = Some x → m2 !! i = Some x.
+Proof.
+ unfold subseteq, map_subseteq, map_relation. split; intros Hm i;
+ specialize (Hm i); destruct (m1 !! i), (m2 !! i); naive_solver.
+Qed.
+Global Instance: EmptySpec (M A).
+Proof.
+ intros A m. rewrite !map_subseteq_spec.
+ intros i x. by rewrite lookup_empty.
+Qed.
+Global Instance: ∀ {A} (R : relation A), PreOrder R → PreOrder (map_included R).
+Proof.
+ split; [intros m i; by destruct (m !! i); simpl|].
+ intros m1 m2 m3 Hm12 Hm23 i; specialize (Hm12 i); specialize (Hm23 i).
+ destruct (m1 !! i), (m2 !! i), (m3 !! i); simplify_equality';
+ done || etransitivity; eauto.
+Qed.
+Global Instance: PartialOrder ((⊆) : relation (M A)).
+Proof.
+ split; [apply _|].
+ intros m1 m2; rewrite !map_subseteq_spec.
+ intros; apply map_eq; intros i; apply option_eq; naive_solver.
+Qed.
+Lemma lookup_weaken {A} (m1 m2 : M A) i x :
+ m1 !! i = Some x → m1 ⊆ m2 → m2 !! i = Some x.
+Proof. rewrite !map_subseteq_spec. auto. Qed.
+Lemma lookup_weaken_is_Some {A} (m1 m2 : M A) i :
+ is_Some (m1 !! i) → m1 ⊆ m2 → is_Some (m2 !! i).
+Proof. inversion 1. eauto using lookup_weaken. Qed.
+Lemma lookup_weaken_None {A} (m1 m2 : M A) i :
+ m2 !! i = None → m1 ⊆ m2 → m1 !! i = None.
+Proof.
+ rewrite map_subseteq_spec, !eq_None_not_Some.
+ intros Hm2 Hm [??]; destruct Hm2; eauto.
+Qed.
+Lemma lookup_weaken_inv {A} (m1 m2 : M A) i x y :
+ m1 !! i = Some x → m1 ⊆ m2 → m2 !! i = Some y → x = y.
+Proof. intros Hm1 ? Hm2. eapply lookup_weaken in Hm1; eauto. congruence. Qed.
+Lemma lookup_ne {A} (m : M A) i j : m !! i ≠m !! j → i ≠j.
+Proof. congruence. Qed.
+Lemma map_empty {A} (m : M A) : (∀ i, m !! i = None) → m = ∅.
+Proof. intros Hm. apply map_eq. intros. by rewrite Hm, lookup_empty. Qed.
+Lemma lookup_empty_is_Some {A} i : ¬is_Some ((∅ : M A) !! i).
+Proof. rewrite lookup_empty. by inversion 1. Qed.
+Lemma lookup_empty_Some {A} i (x : A) : ¬∅ !! i = Some x.
+Proof. by rewrite lookup_empty. Qed.
+Lemma map_subset_empty {A} (m : M A) : m ⊄ ∅.
+Proof.
+ intros [_ []]. rewrite map_subseteq_spec. intros ??. by rewrite lookup_empty.
+Qed.
+Lemma map_fmap_empty {A B} (f : A → B) : f <$> (∅ : M A) = ∅.
+Proof. by apply map_eq; intros i; rewrite lookup_fmap, !lookup_empty. Qed.
+
+(** ** Properties of the [partial_alter] operation *)
+Lemma partial_alter_ext {A} (f g : option A → option A) (m : M A) i :
+ (∀ x, m !! i = x → f x = g x) → partial_alter f i m = partial_alter g i m.
+Proof.
+ intros. apply map_eq; intros j. by destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne; auto.
+Qed.
+Lemma partial_alter_compose {A} f g (m : M A) i:
+ partial_alter (f ∘ g) i m = partial_alter f i (partial_alter g i m).
+Proof.
+ intros. apply map_eq. intros ii. by destruct (decide (i = ii)) as [->|?];
+ rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne.
+Qed.
+Lemma partial_alter_commute {A} f g (m : M A) i j :
+ i ≠j → partial_alter f i (partial_alter g j m) =
+ partial_alter g j (partial_alter f i m).
+Proof.
+ intros. apply map_eq; intros jj. destruct (decide (jj = j)) as [->|?].
+ { by rewrite lookup_partial_alter_ne,
+ !lookup_partial_alter, lookup_partial_alter_ne. }
+ destruct (decide (jj = i)) as [->|?].
+ * by rewrite lookup_partial_alter,
+ !lookup_partial_alter_ne, lookup_partial_alter by congruence.
+ * by rewrite !lookup_partial_alter_ne by congruence.
+Qed.
+Lemma partial_alter_self_alt {A} (m : M A) i x :
+ x = m !! i → partial_alter (λ _, x) i m = m.
+Proof.
+ intros. apply map_eq. intros ii. by destruct (decide (i = ii)) as [->|];
+ rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne.
+Qed.
+Lemma partial_alter_self {A} (m : M A) i : partial_alter (λ _, m !! i) i m = m.
+Proof. by apply partial_alter_self_alt. Qed.
+Lemma partial_alter_subseteq {A} f (m : M A) i :
+ m !! i = None → m ⊆ partial_alter f i m.
+Proof.
+ rewrite map_subseteq_spec. intros Hi j x Hj.
+ rewrite lookup_partial_alter_ne; congruence.
+Qed.
+Lemma partial_alter_subset {A} f (m : M A) i :
+ m !! i = None → is_Some (f (m !! i)) → m ⊂ partial_alter f i m.
+Proof.
+ intros Hi Hfi. split; [by apply partial_alter_subseteq|].
+ rewrite !map_subseteq_spec. inversion Hfi as [x Hx]. intros Hm.
+ apply (Some_ne_None x). rewrite <-(Hm i x); [done|].
+ by rewrite lookup_partial_alter.
+Qed.
+
+(** ** Properties of the [alter] operation *)
+Lemma alter_ext {A} (f g : A → A) (m : M A) i :
+ (∀ x, m !! i = Some x → f x = g x) → alter f i m = alter g i m.
+Proof. intro. apply partial_alter_ext. intros [x|] ?; f_equal'; auto. Qed.
+Lemma lookup_alter {A} (f : A → A) m i : alter f i m !! i = f <$> m !! i.
+Proof. unfold alter. apply lookup_partial_alter. Qed.
+Lemma lookup_alter_ne {A} (f : A → A) m i j : i ≠j → alter f i m !! j = m !! j.
+Proof. unfold alter. apply lookup_partial_alter_ne. Qed.
+Lemma alter_compose {A} (f g : A → A) (m : M A) i:
+ alter (f ∘ g) i m = alter f i (alter g i m).
+Proof.
+ unfold alter, map_alter. rewrite <-partial_alter_compose.
+ apply partial_alter_ext. by intros [?|].
+Qed.
+Lemma alter_commute {A} (f g : A → A) (m : M A) i j :
+ i ≠j → alter f i (alter g j m) = alter g j (alter f i m).
+Proof. apply partial_alter_commute. Qed.
+Lemma lookup_alter_Some {A} (f : A → A) m i j y :
+ alter f i m !! j = Some y ↔
+ (i = j ∧ ∃ x, m !! j = Some x ∧ y = f x) ∨ (i ≠j ∧ m !! j = Some y).
+Proof.
+ destruct (decide (i = j)) as [->|?].
+ * rewrite lookup_alter. naive_solver (simplify_option_equality; eauto).
+ * rewrite lookup_alter_ne by done. naive_solver.
+Qed.
+Lemma lookup_alter_None {A} (f : A → A) m i j :
+ alter f i m !! j = None ↔ m !! j = None.
+Proof.
+ by destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_alter, ?fmap_None, ?lookup_alter_ne.
+Qed.
+Lemma alter_id {A} (f : A → A) m i :
+ (∀ x, m !! i = Some x → f x = x) → alter f i m = m.
+Proof.
+ intros Hi; apply map_eq; intros j; destruct (decide (i = j)) as [->|?].
+ { rewrite lookup_alter; destruct (m !! j); f_equal'; auto. }
+ by rewrite lookup_alter_ne by done.
+Qed.
+
+(** ** Properties of the [delete] operation *)
+Lemma lookup_delete {A} (m : M A) i : delete i m !! i = None.
+Proof. apply lookup_partial_alter. Qed.
+Lemma lookup_delete_ne {A} (m : M A) i j : i ≠j → delete i m !! j = m !! j.
+Proof. apply lookup_partial_alter_ne. Qed.
+Lemma lookup_delete_Some {A} (m : M A) i j y :
+ delete i m !! j = Some y ↔ i ≠j ∧ m !! j = Some y.
+Proof.
+ split.
+ * destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_delete, ?lookup_delete_ne; intuition congruence.
+ * intros [??]. by rewrite lookup_delete_ne.
+Qed.
+Lemma lookup_delete_is_Some {A} (m : M A) i j :
+ is_Some (delete i m !! j) ↔ i ≠j ∧ is_Some (m !! j).
+Proof. unfold is_Some; setoid_rewrite lookup_delete_Some; naive_solver. Qed.
+Lemma lookup_delete_None {A} (m : M A) i j :
+ delete i m !! j = None ↔ i = j ∨ m !! j = None.
+Proof.
+ destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_delete, ?lookup_delete_ne; tauto.
+Qed.
+Lemma delete_empty {A} i : delete i (∅ : M A) = ∅.
+Proof. rewrite <-(partial_alter_self ∅) at 2. by rewrite lookup_empty. Qed.
+Lemma delete_singleton {A} i (x : A) : delete i {[i ↦ x]} = ∅.
+Proof. setoid_rewrite <-partial_alter_compose. apply delete_empty. Qed.
+Lemma delete_commute {A} (m : M A) i j :
+ delete i (delete j m) = delete j (delete i m).
+Proof. destruct (decide (i = j)). by subst. by apply partial_alter_commute. Qed.
+Lemma delete_insert_ne {A} (m : M A) i j x :
+ i ≠j → delete i (<[j:=x]>m) = <[j:=x]>(delete i m).
+Proof. intro. by apply partial_alter_commute. Qed.
+Lemma delete_notin {A} (m : M A) i : m !! i = None → delete i m = m.
+Proof.
+ intros. apply map_eq. intros j. by destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_delete, ?lookup_delete_ne.
+Qed.
+Lemma delete_partial_alter {A} (m : M A) i f :
+ m !! i = None → delete i (partial_alter f i m) = m.
+Proof.
+ intros. unfold delete, map_delete. rewrite <-partial_alter_compose.
+ unfold compose. by apply partial_alter_self_alt.
+Qed.
+Lemma delete_insert {A} (m : M A) i x :
+ m !! i = None → delete i (<[i:=x]>m) = m.
+Proof. apply delete_partial_alter. Qed.
+Lemma insert_delete {A} (m : M A) i x :
+ m !! i = Some x → <[i:=x]>(delete i m) = m.
+Proof.
+ intros Hmi. unfold delete, map_delete, insert, map_insert.
+ rewrite <-partial_alter_compose. unfold compose. rewrite <-Hmi.
+ by apply partial_alter_self_alt.
+Qed.
+Lemma delete_subseteq {A} (m : M A) i : delete i m ⊆ m.
+Proof.
+ rewrite !map_subseteq_spec. intros j x. rewrite lookup_delete_Some. tauto.
+Qed.
+Lemma delete_subseteq_compat {A} (m1 m2 : M A) i :
+ m1 ⊆ m2 → delete i m1 ⊆ delete i m2.
+Proof.
+ rewrite !map_subseteq_spec. intros ? j x.
+ rewrite !lookup_delete_Some. intuition eauto.
+Qed.
+Lemma delete_subset_alt {A} (m : M A) i x : m !! i = Some x → delete i m ⊂ m.
+Proof.
+ split; [apply delete_subseteq|].
+ rewrite !map_subseteq_spec. intros Hi. apply (None_ne_Some x).
+ by rewrite <-(lookup_delete m i), (Hi i x).
+Qed.
+Lemma delete_subset {A} (m : M A) i : is_Some (m !! i) → delete i m ⊂ m.
+Proof. inversion 1. eauto using delete_subset_alt. Qed.
+
+(** ** Properties of the [insert] operation *)
+Lemma lookup_insert {A} (m : M A) i x : <[i:=x]>m !! i = Some x.
+Proof. unfold insert. apply lookup_partial_alter. Qed.
+Lemma lookup_insert_rev {A} (m : M A) i x y : <[i:=x]>m !! i = Some y → x = y.
+Proof. rewrite lookup_insert. congruence. Qed.
+Lemma lookup_insert_ne {A} (m : M A) i j x : i ≠j → <[i:=x]>m !! j = m !! j.
+Proof. unfold insert. apply lookup_partial_alter_ne. Qed.
+Lemma insert_commute {A} (m : M A) i j x y :
+ i ≠j → <[i:=x]>(<[j:=y]>m) = <[j:=y]>(<[i:=x]>m).
+Proof. apply partial_alter_commute. Qed.
+Lemma lookup_insert_Some {A} (m : M A) i j x y :
+ <[i:=x]>m !! j = Some y ↔ (i = j ∧ x = y) ∨ (i ≠j ∧ m !! j = Some y).
+Proof.
+ split.
+ * destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_insert, ?lookup_insert_ne; intuition congruence.
+ * intros [[-> ->]|[??]]; [apply lookup_insert|]. by rewrite lookup_insert_ne.
+Qed.
+Lemma lookup_insert_is_Some {A} (m : M A) i j x :
+ is_Some (<[i:=x]>m !! j) ↔ i = j ∨ i ≠j ∧ is_Some (m !! j).
+Proof. unfold is_Some; setoid_rewrite lookup_insert_Some; naive_solver. Qed.
+Lemma lookup_insert_None {A} (m : M A) i j x :
+ <[i:=x]>m !! j = None ↔ m !! j = None ∧ i ≠j.
+Proof.
+ split; [|by intros [??]; rewrite lookup_insert_ne].
+ destruct (decide (i = j)) as [->|];
+ rewrite ?lookup_insert, ?lookup_insert_ne; intuition congruence.
+Qed.
+Lemma insert_id {A} (m : M A) i x : m !! i = Some x → <[i:=x]>m = m.
+Proof.
+ intros; apply map_eq; intros j; destruct (decide (i = j)) as [->|];
+ by rewrite ?lookup_insert, ?lookup_insert_ne by done.
+Qed.
+Lemma insert_included {A} R `{!Reflexive R} (m : M A) i x :
+ (∀ y, m !! i = Some y → R y x) → map_included R m (<[i:=x]>m).
+Proof.
+ intros ? j; destruct (decide (i = j)) as [->|].
+ * rewrite lookup_insert. destruct (m !! j); simpl; eauto.
+ * rewrite lookup_insert_ne by done. by destruct (m !! j); simpl.
+Qed.
+Lemma insert_subseteq {A} (m : M A) i x : m !! i = None → m ⊆ <[i:=x]>m.
+Proof. apply partial_alter_subseteq. Qed.
+Lemma insert_subset {A} (m : M A) i x : m !! i = None → m ⊂ <[i:=x]>m.
+Proof. intro. apply partial_alter_subset; eauto. Qed.
+Lemma insert_subseteq_r {A} (m1 m2 : M A) i x :
+ m1 !! i = None → m1 ⊆ m2 → m1 ⊆ <[i:=x]>m2.
+Proof.
+ rewrite !map_subseteq_spec. intros ?? j ?.
+ destruct (decide (j = i)) as [->|?]; [congruence|].
+ rewrite lookup_insert_ne; auto.
+Qed.
+Lemma insert_delete_subseteq {A} (m1 m2 : M A) i x :
+ m1 !! i = None → <[i:=x]> m1 ⊆ m2 → m1 ⊆ delete i m2.
+Proof.
+ rewrite !map_subseteq_spec. intros Hi Hix j y Hj.
+ destruct (decide (i = j)) as [->|]; [congruence|].
+ rewrite lookup_delete_ne by done.
+ apply Hix; by rewrite lookup_insert_ne by done.
+Qed.
+Lemma delete_insert_subseteq {A} (m1 m2 : M A) i x :
+ m1 !! i = Some x → delete i m1 ⊆ m2 → m1 ⊆ <[i:=x]> m2.
+Proof.
+ rewrite !map_subseteq_spec.
+ intros Hix Hi j y Hj. destruct (decide (i = j)) as [->|?].
+ * rewrite lookup_insert. congruence.
+ * rewrite lookup_insert_ne by done. apply Hi. by rewrite lookup_delete_ne.
+Qed.
+Lemma insert_delete_subset {A} (m1 m2 : M A) i x :
+ m1 !! i = None → <[i:=x]> m1 ⊂ m2 → m1 ⊂ delete i m2.
+Proof.
+ intros ? [Hm12 Hm21]; split; [eauto using insert_delete_subseteq|].
+ contradict Hm21. apply delete_insert_subseteq; auto.
+ eapply lookup_weaken, Hm12. by rewrite lookup_insert.
+Qed.
+Lemma insert_subset_inv {A} (m1 m2 : M A) i x :
+ m1 !! i = None → <[i:=x]> m1 ⊂ m2 →
+ ∃ m2', m2 = <[i:=x]>m2' ∧ m1 ⊂ m2' ∧ m2' !! i = None.
+Proof.
+ intros Hi Hm1m2. exists (delete i m2). split_ands.
+ * rewrite insert_delete. done. eapply lookup_weaken, strict_include; eauto.
+ by rewrite lookup_insert.
+ * eauto using insert_delete_subset.
+ * by rewrite lookup_delete.
+Qed.
+Lemma fmap_insert {A B} (f : A → B) (m : M A) i x :
+ f <$> <[i:=x]>m = <[i:=f x]>(f <$> m).
+Proof.
+ apply map_eq; intros i'; destruct (decide (i' = i)) as [->|].
+ * by rewrite lookup_fmap, !lookup_insert.
+ * by rewrite lookup_fmap, !lookup_insert_ne, lookup_fmap by done.
+Qed.
+Lemma insert_empty {A} i (x : A) : <[i:=x]>∅ = {[i ↦ x]}.
+Proof. done. Qed.
+
+(** ** Properties of the singleton maps *)
+Lemma lookup_singleton_Some {A} i j (x y : A) :
+ {[i ↦ x]} !! j = Some y ↔ i = j ∧ x = y.
+Proof.
+ rewrite <-insert_empty,lookup_insert_Some, lookup_empty; intuition congruence.
+Qed.
+Lemma lookup_singleton_None {A} i j (x : A) : {[i ↦ x]} !! j = None ↔ i ≠j.
+Proof. rewrite <-insert_empty,lookup_insert_None, lookup_empty; tauto. Qed.
+Lemma lookup_singleton {A} i (x : A) : {[i ↦ x]} !! i = Some x.
+Proof. by rewrite lookup_singleton_Some. Qed.
+Lemma lookup_singleton_ne {A} i j (x : A) : i ≠j → {[i ↦ x]} !! j = None.
+Proof. by rewrite lookup_singleton_None. Qed.
+Lemma map_non_empty_singleton {A} i (x : A) : {[i ↦ x]} ≠∅.
+Proof.
+ intros Hix. apply (f_equal (!! i)) in Hix.
+ by rewrite lookup_empty, lookup_singleton in Hix.
+Qed.
+Lemma insert_singleton {A} i (x y : A) : <[i:=y]>{[i ↦ x]} = {[i ↦ y]}.
+Proof.
+ unfold singletonM, map_singleton, insert, map_insert.
+ by rewrite <-partial_alter_compose.
+Qed.
+Lemma alter_singleton {A} (f : A → A) i x : alter f i {[i ↦ x]} = {[i ↦ f x]}.
+Proof.
+ intros. apply map_eq. intros i'. destruct (decide (i = i')) as [->|?].
+ * by rewrite lookup_alter, !lookup_singleton.
+ * by rewrite lookup_alter_ne, !lookup_singleton_ne.
+Qed.
+Lemma alter_singleton_ne {A} (f : A → A) i j x :
+ i ≠j → alter f i {[j ↦ x]} = {[j ↦ x]}.
+Proof.
+ intros. apply map_eq; intros i'. by destruct (decide (i = i')) as [->|?];
+ rewrite ?lookup_alter, ?lookup_singleton_ne, ?lookup_alter_ne by done.
+Qed.
+Lemma map_fmap_singleton {A B} (f : A → B) i x : f <$> {[i ↦ x]} = {[i ↦ f x]}.
+Proof.
+ by unfold singletonM, map_singleton; rewrite fmap_insert, map_fmap_empty.
+Qed.
+
+(** ** Properties of the map operations *)
+Lemma fmap_empty {A B} (f : A → B) : f <$> ∅ = ∅.
+Proof. apply map_empty; intros i. by rewrite lookup_fmap, lookup_empty. Qed.
+Lemma omap_empty {A B} (f : A → option B) : omap f ∅ = ∅.
+Proof. apply map_empty; intros i. by rewrite lookup_omap, lookup_empty. Qed.
+Lemma omap_singleton {A B} (f : A → option B) i x y :
+ f x = Some y → omap f {[ i ↦ x ]} = {[ i ↦ y ]}.
+Proof.
+ intros; apply map_eq; intros j; destruct (decide (i = j)) as [->|].
+ * by rewrite lookup_omap, !lookup_singleton.
+ * by rewrite lookup_omap, !lookup_singleton_ne.
+Qed.
+Lemma map_fmap_id {A} (m : M A) : id <$> m = m.
+Proof. apply map_eq; intros i; by rewrite lookup_fmap, option_fmap_id. Qed.
+Lemma map_fmap_compose {A B C} (f : A → B) (g : B → C) (m : M A) :
+ g ∘ f <$> m = g <$> f <$> m.
+Proof. apply map_eq; intros i; by rewrite !lookup_fmap,option_fmap_compose. Qed.
+Lemma map_fmap_setoid_ext `{Equiv A, Equiv B} (f1 f2 : A → B) m :
+ (∀ i x, m !! i = Some x → f1 x ≡ f2 x) → f1 <$> m ≡ f2 <$> m.
+Proof.
+ intros Hi i; rewrite !lookup_fmap.
+ destruct (m !! i) eqn:?; constructor; eauto.
+Qed.
+Lemma map_fmap_ext {A B} (f1 f2 : A → B) m :
+ (∀ i x, m !! i = Some x → f1 x = f2 x) → f1 <$> m = f2 <$> m.
+Proof.
+ intros Hi; apply map_eq; intros i; rewrite !lookup_fmap.
+ by destruct (m !! i) eqn:?; simpl; erewrite ?Hi by eauto.
+Qed.
+
+(** ** Properties of conversion to lists *)
+Lemma map_to_list_unique {A} (m : M A) i x y :
+ (i,x) ∈ map_to_list m → (i,y) ∈ map_to_list m → x = y.
+Proof. rewrite !elem_of_map_to_list. congruence. Qed.
+Lemma NoDup_fst_map_to_list {A} (m : M A) : NoDup ((map_to_list m).*1).
+Proof. eauto using NoDup_fmap_fst, map_to_list_unique, NoDup_map_to_list. Qed.
+Lemma elem_of_map_of_list_1_help {A} (l : list (K * A)) i x :
+ (i,x) ∈ l → (∀ y, (i,y) ∈ l → y = x) → map_of_list l !! i = Some x.
+Proof.
+ induction l as [|[j y] l IH]; csimpl; [by rewrite elem_of_nil|].
+ setoid_rewrite elem_of_cons.
+ intros [?|?] Hdup; simplify_equality; [by rewrite lookup_insert|].
+ destruct (decide (i = j)) as [->|].
+ * rewrite lookup_insert; f_equal; eauto.
+ * rewrite lookup_insert_ne by done; eauto.
+Qed.
+Lemma elem_of_map_of_list_1 {A} (l : list (K * A)) i x :
+ NoDup (l.*1) → (i,x) ∈ l → map_of_list l !! i = Some x.
+Proof.
+ intros ? Hx; apply elem_of_map_of_list_1_help; eauto using NoDup_fmap_fst.
+ intros y; revert Hx. rewrite !elem_of_list_lookup; intros [i' Hi'] [j' Hj'].
+ cut (i' = j'); [naive_solver|]. apply NoDup_lookup with (l.*1) i;
+ by rewrite ?list_lookup_fmap, ?Hi', ?Hj'.
+Qed.
+Lemma elem_of_map_of_list_2 {A} (l : list (K * A)) i x :
+ map_of_list l !! i = Some x → (i,x) ∈ l.
+Proof.
+ induction l as [|[j y] l IH]; simpl; [by rewrite lookup_empty|].
+ rewrite elem_of_cons. destruct (decide (i = j)) as [->|];
+ rewrite ?lookup_insert, ?lookup_insert_ne; intuition congruence.
+Qed.
+Lemma elem_of_map_of_list {A} (l : list (K * A)) i x :
+ NoDup (l.*1) → (i,x) ∈ l ↔ map_of_list l !! i = Some x.
+Proof. split; auto using elem_of_map_of_list_1, elem_of_map_of_list_2. Qed.
+Lemma not_elem_of_map_of_list_1 {A} (l : list (K * A)) i :
+ i ∉ l.*1 → map_of_list l !! i = None.
+Proof.
+ rewrite elem_of_list_fmap, eq_None_not_Some. intros Hi [x ?]; destruct Hi.
+ exists (i,x); simpl; auto using elem_of_map_of_list_2.
+Qed.
+Lemma not_elem_of_map_of_list_2 {A} (l : list (K * A)) i :
+ map_of_list l !! i = None → i ∉ l.*1.
+Proof.
+ induction l as [|[j y] l IH]; csimpl; [rewrite elem_of_nil; tauto|].
+ rewrite elem_of_cons. destruct (decide (i = j)); simplify_equality.
+ * by rewrite lookup_insert.
+ * by rewrite lookup_insert_ne; intuition.
+Qed.
+Lemma not_elem_of_map_of_list {A} (l : list (K * A)) i :
+ i ∉ l.*1 ↔ map_of_list l !! i = None.
+Proof. red; auto using not_elem_of_map_of_list_1,not_elem_of_map_of_list_2. Qed.
+Lemma map_of_list_proper {A} (l1 l2 : list (K * A)) :
+ NoDup (l1.*1) → l1 ≡ₚ l2 → map_of_list l1 = map_of_list l2.
+Proof.
+ intros ? Hperm. apply map_eq. intros i. apply option_eq. intros x.
+ by rewrite <-!elem_of_map_of_list; rewrite <-?Hperm.
+Qed.
+Lemma map_of_list_inj {A} (l1 l2 : list (K * A)) :
+ NoDup (l1.*1) → NoDup (l2.*1) → map_of_list l1 = map_of_list l2 → l1 ≡ₚ l2.
+Proof.
+ intros ?? Hl1l2. apply NoDup_Permutation; auto using (NoDup_fmap_1 fst).
+ intros [i x]. by rewrite !elem_of_map_of_list, Hl1l2.
+Qed.
+Lemma map_of_to_list {A} (m : M A) : map_of_list (map_to_list m) = m.
+Proof.
+ apply map_eq. intros i. apply option_eq. intros x.
+ by rewrite <-elem_of_map_of_list, elem_of_map_to_list
+ by auto using NoDup_fst_map_to_list.
+Qed.
+Lemma map_to_of_list {A} (l : list (K * A)) :
+ NoDup (l.*1) → map_to_list (map_of_list l) ≡ₚ l.
+Proof. auto using map_of_list_inj, NoDup_fst_map_to_list, map_of_to_list. Qed.
+Lemma map_to_list_inj {A} (m1 m2 : M A) :
+ map_to_list m1 ≡ₚ map_to_list m2 → m1 = m2.
+Proof.
+ intros. rewrite <-(map_of_to_list m1), <-(map_of_to_list m2).
+ auto using map_of_list_proper, NoDup_fst_map_to_list.
+Qed.
+Lemma map_to_of_list_flip {A} (m1 : M A) l2 :
+ map_to_list m1 ≡ₚ l2 → m1 = map_of_list l2.
+Proof.
+ intros. rewrite <-(map_of_to_list m1).
+ auto using map_of_list_proper, NoDup_fst_map_to_list.
+Qed.
+Lemma map_to_list_empty {A} : map_to_list ∅ = @nil (K * A).
+Proof.
+ apply elem_of_nil_inv. intros [i x].
+ rewrite elem_of_map_to_list. apply lookup_empty_Some.
+Qed.
+Lemma map_to_list_insert {A} (m : M A) i x :
+ m !! i = None → map_to_list (<[i:=x]>m) ≡ₚ (i,x) :: map_to_list m.
+Proof.
+ intros. apply map_of_list_inj; csimpl.
+ * apply NoDup_fst_map_to_list.
+ * constructor; auto using NoDup_fst_map_to_list.
+ rewrite elem_of_list_fmap. intros [[??] [? Hlookup]]; subst; simpl in *.
+ rewrite elem_of_map_to_list in Hlookup. congruence.
+ * by rewrite !map_of_to_list.
+Qed.
+Lemma map_of_list_nil {A} : map_of_list (@nil (K * A)) = ∅.
+Proof. done. Qed.
+Lemma map_of_list_cons {A} (l : list (K * A)) i x :
+ map_of_list ((i, x) :: l) = <[i:=x]>(map_of_list l).
+Proof. done. Qed.
+Lemma map_to_list_empty_inv_alt {A} (m : M A) : map_to_list m ≡ₚ [] → m = ∅.
+Proof. rewrite <-map_to_list_empty. apply map_to_list_inj. Qed.
+Lemma map_to_list_empty_inv {A} (m : M A) : map_to_list m = [] → m = ∅.
+Proof. intros Hm. apply map_to_list_empty_inv_alt. by rewrite Hm. Qed.
+Lemma map_to_list_insert_inv {A} (m : M A) l i x :
+ map_to_list m ≡ₚ (i,x) :: l → m = <[i:=x]>(map_of_list l).
+Proof.
+ intros Hperm. apply map_to_list_inj.
+ assert (i ∉ l.*1 ∧ NoDup (l.*1)) as [].
+ { rewrite <-NoDup_cons. change (NoDup (((i,x)::l).*1)). rewrite <-Hperm.
+ auto using NoDup_fst_map_to_list. }
+ rewrite Hperm, map_to_list_insert, map_to_of_list;
+ auto using not_elem_of_map_of_list_1.
+Qed.
+Lemma map_choose {A} (m : M A) : m ≠∅ → ∃ i x, m !! i = Some x.
+Proof.
+ intros Hemp. destruct (map_to_list m) as [|[i x] l] eqn:Hm.
+ { destruct Hemp; eauto using map_to_list_empty_inv. }
+ exists i, x. rewrite <-elem_of_map_to_list, Hm. by left.
+Qed.
+
+(** Properties of the imap function *)
+Lemma lookup_imap {A B} (f : K → A → option B) m i :
+ map_imap f m !! i = m !! i ≫= f i.
+Proof.
+ unfold map_imap; destruct (m !! i ≫= f i) as [y|] eqn:Hi; simpl.
+ * destruct (m !! i) as [x|] eqn:?; simplify_equality'.
+ apply elem_of_map_of_list_1_help.
+ { apply elem_of_list_omap; exists (i,x); split;
+ [by apply elem_of_map_to_list|by simplify_option_equality]. }
+ intros y'; rewrite elem_of_list_omap; intros ([i' x']&Hi'&?).
+ by rewrite elem_of_map_to_list in Hi'; simplify_option_equality.
+ * apply not_elem_of_map_of_list; rewrite elem_of_list_fmap.
+ intros ([i' x]&->&Hi'); simplify_equality'.
+ rewrite elem_of_list_omap in Hi'; destruct Hi' as ([j y]&Hj&?).
+ rewrite elem_of_map_to_list in Hj; simplify_option_equality.
+Qed.
+
+(** ** Properties of conversion from collections *)
+Lemma lookup_map_of_collection {A} `{FinCollection K C}
+ (f : K → option A) X i x :
+ map_of_collection f X !! i = Some x ↔ i ∈ X ∧ f i = Some x.
+Proof.
+ assert (NoDup (fst <$> omap (λ i, (i,) <$> f i) (elements X))).
+ { induction (NoDup_elements X) as [|i' l]; csimpl; [constructor|].
+ destruct (f i') as [x'|]; csimpl; auto; constructor; auto.
+ rewrite elem_of_list_fmap. setoid_rewrite elem_of_list_omap.
+ by intros (?&?&?&?&?); simplify_option_equality. }
+ unfold map_of_collection; rewrite <-elem_of_map_of_list by done.
+ rewrite elem_of_list_omap. setoid_rewrite elem_of_elements; split.
+ * intros (?&?&?); simplify_option_equality; eauto.
+ * intros [??]; exists i; simplify_option_equality; eauto.
+Qed.
+
+(** ** Induction principles *)
+Lemma map_ind {A} (P : M A → Prop) :
+ P ∅ → (∀ i x m, m !! i = None → P m → P (<[i:=x]>m)) → ∀ m, P m.
+Proof.
+ intros ? Hins. cut (∀ l, NoDup (l.*1) → ∀ m, map_to_list m ≡ₚ l → P m).
+ { intros help m.
+ apply (help (map_to_list m)); auto using NoDup_fst_map_to_list. }
+ induction l as [|[i x] l IH]; intros Hnodup m Hml.
+ { apply map_to_list_empty_inv_alt in Hml. by subst. }
+ inversion_clear Hnodup.
+ apply map_to_list_insert_inv in Hml; subst m. apply Hins.
+ * by apply not_elem_of_map_of_list_1.
+ * apply IH; auto using map_to_of_list.
+Qed.
+Lemma map_to_list_length {A} (m1 m2 : M A) :
+ m1 ⊂ m2 → length (map_to_list m1) < length (map_to_list m2).
+Proof.
+ revert m2. induction m1 as [|i x m ? IH] using map_ind.
+ { intros m2 Hm2. rewrite map_to_list_empty. simpl.
+ apply neq_0_lt. intros Hlen. symmetry in Hlen.
+ apply nil_length_inv, map_to_list_empty_inv in Hlen.
+ rewrite Hlen in Hm2. destruct (irreflexivity (⊂) ∅ Hm2). }
+ intros m2 Hm2.
+ destruct (insert_subset_inv m m2 i x) as (m2'&?&?&?); auto; subst.
+ rewrite !map_to_list_insert; simpl; auto with arith.
+Qed.
+Lemma map_wf {A} : wf (strict (@subseteq (M A) _)).
+Proof.
+ apply (wf_projected (<) (length ∘ map_to_list)).
+ * by apply map_to_list_length.
+ * by apply lt_wf.
+Qed.
+
+(** ** Properties of the [map_Forall] predicate *)
+Section map_Forall.
+Context {A} (P : K → A → Prop).
+
+Lemma map_Forall_to_list m : map_Forall P m ↔ Forall (curry P) (map_to_list m).
+Proof.
+ rewrite Forall_forall. split.
+ * intros Hforall [i x]. rewrite elem_of_map_to_list. by apply (Hforall i x).
+ * intros Hforall i x. rewrite <-elem_of_map_to_list. by apply (Hforall (i,x)).
+Qed.
+Lemma map_Forall_empty : map_Forall P ∅.
+Proof. intros i x. by rewrite lookup_empty. Qed.
+Lemma map_Forall_impl (Q : K → A → Prop) m :
+ map_Forall P m → (∀ i x, P i x → Q i x) → map_Forall Q m.
+Proof. unfold map_Forall; naive_solver. Qed.
+Lemma map_Forall_insert_11 m i x : map_Forall P (<[i:=x]>m) → P i x.
+Proof. intros Hm. by apply Hm; rewrite lookup_insert. Qed.
+Lemma map_Forall_insert_12 m i x :
+ m !! i = None → map_Forall P (<[i:=x]>m) → map_Forall P m.
+Proof.
+ intros ? Hm j y ?; apply Hm. by rewrite lookup_insert_ne by congruence.
+Qed.
+Lemma map_Forall_insert_2 m i x :
+ P i x → map_Forall P m → map_Forall P (<[i:=x]>m).
+Proof. intros ?? j y; rewrite lookup_insert_Some; naive_solver. Qed.
+Lemma map_Forall_insert m i x :
+ m !! i = None → map_Forall P (<[i:=x]>m) ↔ P i x ∧ map_Forall P m.
+Proof.
+ naive_solver eauto using map_Forall_insert_11,
+ map_Forall_insert_12, map_Forall_insert_2.
+Qed.
+Lemma map_Forall_ind (Q : M A → Prop) :
+ Q ∅ →
+ (∀ m i x, m !! i = None → P i x → map_Forall P m → Q m → Q (<[i:=x]>m)) →
+ ∀ m, map_Forall P m → Q m.
+Proof.
+ intros Hnil Hinsert m. induction m using map_ind; auto.
+ rewrite map_Forall_insert by done; intros [??]; eauto.
+Qed.
+
+Context `{∀ i x, Decision (P i x)}.
+Global Instance map_Forall_dec m : Decision (map_Forall P m).
+Proof.
+ refine (cast_if (decide (Forall (curry P) (map_to_list m))));
+ by rewrite map_Forall_to_list.
+Defined.
+Lemma map_not_Forall (m : M A) :
+ ¬map_Forall P m ↔ ∃ i x, m !! i = Some x ∧ ¬P i x.
+Proof.
+ split; [|intros (i&x&?&?) Hm; specialize (Hm i x); tauto].
+ rewrite map_Forall_to_list. intros Hm.
+ apply (not_Forall_Exists _), Exists_exists in Hm.
+ destruct Hm as ([i x]&?&?). exists i, x. by rewrite <-elem_of_map_to_list.
+Qed.
+End map_Forall.
+
+(** ** Properties of the [merge] operation *)
+Section merge.
+Context {A} (f : option A → option A → option A).
+Context `{!PropHolds (f None None = None)}.
+Global Instance: LeftId (=) None f → LeftId (=) ∅ (merge f).
+Proof.
+ intros ??. apply map_eq. intros.
+ by rewrite !(lookup_merge f), lookup_empty, (left_id_L None f).
+Qed.
+Global Instance: RightId (=) None f → RightId (=) ∅ (merge f).
+Proof.
+ intros ??. apply map_eq. intros.
+ by rewrite !(lookup_merge f), lookup_empty, (right_id_L None f).
+Qed.
+Lemma merge_commutative m1 m2 :
+ (∀ i, f (m1 !! i) (m2 !! i) = f (m2 !! i) (m1 !! i)) →
+ merge f m1 m2 = merge f m2 m1.
+Proof. intros. apply map_eq. intros. by rewrite !(lookup_merge f). Qed.
+Global Instance: Commutative (=) f → Commutative (=) (merge f).
+Proof.
+ intros ???. apply merge_commutative. intros. by apply (commutative f).
+Qed.
+Lemma merge_associative m1 m2 m3 :
+ (∀ i, f (m1 !! i) (f (m2 !! i) (m3 !! i)) =
+ f (f (m1 !! i) (m2 !! i)) (m3 !! i)) →
+ merge f m1 (merge f m2 m3) = merge f (merge f m1 m2) m3.
+Proof. intros. apply map_eq. intros. by rewrite !(lookup_merge f). Qed.
+Global Instance: Associative (=) f → Associative (=) (merge f).
+Proof.
+ intros ????. apply merge_associative. intros. by apply (associative_L f).
+Qed.
+Lemma merge_idempotent m1 :
+ (∀ i, f (m1 !! i) (m1 !! i) = m1 !! i) → merge f m1 m1 = m1.
+Proof. intros. apply map_eq. intros. by rewrite !(lookup_merge f). Qed.
+Global Instance: Idempotent (=) f → Idempotent (=) (merge f).
+Proof. intros ??. apply merge_idempotent. intros. by apply (idempotent f). Qed.
+End merge.
+
+Section more_merge.
+Context {A B C} (f : option A → option B → option C).
+Context `{!PropHolds (f None None = None)}.
+Lemma merge_Some m1 m2 m :
+ (∀ i, m !! i = f (m1 !! i) (m2 !! i)) ↔ merge f m1 m2 = m.
+Proof.
+ split; [|intros <-; apply (lookup_merge _) ].
+ intros Hlookup. apply map_eq; intros. rewrite Hlookup. apply (lookup_merge _).
+Qed.
+Lemma merge_empty : merge f ∅ ∅ = ∅.
+Proof. apply map_eq. intros. by rewrite !(lookup_merge f), !lookup_empty. Qed.
+Lemma partial_alter_merge g g1 g2 m1 m2 i :
+ g (f (m1 !! i) (m2 !! i)) = f (g1 (m1 !! i)) (g2 (m2 !! i)) →
+ partial_alter g i (merge f m1 m2) =
+ merge f (partial_alter g1 i m1) (partial_alter g2 i m2).
+Proof.
+ intro. apply map_eq. intros j. destruct (decide (i = j)); subst.
+ * by rewrite (lookup_merge _), !lookup_partial_alter, !(lookup_merge _).
+ * by rewrite (lookup_merge _), !lookup_partial_alter_ne, (lookup_merge _).
+Qed.
+Lemma partial_alter_merge_l g g1 m1 m2 i :
+ g (f (m1 !! i) (m2 !! i)) = f (g1 (m1 !! i)) (m2 !! i) →
+ partial_alter g i (merge f m1 m2) = merge f (partial_alter g1 i m1) m2.
+Proof.
+ intro. apply map_eq. intros j. destruct (decide (i = j)); subst.
+ * by rewrite (lookup_merge _), !lookup_partial_alter, !(lookup_merge _).
+ * by rewrite (lookup_merge _), !lookup_partial_alter_ne, (lookup_merge _).
+Qed.
+Lemma partial_alter_merge_r g g2 m1 m2 i :
+ g (f (m1 !! i) (m2 !! i)) = f (m1 !! i) (g2 (m2 !! i)) →
+ partial_alter g i (merge f m1 m2) = merge f m1 (partial_alter g2 i m2).
+Proof.
+ intro. apply map_eq. intros j. destruct (decide (i = j)); subst.
+ * by rewrite (lookup_merge _), !lookup_partial_alter, !(lookup_merge _).
+ * by rewrite (lookup_merge _), !lookup_partial_alter_ne, (lookup_merge _).
+Qed.
+Lemma insert_merge m1 m2 i x y z :
+ f (Some y) (Some z) = Some x →
+ <[i:=x]>(merge f m1 m2) = merge f (<[i:=y]>m1) (<[i:=z]>m2).
+Proof. by intros; apply partial_alter_merge. Qed.
+Lemma merge_singleton i x y z :
+ f (Some y) (Some z) = Some x → merge f {[i ↦ y]} {[i ↦ z]} = {[i ↦ x]}.
+Proof.
+ intros. by erewrite <-!insert_empty, <-insert_merge, merge_empty by eauto.
+Qed.
+Lemma insert_merge_l m1 m2 i x y :
+ f (Some y) (m2 !! i) = Some x →
+ <[i:=x]>(merge f m1 m2) = merge f (<[i:=y]>m1) m2.
+Proof. by intros; apply partial_alter_merge_l. Qed.
+Lemma insert_merge_r m1 m2 i x z :
+ f (m1 !! i) (Some z) = Some x →
+ <[i:=x]>(merge f m1 m2) = merge f m1 (<[i:=z]>m2).
+Proof. by intros; apply partial_alter_merge_r. Qed.
+End more_merge.
+
+(** ** Properties on the [map_relation] relation *)
+Section Forall2.
+Context {A B} (R : A → B → Prop) (P : A → Prop) (Q : B → Prop).
+Context `{∀ x y, Decision (R x y), ∀ x, Decision (P x), ∀ y, Decision (Q y)}.
+
+Let f (mx : option A) (my : option B) : option bool :=
+ match mx, my with
+ | Some x, Some y => Some (bool_decide (R x y))
+ | Some x, None => Some (bool_decide (P x))
+ | None, Some y => Some (bool_decide (Q y))
+ | None, None => None
+ end.
+Lemma map_relation_alt (m1 : M A) (m2 : M B) :
+ map_relation R P Q m1 m2 ↔ map_Forall (λ _, Is_true) (merge f m1 m2).
+Proof.
+ split.
+ * intros Hm i P'; rewrite lookup_merge by done; intros.
+ specialize (Hm i). destruct (m1 !! i), (m2 !! i);
+ simplify_equality'; auto using bool_decide_pack.
+ * intros Hm i. specialize (Hm i). rewrite lookup_merge in Hm by done.
+ destruct (m1 !! i), (m2 !! i); simplify_equality'; auto;
+ by eapply bool_decide_unpack, Hm.
+Qed.
+Global Instance map_relation_dec `{∀ x y, Decision (R x y), ∀ x, Decision (P x),
+ ∀ y, Decision (Q y)} m1 m2 : Decision (map_relation R P Q m1 m2).
+Proof.
+ refine (cast_if (decide (map_Forall (λ _, Is_true) (merge f m1 m2))));
+ abstract by rewrite map_relation_alt.
+Defined.
+(** Due to the finiteness of finite maps, we can extract a witness if the
+relation does not hold. *)
+Lemma map_not_Forall2 (m1 : M A) (m2 : M B) :
+ ¬map_relation R P Q m1 m2 ↔ ∃ i,
+ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ ¬R x y)
+ ∨ (∃ x, m1 !! i = Some x ∧ m2 !! i = None ∧ ¬P x)
+ ∨ (∃ y, m1 !! i = None ∧ m2 !! i = Some y ∧ ¬Q y).
+Proof.
+ split.
+ * rewrite map_relation_alt, (map_not_Forall _). intros (i&?&Hm&?); exists i.
+ rewrite lookup_merge in Hm by done.
+ destruct (m1 !! i), (m2 !! i); naive_solver auto 2 using bool_decide_pack.
+ * unfold map_relation, option_relation.
+ by intros [i[(x&y&?&?&?)|[(x&?&?&?)|(y&?&?&?)]]] Hm;
+ specialize (Hm i); simplify_option_equality.
+Qed.
+End Forall2.
+
+(** ** Properties on the disjoint maps *)
+Lemma map_disjoint_spec {A} (m1 m2 : M A) :
+ m1 ⊥ₘ m2 ↔ ∀ i x y, m1 !! i = Some x → m2 !! i = Some y → False.
+Proof.
+ split; intros Hm i; specialize (Hm i);
+ destruct (m1 !! i), (m2 !! i); naive_solver.
+Qed.
+Lemma map_disjoint_alt {A} (m1 m2 : M A) :
+ m1 ⊥ₘ m2 ↔ ∀ i, m1 !! i = None ∨ m2 !! i = None.
+Proof.
+ split; intros Hm1m2 i; specialize (Hm1m2 i);
+ destruct (m1 !! i), (m2 !! i); naive_solver.
+Qed.
+Lemma map_not_disjoint {A} (m1 m2 : M A) :
+ ¬m1 ⊥ₘ m2 ↔ ∃ i x1 x2, m1 !! i = Some x1 ∧ m2 !! i = Some x2.
+Proof.
+ unfold disjoint, map_disjoint. rewrite map_not_Forall2 by solve_decision.
+ split; [|naive_solver].
+ intros [i[(x&y&?&?&?)|[(x&?&?&[])|(y&?&?&[])]]]; naive_solver.
+Qed.
+Global Instance: Symmetric (map_disjoint : relation (M A)).
+Proof. intros A m1 m2. rewrite !map_disjoint_spec. naive_solver. Qed.
+Lemma map_disjoint_empty_l {A} (m : M A) : ∅ ⊥ₘ m.
+Proof. rewrite !map_disjoint_spec. intros i x y. by rewrite lookup_empty. Qed.
+Lemma map_disjoint_empty_r {A} (m : M A) : m ⊥ₘ ∅.
+Proof. rewrite !map_disjoint_spec. intros i x y. by rewrite lookup_empty. Qed.
+Lemma map_disjoint_weaken {A} (m1 m1' m2 m2' : M A) :
+ m1' ⊥ₘ m2' → m1 ⊆ m1' → m2 ⊆ m2' → m1 ⊥ₘ m2.
+Proof. rewrite !map_subseteq_spec, !map_disjoint_spec. eauto. Qed.
+Lemma map_disjoint_weaken_l {A} (m1 m1' m2 : M A) :
+ m1' ⊥ₘ m2 → m1 ⊆ m1' → m1 ⊥ₘ m2.
+Proof. eauto using map_disjoint_weaken. Qed.
+Lemma map_disjoint_weaken_r {A} (m1 m2 m2' : M A) :
+ m1 ⊥ₘ m2' → m2 ⊆ m2' → m1 ⊥ₘ m2.
+Proof. eauto using map_disjoint_weaken. Qed.
+Lemma map_disjoint_Some_l {A} (m1 m2 : M A) i x:
+ m1 ⊥ₘ m2 → m1 !! i = Some x → m2 !! i = None.
+Proof. rewrite map_disjoint_spec, eq_None_not_Some. intros ?? [??]; eauto. Qed.
+Lemma map_disjoint_Some_r {A} (m1 m2 : M A) i x:
+ m1 ⊥ₘ m2 → m2 !! i = Some x → m1 !! i = None.
+Proof. rewrite (symmetry_iff map_disjoint). apply map_disjoint_Some_l. Qed.
+Lemma map_disjoint_singleton_l {A} (m: M A) i x : {[i↦x]} ⊥ₘ m ↔ m !! i = None.
+Proof.
+ split; [|rewrite !map_disjoint_spec].
+ * intro. apply (map_disjoint_Some_l {[i ↦ x]} _ _ x);
+ auto using lookup_singleton.
+ * intros ? j y1 y2. destruct (decide (i = j)) as [->|].
+ + rewrite lookup_singleton. intuition congruence.
+ + by rewrite lookup_singleton_ne.
+Qed.
+Lemma map_disjoint_singleton_r {A} (m : M A) i x :
+ m ⊥ₘ {[i ↦ x]} ↔ m !! i = None.
+Proof. by rewrite (symmetry_iff map_disjoint), map_disjoint_singleton_l. Qed.
+Lemma map_disjoint_singleton_l_2 {A} (m : M A) i x :
+ m !! i = None → {[i ↦ x]} ⊥ₘ m.
+Proof. by rewrite map_disjoint_singleton_l. Qed.
+Lemma map_disjoint_singleton_r_2 {A} (m : M A) i x :
+ m !! i = None → m ⊥ₘ {[i ↦ x]}.
+Proof. by rewrite map_disjoint_singleton_r. Qed.
+Lemma map_disjoint_delete_l {A} (m1 m2 : M A) i : m1 ⊥ₘ m2 → delete i m1 ⊥ₘ m2.
+Proof.
+ rewrite !map_disjoint_alt. intros Hdisjoint j. destruct (Hdisjoint j); auto.
+ rewrite lookup_delete_None. tauto.
+Qed.
+Lemma map_disjoint_delete_r {A} (m1 m2 : M A) i : m1 ⊥ₘ m2 → m1 ⊥ₘ delete i m2.
+Proof. symmetry. by apply map_disjoint_delete_l. Qed.
+
+(** ** Properties of the [union_with] operation *)
+Section union_with.
+Context {A} (f : A → A → option A).
+
+Lemma lookup_union_with m1 m2 i :
+ union_with f m1 m2 !! i = union_with f (m1 !! i) (m2 !! i).
+Proof. by rewrite <-(lookup_merge _). Qed.
+Lemma lookup_union_with_Some m1 m2 i z :
+ union_with f m1 m2 !! i = Some z ↔
+ (m1 !! i = Some z ∧ m2 !! i = None) ∨
+ (m1 !! i = None ∧ m2 !! i = Some z) ∨
+ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ f x y = Some z).
+Proof.
+ rewrite lookup_union_with.
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+Global Instance: LeftId (@eq (M A)) ∅ (union_with f).
+Proof. unfold union_with, map_union_with. apply _. Qed.
+Global Instance: RightId (@eq (M A)) ∅ (union_with f).
+Proof. unfold union_with, map_union_with. apply _. Qed.
+Lemma union_with_commutative m1 m2 :
+ (∀ i x y, m1 !! i = Some x → m2 !! i = Some y → f x y = f y x) →
+ union_with f m1 m2 = union_with f m2 m1.
+Proof.
+ intros. apply (merge_commutative _). intros i.
+ destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; simpl; eauto.
+Qed.
+Global Instance: Commutative (=) f → Commutative (@eq (M A)) (union_with f).
+Proof. intros ???. apply union_with_commutative. eauto. Qed.
+Lemma union_with_idempotent m :
+ (∀ i x, m !! i = Some x → f x x = Some x) → union_with f m m = m.
+Proof.
+ intros. apply (merge_idempotent _). intros i.
+ destruct (m !! i) eqn:?; simpl; eauto.
+Qed.
+Lemma alter_union_with (g : A → A) m1 m2 i :
+ (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f (g x) (g y)) →
+ alter g i (union_with f m1 m2) =
+ union_with f (alter g i m1) (alter g i m2).
+Proof.
+ intros. apply (partial_alter_merge _).
+ destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; simpl; eauto.
+Qed.
+Lemma alter_union_with_l (g : A → A) m1 m2 i :
+ (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f (g x) y) →
+ (∀ y, m1 !! i = None → m2 !! i = Some y → g y = y) →
+ alter g i (union_with f m1 m2) = union_with f (alter g i m1) m2.
+Proof.
+ intros. apply (partial_alter_merge_l _).
+ destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; f_equal'; auto.
+Qed.
+Lemma alter_union_with_r (g : A → A) m1 m2 i :
+ (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f x (g y)) →
+ (∀ x, m1 !! i = Some x → m2 !! i = None → g x = x) →
+ alter g i (union_with f m1 m2) = union_with f m1 (alter g i m2).
+Proof.
+ intros. apply (partial_alter_merge_r _).
+ destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; f_equal'; auto.
+Qed.
+Lemma delete_union_with m1 m2 i :
+ delete i (union_with f m1 m2) = union_with f (delete i m1) (delete i m2).
+Proof. by apply (partial_alter_merge _). Qed.
+Lemma foldr_delete_union_with (m1 m2 : M A) is :
+ foldr delete (union_with f m1 m2) is =
+ union_with f (foldr delete m1 is) (foldr delete m2 is).
+Proof. induction is; simpl. done. by rewrite IHis, delete_union_with. Qed.
+Lemma insert_union_with m1 m2 i x y z :
+ f x y = Some z →
+ <[i:=z]>(union_with f m1 m2) = union_with f (<[i:=x]>m1) (<[i:=y]>m2).
+Proof. by intros; apply (partial_alter_merge _). Qed.
+Lemma insert_union_with_l m1 m2 i x :
+ m2 !! i = None → <[i:=x]>(union_with f m1 m2) = union_with f (<[i:=x]>m1) m2.
+Proof.
+ intros Hm2. unfold union_with, map_union_with.
+ by erewrite (insert_merge_l _) by (by rewrite Hm2).
+Qed.
+Lemma insert_union_with_r m1 m2 i x :
+ m1 !! i = None → <[i:=x]>(union_with f m1 m2) = union_with f m1 (<[i:=x]>m2).
+Proof.
+ intros Hm1. unfold union_with, map_union_with.
+ by erewrite (insert_merge_r _) by (by rewrite Hm1).
+Qed.
+End union_with.
+
+(** ** Properties of the [union] operation *)
+Global Instance: LeftId (@eq (M A)) ∅ (∪) := _.
+Global Instance: RightId (@eq (M A)) ∅ (∪) := _.
+Global Instance: Associative (@eq (M A)) (∪).
+Proof.
+ intros A m1 m2 m3. unfold union, map_union, union_with, map_union_with.
+ apply (merge_associative _). intros i.
+ by destruct (m1 !! i), (m2 !! i), (m3 !! i).
+Qed.
+Global Instance: Idempotent (@eq (M A)) (∪).
+Proof. intros A ?. by apply union_with_idempotent. Qed.
+Lemma lookup_union_Some_raw {A} (m1 m2 : M A) i x :
+ (m1 ∪ m2) !! i = Some x ↔
+ m1 !! i = Some x ∨ (m1 !! i = None ∧ m2 !! i = Some x).
+Proof.
+ unfold union, map_union, union_with, map_union_with. rewrite (lookup_merge _).
+ destruct (m1 !! i), (m2 !! i); compute; intuition congruence.
+Qed.
+Lemma lookup_union_None {A} (m1 m2 : M A) i :
+ (m1 ∪ m2) !! i = None ↔ m1 !! i = None ∧ m2 !! i = None.
+Proof.
+ unfold union, map_union, union_with, map_union_with. rewrite (lookup_merge _).
+ destruct (m1 !! i), (m2 !! i); compute; intuition congruence.
+Qed.
+Lemma map_positive_l {A} (m1 m2 : M A) : m1 ∪ m2 = ∅ → m1 = ∅.
+Proof.
+ intros Hm. apply map_empty. intros i. apply (f_equal (!! i)) in Hm.
+ rewrite lookup_empty, lookup_union_None in Hm; tauto.
+Qed.
+Lemma map_positive_l_alt {A} (m1 m2 : M A) : m1 ≠∅ → m1 ∪ m2 ≠∅.
+Proof. eauto using map_positive_l. Qed.
+Lemma lookup_union_Some {A} (m1 m2 : M A) i x :
+ m1 ⊥ₘ m2 → (m1 ∪ m2) !! i = Some x ↔ m1 !! i = Some x ∨ m2 !! i = Some x.
+Proof.
+ intros Hdisjoint. rewrite lookup_union_Some_raw.
+ intuition eauto using map_disjoint_Some_r.
+Qed.
+Lemma lookup_union_Some_l {A} (m1 m2 : M A) i x :
+ m1 !! i = Some x → (m1 ∪ m2) !! i = Some x.
+Proof. intro. rewrite lookup_union_Some_raw; intuition. Qed.
+Lemma lookup_union_Some_r {A} (m1 m2 : M A) i x :
+ m1 ⊥ₘ m2 → m2 !! i = Some x → (m1 ∪ m2) !! i = Some x.
+Proof. intro. rewrite lookup_union_Some; intuition. Qed.
+Lemma map_union_commutative {A} (m1 m2 : M A) : m1 ⊥ₘ m2 → m1 ∪ m2 = m2 ∪ m1.
+Proof.
+ intros Hdisjoint. apply (merge_commutative (union_with (λ x _, Some x))).
+ intros i. specialize (Hdisjoint i).
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+Lemma map_subseteq_union {A} (m1 m2 : M A) : m1 ⊆ m2 → m1 ∪ m2 = m2.
+Proof.
+ rewrite map_subseteq_spec.
+ intros Hm1m2. apply map_eq. intros i. apply option_eq. intros x.
+ rewrite lookup_union_Some_raw. split; [by intuition |].
+ intros Hm2. specialize (Hm1m2 i). destruct (m1 !! i) as [y|]; [| by auto].
+ rewrite (Hm1m2 y eq_refl) in Hm2. intuition congruence.
+Qed.
+Lemma map_union_subseteq_l {A} (m1 m2 : M A) : m1 ⊆ m1 ∪ m2.
+Proof.
+ rewrite map_subseteq_spec. intros ? i x. rewrite lookup_union_Some_raw. tauto.
+Qed.
+Lemma map_union_subseteq_r {A} (m1 m2 : M A) : m1 ⊥ₘ m2 → m2 ⊆ m1 ∪ m2.
+Proof.
+ intros. rewrite map_union_commutative by done. by apply map_union_subseteq_l.
+Qed.
+Lemma map_union_subseteq_l_alt {A} (m1 m2 m3 : M A) : m1 ⊆ m2 → m1 ⊆ m2 ∪ m3.
+Proof. intros. transitivity m2; auto using map_union_subseteq_l. Qed.
+Lemma map_union_subseteq_r_alt {A} (m1 m2 m3 : M A) :
+ m2 ⊥ₘ m3 → m1 ⊆ m3 → m1 ⊆ m2 ∪ m3.
+Proof. intros. transitivity m3; auto using map_union_subseteq_r. Qed.
+Lemma map_union_preserving_l {A} (m1 m2 m3 : M A) : m1 ⊆ m2 → m3 ∪ m1 ⊆ m3 ∪ m2.
+Proof.
+ rewrite !map_subseteq_spec. intros ???.
+ rewrite !lookup_union_Some_raw. naive_solver.
+Qed.
+Lemma map_union_preserving_r {A} (m1 m2 m3 : M A) :
+ m2 ⊥ₘ m3 → m1 ⊆ m2 → m1 ∪ m3 ⊆ m2 ∪ m3.
+Proof.
+ intros. rewrite !(map_union_commutative _ m3)
+ by eauto using map_disjoint_weaken_l.
+ by apply map_union_preserving_l.
+Qed.
+Lemma map_union_reflecting_l {A} (m1 m2 m3 : M A) :
+ m3 ⊥ₘ m1 → m3 ⊥ₘ m2 → m3 ∪ m1 ⊆ m3 ∪ m2 → m1 ⊆ m2.
+Proof.
+ rewrite !map_subseteq_spec. intros Hm31 Hm32 Hm i x ?. specialize (Hm i x).
+ rewrite !lookup_union_Some in Hm by done. destruct Hm; auto.
+ by rewrite map_disjoint_spec in Hm31; destruct (Hm31 i x x).
+Qed.
+Lemma map_union_reflecting_r {A} (m1 m2 m3 : M A) :
+ m1 ⊥ₘ m3 → m2 ⊥ₘ m3 → m1 ∪ m3 ⊆ m2 ∪ m3 → m1 ⊆ m2.
+Proof.
+ intros ??. rewrite !(map_union_commutative _ m3) by done.
+ by apply map_union_reflecting_l.
+Qed.
+Lemma map_union_cancel_l {A} (m1 m2 m3 : M A) :
+ m1 ⊥ₘ m3 → m2 ⊥ₘ m3 → m3 ∪ m1 = m3 ∪ m2 → m1 = m2.
+Proof.
+ intros. apply (anti_symmetric (⊆));
+ apply map_union_reflecting_l with m3; auto using (reflexive_eq (R:=(⊆))).
+Qed.
+Lemma map_union_cancel_r {A} (m1 m2 m3 : M A) :
+ m1 ⊥ₘ m3 → m2 ⊥ₘ m3 → m1 ∪ m3 = m2 ∪ m3 → m1 = m2.
+Proof.
+ intros. apply (anti_symmetric (⊆));
+ apply map_union_reflecting_r with m3; auto using (reflexive_eq (R:=(⊆))).
+Qed.
+Lemma map_disjoint_union_l {A} (m1 m2 m3 : M A) :
+ m1 ∪ m2 ⊥ₘ m3 ↔ m1 ⊥ₘ m3 ∧ m2 ⊥ₘ m3.
+Proof.
+ rewrite !map_disjoint_alt. setoid_rewrite lookup_union_None. naive_solver.
+Qed.
+Lemma map_disjoint_union_r {A} (m1 m2 m3 : M A) :
+ m1 ⊥ₘ m2 ∪ m3 ↔ m1 ⊥ₘ m2 ∧ m1 ⊥ₘ m3.
+Proof.
+ rewrite !map_disjoint_alt. setoid_rewrite lookup_union_None. naive_solver.
+Qed.
+Lemma map_disjoint_union_l_2 {A} (m1 m2 m3 : M A) :
+ m1 ⊥ₘ m3 → m2 ⊥ₘ m3 → m1 ∪ m2 ⊥ₘ m3.
+Proof. by rewrite map_disjoint_union_l. Qed.
+Lemma map_disjoint_union_r_2 {A} (m1 m2 m3 : M A) :
+ m1 ⊥ₘ m2 → m1 ⊥ₘ m3 → m1 ⊥ₘ m2 ∪ m3.
+Proof. by rewrite map_disjoint_union_r. Qed.
+Lemma insert_union_singleton_l {A} (m : M A) i x : <[i:=x]>m = {[i ↦ x]} ∪ m.
+Proof.
+ apply map_eq. intros j. apply option_eq. intros y.
+ rewrite lookup_union_Some_raw.
+ destruct (decide (i = j)); subst.
+ * rewrite !lookup_singleton, lookup_insert. intuition congruence.
+ * rewrite !lookup_singleton_ne, lookup_insert_ne; intuition congruence.
+Qed.
+Lemma insert_union_singleton_r {A} (m : M A) i x :
+ m !! i = None → <[i:=x]>m = m ∪ {[i ↦ x]}.
+Proof.
+ intro. rewrite insert_union_singleton_l, map_union_commutative; [done |].
+ by apply map_disjoint_singleton_l.
+Qed.
+Lemma map_disjoint_insert_l {A} (m1 m2 : M A) i x :
+ <[i:=x]>m1 ⊥ₘ m2 ↔ m2 !! i = None ∧ m1 ⊥ₘ m2.
+Proof.
+ rewrite insert_union_singleton_l.
+ by rewrite map_disjoint_union_l, map_disjoint_singleton_l.
+Qed.
+Lemma map_disjoint_insert_r {A} (m1 m2 : M A) i x :
+ m1 ⊥ₘ <[i:=x]>m2 ↔ m1 !! i = None ∧ m1 ⊥ₘ m2.
+Proof.
+ rewrite insert_union_singleton_l.
+ by rewrite map_disjoint_union_r, map_disjoint_singleton_r.
+Qed.
+Lemma map_disjoint_insert_l_2 {A} (m1 m2 : M A) i x :
+ m2 !! i = None → m1 ⊥ₘ m2 → <[i:=x]>m1 ⊥ₘ m2.
+Proof. by rewrite map_disjoint_insert_l. Qed.
+Lemma map_disjoint_insert_r_2 {A} (m1 m2 : M A) i x :
+ m1 !! i = None → m1 ⊥ₘ m2 → m1 ⊥ₘ <[i:=x]>m2.
+Proof. by rewrite map_disjoint_insert_r. Qed.
+Lemma insert_union_l {A} (m1 m2 : M A) i x :
+ <[i:=x]>(m1 ∪ m2) = <[i:=x]>m1 ∪ m2.
+Proof. by rewrite !insert_union_singleton_l, (associative_L (∪)). Qed.
+Lemma insert_union_r {A} (m1 m2 : M A) i x :
+ m1 !! i = None → <[i:=x]>(m1 ∪ m2) = m1 ∪ <[i:=x]>m2.
+Proof.
+ intro. rewrite !insert_union_singleton_l, !(associative_L (∪)).
+ rewrite (map_union_commutative m1); [done |].
+ by apply map_disjoint_singleton_r.
+Qed.
+Lemma foldr_insert_union {A} (m : M A) l :
+ foldr (λ p, <[p.1:=p.2]>) m l = map_of_list l ∪ m.
+Proof.
+ induction l as [|i l IH]; simpl; [by rewrite (left_id_L _ _)|].
+ by rewrite IH, insert_union_l.
+Qed.
+Lemma delete_union {A} (m1 m2 : M A) i :
+ delete i (m1 ∪ m2) = delete i m1 ∪ delete i m2.
+Proof. apply delete_union_with. Qed.
+
+(** ** Properties of the [union_list] operation *)
+Lemma map_disjoint_union_list_l {A} (ms : list (M A)) (m : M A) :
+ ⋃ ms ⊥ₘ m ↔ Forall (.⊥ₘ m) ms.
+Proof.
+ split.
+ * induction ms; simpl; rewrite ?map_disjoint_union_l; intuition.
+ * induction 1; simpl; [apply map_disjoint_empty_l |].
+ by rewrite map_disjoint_union_l.
+Qed.
+Lemma map_disjoint_union_list_r {A} (ms : list (M A)) (m : M A) :
+ m ⊥ₘ ⋃ ms ↔ Forall (.⊥ₘ m) ms.
+Proof. by rewrite (symmetry_iff map_disjoint), map_disjoint_union_list_l. Qed.
+Lemma map_disjoint_union_list_l_2 {A} (ms : list (M A)) (m : M A) :
+ Forall (.⊥ₘ m) ms → ⋃ ms ⊥ₘ m.
+Proof. by rewrite map_disjoint_union_list_l. Qed.
+Lemma map_disjoint_union_list_r_2 {A} (ms : list (M A)) (m : M A) :
+ Forall (.⊥ₘ m) ms → m ⊥ₘ ⋃ ms.
+Proof. by rewrite map_disjoint_union_list_r. Qed.
+
+(** ** Properties of the folding the [delete] function *)
+Lemma lookup_foldr_delete {A} (m : M A) is j :
+ j ∈ is → foldr delete m is !! j = None.
+Proof.
+ induction 1 as [|i j is]; simpl; [by rewrite lookup_delete|].
+ by destruct (decide (i = j)) as [->|?];
+ rewrite ?lookup_delete, ?lookup_delete_ne by done.
+Qed.
+Lemma lookup_foldr_delete_not_elem_of {A} (m : M A) is j :
+ j ∉ is → foldr delete m is !! j = m !! j.
+Proof.
+ induction is; simpl; [done |]. rewrite elem_of_cons; intros.
+ rewrite lookup_delete_ne; intuition.
+Qed.
+Lemma foldr_delete_notin {A} (m : M A) is :
+ Forall (λ i, m !! i = None) is → foldr delete m is = m.
+Proof. induction 1; simpl; [done |]. rewrite delete_notin; congruence. Qed.
+Lemma foldr_delete_insert_ne {A} (m : M A) is j x :
+ j ∉ is → foldr delete (<[j:=x]>m) is = <[j:=x]>(foldr delete m is).
+Proof.
+ induction is; simpl; [done |]. rewrite elem_of_cons. intros.
+ rewrite IHis, delete_insert_ne; intuition.
+Qed.
+Lemma map_disjoint_foldr_delete_l {A} (m1 m2 : M A) is :
+ m1 ⊥ₘ m2 → foldr delete m1 is ⊥ₘ m2.
+Proof. induction is; simpl; auto using map_disjoint_delete_l. Qed.
+Lemma map_disjoint_foldr_delete_r {A} (m1 m2 : M A) is :
+ m1 ⊥ₘ m2 → m1 ⊥ₘ foldr delete m2 is.
+Proof. induction is; simpl; auto using map_disjoint_delete_r. Qed.
+Lemma foldr_delete_union {A} (m1 m2 : M A) is :
+ foldr delete (m1 ∪ m2) is = foldr delete m1 is ∪ foldr delete m2 is.
+Proof. apply foldr_delete_union_with. Qed.
+
+(** ** Properties on disjointness of conversion to lists *)
+Lemma map_disjoint_of_list_l {A} (m : M A) ixs :
+ map_of_list ixs ⊥ₘ m ↔ Forall (λ ix, m !! ix.1 = None) ixs.
+Proof.
+ split.
+ * induction ixs; simpl; rewrite ?map_disjoint_insert_l in *; intuition.
+ * induction 1; simpl; [apply map_disjoint_empty_l|].
+ rewrite map_disjoint_insert_l. auto.
+Qed.
+Lemma map_disjoint_of_list_r {A} (m : M A) ixs :
+ m ⊥ₘ map_of_list ixs ↔ Forall (λ ix, m !! ix.1 = None) ixs.
+Proof. by rewrite (symmetry_iff map_disjoint), map_disjoint_of_list_l. Qed.
+Lemma map_disjoint_of_list_zip_l {A} (m : M A) is xs :
+ length is = length xs →
+ map_of_list (zip is xs) ⊥ₘ m ↔ Forall (λ i, m !! i = None) is.
+Proof.
+ intro. rewrite map_disjoint_of_list_l.
+ rewrite <-(fst_zip is xs) at 2 by lia. by rewrite Forall_fmap.
+Qed.
+Lemma map_disjoint_of_list_zip_r {A} (m : M A) is xs :
+ length is = length xs →
+ m ⊥ₘ map_of_list (zip is xs) ↔ Forall (λ i, m !! i = None) is.
+Proof.
+ intro. by rewrite (symmetry_iff map_disjoint), map_disjoint_of_list_zip_l.
+Qed.
+Lemma map_disjoint_of_list_zip_l_2 {A} (m : M A) is xs :
+ length is = length xs → Forall (λ i, m !! i = None) is →
+ map_of_list (zip is xs) ⊥ₘ m.
+Proof. intro. by rewrite map_disjoint_of_list_zip_l. Qed.
+Lemma map_disjoint_of_list_zip_r_2 {A} (m : M A) is xs :
+ length is = length xs → Forall (λ i, m !! i = None) is →
+ m ⊥ₘ map_of_list (zip is xs).
+Proof. intro. by rewrite map_disjoint_of_list_zip_r. Qed.
+
+(** ** Properties of the [intersection_with] operation *)
+Lemma lookup_intersection_with {A} (f : A → A → option A) m1 m2 i :
+ intersection_with f m1 m2 !! i = intersection_with f (m1 !! i) (m2 !! i).
+Proof. by rewrite <-(lookup_merge _). Qed.
+Lemma lookup_intersection_with_Some {A} (f : A → A → option A) m1 m2 i z :
+ intersection_with f m1 m2 !! i = Some z ↔
+ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ f x y = Some z).
+Proof.
+ rewrite lookup_intersection_with.
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+
+(** ** Properties of the [intersection] operation *)
+Lemma lookup_intersection_Some {A} (m1 m2 : M A) i x :
+ (m1 ∩ m2) !! i = Some x ↔ m1 !! i = Some x ∧ is_Some (m2 !! i).
+Proof.
+ unfold intersection, map_intersection. rewrite lookup_intersection_with.
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+Lemma lookup_intersection_None {A} (m1 m2 : M A) i :
+ (m1 ∩ m2) !! i = None ↔ m1 !! i = None ∨ m2 !! i = None.
+Proof.
+ unfold intersection, map_intersection. rewrite lookup_intersection_with.
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+
+(** ** Properties of the [difference_with] operation *)
+Lemma lookup_difference_with {A} (f : A → A → option A) m1 m2 i :
+ difference_with f m1 m2 !! i = difference_with f (m1 !! i) (m2 !! i).
+Proof. by rewrite <-lookup_merge by done. Qed.
+Lemma lookup_difference_with_Some {A} (f : A → A → option A) m1 m2 i z :
+ difference_with f m1 m2 !! i = Some z ↔
+ (m1 !! i = Some z ∧ m2 !! i = None) ∨
+ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ f x y = Some z).
+Proof.
+ rewrite lookup_difference_with.
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+
+(** ** Properties of the [difference] operation *)
+Lemma lookup_difference_Some {A} (m1 m2 : M A) i x :
+ (m1 ∖ m2) !! i = Some x ↔ m1 !! i = Some x ∧ m2 !! i = None.
+Proof.
+ unfold difference, map_difference; rewrite lookup_difference_with.
+ destruct (m1 !! i), (m2 !! i); compute; intuition congruence.
+Qed.
+Lemma lookup_difference_None {A} (m1 m2 : M A) i :
+ (m1 ∖ m2) !! i = None ↔ m1 !! i = None ∨ is_Some (m2 !! i).
+Proof.
+ unfold difference, map_difference; rewrite lookup_difference_with.
+ destruct (m1 !! i), (m2 !! i); compute; naive_solver.
+Qed.
+Lemma map_disjoint_difference_l {A} (m1 m2 : M A) : m1 ⊆ m2 → m2 ∖ m1 ⊥ₘ m1.
+Proof.
+ intros Hm i; specialize (Hm i).
+ unfold difference, map_difference; rewrite lookup_difference_with.
+ by destruct (m1 !! i), (m2 !! i).
+Qed.
+Lemma map_disjoint_difference_r {A} (m1 m2 : M A) : m1 ⊆ m2 → m1 ⊥ₘ m2 ∖ m1.
+Proof. intros. symmetry. by apply map_disjoint_difference_l. Qed.
+Lemma map_difference_union {A} (m1 m2 : M A) :
+ m1 ⊆ m2 → m1 ∪ m2 ∖ m1 = m2.
+Proof.
+ rewrite map_subseteq_spec. intro Hm1m2. apply map_eq. intros i.
+ apply option_eq. intros v. specialize (Hm1m2 i).
+ unfold difference, map_difference, difference_with, map_difference_with.
+ rewrite lookup_union_Some_raw, (lookup_merge _).
+ destruct (m1 !! i) as [x'|], (m2 !! i);
+ try specialize (Hm1m2 x'); compute; intuition congruence.
+Qed.
+End theorems.
+
+(** * Tactics *)
+(** The tactic [decompose_map_disjoint] simplifies occurrences of [disjoint]
+in the hypotheses that involve the empty map [∅], the union [(∪)] or insert
+[<[_:=_]>] operation, the singleton [{[_↦ _]}] map, and disjointness of lists of
+maps. This tactic does not yield any information loss as all simplifications
+performed are reversible. *)
+Ltac decompose_map_disjoint := repeat
+ match goal with
+ | H : _ ∪ _ ⊥ₘ _ |- _ => apply map_disjoint_union_l in H; destruct H
+ | H : _ ⊥ₘ _ ∪ _ |- _ => apply map_disjoint_union_r in H; destruct H
+ | H : {[ _ ↦ _ ]} ⊥ₘ _ |- _ => apply map_disjoint_singleton_l in H
+ | H : _ ⊥ₘ {[ _ ↦ _ ]} |- _ => apply map_disjoint_singleton_r in H
+ | H : <[_:=_]>_ ⊥ₘ _ |- _ => apply map_disjoint_insert_l in H; destruct H
+ | H : _ ⊥ₘ <[_:=_]>_ |- _ => apply map_disjoint_insert_r in H; destruct H
+ | H : ⋃ _ ⊥ₘ _ |- _ => apply map_disjoint_union_list_l in H
+ | H : _ ⊥ₘ ⋃ _ |- _ => apply map_disjoint_union_list_r in H
+ | H : ∅ ⊥ₘ _ |- _ => clear H
+ | H : _ ⊥ₘ ∅ |- _ => clear H
+ | H : Forall (.⊥ₘ _) _ |- _ => rewrite Forall_vlookup in H
+ | H : Forall (.⊥ₘ _) [] |- _ => clear H
+ | H : Forall (.⊥ₘ _) (_ :: _) |- _ => rewrite Forall_cons in H; destruct H
+ | H : Forall (.⊥ₘ _) (_ :: _) |- _ => rewrite Forall_app in H; destruct H
+ end.
+
+(** To prove a disjointness property, we first decompose all hypotheses, and
+then use an auto database to prove the required property. *)
+Create HintDb map_disjoint.
+Ltac solve_map_disjoint :=
+ solve [decompose_map_disjoint; auto with map_disjoint].
+
+(** We declare these hints using [Hint Extern] instead of [Hint Resolve] as
+[eauto] works badly with hints parametrized by type class constraints. *)
+Hint Extern 1 (_ ⊥ₘ _) => done : map_disjoint.
+Hint Extern 2 (∅ ⊥ₘ _) => apply map_disjoint_empty_l : map_disjoint.
+Hint Extern 2 (_ ⊥ₘ ∅) => apply map_disjoint_empty_r : map_disjoint.
+Hint Extern 2 ({[ _ ↦ _ ]} ⊥ₘ _) =>
+ apply map_disjoint_singleton_l_2 : map_disjoint.
+Hint Extern 2 (_ ⊥ₘ {[ _ ↦ _ ]}) =>
+ apply map_disjoint_singleton_r_2 : map_disjoint.
+Hint Extern 2 (_ ∪ _ ⊥ₘ _) => apply map_disjoint_union_l_2 : map_disjoint.
+Hint Extern 2 (_ ⊥ₘ _ ∪ _) => apply map_disjoint_union_r_2 : map_disjoint.
+Hint Extern 2 (<[_:=_]>_ ⊥ₘ _) => apply map_disjoint_insert_l_2 : map_disjoint.
+Hint Extern 2 (_ ⊥ₘ <[_:=_]>_) => apply map_disjoint_insert_r_2 : map_disjoint.
+Hint Extern 2 (delete _ _ ⊥ₘ _) => apply map_disjoint_delete_l : map_disjoint.
+Hint Extern 2 (_ ⊥ₘ delete _ _) => apply map_disjoint_delete_r : map_disjoint.
+Hint Extern 2 (map_of_list _ ⊥ₘ _) =>
+ apply map_disjoint_of_list_zip_l_2 : mem_disjoint.
+Hint Extern 2 (_ ⊥ₘ map_of_list _) =>
+ apply map_disjoint_of_list_zip_r_2 : mem_disjoint.
+Hint Extern 2 (⋃ _ ⊥ₘ _) => apply map_disjoint_union_list_l_2 : mem_disjoint.
+Hint Extern 2 (_ ⊥ₘ ⋃ _) => apply map_disjoint_union_list_r_2 : mem_disjoint.
+Hint Extern 2 (foldr delete _ _ ⊥ₘ _) =>
+ apply map_disjoint_foldr_delete_l : map_disjoint.
+Hint Extern 2 (_ ⊥ₘ foldr delete _ _) =>
+ apply map_disjoint_foldr_delete_r : map_disjoint.
+
+(** The tactic [simpl_map by tac] simplifies occurrences of finite map look
+ups. It uses [tac] to discharge generated inequalities. Look ups in unions do
+not have nice equational properties, hence it invokes [tac] to prove that such
+look ups yield [Some]. *)
+Tactic Notation "simpl_map" "by" tactic3(tac) := repeat
+ match goal with
+ | H : context[ ∅ !! _ ] |- _ => rewrite lookup_empty in H
+ | H : context[ (<[_:=_]>_) !! _ ] |- _ =>
+ rewrite lookup_insert in H || rewrite lookup_insert_ne in H by tac
+ | H : context[ (alter _ _ _) !! _] |- _ =>
+ rewrite lookup_alter in H || rewrite lookup_alter_ne in H by tac
+ | H : context[ (delete _ _) !! _] |- _ =>
+ rewrite lookup_delete in H || rewrite lookup_delete_ne in H by tac
+ | H : context[ {[ _ ↦ _ ]} !! _ ] |- _ =>
+ rewrite lookup_singleton in H || rewrite lookup_singleton_ne in H by tac
+ | H : context[ (_ <$> _) !! _ ] |- _ => rewrite lookup_fmap in H
+ | H : context[ (omap _ _) !! _ ] |- _ => rewrite lookup_omap in H
+ | H : context[ lookup (A:=?A) ?i (?m1 ∪ ?m2) ] |- _ =>
+ let x := fresh in evar (x:A);
+ let x' := eval unfold x in x in clear x;
+ let E := fresh in
+ assert ((m1 ∪ m2) !! i = Some x') as E by (clear H; by tac);
+ rewrite E in H; clear E
+ | |- context[ ∅ !! _ ] => rewrite lookup_empty
+ | |- context[ (<[_:=_]>_) !! _ ] =>
+ rewrite lookup_insert || rewrite lookup_insert_ne by tac
+ | |- context[ (alter _ _ _) !! _ ] =>
+ rewrite lookup_alter || rewrite lookup_alter_ne by tac
+ | |- context[ (delete _ _) !! _ ] =>
+ rewrite lookup_delete || rewrite lookup_delete_ne by tac
+ | |- context[ {[ _ ↦ _ ]} !! _ ] =>
+ rewrite lookup_singleton || rewrite lookup_singleton_ne by tac
+ | |- context[ (_ <$> _) !! _ ] => rewrite lookup_fmap
+ | |- context[ (omap _ _) !! _ ] => rewrite lookup_omap
+ | |- context [ lookup (A:=?A) ?i ?m ] =>
+ let x := fresh in evar (x:A);
+ let x' := eval unfold x in x in clear x;
+ let E := fresh in
+ assert (m !! i = Some x') as E by tac;
+ rewrite E; clear E
+ end.
+
+Create HintDb simpl_map.
+Tactic Notation "simpl_map" := simpl_map by eauto with simpl_map map_disjoint.
+
+Hint Extern 80 ((_ ∪ _) !! _ = Some _) => apply lookup_union_Some_l : simpl_map.
+Hint Extern 81 ((_ ∪ _) !! _ = Some _) => apply lookup_union_Some_r : simpl_map.
+Hint Extern 80 ({[ _↦_ ]} !! _ = Some _) => apply lookup_singleton : simpl_map.
+Hint Extern 80 (<[_:=_]> _ !! _ = Some _) => apply lookup_insert : simpl_map.
+
+(** Now we take everything together and also discharge conflicting look ups,
+simplify overlapping look ups, and perform cancellations of equalities
+involving unions. *)
+Tactic Notation "simplify_map_equality" "by" tactic3(tac) :=
+ decompose_map_disjoint;
+ repeat match goal with
+ | _ => progress simpl_map by tac
+ | _ => progress simplify_equality
+ | _ => progress simpl_option by tac
+ | H : {[ _ ↦ _ ]} !! _ = None |- _ => rewrite lookup_singleton_None in H
+ | H : {[ _ ↦ _ ]} !! _ = Some _ |- _ =>
+ rewrite lookup_singleton_Some in H; destruct H
+ | H1 : ?m1 !! ?i = Some ?x, H2 : ?m2 !! ?i = Some ?y |- _ =>
+ let H3 := fresh in
+ feed pose proof (lookup_weaken_inv m1 m2 i x y) as H3; [done|by tac|done|];
+ clear H2; symmetry in H3
+ | H1 : ?m1 !! ?i = Some ?x, H2 : ?m2 !! ?i = None |- _ =>
+ let H3 := fresh in
+ apply (lookup_weaken _ m2) in H1; [congruence|by tac]
+ | H : ?m ∪ _ = ?m ∪ _ |- _ =>
+ apply map_union_cancel_l in H; [|by tac|by tac]
+ | H : _ ∪ ?m = _ ∪ ?m |- _ =>
+ apply map_union_cancel_r in H; [|by tac|by tac]
+ | H : {[?i ↦ ?x]} = ∅ |- _ => by destruct (map_non_empty_singleton i x)
+ | H : ∅ = {[?i ↦ ?x]} |- _ => by destruct (map_non_empty_singleton i x)
+ | H : ?m !! ?i = Some _, H2 : ?m !! ?j = None |- _ =>
+ unless (i ≠j) by done;
+ assert (i ≠j) by (by intros ?; simplify_equality)
+ end.
+Tactic Notation "simplify_map_equality'" "by" tactic3(tac) :=
+ repeat (progress csimpl in * || simplify_map_equality by tac).
+Tactic Notation "simplify_map_equality" :=
+ simplify_map_equality by eauto with simpl_map map_disjoint.
+Tactic Notation "simplify_map_equality'" :=
+ simplify_map_equality' by eauto with simpl_map map_disjoint.
diff --git a/prelude/finite.v b/prelude/finite.v
new file mode 100644
index 0000000000000000000000000000000000000000..76006bf3a8d8596ce3256f95c0e0271f7e8e5cad
--- /dev/null
+++ b/prelude/finite.v
@@ -0,0 +1,299 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Export prelude.countable prelude.list.
+
+Class Finite A `{∀ x y : A, Decision (x = y)} := {
+ enum : list A;
+ NoDup_enum : NoDup enum;
+ elem_of_enum x : x ∈ enum
+}.
+Arguments enum _ {_ _} : clear implicits.
+Arguments NoDup_enum _ {_ _} : clear implicits.
+Definition card A `{Finite A} := length (enum A).
+Program Instance finite_countable `{Finite A} : Countable A := {|
+ encode := λ x,
+ Pos.of_nat $ S $ from_option 0 $ fst <$> list_find (x =) (enum A);
+ decode := λ p, enum A !! pred (Pos.to_nat p)
+|}.
+Arguments Pos.of_nat _ : simpl never.
+Next Obligation.
+ intros ?? [xs Hxs HA] x; unfold encode, decode; simpl.
+ destruct (list_find_elem_of (x =) xs x) as [[i y] Hi]; auto.
+ rewrite Nat2Pos.id by done; simpl; rewrite Hi; simpl.
+ destruct (list_find_Some (x =) xs i y); naive_solver.
+Qed.
+Definition find `{Finite A} P `{∀ x, Decision (P x)} : option A :=
+ list_find P (enum A) ≫= decode_nat ∘ fst.
+
+Lemma encode_lt_card `{finA: Finite A} x : encode_nat x < card A.
+Proof.
+ destruct finA as [xs Hxs HA]; unfold encode_nat, encode, card; simpl.
+ rewrite Nat2Pos.id by done; simpl.
+ destruct (list_find _ xs) as [[i y]|] eqn:?; simpl.
+ * destruct (list_find_Some (x =) xs i y); eauto using lookup_lt_Some.
+ * destruct xs; simpl. exfalso; eapply not_elem_of_nil, (HA x). lia.
+Qed.
+Lemma encode_decode A `{finA: Finite A} i :
+ i < card A → ∃ x, decode_nat i = Some x ∧ encode_nat x = i.
+Proof.
+ destruct finA as [xs Hxs HA].
+ unfold encode_nat, decode_nat, encode, decode, card; simpl.
+ intros Hi. apply lookup_lt_is_Some in Hi. destruct Hi as [x Hx].
+ exists x. rewrite !Nat2Pos.id by done; simpl.
+ destruct (list_find_elem_of (x =) xs x) as [[j y] Hj]; auto.
+ destruct (list_find_Some (x =) xs j y) as [? ->]; auto.
+ rewrite Hj; csimpl; eauto using NoDup_lookup.
+Qed.
+Lemma find_Some `{finA: Finite A} P `{∀ x, Decision (P x)} x :
+ find P = Some x → P x.
+Proof.
+ destruct finA as [xs Hxs HA]; unfold find, decode_nat, decode; simpl.
+ intros Hx. destruct (list_find _ _) as [[i y]|] eqn:Hi; simplify_equality'.
+ rewrite !Nat2Pos.id in Hx by done.
+ destruct (list_find_Some P xs i y); naive_solver.
+Qed.
+Lemma find_is_Some `{finA: Finite A} P `{∀ x, Decision (P x)} x :
+ P x → ∃ y, find P = Some y ∧ P y.
+Proof.
+ destruct finA as [xs Hxs HA]; unfold find, decode; simpl.
+ intros Hx. destruct (list_find_elem_of P xs x) as [[i y] Hi]; auto.
+ rewrite Hi. destruct (list_find_Some P xs i y); simplify_equality'; auto.
+ exists y. by rewrite !Nat2Pos.id by done.
+Qed.
+
+Lemma card_0_inv P `{finA: Finite A} : card A = 0 → A → P.
+Proof.
+ intros ? x. destruct finA as [[|??] ??]; simplify_equality.
+ by destruct (not_elem_of_nil x).
+Qed.
+Lemma finite_inhabited A `{finA: Finite A} : 0 < card A → Inhabited A.
+Proof.
+ unfold card; intros. destruct finA as [[|x ?] ??]; simpl in *; [exfalso;lia|].
+ constructor; exact x.
+Qed.
+Lemma finite_injective_contains `{finA: Finite A} `{finB: Finite B} (f: A → B)
+ `{!Injective (=) (=) f} : f <$> enum A `contains` enum B.
+Proof.
+ intros. destruct finA, finB. apply NoDup_contains; auto using NoDup_fmap_2.
+Qed.
+Lemma finite_injective_Permutation `{Finite A} `{Finite B} (f : A → B)
+ `{!Injective (=) (=) f} : card A = card B → f <$> enum A ≡ₚ enum B.
+Proof.
+ intros. apply contains_Permutation_length_eq.
+ * by rewrite fmap_length.
+ * by apply finite_injective_contains.
+Qed.
+Lemma finite_injective_surjective `{Finite A} `{Finite B} (f : A → B)
+ `{!Injective (=) (=) f} : card A = card B → Surjective (=) f.
+Proof.
+ intros HAB y. destruct (elem_of_list_fmap_2 f (enum A) y) as (x&?&?); eauto.
+ rewrite finite_injective_Permutation; auto using elem_of_enum.
+Qed.
+
+Lemma finite_surjective A `{Finite A} B `{Finite B} :
+ 0 < card A ≤ card B → ∃ g : B → A, Surjective (=) g.
+Proof.
+ intros [??]. destruct (finite_inhabited A) as [x']; auto with lia.
+ exists (λ y : B, from_option x' (decode_nat (encode_nat y))).
+ intros x. destruct (encode_decode B (encode_nat x)) as (y&Hy1&Hy2).
+ { pose proof (encode_lt_card x); lia. }
+ exists y. by rewrite Hy2, decode_encode_nat.
+Qed.
+Lemma finite_injective A `{Finite A} B `{Finite B} :
+ card A ≤ card B ↔ ∃ f : A → B, Injective (=) (=) f.
+Proof.
+ split.
+ * intros. destruct (decide (card A = 0)) as [HA|?].
+ { exists (card_0_inv B HA). intros y. apply (card_0_inv _ HA y). }
+ destruct (finite_surjective A B) as (g&?); auto with lia.
+ destruct (surjective_cancel g) as (f&?). exists f. apply cancel_injective.
+ * intros [f ?]. unfold card. rewrite <-(fmap_length f).
+ by apply contains_length, (finite_injective_contains f).
+Qed.
+Lemma finite_bijective A `{Finite A} B `{Finite B} :
+ card A = card B ↔ ∃ f : A → B, Injective (=) (=) f ∧ Surjective (=) f.
+Proof.
+ split.
+ * intros; destruct (proj1 (finite_injective A B)) as [f ?]; auto with lia.
+ exists f; auto using (finite_injective_surjective f).
+ * intros (f&?&?). apply (anti_symmetric (≤)); apply finite_injective.
+ + by exists f.
+ + destruct (surjective_cancel f) as (g&?); eauto using cancel_injective.
+Qed.
+Lemma injective_card `{Finite A} `{Finite B} (f : A → B)
+ `{!Injective (=) (=) f} : card A ≤ card B.
+Proof. apply finite_injective. eauto. Qed.
+Lemma surjective_card `{Finite A} `{Finite B} (f : A → B)
+ `{!Surjective (=) f} : card B ≤ card A.
+Proof.
+ destruct (surjective_cancel f) as (g&?).
+ apply injective_card with g, cancel_injective.
+Qed.
+Lemma bijective_card `{Finite A} `{Finite B} (f : A → B)
+ `{!Injective (=) (=) f} `{!Surjective (=) f} : card A = card B.
+Proof. apply finite_bijective. eauto. Qed.
+
+(** Decidability of quantification over finite types *)
+Section forall_exists.
+ Context `{Finite A} (P : A → Prop) `{∀ x, Decision (P x)}.
+
+ Lemma Forall_finite : Forall P (enum A) ↔ (∀ x, P x).
+ Proof. rewrite Forall_forall. intuition auto using elem_of_enum. Qed.
+ Lemma Exists_finite : Exists P (enum A) ↔ (∃ x, P x).
+ Proof. rewrite Exists_exists. naive_solver eauto using elem_of_enum. Qed.
+
+ Global Instance forall_dec: Decision (∀ x, P x).
+ Proof.
+ refine (cast_if (decide (Forall P (enum A))));
+ abstract by rewrite <-Forall_finite.
+ Defined.
+ Global Instance exists_dec: Decision (∃ x, P x).
+ Proof.
+ refine (cast_if (decide (Exists P (enum A))));
+ abstract by rewrite <-Exists_finite.
+ Defined.
+End forall_exists.
+
+(** Instances *)
+Section enc_finite.
+ Context `{∀ x y : A, Decision (x = y)}.
+ Context (to_nat : A → nat) (of_nat : nat → A) (c : nat).
+ Context (of_to_nat : ∀ x, of_nat (to_nat x) = x).
+ Context (to_nat_c : ∀ x, to_nat x < c).
+ Context (to_of_nat : ∀ i, i < c → to_nat (of_nat i) = i).
+
+ Program Instance enc_finite : Finite A := {| enum := of_nat <$> seq 0 c |}.
+ Next Obligation.
+ apply NoDup_alt. intros i j x. rewrite !list_lookup_fmap. intros Hi Hj.
+ destruct (seq _ _ !! i) as [i'|] eqn:Hi',
+ (seq _ _ !! j) as [j'|] eqn:Hj'; simplify_equality'.
+ destruct (lookup_seq_inv _ _ _ _ Hi'), (lookup_seq_inv _ _ _ _ Hj'); subst.
+ rewrite <-(to_of_nat i), <-(to_of_nat j) by done. by f_equal.
+ Qed.
+ Next Obligation.
+ intros x. rewrite elem_of_list_fmap. exists (to_nat x).
+ split; auto. by apply elem_of_list_lookup_2 with (to_nat x), lookup_seq.
+ Qed.
+ Lemma enc_finite_card : card A = c.
+ Proof. unfold card. simpl. by rewrite fmap_length, seq_length. Qed.
+End enc_finite.
+
+Section bijective_finite.
+ Context `{Finite A, ∀ x y : B, Decision (x = y)} (f : A → B) (g : B → A).
+ Context `{!Injective (=) (=) f, !Cancel (=) f g}.
+
+ Program Instance bijective_finite: Finite B := {| enum := f <$> enum A |}.
+ Next Obligation. apply (NoDup_fmap_2 _), NoDup_enum. Qed.
+ Next Obligation.
+ intros y. rewrite elem_of_list_fmap. eauto using elem_of_enum.
+ Qed.
+End bijective_finite.
+
+Program Instance option_finite `{Finite A} : Finite (option A) :=
+ {| enum := None :: Some <$> enum A |}.
+Next Obligation.
+ constructor.
+ * rewrite elem_of_list_fmap. by intros (?&?&?).
+ * apply (NoDup_fmap_2 _); auto using NoDup_enum.
+Qed.
+Next Obligation.
+ intros ??? [x|]; [right|left]; auto.
+ apply elem_of_list_fmap. eauto using elem_of_enum.
+Qed.
+Lemma option_cardinality `{Finite A} : card (option A) = S (card A).
+Proof. unfold card. simpl. by rewrite fmap_length. Qed.
+
+Program Instance unit_finite : Finite () := {| enum := [tt] |}.
+Next Obligation. apply NoDup_singleton. Qed.
+Next Obligation. intros []. by apply elem_of_list_singleton. Qed.
+Lemma unit_card : card unit = 1.
+Proof. done. Qed.
+
+Program Instance bool_finite : Finite bool := {| enum := [true; false] |}.
+Next Obligation.
+ constructor. by rewrite elem_of_list_singleton. apply NoDup_singleton.
+Qed.
+Next Obligation. intros [|]. left. right; left. Qed.
+Lemma bool_card : card bool = 2.
+Proof. done. Qed.
+
+Program Instance sum_finite `{Finite A, Finite B} : Finite (A + B)%type :=
+ {| enum := (inl <$> enum A) ++ (inr <$> enum B) |}.
+Next Obligation.
+ intros. apply NoDup_app; split_ands.
+ * apply (NoDup_fmap_2 _). by apply NoDup_enum.
+ * intro. rewrite !elem_of_list_fmap. intros (?&?&?) (?&?&?); congruence.
+ * apply (NoDup_fmap_2 _). by apply NoDup_enum.
+Qed.
+Next Obligation.
+ intros ?????? [x|y]; rewrite elem_of_app, !elem_of_list_fmap;
+ eauto using @elem_of_enum.
+Qed.
+Lemma sum_card `{Finite A, Finite B} : card (A + B) = card A + card B.
+Proof. unfold card. simpl. by rewrite app_length, !fmap_length. Qed.
+
+Program Instance prod_finite `{Finite A, Finite B} : Finite (A * B)%type :=
+ {| enum := foldr (λ x, (pair x <$> enum B ++)) [] (enum A) |}.
+Next Obligation.
+ intros ??????. induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl.
+ { constructor. }
+ apply NoDup_app; split_ands.
+ * by apply (NoDup_fmap_2 _), NoDup_enum.
+ * intros [? y]. rewrite elem_of_list_fmap. intros (?&?&?); simplify_equality.
+ clear IH. induction Hxs as [|x' xs ?? IH]; simpl.
+ { rewrite elem_of_nil. tauto. }
+ rewrite elem_of_app, elem_of_list_fmap.
+ intros [(?&?&?)|?]; simplify_equality.
+ + destruct Hx. by left.
+ + destruct IH. by intro; destruct Hx; right. auto.
+ * done.
+Qed.
+Next Obligation.
+ intros ?????? [x y]. induction (elem_of_enum x); simpl.
+ * rewrite elem_of_app, !elem_of_list_fmap. eauto using @elem_of_enum.
+ * rewrite elem_of_app; eauto.
+Qed.
+Lemma prod_card `{Finite A} `{Finite B} : card (A * B) = card A * card B.
+Proof.
+ unfold card; simpl. induction (enum A); simpl; auto.
+ rewrite app_length, fmap_length. auto.
+Qed.
+
+Let list_enum {A} (l : list A) : ∀ n, list { l : list A | length l = n } :=
+ fix go n :=
+ match n with
+ | 0 => [[]↾eq_refl]
+ | S n => foldr (λ x, (sig_map (x ::) (λ _ H, f_equal S H) <$> (go n) ++)) [] l
+ end.
+Program Instance list_finite `{Finite A} n : Finite { l | length l = n } :=
+ {| enum := list_enum (enum A) n |}.
+Next Obligation.
+ intros ????. induction n as [|n IH]; simpl; [apply NoDup_singleton |].
+ revert IH. generalize (list_enum (enum A) n). intros l Hl.
+ induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl; auto; [constructor |].
+ apply NoDup_app; split_ands.
+ * by apply (NoDup_fmap_2 _).
+ * intros [k1 Hk1]. clear Hxs IH. rewrite elem_of_list_fmap.
+ intros ([k2 Hk2]&?&?) Hxk2; simplify_equality'. destruct Hx. revert Hxk2.
+ induction xs as [|x' xs IH]; simpl in *; [by rewrite elem_of_nil |].
+ rewrite elem_of_app, elem_of_list_fmap, elem_of_cons.
+ intros [([??]&?&?)|?]; simplify_equality'; auto.
+ * apply IH.
+Qed.
+Next Obligation.
+ intros ???? [l Hl]. revert l Hl.
+ induction n as [|n IH]; intros [|x l] ?; simpl; simplify_equality.
+ { apply elem_of_list_singleton. by apply (sig_eq_pi _). }
+ revert IH. generalize (list_enum (enum A) n). intros k Hk.
+ induction (elem_of_enum x) as [x xs|x xs]; simpl in *.
+ * rewrite elem_of_app, elem_of_list_fmap. left. injection Hl. intros Hl'.
+ eexists (l↾Hl'). split. by apply (sig_eq_pi _). done.
+ * rewrite elem_of_app. eauto.
+Qed.
+Lemma list_card `{Finite A} n : card { l | length l = n } = card A ^ n.
+Proof.
+ unfold card; simpl. induction n as [|n IH]; simpl; auto.
+ rewrite <-IH. clear IH. generalize (list_enum (enum A) n).
+ induction (enum A) as [|x xs IH]; intros l; simpl; auto.
+ by rewrite app_length, fmap_length, IH.
+Qed.
diff --git a/prelude/gmap.v b/prelude/gmap.v
new file mode 100644
index 0000000000000000000000000000000000000000..1c2cd5ec7865d8fb95e8b64bfb27d7443543f975
--- /dev/null
+++ b/prelude/gmap.v
@@ -0,0 +1,133 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file implements finite maps and finite sets with keys of any countable
+type. The implementation is based on [Pmap]s, radix-2 search trees. *)
+Require Export prelude.countable prelude.fin_maps prelude.fin_map_dom.
+Require Import prelude.pmap prelude.mapset.
+
+(** * The data structure *)
+(** We pack a [Pmap] together with a proof that ensures that all keys correspond
+to codes of actual elements of the countable type. *)
+Definition gmap_wf `{Countable K} {A} : Pmap A → Prop :=
+ map_Forall (λ p _, encode <$> decode p = Some p).
+Record gmap K `{Countable K} A := GMap {
+ gmap_car : Pmap A;
+ gmap_prf : bool_decide (gmap_wf gmap_car)
+}.
+Arguments GMap {_ _ _ _} _ _.
+Arguments gmap_car {_ _ _ _} _.
+Lemma gmap_eq `{Countable K} {A} (m1 m2 : gmap K A) :
+ m1 = m2 ↔ gmap_car m1 = gmap_car m2.
+Proof.
+ split; [by intros ->|intros]. destruct m1, m2; simplify_equality'.
+ f_equal; apply proof_irrel.
+Qed.
+Instance gmap_eq_eq `{Countable K} `{∀ x y : A, Decision (x = y)}
+ (m1 m2 : gmap K A) : Decision (m1 = m2).
+Proof.
+ refine (cast_if (decide (gmap_car m1 = gmap_car m2)));
+ abstract (by rewrite gmap_eq).
+Defined.
+
+(** * Operations on the data structure *)
+Instance gmap_lookup `{Countable K} {A} : Lookup K A (gmap K A) := λ i m,
+ let (m,_) := m in m !! encode i.
+Instance gmap_empty `{Countable K} {A} : Empty (gmap K A) := GMap ∅ I.
+Lemma gmap_partial_alter_wf `{Countable K} {A} (f : option A → option A) m i :
+ gmap_wf m → gmap_wf (partial_alter f (encode i) m).
+Proof.
+ intros Hm p x. destruct (decide (encode i = p)) as [<-|?].
+ * rewrite decode_encode; eauto.
+ * rewrite lookup_partial_alter_ne by done. by apply Hm.
+Qed.
+Instance gmap_partial_alter `{Countable K} {A} :
+ PartialAlter K A (gmap K A) := λ f i m,
+ let (m,Hm) := m in GMap (partial_alter f (encode i) m)
+ (bool_decide_pack _ (gmap_partial_alter_wf f m i
+ (bool_decide_unpack _ Hm))).
+Lemma gmap_fmap_wf `{Countable K} {A B} (f : A → B) m :
+ gmap_wf m → gmap_wf (f <$> m).
+Proof. intros ? p x. rewrite lookup_fmap, fmap_Some; intros (?&?&?); eauto. Qed.
+Instance gmap_fmap `{Countable K} : FMap (gmap K) := λ A B f m,
+ let (m,Hm) := m in GMap (f <$> m)
+ (bool_decide_pack _ (gmap_fmap_wf f m (bool_decide_unpack _ Hm))).
+Lemma gmap_omap_wf `{Countable K} {A B} (f : A → option B) m :
+ gmap_wf m → gmap_wf (omap f m).
+Proof. intros ? p x; rewrite lookup_omap, bind_Some; intros (?&?&?); eauto. Qed.
+Instance gmap_omap `{Countable K} : OMap (gmap K) := λ A B f m,
+ let (m,Hm) := m in GMap (omap f m)
+ (bool_decide_pack _ (gmap_omap_wf f m (bool_decide_unpack _ Hm))).
+Lemma gmap_merge_wf `{Countable K} {A B C}
+ (f : option A → option B → option C) m1 m2 :
+ let f' o1 o2 := match o1, o2 with None, None => None | _, _ => f o1 o2 end in
+ gmap_wf m1 → gmap_wf m2 → gmap_wf (merge f' m1 m2).
+Proof.
+ intros f' Hm1 Hm2 p z; rewrite lookup_merge by done; intros.
+ destruct (m1 !! _) eqn:?, (m2 !! _) eqn:?; naive_solver.
+Qed.
+Instance gmap_merge `{Countable K} : Merge (gmap K) := λ A B C f m1 m2,
+ let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in
+ let f' o1 o2 := match o1, o2 with None, None => None | _, _ => f o1 o2 end in
+ GMap (merge f' m1 m2) (bool_decide_pack _ (gmap_merge_wf f _ _
+ (bool_decide_unpack _ Hm1) (bool_decide_unpack _ Hm2))).
+Instance gmap_to_list `{Countable K} {A} : FinMapToList K A (gmap K A) := λ m,
+ let (m,_) := m in omap (λ ix : positive * A,
+ let (i,x) := ix in (,x) <$> decode i) (map_to_list m).
+
+(** * Instantiation of the finite map interface *)
+Instance gmap_finmap `{Countable K} : FinMap K (gmap K).
+Proof.
+ split.
+ * unfold lookup; intros A [m1 Hm1] [m2 Hm2] Hm.
+ apply gmap_eq, map_eq; intros i; simpl in *.
+ apply bool_decide_unpack in Hm1; apply bool_decide_unpack in Hm2.
+ apply option_eq; intros x; split; intros Hi.
+ + pose proof (Hm1 i x Hi); simpl in *.
+ by destruct (decode i); simplify_equality'; rewrite <-Hm.
+ + pose proof (Hm2 i x Hi); simpl in *.
+ by destruct (decode i); simplify_equality'; rewrite Hm.
+ * done.
+ * intros A f [m Hm] i; apply (lookup_partial_alter f m).
+ * intros A f [m Hm] i j Hs; apply (lookup_partial_alter_ne f m).
+ by contradict Hs; apply (injective encode).
+ * intros A B f [m Hm] i; apply (lookup_fmap f m).
+ * intros A [m Hm]; unfold map_to_list; simpl.
+ apply bool_decide_unpack, map_Forall_to_list in Hm; revert Hm.
+ induction (NoDup_map_to_list m) as [|[p x] l Hpx];
+ inversion 1 as [|??? Hm']; simplify_equality'; [by constructor|].
+ destruct (decode p) as [i|] eqn:?; simplify_equality'; constructor; eauto.
+ rewrite elem_of_list_omap; intros ([p' x']&?&?); simplify_equality'.
+ feed pose proof (proj1 (Forall_forall _ _) Hm' (p',x')); simpl in *; auto.
+ by destruct (decode p') as [i'|]; simplify_equality'.
+ * intros A [m Hm] i x; unfold map_to_list, lookup; simpl.
+ apply bool_decide_unpack in Hm; rewrite elem_of_list_omap; split.
+ + intros ([p' x']&Hp'&?); apply elem_of_map_to_list in Hp'.
+ feed pose proof (Hm p' x'); simpl in *; auto.
+ by destruct (decode p') as [i'|] eqn:?; simplify_equality'.
+ + intros; exists (encode i,x); simpl.
+ by rewrite elem_of_map_to_list, decode_encode.
+ * intros A B f [m Hm] i; apply (lookup_omap f m).
+ * intros A B C f ? [m1 Hm1] [m2 Hm2] i; unfold merge, lookup; simpl.
+ set (f' o1 o2 := match o1, o2 with None,None => None | _, _ => f o1 o2 end).
+ by rewrite lookup_merge by done; destruct (m1 !! _), (m2 !! _).
+Qed.
+
+(** * Finite sets *)
+Notation gset K := (mapset (gmap K)).
+Instance gset_dom `{Countable K} {A} : Dom (gmap K A) (gset K) := mapset_dom.
+Instance gset_dom_spec `{Countable K} :
+ FinMapDom K (gmap K) (gset K) := mapset_dom_spec.
+
+(** * Fresh elements *)
+(* This is pretty ad-hoc and just for the case of [gset positive]. We need a
+notion of countable non-finite types to generalize this. *)
+Instance gset_positive_fresh : Fresh positive (gset positive) := λ X,
+ let 'Mapset (GMap m _) := X in fresh (dom _ m).
+Instance gset_positive_fresh_spec : FreshSpec positive (gset positive).
+Proof.
+ split.
+ * apply _.
+ * by intros X Y; rewrite <-elem_of_equiv_L; intros ->.
+ * intros [[m Hm]]; unfold fresh; simpl.
+ by intros ?; apply (is_fresh (dom Pset m)), elem_of_dom_2 with ().
+Qed.
diff --git a/prelude/hashset.v b/prelude/hashset.v
new file mode 100644
index 0000000000000000000000000000000000000000..c6327dad01118aa1f8b86fd9ea91aa17e1fdd4ce
--- /dev/null
+++ b/prelude/hashset.v
@@ -0,0 +1,171 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file implements finite set using hash maps. Hash sets are represented
+using radix-2 search trees. Each hash bucket is thus indexed using an binary
+integer of type [Z], and contains an unordered list without duplicates. *)
+Require Export prelude.fin_maps prelude.listset.
+Require Import prelude.zmap.
+
+Record hashset {A} (hash : A → Z) := Hashset {
+ hashset_car : Zmap (list A);
+ hashset_prf :
+ map_Forall (λ n l, Forall (λ x, hash x = n) l ∧ NoDup l) hashset_car
+}.
+Arguments Hashset {_ _} _ _.
+Arguments hashset_car {_ _} _.
+
+Section hashset.
+Context `{∀ x y : A, Decision (x = y)} (hash : A → Z).
+
+Instance hashset_elem_of: ElemOf A (hashset hash) := λ x m, ∃ l,
+ hashset_car m !! hash x = Some l ∧ x ∈ l.
+
+Program Instance hashset_empty: Empty (hashset hash) := Hashset ∅ _.
+Next Obligation. by intros n X; simpl_map. Qed.
+Program Instance hashset_singleton: Singleton A (hashset hash) := λ x,
+ Hashset {[ hash x ↦ [x] ]} _.
+Next Obligation.
+ intros x n l [<- <-]%lookup_singleton_Some.
+ rewrite Forall_singleton; auto using NoDup_singleton.
+Qed.
+Program Instance hashset_union: Union (hashset hash) := λ m1 m2,
+ let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in
+ Hashset (union_with (λ l k, Some (list_union l k)) m1 m2) _.
+Next Obligation.
+ intros _ _ m1 Hm1 m2 Hm2 n l'; rewrite lookup_union_with_Some.
+ intros [[??]|[[??]|(l&k&?&?&?)]]; simplify_equality'; auto.
+ split; [apply Forall_list_union|apply NoDup_list_union];
+ first [by eapply Hm1; eauto | by eapply Hm2; eauto].
+Qed.
+Program Instance hashset_intersection: Intersection (hashset hash) := λ m1 m2,
+ let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in
+ Hashset (intersection_with (λ l k,
+ let l' := list_intersection l k in guard (l' ≠[]); Some l') m1 m2) _.
+Next Obligation.
+ intros _ _ m1 Hm1 m2 Hm2 n l'. rewrite lookup_intersection_with_Some.
+ intros (?&?&?&?&?); simplify_option_equality.
+ split; [apply Forall_list_intersection|apply NoDup_list_intersection];
+ first [by eapply Hm1; eauto | by eapply Hm2; eauto].
+Qed.
+Program Instance hashset_difference: Difference (hashset hash) := λ m1 m2,
+ let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in
+ Hashset (difference_with (λ l k,
+ let l' := list_difference l k in guard (l' ≠[]); Some l') m1 m2) _.
+Next Obligation.
+ intros _ _ m1 Hm1 m2 Hm2 n l'. rewrite lookup_difference_with_Some.
+ intros [[??]|(?&?&?&?&?)]; simplify_option_equality; auto.
+ split; [apply Forall_list_difference|apply NoDup_list_difference];
+ first [by eapply Hm1; eauto | by eapply Hm2; eauto].
+Qed.
+Instance hashset_elems: Elements A (hashset hash) := λ m,
+ map_to_list (hashset_car m) ≫= snd.
+
+Global Instance: FinCollection A (hashset hash).
+Proof.
+ split; [split; [split| |]| |].
+ * intros ? (?&?&?); simplify_map_equality'.
+ * unfold elem_of, hashset_elem_of, singleton, hashset_singleton; simpl.
+ intros x y. setoid_rewrite lookup_singleton_Some. split.
+ { by intros (?&[? <-]&?); decompose_elem_of_list. }
+ intros ->; eexists [y]. by rewrite elem_of_list_singleton.
+ * unfold elem_of, hashset_elem_of, union, hashset_union.
+ intros [m1 Hm1] [m2 Hm2] x; simpl; setoid_rewrite lookup_union_with_Some.
+ split.
+ { intros (?&[[]|[[]|(l&k&?&?&?)]]&Hx); simplify_equality'; eauto.
+ rewrite elem_of_list_union in Hx; destruct Hx; eauto. }
+ intros [(l&?&?)|(k&?&?)].
+ + destruct (m2 !! hash x) as [k|]; eauto.
+ exists (list_union l k). rewrite elem_of_list_union. naive_solver.
+ + destruct (m1 !! hash x) as [l|]; eauto 6.
+ exists (list_union l k). rewrite elem_of_list_union. naive_solver.
+ * unfold elem_of, hashset_elem_of, intersection, hashset_intersection.
+ intros [m1 ?] [m2 ?] x; simpl.
+ setoid_rewrite lookup_intersection_with_Some. split.
+ { intros (?&(l&k&?&?&?)&Hx); simplify_option_equality.
+ rewrite elem_of_list_intersection in Hx; naive_solver. }
+ intros [(l&?&?) (k&?&?)]. assert (x ∈ list_intersection l k)
+ by (by rewrite elem_of_list_intersection).
+ exists (list_intersection l k); split; [exists l, k|]; split_ands; auto.
+ by rewrite option_guard_True by eauto using elem_of_not_nil.
+ * unfold elem_of, hashset_elem_of, intersection, hashset_intersection.
+ intros [m1 ?] [m2 ?] x; simpl.
+ setoid_rewrite lookup_difference_with_Some. split.
+ { intros (l'&[[??]|(l&k&?&?&?)]&Hx); simplify_option_equality;
+ rewrite ?elem_of_list_difference in Hx; naive_solver. }
+ intros [(l&?&?) Hm2]; destruct (m2 !! hash x) as [k|] eqn:?; eauto.
+ destruct (decide (x ∈ k)); [destruct Hm2; eauto|].
+ assert (x ∈ list_difference l k) by (by rewrite elem_of_list_difference).
+ exists (list_difference l k); split; [right; exists l,k|]; split_ands; auto.
+ by rewrite option_guard_True by eauto using elem_of_not_nil.
+ * unfold elem_of at 2, hashset_elem_of, elements, hashset_elems.
+ intros [m Hm] x; simpl. setoid_rewrite elem_of_list_bind. split.
+ { intros ([n l]&Hx&Hn); simpl in *; rewrite elem_of_map_to_list in Hn.
+ cut (hash x = n); [intros <-; eauto|].
+ eapply (Forall_forall (λ x, hash x = n) l); eauto. eapply Hm; eauto. }
+ intros (l&?&?). exists (hash x, l); simpl. by rewrite elem_of_map_to_list.
+ * unfold elements, hashset_elems. intros [m Hm]; simpl.
+ rewrite map_Forall_to_list in Hm. generalize (NoDup_fst_map_to_list m).
+ induction Hm as [|[n l] m' [??]];
+ csimpl; inversion_clear 1 as [|?? Hn]; [constructor|].
+ apply NoDup_app; split_ands; eauto.
+ setoid_rewrite elem_of_list_bind; intros x ? ([n' l']&?&?); simpl in *.
+ assert (hash x = n ∧ hash x = n') as [??]; subst.
+ { split; [eapply (Forall_forall (λ x, hash x = n) l); eauto|].
+ eapply (Forall_forall (λ x, hash x = n') l'); eauto.
+ rewrite Forall_forall in Hm. eapply (Hm (_,_)); eauto. }
+ destruct Hn; rewrite elem_of_list_fmap; exists (hash x, l'); eauto.
+Qed.
+End hashset.
+
+(** These instances are declared using [Hint Extern] to avoid too
+eager type class search. *)
+Hint Extern 1 (ElemOf _ (hashset _)) =>
+ eapply @hashset_elem_of : typeclass_instances.
+Hint Extern 1 (Empty (hashset _)) =>
+ eapply @hashset_empty : typeclass_instances.
+Hint Extern 1 (Singleton _ (hashset _)) =>
+ eapply @hashset_singleton : typeclass_instances.
+Hint Extern 1 (Union (hashset _)) =>
+ eapply @hashset_union : typeclass_instances.
+Hint Extern 1 (Intersection (hashset _)) =>
+ eapply @hashset_intersection : typeclass_instances.
+Hint Extern 1 (Difference (hashset _)) =>
+ eapply @hashset_difference : typeclass_instances.
+Hint Extern 1 (Elements _ (hashset _)) =>
+ eapply @hashset_elems : typeclass_instances.
+
+Section remove_duplicates.
+Context `{∀ x y : A, Decision (x = y)} (hash : A → Z).
+
+Definition remove_dups_fast (l : list A) : list A :=
+ match l with
+ | [] => []
+ | [x] => [x]
+ | _ =>
+ let n : Z := length l in
+ elements (foldr (λ x, ({[ x ]} ∪)) ∅ l :
+ hashset (λ x, hash x `mod` (2 * n))%Z)
+ end.
+Lemma elem_of_remove_dups_fast l x : x ∈ remove_dups_fast l ↔ x ∈ l.
+Proof.
+ destruct l as [|x1 [|x2 l]]; try reflexivity.
+ unfold remove_dups_fast; generalize (x1 :: x2 :: l); clear l; intros l.
+ generalize (λ x, hash x `mod` (2 * length l))%Z; intros f.
+ rewrite elem_of_elements; split.
+ * revert x. induction l as [|y l IH]; intros x; simpl.
+ { by rewrite elem_of_empty. }
+ rewrite elem_of_union, elem_of_singleton. intros [->|]; [left|right]; eauto.
+ * induction 1; solve_elem_of.
+Qed.
+Lemma NoDup_remove_dups_fast l : NoDup (remove_dups_fast l).
+Proof.
+ unfold remove_dups_fast; destruct l as [|x1 [|x2 l]].
+ apply NoDup_nil_2. apply NoDup_singleton. apply NoDup_elements.
+Qed.
+Definition listset_normalize (X : listset A) : listset A :=
+ let (l) := X in Listset (remove_dups_fast l).
+Lemma listset_normalize_correct X : listset_normalize X ≡ X.
+Proof.
+ destruct X as [l]. apply elem_of_equiv; intro; apply elem_of_remove_dups_fast.
+Qed.
+End remove_duplicates.
diff --git a/prelude/lexico.v b/prelude/lexico.v
new file mode 100644
index 0000000000000000000000000000000000000000..31ddc33ba9194a8e9100381dd3af53672cfbaed4
--- /dev/null
+++ b/prelude/lexico.v
@@ -0,0 +1,153 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files defines a lexicographic order on various common data structures
+and proves that it is a partial order having a strong variant of trichotomy. *)
+Require Import prelude.numbers.
+
+Notation cast_trichotomy T :=
+ match T with
+ | inleft (left _) => inleft (left _)
+ | inleft (right _) => inleft (right _)
+ | inright _ => inright _
+ end.
+
+Instance prod_lexico `{Lexico A, Lexico B} : Lexico (A * B) := λ p1 p2,
+ (**i 1.) *) lexico (p1.1) (p2.1) ∨
+ (**i 2.) *) p1.1 = p2.1 ∧ lexico (p1.2) (p2.2).
+
+Instance bool_lexico : Lexico bool := λ b1 b2,
+ match b1, b2 with false, true => True | _, _ => False end.
+Instance nat_lexico : Lexico nat := (<).
+Instance N_lexico : Lexico N := (<)%N.
+Instance Z_lexico : Lexico Z := (<)%Z.
+Typeclasses Opaque bool_lexico nat_lexico N_lexico Z_lexico.
+Instance list_lexico `{Lexico A} : Lexico (list A) :=
+ fix go l1 l2 :=
+ let _ : Lexico (list A) := @go in
+ match l1, l2 with
+ | [], _ :: _ => True
+ | x1 :: l1, x2 :: l2 => lexico (x1,l1) (x2,l2)
+ | _, _ => False
+ end.
+Instance sig_lexico `{Lexico A} (P : A → Prop) `{∀ x, ProofIrrel (P x)} :
+ Lexico (sig P) := λ x1 x2, lexico (`x1) (`x2).
+
+Lemma prod_lexico_irreflexive `{Lexico A, Lexico B, !Irreflexive (@lexico A _)}
+ (x : A) (y : B) : complement lexico y y → complement lexico (x,y) (x,y).
+Proof. intros ? [?|[??]]. by apply (irreflexivity lexico x). done. Qed.
+Lemma prod_lexico_transitive `{Lexico A, Lexico B, !Transitive (@lexico A _)}
+ (x1 x2 x3 : A) (y1 y2 y3 : B) :
+ lexico (x1,y1) (x2,y2) → lexico (x2,y2) (x3,y3) →
+ (lexico y1 y2 → lexico y2 y3 → lexico y1 y3) → lexico (x1,y1) (x3,y3).
+Proof.
+ intros Hx12 Hx23 ?; revert Hx12 Hx23. unfold lexico, prod_lexico.
+ intros [|[??]] [?|[??]]; simplify_equality'; auto.
+ by left; transitivity x2.
+Qed.
+
+Instance prod_lexico_po `{Lexico A, Lexico B, !StrictOrder (@lexico A _)}
+ `{!StrictOrder (@lexico B _)} : StrictOrder (@lexico (A * B) _).
+Proof.
+ split.
+ * intros [x y]. apply prod_lexico_irreflexive.
+ by apply (irreflexivity lexico y).
+ * intros [??] [??] [??] ??.
+ eapply prod_lexico_transitive; eauto. apply transitivity.
+Qed.
+Instance prod_lexico_trichotomyT `{Lexico A, tA : !TrichotomyT (@lexico A _)}
+ `{Lexico B, tB : !TrichotomyT (@lexico B _)}: TrichotomyT (@lexico (A * B) _).
+Proof.
+ red; refine (λ p1 p2,
+ match trichotomyT lexico (p1.1) (p2.1) with
+ | inleft (left _) => inleft (left _)
+ | inleft (right _) => cast_trichotomy (trichotomyT lexico (p1.2) (p2.2))
+ | inright _ => inright _
+ end); clear tA tB;
+ abstract (unfold lexico, prod_lexico; auto using injective_projections).
+Defined.
+
+Instance bool_lexico_po : StrictOrder (@lexico bool _).
+Proof. split. by intros [] ?. by intros [] [] [] ??. Qed.
+Instance bool_lexico_trichotomy: TrichotomyT (@lexico bool _).
+Proof.
+ red; refine (λ b1 b2,
+ match b1, b2 with
+ | false, false => inleft (right _)
+ | false, true => inleft (left _)
+ | true, false => inright _
+ | true, true => inleft (right _)
+ end); abstract (unfold strict, lexico, bool_lexico; naive_solver).
+Defined.
+
+Instance nat_lexico_po : StrictOrder (@lexico nat _).
+Proof. unfold lexico, nat_lexico. apply _. Qed.
+Instance nat_lexico_trichotomy: TrichotomyT (@lexico nat _).
+Proof.
+ red; refine (λ n1 n2,
+ match Nat.compare n1 n2 as c return Nat.compare n1 n2 = c → _ with
+ | Lt => λ H, inleft (left (nat_compare_Lt_lt _ _ H))
+ | Eq => λ H, inleft (right (nat_compare_eq _ _ H))
+ | Gt => λ H, inright (nat_compare_Gt_gt _ _ H)
+ end eq_refl).
+Defined.
+
+Instance N_lexico_po : StrictOrder (@lexico N _).
+Proof. unfold lexico, N_lexico. apply _. Qed.
+Instance N_lexico_trichotomy: TrichotomyT (@lexico N _).
+Proof.
+ red; refine (λ n1 n2,
+ match N.compare n1 n2 as c return N.compare n1 n2 = c → _ with
+ | Lt => λ H, inleft (left (proj2 (N.compare_lt_iff _ _) H))
+ | Eq => λ H, inleft (right (N.compare_eq _ _ H))
+ | Gt => λ H, inright (proj1 (N.compare_gt_iff _ _) H)
+ end eq_refl).
+Defined.
+
+Instance Z_lexico_po : StrictOrder (@lexico Z _).
+Proof. unfold lexico, Z_lexico. apply _. Qed.
+Instance Z_lexico_trichotomy: TrichotomyT (@lexico Z _).
+Proof.
+ red; refine (λ n1 n2,
+ match Z.compare n1 n2 as c return Z.compare n1 n2 = c → _ with
+ | Lt => λ H, inleft (left (proj2 (Z.compare_lt_iff _ _) H))
+ | Eq => λ H, inleft (right (Z.compare_eq _ _ H))
+ | Gt => λ H, inright (proj1 (Z.compare_gt_iff _ _) H)
+ end eq_refl).
+Defined.
+
+Instance list_lexico_po `{Lexico A, !StrictOrder (@lexico A _)} :
+ StrictOrder (@lexico (list A) _).
+Proof.
+ split.
+ * intros l. induction l. by intros ?. by apply prod_lexico_irreflexive.
+ * intros l1. induction l1 as [|x1 l1]; intros [|x2 l2] [|x3 l3] ??; try done.
+ eapply prod_lexico_transitive; eauto.
+Qed.
+Instance list_lexico_trichotomy `{Lexico A, tA : !TrichotomyT (@lexico A _)} :
+ TrichotomyT (@lexico (list A) _).
+Proof.
+ refine (
+ fix go l1 l2 :=
+ let go' : TrichotomyT (@lexico (list A) _) := @go in
+ match l1, l2 with
+ | [], [] => inleft (right _)
+ | [], _ :: _ => inleft (left _)
+ | _ :: _, [] => inright _
+ | x1 :: l1, x2 :: l2 => cast_trichotomy (trichotomyT lexico (x1,l1) (x2,l2))
+ end); clear tA go go';
+ abstract (repeat (done || constructor || congruence || by inversion 1)).
+Defined.
+
+Instance sig_lexico_po `{Lexico A, !StrictOrder (@lexico A _)}
+ (P : A → Prop) `{∀ x, ProofIrrel (P x)} : StrictOrder (@lexico (sig P) _).
+Proof.
+ unfold lexico, sig_lexico. split.
+ * intros [x ?] ?. by apply (irreflexivity lexico x).
+ * intros [x1 ?] [x2 ?] [x3 ?] ??. by transitivity x2.
+Qed.
+Instance sig_lexico_trichotomy `{Lexico A, tA : !TrichotomyT (@lexico A _)}
+ (P : A → Prop) `{∀ x, ProofIrrel (P x)} : TrichotomyT (@lexico (sig P) _).
+Proof.
+ red; refine (λ x1 x2, cast_trichotomy (trichotomyT lexico (`x1) (`x2)));
+ abstract (repeat (done || constructor || apply (sig_eq_pi P))).
+Defined.
diff --git a/prelude/list.v b/prelude/list.v
new file mode 100644
index 0000000000000000000000000000000000000000..ef167dc392dd8dbcd7307416bb4e333f26e57bc4
--- /dev/null
+++ b/prelude/list.v
@@ -0,0 +1,3518 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects general purpose definitions and theorems on lists that
+are not in the Coq standard library. *)
+Require Export Permutation.
+Require Export prelude.numbers prelude.base prelude.decidable prelude.option.
+
+Arguments length {_} _.
+Arguments cons {_} _ _.
+Arguments app {_} _ _.
+Arguments Permutation {_} _ _.
+Arguments Forall_cons {_} _ _ _ _ _.
+
+Notation tail := tl.
+Notation take := firstn.
+Notation drop := skipn.
+
+Arguments take {_} !_ !_ /.
+Arguments drop {_} !_ !_ /.
+
+Notation "(::)" := cons (only parsing) : C_scope.
+Notation "( x ::)" := (cons x) (only parsing) : C_scope.
+Notation "(:: l )" := (λ x, cons x l) (only parsing) : C_scope.
+Notation "(++)" := app (only parsing) : C_scope.
+Notation "( l ++)" := (app l) (only parsing) : C_scope.
+Notation "(++ k )" := (λ l, app l k) (only parsing) : C_scope.
+
+Infix "≡ₚ" := Permutation (at level 70, no associativity) : C_scope.
+Notation "(≡ₚ)" := Permutation (only parsing) : C_scope.
+Notation "( x ≡ₚ)" := (Permutation x) (only parsing) : C_scope.
+Notation "(≡ₚ x )" := (λ y, y ≡ₚ x) (only parsing) : C_scope.
+Notation "(≢ₚ)" := (λ x y, ¬x ≡ₚ y) (only parsing) : C_scope.
+Notation "x ≢ₚ y":= (¬x ≡ₚ y) (at level 70, no associativity) : C_scope.
+Notation "( x ≢ₚ)" := (λ y, x ≢ₚ y) (only parsing) : C_scope.
+Notation "(≢ₚ x )" := (λ y, y ≢ₚ x) (only parsing) : C_scope.
+
+Instance maybe_cons {A} : Maybe2 (@cons A) := λ l,
+ match l with x :: l => Some (x,l) | _ => None end.
+
+(** * Definitions *)
+(** Setoid equality lifted to lists *)
+Inductive list_equiv `{Equiv A} : Equiv (list A) :=
+ | nil_equiv : [] ≡ []
+ | cons_equiv x y l k : x ≡ y → l ≡ k → x :: l ≡ y :: k.
+Existing Instance list_equiv.
+
+(** The operation [l !! i] gives the [i]th element of the list [l], or [None]
+in case [i] is out of bounds. *)
+Instance list_lookup {A} : Lookup nat A (list A) :=
+ fix go i l {struct l} : option A := let _ : Lookup _ _ _ := @go in
+ match l with
+ | [] => None | x :: l => match i with 0 => Some x | S i => l !! i end
+ end.
+
+(** The operation [alter f i l] applies the function [f] to the [i]th element
+of [l]. In case [i] is out of bounds, the list is returned unchanged. *)
+Instance list_alter {A} : Alter nat A (list A) := λ f,
+ fix go i l {struct l} :=
+ match l with
+ | [] => []
+ | x :: l => match i with 0 => f x :: l | S i => x :: go i l end
+ end.
+
+(** The operation [<[i:=x]> l] overwrites the element at position [i] with the
+value [x]. In case [i] is out of bounds, the list is returned unchanged. *)
+Instance list_insert {A} : Insert nat A (list A) :=
+ fix go i y l {struct l} := let _ : Insert _ _ _ := @go in
+ match l with
+ | [] => []
+ | x :: l => match i with 0 => y :: l | S i => x :: <[i:=y]>l end
+ end.
+Fixpoint list_inserts {A} (i : nat) (k l : list A) : list A :=
+ match k with
+ | [] => l
+ | y :: k => <[i:=y]>(list_inserts (S i) k l)
+ end.
+
+(** The operation [delete i l] removes the [i]th element of [l] and moves
+all consecutive elements one position ahead. In case [i] is out of bounds,
+the list is returned unchanged. *)
+Instance list_delete {A} : Delete nat (list A) :=
+ fix go (i : nat) (l : list A) {struct l} : list A :=
+ match l with
+ | [] => []
+ | x :: l => match i with 0 => l | S i => x :: @delete _ _ go i l end
+ end.
+
+(** The function [option_list o] converts an element [Some x] into the
+singleton list [[x]], and [None] into the empty list [[]]. *)
+Definition option_list {A} : option A → list A := option_rect _ (λ x, [x]) [].
+Definition list_singleton {A} (l : list A) : option A :=
+ match l with [x] => Some x | _ => None end.
+
+(** The function [filter P l] returns the list of elements of [l] that
+satisfies [P]. The order remains unchanged. *)
+Instance list_filter {A} : Filter A (list A) :=
+ fix go P _ l := let _ : Filter _ _ := @go in
+ match l with
+ | [] => []
+ | x :: l => if decide (P x) then x :: filter P l else filter P l
+ end.
+
+(** The function [list_find P l] returns the first index [i] whose element
+satisfies the predicate [P]. *)
+Definition list_find {A} P `{∀ x, Decision (P x)} : list A → option (nat * A) :=
+ fix go l :=
+ match l with
+ | [] => None
+ | x :: l => if decide (P x) then Some (0,x) else prod_map S id <$> go l
+ end.
+
+(** The function [replicate n x] generates a list with length [n] of elements
+with value [x]. *)
+Fixpoint replicate {A} (n : nat) (x : A) : list A :=
+ match n with 0 => [] | S n => x :: replicate n x end.
+
+(** The function [reverse l] returns the elements of [l] in reverse order. *)
+Definition reverse {A} (l : list A) : list A := rev_append l [].
+
+(** The function [last l] returns the last element of the list [l], or [None]
+if the list [l] is empty. *)
+Fixpoint last {A} (l : list A) : option A :=
+ match l with [] => None | [x] => Some x | _ :: l => last l end.
+
+(** The function [resize n y l] takes the first [n] elements of [l] in case
+[length l ≤ n], and otherwise appends elements with value [x] to [l] to obtain
+a list of length [n]. *)
+Fixpoint resize {A} (n : nat) (y : A) (l : list A) : list A :=
+ match l with
+ | [] => replicate n y
+ | x :: l => match n with 0 => [] | S n => x :: resize n y l end
+ end.
+Arguments resize {_} !_ _ !_.
+
+(** The function [reshape k l] transforms [l] into a list of lists whose sizes
+are specified by [k]. In case [l] is too short, the resulting list will be
+padded with empty lists. In case [l] is too long, it will be truncated. *)
+Fixpoint reshape {A} (szs : list nat) (l : list A) : list (list A) :=
+ match szs with
+ | [] => [] | sz :: szs => take sz l :: reshape szs (drop sz l)
+ end.
+
+Definition sublist_lookup {A} (i n : nat) (l : list A) : option (list A) :=
+ guard (i + n ≤ length l); Some (take n (drop i l)).
+Definition sublist_alter {A} (f : list A → list A)
+ (i n : nat) (l : list A) : list A :=
+ take i l ++ f (take n (drop i l)) ++ drop (i + n) l.
+
+(** Functions to fold over a list. We redefine [foldl] with the arguments in
+the same order as in Haskell. *)
+Notation foldr := fold_right.
+Definition foldl {A B} (f : A → B → A) : A → list B → A :=
+ fix go a l := match l with [] => a | x :: l => go (f a x) l end.
+
+(** The monadic operations. *)
+Instance list_ret: MRet list := λ A x, x :: @nil A.
+Instance list_fmap : FMap list := λ A B f,
+ fix go (l : list A) := match l with [] => [] | x :: l => f x :: go l end.
+Instance list_omap : OMap list := λ A B f,
+ fix go (l : list A) :=
+ match l with
+ | [] => []
+ | x :: l => match f x with Some y => y :: go l | None => go l end
+ end.
+Instance list_bind : MBind list := λ A B f,
+ fix go (l : list A) := match l with [] => [] | x :: l => f x ++ go l end.
+Instance list_join: MJoin list :=
+ fix go A (ls : list (list A)) : list A :=
+ match ls with [] => [] | l :: ls => l ++ @mjoin _ go _ ls end.
+Definition mapM `{MBind M, MRet M} {A B} (f : A → M B) : list A → M (list B) :=
+ fix go l :=
+ match l with [] => mret [] | x :: l => y ↠f x; k ↠go l; mret (y :: k) end.
+
+(** We define stronger variants of map and fold that allow the mapped
+function to use the index of the elements. *)
+Definition imap_go {A B} (f : nat → A → B) : nat → list A → list B :=
+ fix go (n : nat) (l : list A) :=
+ match l with [] => [] | x :: l => f n x :: go (S n) l end.
+Definition imap {A B} (f : nat → A → B) : list A → list B := imap_go f 0.
+Definition zipped_map {A B} (f : list A → list A → A → B) :
+ list A → list A → list B := fix go l k :=
+ match k with [] => [] | x :: k => f l k x :: go (x :: l) k end.
+
+Definition imap2_go {A B C} (f : nat → A → B → C) :
+ nat → list A → list B → list C:=
+ fix go (n : nat) (l : list A) (k : list B) :=
+ match l, k with
+ | [], _ |_, [] => [] | x :: l, y :: k => f n x y :: go (S n) l k
+ end.
+Definition imap2 {A B C} (f : nat → A → B → C) :
+ list A → list B → list C := imap2_go f 0.
+
+Inductive zipped_Forall {A} (P : list A → list A → A → Prop) :
+ list A → list A → Prop :=
+ | zipped_Forall_nil l : zipped_Forall P l []
+ | zipped_Forall_cons l k x :
+ P l k x → zipped_Forall P (x :: l) k → zipped_Forall P l (x :: k).
+Arguments zipped_Forall_nil {_ _} _.
+Arguments zipped_Forall_cons {_ _} _ _ _ _ _.
+
+(** The function [mask f βs l] applies the function [f] to elements in [l] at
+positions that are [true] in [βs]. *)
+Fixpoint mask {A} (f : A → A) (βs : list bool) (l : list A) : list A :=
+ match βs, l with
+ | β :: βs, x :: l => (if β then f x else x) :: mask f βs l
+ | _, _ => l
+ end.
+
+(** The function [permutations l] yields all permutations of [l]. *)
+Fixpoint interleave {A} (x : A) (l : list A) : list (list A) :=
+ match l with
+ | [] => [[x]]| y :: l => (x :: y :: l) :: ((y ::) <$> interleave x l)
+ end.
+Fixpoint permutations {A} (l : list A) : list (list A) :=
+ match l with [] => [[]] | x :: l => permutations l ≫= interleave x end.
+
+(** The predicate [suffix_of] holds if the first list is a suffix of the second.
+The predicate [prefix_of] holds if the first list is a prefix of the second. *)
+Definition suffix_of {A} : relation (list A) := λ l1 l2, ∃ k, l2 = k ++ l1.
+Definition prefix_of {A} : relation (list A) := λ l1 l2, ∃ k, l2 = l1 ++ k.
+Infix "`suffix_of`" := suffix_of (at level 70) : C_scope.
+Infix "`prefix_of`" := prefix_of (at level 70) : C_scope.
+Hint Extern 0 (?x `prefix_of` ?y) => reflexivity.
+Hint Extern 0 (?x `suffix_of` ?y) => reflexivity.
+
+Section prefix_suffix_ops.
+ Context `{∀ x y : A, Decision (x = y)}.
+ Definition max_prefix_of : list A → list A → list A * list A * list A :=
+ fix go l1 l2 :=
+ match l1, l2 with
+ | [], l2 => ([], l2, [])
+ | l1, [] => (l1, [], [])
+ | x1 :: l1, x2 :: l2 =>
+ if decide_rel (=) x1 x2
+ then prod_map id (x1 ::) (go l1 l2) else (x1 :: l1, x2 :: l2, [])
+ end.
+ Definition max_suffix_of (l1 l2 : list A) : list A * list A * list A :=
+ match max_prefix_of (reverse l1) (reverse l2) with
+ | (k1, k2, k3) => (reverse k1, reverse k2, reverse k3)
+ end.
+ Definition strip_prefix (l1 l2 : list A) := (max_prefix_of l1 l2).1.2.
+ Definition strip_suffix (l1 l2 : list A) := (max_suffix_of l1 l2).1.2.
+End prefix_suffix_ops.
+
+(** A list [l1] is a sublist of [l2] if [l2] is obtained by removing elements
+from [l1] without changing the order. *)
+Inductive sublist {A} : relation (list A) :=
+ | sublist_nil : sublist [] []
+ | sublist_skip x l1 l2 : sublist l1 l2 → sublist (x :: l1) (x :: l2)
+ | sublist_cons x l1 l2 : sublist l1 l2 → sublist l1 (x :: l2).
+Infix "`sublist`" := sublist (at level 70) : C_scope.
+Hint Extern 0 (?x `sublist` ?y) => reflexivity.
+
+(** A list [l2] contains a list [l1] if [l2] is obtained by removing elements
+from [l1] while possiblity changing the order. *)
+Inductive contains {A} : relation (list A) :=
+ | contains_nil : contains [] []
+ | contains_skip x l1 l2 : contains l1 l2 → contains (x :: l1) (x :: l2)
+ | contains_swap x y l : contains (y :: x :: l) (x :: y :: l)
+ | contains_cons x l1 l2 : contains l1 l2 → contains l1 (x :: l2)
+ | contains_trans l1 l2 l3 : contains l1 l2 → contains l2 l3 → contains l1 l3.
+Infix "`contains`" := contains (at level 70) : C_scope.
+Hint Extern 0 (?x `contains` ?y) => reflexivity.
+
+Section contains_dec_help.
+ Context {A} {dec : ∀ x y : A, Decision (x = y)}.
+ Fixpoint list_remove (x : A) (l : list A) : option (list A) :=
+ match l with
+ | [] => None
+ | y :: l => if decide (x = y) then Some l else (y ::) <$> list_remove x l
+ end.
+ Fixpoint list_remove_list (k : list A) (l : list A) : option (list A) :=
+ match k with
+ | [] => Some l | x :: k => list_remove x l ≫= list_remove_list k
+ end.
+End contains_dec_help.
+
+Inductive Forall3 {A B C} (P : A → B → C → Prop) :
+ list A → list B → list C → Prop :=
+ | Forall3_nil : Forall3 P [] [] []
+ | Forall3_cons x y z l k k' :
+ P x y z → Forall3 P l k k' → Forall3 P (x :: l) (y :: k) (z :: k').
+
+(** Set operations on lists *)
+Section list_set.
+ Context {A} {dec : ∀ x y : A, Decision (x = y)}.
+ Global Instance elem_of_list_dec {dec : ∀ x y : A, Decision (x = y)}
+ (x : A) : ∀ l, Decision (x ∈ l).
+ Proof.
+ refine (
+ fix go l :=
+ match l return Decision (x ∈ l) with
+ | [] => right _
+ | y :: l => cast_if_or (decide (x = y)) (go l)
+ end); clear go dec; subst; try (by constructor); abstract by inversion 1.
+ Defined.
+ Fixpoint remove_dups (l : list A) : list A :=
+ match l with
+ | [] => []
+ | x :: l =>
+ if decide_rel (∈) x l then remove_dups l else x :: remove_dups l
+ end.
+ Fixpoint list_difference (l k : list A) : list A :=
+ match l with
+ | [] => []
+ | x :: l =>
+ if decide_rel (∈) x k
+ then list_difference l k else x :: list_difference l k
+ end.
+ Definition list_union (l k : list A) : list A := list_difference l k ++ k.
+ Fixpoint list_intersection (l k : list A) : list A :=
+ match l with
+ | [] => []
+ | x :: l =>
+ if decide_rel (∈) x k
+ then x :: list_intersection l k else list_intersection l k
+ end.
+ Definition list_intersection_with (f : A → A → option A) :
+ list A → list A → list A := fix go l k :=
+ match l with
+ | [] => []
+ | x :: l => foldr (λ y,
+ match f x y with None => id | Some z => (z ::) end) (go l k) k
+ end.
+End list_set.
+
+(** * Basic tactics on lists *)
+(** The tactic [discriminate_list_equality] discharges a goal if it contains
+a list equality involving [(::)] and [(++)] of two lists that have a different
+length as one of its hypotheses. *)
+Tactic Notation "discriminate_list_equality" hyp(H) :=
+ apply (f_equal length) in H;
+ repeat (csimpl in H || rewrite app_length in H); exfalso; lia.
+Tactic Notation "discriminate_list_equality" :=
+ match goal with
+ | H : @eq (list _) _ _ |- _ => discriminate_list_equality H
+ end.
+
+(** The tactic [simplify_list_equality] simplifies hypotheses involving
+equalities on lists using injectivity of [(::)] and [(++)]. Also, it simplifies
+lookups in singleton lists. *)
+Lemma app_injective_1 {A} (l1 k1 l2 k2 : list A) :
+ length l1 = length k1 → l1 ++ l2 = k1 ++ k2 → l1 = k1 ∧ l2 = k2.
+Proof. revert k1. induction l1; intros [|??]; naive_solver. Qed.
+Lemma app_injective_2 {A} (l1 k1 l2 k2 : list A) :
+ length l2 = length k2 → l1 ++ l2 = k1 ++ k2 → l1 = k1 ∧ l2 = k2.
+Proof.
+ intros ? Hl. apply app_injective_1; auto.
+ apply (f_equal length) in Hl. rewrite !app_length in Hl. lia.
+Qed.
+Ltac simplify_list_equality :=
+ repeat match goal with
+ | _ => progress simplify_equality'
+ | H : _ ++ _ = _ ++ _ |- _ => first
+ [ apply app_inv_head in H | apply app_inv_tail in H
+ | apply app_injective_1 in H; [destruct H|done]
+ | apply app_injective_2 in H; [destruct H|done] ]
+ | H : [?x] !! ?i = Some ?y |- _ =>
+ destruct i; [change (Some x = Some y) in H | discriminate]
+ end.
+
+(** * General theorems *)
+Section general_properties.
+Context {A : Type}.
+Implicit Types x y z : A.
+Implicit Types l k : list A.
+
+Section setoid.
+ Context `{Equiv A} `{!Equivalence ((≡) : relation A)}.
+ Global Instance map_equivalence : Equivalence ((≡) : relation (list A)).
+ Proof.
+ split.
+ * intros l; induction l; constructor; auto.
+ * induction 1; constructor; auto.
+ * intros l1 l2 l3 Hl; revert l3.
+ induction Hl; inversion_clear 1; constructor; try etransitivity; eauto.
+ Qed.
+ Global Instance cons_proper : Proper ((≡) ==> (≡) ==> (≡)) (@cons A).
+ Proof. by constructor. Qed.
+ Global Instance app_proper : Proper ((≡) ==> (≡) ==> (≡)) (@app A).
+ Proof.
+ induction 1 as [|x y l k ?? IH]; intros ?? Htl; simpl; auto.
+ by apply cons_equiv, IH.
+ Qed.
+ Global Instance list_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (list A).
+ Proof. induction 1; f_equal; fold_leibniz; auto. Qed.
+End setoid.
+
+Global Instance: Injective2 (=) (=) (=) (@cons A).
+Proof. by injection 1. Qed.
+Global Instance: ∀ k, Injective (=) (=) (k ++).
+Proof. intros ???. apply app_inv_head. Qed.
+Global Instance: ∀ k, Injective (=) (=) (++ k).
+Proof. intros ???. apply app_inv_tail. Qed.
+Global Instance: Associative (=) (@app A).
+Proof. intros ???. apply app_assoc. Qed.
+Global Instance: LeftId (=) [] (@app A).
+Proof. done. Qed.
+Global Instance: RightId (=) [] (@app A).
+Proof. intro. apply app_nil_r. Qed.
+
+Lemma app_nil l1 l2 : l1 ++ l2 = [] ↔ l1 = [] ∧ l2 = [].
+Proof. split. apply app_eq_nil. by intros [-> ->]. Qed.
+Lemma app_singleton l1 l2 x :
+ l1 ++ l2 = [x] ↔ l1 = [] ∧ l2 = [x] ∨ l1 = [x] ∧ l2 = [].
+Proof. split. apply app_eq_unit. by intros [[-> ->]|[-> ->]]. Qed.
+Lemma cons_middle x l1 l2 : l1 ++ x :: l2 = l1 ++ [x] ++ l2.
+Proof. done. Qed.
+Lemma list_eq l1 l2 : (∀ i, l1 !! i = l2 !! i) → l1 = l2.
+Proof.
+ revert l2. induction l1; intros [|??] H.
+ * done.
+ * discriminate (H 0).
+ * discriminate (H 0).
+ * f_equal; [by injection (H 0)|]. apply (IHl1 _ $ λ i, H (S i)).
+Qed.
+Global Instance list_eq_dec {dec : ∀ x y, Decision (x = y)} : ∀ l k,
+ Decision (l = k) := list_eq_dec dec.
+Global Instance list_eq_nil_dec l : Decision (l = []).
+Proof. by refine match l with [] => left _ | _ => right _ end. Defined.
+Lemma list_singleton_reflect l :
+ option_reflect (λ x, l = [x]) (length l ≠1) (list_singleton l).
+Proof. by destruct l as [|? []]; constructor. Defined.
+
+Definition nil_length : length (@nil A) = 0 := eq_refl.
+Definition cons_length x l : length (x :: l) = S (length l) := eq_refl.
+Lemma nil_or_length_pos l : l = [] ∨ length l ≠0.
+Proof. destruct l; simpl; auto with lia. Qed.
+Lemma nil_length_inv l : length l = 0 → l = [].
+Proof. by destruct l. Qed.
+Lemma lookup_nil i : @nil A !! i = None.
+Proof. by destruct i. Qed.
+Lemma lookup_tail l i : tail l !! i = l !! S i.
+Proof. by destruct l. Qed.
+Lemma lookup_lt_Some l i x : l !! i = Some x → i < length l.
+Proof.
+ revert i. induction l; intros [|?] ?; simplify_equality'; auto with arith.
+Qed.
+Lemma lookup_lt_is_Some_1 l i : is_Some (l !! i) → i < length l.
+Proof. intros [??]; eauto using lookup_lt_Some. Qed.
+Lemma lookup_lt_is_Some_2 l i : i < length l → is_Some (l !! i).
+Proof.
+ revert i. induction l; intros [|?] ?; simplify_equality'; eauto with lia.
+Qed.
+Lemma lookup_lt_is_Some l i : is_Some (l !! i) ↔ i < length l.
+Proof. split; auto using lookup_lt_is_Some_1, lookup_lt_is_Some_2. Qed.
+Lemma lookup_ge_None l i : l !! i = None ↔ length l ≤ i.
+Proof. rewrite eq_None_not_Some, lookup_lt_is_Some. lia. Qed.
+Lemma lookup_ge_None_1 l i : l !! i = None → length l ≤ i.
+Proof. by rewrite lookup_ge_None. Qed.
+Lemma lookup_ge_None_2 l i : length l ≤ i → l !! i = None.
+Proof. by rewrite lookup_ge_None. Qed.
+Lemma list_eq_same_length l1 l2 n :
+ length l2 = n → length l1 = n →
+ (∀ i x y, i < n → l1 !! i = Some x → l2 !! i = Some y → x = y) → l1 = l2.
+Proof.
+ intros <- Hlen Hl; apply list_eq; intros i. destruct (l2 !! i) as [x|] eqn:Hx.
+ * destruct (lookup_lt_is_Some_2 l1 i) as [y Hy].
+ { rewrite Hlen; eauto using lookup_lt_Some. }
+ rewrite Hy; f_equal; apply (Hl i); eauto using lookup_lt_Some.
+ * by rewrite lookup_ge_None, Hlen, <-lookup_ge_None.
+Qed.
+Lemma lookup_app_l l1 l2 i : i < length l1 → (l1 ++ l2) !! i = l1 !! i.
+Proof. revert i. induction l1; intros [|?]; simpl; auto with lia. Qed.
+Lemma lookup_app_l_Some l1 l2 i x : l1 !! i = Some x → (l1 ++ l2) !! i = Some x.
+Proof. intros. rewrite lookup_app_l; eauto using lookup_lt_Some. Qed.
+Lemma lookup_app_r l1 l2 i :
+ length l1 ≤ i → (l1 ++ l2) !! i = l2 !! (i - length l1).
+Proof. revert i. induction l1; intros [|?]; simpl; auto with lia. Qed.
+Lemma lookup_app_Some l1 l2 i x :
+ (l1 ++ l2) !! i = Some x ↔
+ l1 !! i = Some x ∨ length l1 ≤ i ∧ l2 !! (i - length l1) = Some x.
+Proof.
+ split.
+ * revert i. induction l1 as [|y l1 IH]; intros [|i] ?;
+ simplify_equality'; auto with lia.
+ destruct (IH i) as [?|[??]]; auto with lia.
+ * intros [?|[??]]; auto using lookup_app_l_Some. by rewrite lookup_app_r.
+Qed.
+Lemma list_lookup_middle l1 l2 x n :
+ n = length l1 → (l1 ++ x :: l2) !! n = Some x.
+Proof. intros ->. by induction l1. Qed.
+
+Lemma list_insert_alter l i x : <[i:=x]>l = alter (λ _, x) i l.
+Proof. by revert i; induction l; intros []; intros; f_equal'. Qed.
+Lemma alter_length f l i : length (alter f i l) = length l.
+Proof. revert i. by induction l; intros [|?]; f_equal'. Qed.
+Lemma insert_length l i x : length (<[i:=x]>l) = length l.
+Proof. revert i. by induction l; intros [|?]; f_equal'. Qed.
+Lemma list_lookup_alter f l i : alter f i l !! i = f <$> l !! i.
+Proof. revert i. induction l. done. intros [|i]. done. apply (IHl i). Qed.
+Lemma list_lookup_alter_ne f l i j : i ≠j → alter f i l !! j = l !! j.
+Proof.
+ revert i j. induction l; [done|]. intros [][] ?; csimpl; auto with congruence.
+Qed.
+Lemma list_lookup_insert l i x : i < length l → <[i:=x]>l !! i = Some x.
+Proof. revert i. induction l; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma list_lookup_insert_ne l i j x : i ≠j → <[i:=x]>l !! j = l !! j.
+Proof.
+ revert i j. induction l; [done|]. intros [] [] ?; simpl; auto with congruence.
+Qed.
+Lemma list_lookup_insert_Some l i x j y :
+ <[i:=x]>l !! j = Some y ↔
+ i = j ∧ x = y ∧ j < length l ∨ i ≠j ∧ l !! j = Some y.
+Proof.
+ destruct (decide (i = j)) as [->|];
+ [split|rewrite list_lookup_insert_ne by done; tauto].
+ * intros Hy. assert (j < length l).
+ { rewrite <-(insert_length l j x); eauto using lookup_lt_Some. }
+ rewrite list_lookup_insert in Hy by done; naive_solver.
+ * intros [(?&?&?)|[??]]; rewrite ?list_lookup_insert; naive_solver.
+Qed.
+Lemma list_insert_commute l i j x y :
+ i ≠j → <[i:=x]>(<[j:=y]>l) = <[j:=y]>(<[i:=x]>l).
+Proof. revert i j. by induction l; intros [|?] [|?] ?; f_equal'; auto. Qed.
+Lemma list_lookup_other l i x :
+ length l ≠1 → l !! i = Some x → ∃ j y, j ≠i ∧ l !! j = Some y.
+Proof.
+ intros. destruct i, l as [|x0 [|x1 l]]; simplify_equality'.
+ * by exists 1, x1.
+ * by exists 0, x0.
+Qed.
+Lemma alter_app_l f l1 l2 i :
+ i < length l1 → alter f i (l1 ++ l2) = alter f i l1 ++ l2.
+Proof. revert i. induction l1; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma alter_app_r f l1 l2 i :
+ alter f (length l1 + i) (l1 ++ l2) = l1 ++ alter f i l2.
+Proof. revert i. induction l1; intros [|?]; f_equal'; auto. Qed.
+Lemma alter_app_r_alt f l1 l2 i :
+ length l1 ≤ i → alter f i (l1 ++ l2) = l1 ++ alter f (i - length l1) l2.
+Proof.
+ intros. assert (i = length l1 + (i - length l1)) as Hi by lia.
+ rewrite Hi at 1. by apply alter_app_r.
+Qed.
+Lemma list_alter_id f l i : (∀ x, f x = x) → alter f i l = l.
+Proof. intros ?. revert i. induction l; intros [|?]; f_equal'; auto. Qed.
+Lemma list_alter_ext f g l k i :
+ (∀ x, l !! i = Some x → f x = g x) → l = k → alter f i l = alter g i k.
+Proof. intros H ->. revert i H. induction k; intros [|?] ?; f_equal'; auto. Qed.
+Lemma list_alter_compose f g l i :
+ alter (f ∘ g) i l = alter f i (alter g i l).
+Proof. revert i. induction l; intros [|?]; f_equal'; auto. Qed.
+Lemma list_alter_commute f g l i j :
+ i ≠j → alter f i (alter g j l) = alter g j (alter f i l).
+Proof. revert i j. induction l; intros [|?][|?] ?; f_equal'; auto with lia. Qed.
+Lemma insert_app_l l1 l2 i x :
+ i < length l1 → <[i:=x]>(l1 ++ l2) = <[i:=x]>l1 ++ l2.
+Proof. revert i. induction l1; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma insert_app_r l1 l2 i x : <[length l1+i:=x]>(l1 ++ l2) = l1 ++ <[i:=x]>l2.
+Proof. revert i. induction l1; intros [|?]; f_equal'; auto. Qed.
+Lemma insert_app_r_alt l1 l2 i x :
+ length l1 ≤ i → <[i:=x]>(l1 ++ l2) = l1 ++ <[i - length l1:=x]>l2.
+Proof.
+ intros. assert (i = length l1 + (i - length l1)) as Hi by lia.
+ rewrite Hi at 1. by apply insert_app_r.
+Qed.
+Lemma delete_middle l1 l2 x : delete (length l1) (l1 ++ x :: l2) = l1 ++ l2.
+Proof. induction l1; f_equal'; auto. Qed.
+
+Lemma inserts_length l i k : length (list_inserts i k l) = length l.
+Proof.
+ revert i. induction k; intros ?; csimpl; rewrite ?insert_length; auto.
+Qed.
+Lemma list_lookup_inserts l i k j :
+ i ≤ j < i + length k → j < length l →
+ list_inserts i k l !! j = k !! (j - i).
+Proof.
+ revert i j. induction k as [|y k IH]; csimpl; intros i j ??; [lia|].
+ destruct (decide (i = j)) as [->|].
+ { by rewrite list_lookup_insert, Nat.sub_diag
+ by (rewrite inserts_length; lia). }
+ rewrite list_lookup_insert_ne, IH by lia.
+ by replace (j - i) with (S (j - S i)) by lia.
+Qed.
+Lemma list_lookup_inserts_lt l i k j :
+ j < i → list_inserts i k l !! j = l !! j.
+Proof.
+ revert i j. induction k; intros i j ?; csimpl;
+ rewrite ?list_lookup_insert_ne by lia; auto with lia.
+Qed.
+Lemma list_lookup_inserts_ge l i k j :
+ i + length k ≤ j → list_inserts i k l !! j = l !! j.
+Proof.
+ revert i j. induction k; csimpl; intros i j ?;
+ rewrite ?list_lookup_insert_ne by lia; auto with lia.
+Qed.
+Lemma list_lookup_inserts_Some l i k j y :
+ list_inserts i k l !! j = Some y ↔
+ (j < i ∨ i + length k ≤ j) ∧ l !! j = Some y ∨
+ i ≤ j < i + length k ∧ j < length l ∧ k !! (j - i) = Some y.
+Proof.
+ destruct (decide (j < i)).
+ { rewrite list_lookup_inserts_lt by done; intuition lia. }
+ destruct (decide (i + length k ≤ j)).
+ { rewrite list_lookup_inserts_ge by done; intuition lia. }
+ split.
+ * intros Hy. assert (j < length l).
+ { rewrite <-(inserts_length l i k); eauto using lookup_lt_Some. }
+ rewrite list_lookup_inserts in Hy by lia. intuition lia.
+ * intuition. by rewrite list_lookup_inserts by lia.
+Qed.
+Lemma list_insert_inserts_lt l i j x k :
+ i < j → <[i:=x]>(list_inserts j k l) = list_inserts j k (<[i:=x]>l).
+Proof.
+ revert i j. induction k; intros i j ?; simpl;
+ rewrite 1?list_insert_commute by lia; auto with f_equal.
+Qed.
+
+(** ** Properties of the [elem_of] predicate *)
+Lemma not_elem_of_nil x : x ∉ [].
+Proof. by inversion 1. Qed.
+Lemma elem_of_nil x : x ∈ [] ↔ False.
+Proof. intuition. by destruct (not_elem_of_nil x). Qed.
+Lemma elem_of_nil_inv l : (∀ x, x ∉ l) → l = [].
+Proof. destruct l. done. by edestruct 1; constructor. Qed.
+Lemma elem_of_not_nil x l : x ∈ l → l ≠[].
+Proof. intros ? ->. by apply (elem_of_nil x). Qed.
+Lemma elem_of_cons l x y : x ∈ y :: l ↔ x = y ∨ x ∈ l.
+Proof. by split; [inversion 1; subst|intros [->|?]]; constructor. Qed.
+Lemma not_elem_of_cons l x y : x ∉ y :: l ↔ x ≠y ∧ x ∉ l.
+Proof. rewrite elem_of_cons. tauto. Qed.
+Lemma elem_of_app l1 l2 x : x ∈ l1 ++ l2 ↔ x ∈ l1 ∨ x ∈ l2.
+Proof.
+ induction l1.
+ * split; [by right|]. intros [Hx|]; [|done]. by destruct (elem_of_nil x).
+ * simpl. rewrite !elem_of_cons, IHl1. tauto.
+Qed.
+Lemma not_elem_of_app l1 l2 x : x ∉ l1 ++ l2 ↔ x ∉ l1 ∧ x ∉ l2.
+Proof. rewrite elem_of_app. tauto. Qed.
+Lemma elem_of_list_singleton x y : x ∈ [y] ↔ x = y.
+Proof. rewrite elem_of_cons, elem_of_nil. tauto. Qed.
+Global Instance elem_of_list_permutation_proper x : Proper ((≡ₚ) ==> iff) (x ∈).
+Proof. induction 1; rewrite ?elem_of_nil, ?elem_of_cons; intuition. Qed.
+Lemma elem_of_list_split l x : x ∈ l → ∃ l1 l2, l = l1 ++ x :: l2.
+Proof.
+ induction 1 as [x l|x y l ? [l1 [l2 ->]]]; [by eexists [], l|].
+ by exists (y :: l1), l2.
+Qed.
+Lemma elem_of_list_lookup_1 l x : x ∈ l → ∃ i, l !! i = Some x.
+Proof.
+ induction 1 as [|???? IH]; [by exists 0 |].
+ destruct IH as [i ?]; auto. by exists (S i).
+Qed.
+Lemma elem_of_list_lookup_2 l i x : l !! i = Some x → x ∈ l.
+Proof.
+ revert i. induction l; intros [|i] ?; simplify_equality'; constructor; eauto.
+Qed.
+Lemma elem_of_list_lookup l x : x ∈ l ↔ ∃ i, l !! i = Some x.
+Proof. firstorder eauto using elem_of_list_lookup_1, elem_of_list_lookup_2. Qed.
+Lemma elem_of_list_omap {B} (f : A → option B) l (y : B) :
+ y ∈ omap f l ↔ ∃ x, x ∈ l ∧ f x = Some y.
+Proof.
+ split.
+ * induction l as [|x l]; csimpl; repeat case_match; inversion 1; subst;
+ setoid_rewrite elem_of_cons; naive_solver.
+ * intros (x&Hx&?). by induction Hx; csimpl; repeat case_match;
+ simplify_equality; try constructor; auto.
+Qed.
+
+(** ** Properties of the [NoDup] predicate *)
+Lemma NoDup_nil : NoDup (@nil A) ↔ True.
+Proof. split; constructor. Qed.
+Lemma NoDup_cons x l : NoDup (x :: l) ↔ x ∉ l ∧ NoDup l.
+Proof. split. by inversion 1. intros [??]. by constructor. Qed.
+Lemma NoDup_cons_11 x l : NoDup (x :: l) → x ∉ l.
+Proof. rewrite NoDup_cons. by intros [??]. Qed.
+Lemma NoDup_cons_12 x l : NoDup (x :: l) → NoDup l.
+Proof. rewrite NoDup_cons. by intros [??]. Qed.
+Lemma NoDup_singleton x : NoDup [x].
+Proof. constructor. apply not_elem_of_nil. constructor. Qed.
+Lemma NoDup_app l k : NoDup (l ++ k) ↔ NoDup l ∧ (∀ x, x ∈ l → x ∉ k) ∧ NoDup k.
+Proof.
+ induction l; simpl.
+ * rewrite NoDup_nil. setoid_rewrite elem_of_nil. naive_solver.
+ * rewrite !NoDup_cons.
+ setoid_rewrite elem_of_cons. setoid_rewrite elem_of_app. naive_solver.
+Qed.
+Global Instance NoDup_proper: Proper ((≡ₚ) ==> iff) (@NoDup A).
+Proof.
+ induction 1 as [|x l k Hlk IH | |].
+ * by rewrite !NoDup_nil.
+ * by rewrite !NoDup_cons, IH, Hlk.
+ * rewrite !NoDup_cons, !elem_of_cons. intuition.
+ * intuition.
+Qed.
+Lemma NoDup_lookup l i j x :
+ NoDup l → l !! i = Some x → l !! j = Some x → i = j.
+Proof.
+ intros Hl. revert i j. induction Hl as [|x' l Hx Hl IH].
+ { intros; simplify_equality. }
+ intros [|i] [|j] ??; simplify_equality'; eauto with f_equal;
+ exfalso; eauto using elem_of_list_lookup_2.
+Qed.
+Lemma NoDup_alt l :
+ NoDup l ↔ ∀ i j x, l !! i = Some x → l !! j = Some x → i = j.
+Proof.
+ split; eauto using NoDup_lookup.
+ induction l as [|x l IH]; intros Hl; constructor.
+ * rewrite elem_of_list_lookup. intros [i ?].
+ by feed pose proof (Hl (S i) 0 x); auto.
+ * apply IH. intros i j x' ??. by apply (injective S), (Hl (S i) (S j) x').
+Qed.
+
+Section no_dup_dec.
+ Context `{!∀ x y, Decision (x = y)}.
+ Global Instance NoDup_dec: ∀ l, Decision (NoDup l) :=
+ fix NoDup_dec l :=
+ match l return Decision (NoDup l) with
+ | [] => left NoDup_nil_2
+ | x :: l =>
+ match decide_rel (∈) x l with
+ | left Hin => right (λ H, NoDup_cons_11 _ _ H Hin)
+ | right Hin =>
+ match NoDup_dec l with
+ | left H => left (NoDup_cons_2 _ _ Hin H)
+ | right H => right (H ∘ NoDup_cons_12 _ _)
+ end
+ end
+ end.
+ Lemma elem_of_remove_dups l x : x ∈ remove_dups l ↔ x ∈ l.
+ Proof.
+ split; induction l; simpl; repeat case_decide;
+ rewrite ?elem_of_cons; intuition (simplify_equality; auto).
+ Qed.
+ Lemma NoDup_remove_dups l : NoDup (remove_dups l).
+ Proof.
+ induction l; simpl; repeat case_decide; try constructor; auto.
+ by rewrite elem_of_remove_dups.
+ Qed.
+End no_dup_dec.
+
+(** ** Set operations on lists *)
+Section list_set.
+ Context {dec : ∀ x y, Decision (x = y)}.
+ Lemma elem_of_list_difference l k x : x ∈ list_difference l k ↔ x ∈ l ∧ x ∉ k.
+ Proof.
+ split; induction l; simpl; try case_decide;
+ rewrite ?elem_of_nil, ?elem_of_cons; intuition congruence.
+ Qed.
+ Lemma NoDup_list_difference l k : NoDup l → NoDup (list_difference l k).
+ Proof.
+ induction 1; simpl; try case_decide.
+ * constructor.
+ * done.
+ * constructor. rewrite elem_of_list_difference; intuition. done.
+ Qed.
+ Lemma elem_of_list_union l k x : x ∈ list_union l k ↔ x ∈ l ∨ x ∈ k.
+ Proof.
+ unfold list_union. rewrite elem_of_app, elem_of_list_difference.
+ intuition. case (decide (x ∈ k)); intuition.
+ Qed.
+ Lemma NoDup_list_union l k : NoDup l → NoDup k → NoDup (list_union l k).
+ Proof.
+ intros. apply NoDup_app. repeat split.
+ * by apply NoDup_list_difference.
+ * intro. rewrite elem_of_list_difference. intuition.
+ * done.
+ Qed.
+ Lemma elem_of_list_intersection l k x :
+ x ∈ list_intersection l k ↔ x ∈ l ∧ x ∈ k.
+ Proof.
+ split; induction l; simpl; repeat case_decide;
+ rewrite ?elem_of_nil, ?elem_of_cons; intuition congruence.
+ Qed.
+ Lemma NoDup_list_intersection l k : NoDup l → NoDup (list_intersection l k).
+ Proof.
+ induction 1; simpl; try case_decide.
+ * constructor.
+ * constructor. rewrite elem_of_list_intersection; intuition. done.
+ * done.
+ Qed.
+ Lemma elem_of_list_intersection_with f l k x :
+ x ∈ list_intersection_with f l k ↔ ∃ x1 x2,
+ x1 ∈ l ∧ x2 ∈ k ∧ f x1 x2 = Some x.
+ Proof.
+ split.
+ * induction l as [|x1 l IH]; simpl; [by rewrite elem_of_nil|].
+ intros Hx. setoid_rewrite elem_of_cons.
+ cut ((∃ x2, x2 ∈ k ∧ f x1 x2 = Some x)
+ ∨ x ∈ list_intersection_with f l k); [naive_solver|].
+ clear IH. revert Hx. generalize (list_intersection_with f l k).
+ induction k; simpl; [by auto|].
+ case_match; setoid_rewrite elem_of_cons; naive_solver.
+ * intros (x1&x2&Hx1&Hx2&Hx). induction Hx1 as [x1|x1 ? l ? IH]; simpl.
+ + generalize (list_intersection_with f l k).
+ induction Hx2; simpl; [by rewrite Hx; left |].
+ case_match; simpl; try setoid_rewrite elem_of_cons; auto.
+ + generalize (IH Hx). clear Hx IH Hx2.
+ generalize (list_intersection_with f l k).
+ induction k; simpl; intros; [done|].
+ case_match; simpl; rewrite ?elem_of_cons; auto.
+ Qed.
+End list_set.
+
+(** ** Properties of the [filter] function *)
+Section filter.
+ Context (P : A → Prop) `{∀ x, Decision (P x)}.
+ Lemma elem_of_list_filter l x : x ∈ filter P l ↔ P x ∧ x ∈ l.
+ Proof.
+ unfold filter. induction l; simpl; repeat case_decide;
+ rewrite ?elem_of_nil, ?elem_of_cons; naive_solver.
+ Qed.
+ Lemma NoDup_filter l : NoDup l → NoDup (filter P l).
+ Proof.
+ unfold filter. induction 1; simpl; repeat case_decide;
+ rewrite ?NoDup_nil, ?NoDup_cons, ?elem_of_list_filter; tauto.
+ Qed.
+End filter.
+
+(** ** Properties of the [find] function *)
+Section find.
+ Context (P : A → Prop) `{∀ x, Decision (P x)}.
+ Lemma list_find_Some l i x :
+ list_find P l = Some (i,x) → l !! i = Some x ∧ P x.
+ Proof.
+ revert i; induction l; intros [] ?;
+ repeat (match goal with x : prod _ _ |- _ => destruct x end
+ || simplify_option_equality); eauto.
+ Qed.
+ Lemma list_find_elem_of l x : x ∈ l → P x → is_Some (list_find P l).
+ Proof.
+ induction 1 as [|x y l ? IH]; intros; simplify_option_equality; eauto.
+ by destruct IH as [[i x'] ->]; [|exists (S i, x')].
+ Qed.
+End find.
+
+(** ** Properties of the [reverse] function *)
+Lemma reverse_nil : reverse [] = @nil A.
+Proof. done. Qed.
+Lemma reverse_singleton x : reverse [x] = [x].
+Proof. done. Qed.
+Lemma reverse_cons l x : reverse (x :: l) = reverse l ++ [x].
+Proof. unfold reverse. by rewrite <-!rev_alt. Qed.
+Lemma reverse_snoc l x : reverse (l ++ [x]) = x :: reverse l.
+Proof. unfold reverse. by rewrite <-!rev_alt, rev_unit. Qed.
+Lemma reverse_app l1 l2 : reverse (l1 ++ l2) = reverse l2 ++ reverse l1.
+Proof. unfold reverse. rewrite <-!rev_alt. apply rev_app_distr. Qed.
+Lemma reverse_length l : length (reverse l) = length l.
+Proof. unfold reverse. rewrite <-!rev_alt. apply rev_length. Qed.
+Lemma reverse_involutive l : reverse (reverse l) = l.
+Proof. unfold reverse. rewrite <-!rev_alt. apply rev_involutive. Qed.
+Lemma elem_of_reverse_2 x l : x ∈ l → x ∈ reverse l.
+Proof.
+ induction 1; rewrite reverse_cons, elem_of_app,
+ ?elem_of_list_singleton; intuition.
+Qed.
+Lemma elem_of_reverse x l : x ∈ reverse l ↔ x ∈ l.
+Proof.
+ split; auto using elem_of_reverse_2.
+ intros. rewrite <-(reverse_involutive l). by apply elem_of_reverse_2.
+Qed.
+Global Instance: Injective (=) (=) (@reverse A).
+Proof.
+ intros l1 l2 Hl.
+ by rewrite <-(reverse_involutive l1), <-(reverse_involutive l2), Hl.
+Qed.
+Lemma sum_list_with_app (f : A → nat) l k :
+ sum_list_with f (l ++ k) = sum_list_with f l + sum_list_with f k.
+Proof. induction l; simpl; lia. Qed.
+Lemma sum_list_with_reverse (f : A → nat) l :
+ sum_list_with f (reverse l) = sum_list_with f l.
+Proof.
+ induction l; simpl; rewrite ?reverse_cons, ?sum_list_with_app; simpl; lia.
+Qed.
+
+(** ** Properties of the [last] function *)
+Lemma last_snoc x l : last (l ++ [x]) = Some x.
+Proof. induction l as [|? []]; simpl; auto. Qed.
+Lemma last_reverse l : last (reverse l) = head l.
+Proof. by destruct l as [|x l]; rewrite ?reverse_cons, ?last_snoc. Qed.
+Lemma head_reverse l : head (reverse l) = last l.
+Proof. by rewrite <-last_reverse, reverse_involutive. Qed.
+
+(** ** Properties of the [take] function *)
+Definition take_drop i l : take i l ++ drop i l = l := firstn_skipn i l.
+Lemma take_drop_middle l i x :
+ l !! i = Some x → take i l ++ x :: drop (S i) l = l.
+Proof.
+ revert i x. induction l; intros [|?] ??; simplify_equality'; f_equal; auto.
+Qed.
+Lemma take_nil n : take n (@nil A) = [].
+Proof. by destruct n. Qed.
+Lemma take_app l k : take (length l) (l ++ k) = l.
+Proof. induction l; f_equal'; auto. Qed.
+Lemma take_app_alt l k n : n = length l → take n (l ++ k) = l.
+Proof. intros ->. by apply take_app. Qed.
+Lemma take_app3_alt l1 l2 l3 n : n = length l1 → take n ((l1 ++ l2) ++ l3) = l1.
+Proof. intros ->. by rewrite <-(associative_L (++)), take_app. Qed.
+Lemma take_app_le l k n : n ≤ length l → take n (l ++ k) = take n l.
+Proof. revert n. induction l; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma take_plus_app l k n m :
+ length l = n → take (n + m) (l ++ k) = l ++ take m k.
+Proof. intros <-. induction l; f_equal'; auto. Qed.
+Lemma take_app_ge l k n :
+ length l ≤ n → take n (l ++ k) = l ++ take (n - length l) k.
+Proof. revert n. induction l; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma take_ge l n : length l ≤ n → take n l = l.
+Proof. revert n. induction l; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma take_take l n m : take n (take m l) = take (min n m) l.
+Proof. revert n m. induction l; intros [|?] [|?]; f_equal'; auto. Qed.
+Lemma take_idempotent l n : take n (take n l) = take n l.
+Proof. by rewrite take_take, Min.min_idempotent. Qed.
+Lemma take_length l n : length (take n l) = min n (length l).
+Proof. revert n. induction l; intros [|?]; f_equal'; done. Qed.
+Lemma take_length_le l n : n ≤ length l → length (take n l) = n.
+Proof. rewrite take_length. apply Min.min_l. Qed.
+Lemma take_length_ge l n : length l ≤ n → length (take n l) = length l.
+Proof. rewrite take_length. apply Min.min_r. Qed.
+Lemma take_drop_commute l n m : take n (drop m l) = drop m (take (m + n) l).
+Proof.
+ revert n m. induction l; intros [|?][|?]; simpl; auto using take_nil with lia.
+Qed.
+Lemma lookup_take l n i : i < n → take n l !! i = l !! i.
+Proof. revert n i. induction l; intros [|n] [|i] ?; simpl; auto with lia. Qed.
+Lemma lookup_take_ge l n i : n ≤ i → take n l !! i = None.
+Proof. revert n i. induction l; intros [|?] [|?] ?; simpl; auto with lia. Qed.
+Lemma take_alter f l n i : n ≤ i → take n (alter f i l) = take n l.
+Proof.
+ intros. apply list_eq. intros j. destruct (le_lt_dec n j).
+ * by rewrite !lookup_take_ge.
+ * by rewrite !lookup_take, !list_lookup_alter_ne by lia.
+Qed.
+Lemma take_insert l n i x : n ≤ i → take n (<[i:=x]>l) = take n l.
+Proof.
+ intros. apply list_eq. intros j. destruct (le_lt_dec n j).
+ * by rewrite !lookup_take_ge.
+ * by rewrite !lookup_take, !list_lookup_insert_ne by lia.
+Qed.
+
+(** ** Properties of the [drop] function *)
+Lemma drop_0 l : drop 0 l = l.
+Proof. done. Qed.
+Lemma drop_nil n : drop n (@nil A) = [].
+Proof. by destruct n. Qed.
+Lemma drop_length l n : length (drop n l) = length l - n.
+Proof. revert n. by induction l; intros [|i]; f_equal'. Qed.
+Lemma drop_ge l n : length l ≤ n → drop n l = [].
+Proof. revert n. induction l; intros [|??]; simpl in *; auto with lia. Qed.
+Lemma drop_all l : drop (length l) l = [].
+Proof. by apply drop_ge. Qed.
+Lemma drop_drop l n1 n2 : drop n1 (drop n2 l) = drop (n2 + n1) l.
+Proof. revert n2. induction l; intros [|?]; simpl; rewrite ?drop_nil; auto. Qed.
+Lemma drop_app_le l k n :
+ n ≤ length l → drop n (l ++ k) = drop n l ++ k.
+Proof. revert n. induction l; intros [|?]; simpl; auto with lia. Qed.
+Lemma drop_app l k : drop (length l) (l ++ k) = k.
+Proof. by rewrite drop_app_le, drop_all. Qed.
+Lemma drop_app_alt l k n : n = length l → drop n (l ++ k) = k.
+Proof. intros ->. by apply drop_app. Qed.
+Lemma drop_app3_alt l1 l2 l3 n :
+ n = length l1 → drop n ((l1 ++ l2) ++ l3) = l2 ++ l3.
+Proof. intros ->. by rewrite <-(associative_L (++)), drop_app. Qed.
+Lemma drop_app_ge l k n :
+ length l ≤ n → drop n (l ++ k) = drop (n - length l) k.
+Proof.
+ intros. rewrite <-(Nat.sub_add (length l) n) at 1 by done.
+ by rewrite Nat.add_comm, <-drop_drop, drop_app.
+Qed.
+Lemma drop_plus_app l k n m :
+ length l = n → drop (n + m) (l ++ k) = drop m k.
+Proof. intros <-. by rewrite <-drop_drop, drop_app. Qed.
+Lemma lookup_drop l n i : drop n l !! i = l !! (n + i).
+Proof. revert n i. induction l; intros [|i] ?; simpl; auto. Qed.
+Lemma drop_alter f l n i : i < n → drop n (alter f i l) = drop n l.
+Proof.
+ intros. apply list_eq. intros j.
+ by rewrite !lookup_drop, !list_lookup_alter_ne by lia.
+Qed.
+Lemma drop_insert l n i x : i < n → drop n (<[i:=x]>l) = drop n l.
+Proof.
+ intros. apply list_eq. intros j.
+ by rewrite !lookup_drop, !list_lookup_insert_ne by lia.
+Qed.
+Lemma delete_take_drop l i : delete i l = take i l ++ drop (S i) l.
+Proof. revert i. induction l; intros [|?]; f_equal'; auto. Qed.
+Lemma take_take_drop l n m : take n l ++ take m (drop n l) = take (n + m) l.
+Proof. revert n m. induction l; intros [|?] [|?]; f_equal'; auto. Qed.
+Lemma drop_take_drop l n m : n ≤ m → drop n (take m l) ++ drop m l = drop n l.
+Proof.
+ revert n m. induction l; intros [|?] [|?] ?;
+ f_equal'; auto using take_drop with lia.
+Qed.
+
+(** ** Properties of the [replicate] function *)
+Lemma replicate_length n x : length (replicate n x) = n.
+Proof. induction n; simpl; auto. Qed.
+Lemma lookup_replicate n x y i :
+ replicate n x !! i = Some y ↔ y = x ∧ i < n.
+Proof.
+ split.
+ * revert i. induction n; intros [|?]; naive_solver auto with lia.
+ * intros [-> Hi]. revert i Hi.
+ induction n; intros [|?]; naive_solver auto with lia.
+Qed.
+Lemma lookup_replicate_1 n x y i :
+ replicate n x !! i = Some y → y = x ∧ i < n.
+Proof. by rewrite lookup_replicate. Qed.
+Lemma lookup_replicate_2 n x i : i < n → replicate n x !! i = Some x.
+Proof. by rewrite lookup_replicate. Qed.
+Lemma lookup_replicate_None n x i : n ≤ i ↔ replicate n x !! i = None.
+Proof.
+ rewrite eq_None_not_Some, Nat.le_ngt. split.
+ * intros Hin [x' Hx']; destruct Hin. rewrite lookup_replicate in Hx'; tauto.
+ * intros Hx ?. destruct Hx. exists x; auto using lookup_replicate_2.
+Qed.
+Lemma insert_replicate x n i : <[i:=x]>(replicate n x) = replicate n x.
+Proof. revert i. induction n; intros [|?]; f_equal'; auto. Qed.
+Lemma elem_of_replicate_inv x n y : x ∈ replicate n y → x = y.
+Proof. induction n; simpl; rewrite ?elem_of_nil, ?elem_of_cons; intuition. Qed.
+Lemma replicate_S n x : replicate (S n) x = x :: replicate n x.
+Proof. done. Qed.
+Lemma replicate_plus n m x :
+ replicate (n + m) x = replicate n x ++ replicate m x.
+Proof. induction n; f_equal'; auto. Qed.
+Lemma take_replicate n m x : take n (replicate m x) = replicate (min n m) x.
+Proof. revert m. by induction n; intros [|?]; f_equal'. Qed.
+Lemma take_replicate_plus n m x : take n (replicate (n + m) x) = replicate n x.
+Proof. by rewrite take_replicate, min_l by lia. Qed.
+Lemma drop_replicate n m x : drop n (replicate m x) = replicate (m - n) x.
+Proof. revert m. by induction n; intros [|?]; f_equal'. Qed.
+Lemma drop_replicate_plus n m x : drop n (replicate (n + m) x) = replicate m x.
+Proof. rewrite drop_replicate. f_equal. lia. Qed.
+Lemma replicate_as_elem_of x n l :
+ replicate n x = l ↔ length l = n ∧ ∀ y, y ∈ l → y = x.
+Proof.
+ split; [intros <-; eauto using elem_of_replicate_inv, replicate_length|].
+ intros [<- Hl]. symmetry. induction l as [|y l IH]; f_equal'.
+ * apply Hl. by left.
+ * apply IH. intros ??. apply Hl. by right.
+Qed.
+Lemma reverse_replicate n x : reverse (replicate n x) = replicate n x.
+Proof.
+ symmetry. apply replicate_as_elem_of.
+ rewrite reverse_length, replicate_length. split; auto.
+ intros y. rewrite elem_of_reverse. by apply elem_of_replicate_inv.
+Qed.
+Lemma replicate_false βs n : length βs = n → replicate n false =.>* βs.
+Proof. intros <-. by induction βs; simpl; constructor. Qed.
+
+(** ** Properties of the [resize] function *)
+Lemma resize_spec l n x : resize n x l = take n l ++ replicate (n - length l) x.
+Proof. revert n. induction l; intros [|?]; f_equal'; auto. Qed.
+Lemma resize_0 l x : resize 0 x l = [].
+Proof. by destruct l. Qed.
+Lemma resize_nil n x : resize n x [] = replicate n x.
+Proof. rewrite resize_spec. rewrite take_nil. f_equal'. lia. Qed.
+Lemma resize_ge l n x :
+ length l ≤ n → resize n x l = l ++ replicate (n - length l) x.
+Proof. intros. by rewrite resize_spec, take_ge. Qed.
+Lemma resize_le l n x : n ≤ length l → resize n x l = take n l.
+Proof.
+ intros. rewrite resize_spec, (proj2 (Nat.sub_0_le _ _)) by done.
+ simpl. by rewrite (right_id_L [] (++)).
+Qed.
+Lemma resize_all l x : resize (length l) x l = l.
+Proof. intros. by rewrite resize_le, take_ge. Qed.
+Lemma resize_all_alt l n x : n = length l → resize n x l = l.
+Proof. intros ->. by rewrite resize_all. Qed.
+Lemma resize_plus l n m x :
+ resize (n + m) x l = resize n x l ++ resize m x (drop n l).
+Proof.
+ revert n m. induction l; intros [|?] [|?]; f_equal'; auto.
+ * by rewrite Nat.add_0_r, (right_id_L [] (++)).
+ * by rewrite replicate_plus.
+Qed.
+Lemma resize_plus_eq l n m x :
+ length l = n → resize (n + m) x l = l ++ replicate m x.
+Proof. intros <-. by rewrite resize_plus, resize_all, drop_all, resize_nil. Qed.
+Lemma resize_app_le l1 l2 n x :
+ n ≤ length l1 → resize n x (l1 ++ l2) = resize n x l1.
+Proof.
+ intros. by rewrite !resize_le, take_app_le by (rewrite ?app_length; lia).
+Qed.
+Lemma resize_app l1 l2 n x : n = length l1 → resize n x (l1 ++ l2) = l1.
+Proof. intros ->. by rewrite resize_app_le, resize_all. Qed.
+Lemma resize_app_ge l1 l2 n x :
+ length l1 ≤ n → resize n x (l1 ++ l2) = l1 ++ resize (n - length l1) x l2.
+Proof.
+ intros. rewrite !resize_spec, take_app_ge, (associative_L (++)) by done.
+ do 2 f_equal. rewrite app_length. lia.
+Qed.
+Lemma resize_length l n x : length (resize n x l) = n.
+Proof. rewrite resize_spec, app_length, replicate_length, take_length. lia. Qed.
+Lemma resize_replicate x n m : resize n x (replicate m x) = replicate n x.
+Proof. revert m. induction n; intros [|?]; f_equal'; auto. Qed.
+Lemma resize_resize l n m x : n ≤ m → resize n x (resize m x l) = resize n x l.
+Proof.
+ revert n m. induction l; simpl.
+ * intros. by rewrite !resize_nil, resize_replicate.
+ * intros [|?] [|?] ?; f_equal'; auto with lia.
+Qed.
+Lemma resize_idempotent l n x : resize n x (resize n x l) = resize n x l.
+Proof. by rewrite resize_resize. Qed.
+Lemma resize_take_le l n m x : n ≤ m → resize n x (take m l) = resize n x l.
+Proof. revert n m. induction l; intros [|?][|?] ?; f_equal'; auto with lia. Qed.
+Lemma resize_take_eq l n x : resize n x (take n l) = resize n x l.
+Proof. by rewrite resize_take_le. Qed.
+Lemma take_resize l n m x : take n (resize m x l) = resize (min n m) x l.
+Proof.
+ revert n m. induction l; intros [|?][|?]; f_equal'; auto using take_replicate.
+Qed.
+Lemma take_resize_le l n m x : n ≤ m → take n (resize m x l) = resize n x l.
+Proof. intros. by rewrite take_resize, Min.min_l. Qed.
+Lemma take_resize_eq l n x : take n (resize n x l) = resize n x l.
+Proof. intros. by rewrite take_resize, Min.min_l. Qed.
+Lemma take_resize_plus l n m x : take n (resize (n + m) x l) = resize n x l.
+Proof. by rewrite take_resize, min_l by lia. Qed.
+Lemma drop_resize_le l n m x :
+ n ≤ m → drop n (resize m x l) = resize (m - n) x (drop n l).
+Proof.
+ revert n m. induction l; simpl.
+ * intros. by rewrite drop_nil, !resize_nil, drop_replicate.
+ * intros [|?] [|?] ?; simpl; try case_match; auto with lia.
+Qed.
+Lemma drop_resize_plus l n m x :
+ drop n (resize (n + m) x l) = resize m x (drop n l).
+Proof. rewrite drop_resize_le by lia. f_equal. lia. Qed.
+Lemma lookup_resize l n x i : i < n → i < length l → resize n x l !! i = l !! i.
+Proof.
+ intros ??. destruct (decide (n < length l)).
+ * by rewrite resize_le, lookup_take by lia.
+ * by rewrite resize_ge, lookup_app_l by lia.
+Qed.
+Lemma lookup_resize_new l n x i :
+ length l ≤ i → i < n → resize n x l !! i = Some x.
+Proof.
+ intros ??. rewrite resize_ge by lia.
+ replace i with (length l + (i - length l)) by lia.
+ by rewrite lookup_app_r, lookup_replicate_2 by lia.
+Qed.
+Lemma lookup_resize_old l n x i : n ≤ i → resize n x l !! i = None.
+Proof. intros ?. apply lookup_ge_None_2. by rewrite resize_length. Qed.
+End general_properties.
+
+Section more_general_properties.
+Context {A : Type}.
+Implicit Types x y z : A.
+Implicit Types l k : list A.
+
+(** ** Properties of the [reshape] function *)
+Lemma reshape_length szs l : length (reshape szs l) = length szs.
+Proof. revert l. by induction szs; intros; f_equal'. Qed.
+Lemma join_reshape szs l :
+ sum_list szs = length l → mjoin (reshape szs l) = l.
+Proof.
+ revert l. induction szs as [|sz szs IH]; simpl; intros l Hl; [by destruct l|].
+ by rewrite IH, take_drop by (rewrite drop_length; lia).
+Qed.
+Lemma sum_list_replicate n m : sum_list (replicate m n) = m * n.
+Proof. induction m; simpl; auto. Qed.
+
+(** ** Properties of [sublist_lookup] and [sublist_alter] *)
+Lemma sublist_lookup_length l i n k :
+ sublist_lookup i n l = Some k → length k = n.
+Proof.
+ unfold sublist_lookup; intros; simplify_option_equality.
+ rewrite take_length, drop_length; lia.
+Qed.
+Lemma sublist_lookup_all l n : length l = n → sublist_lookup 0 n l = Some l.
+Proof.
+ intros. unfold sublist_lookup; case_option_guard; [|lia].
+ by rewrite take_ge by (rewrite drop_length; lia).
+Qed.
+Lemma sublist_lookup_Some l i n :
+ i + n ≤ length l → sublist_lookup i n l = Some (take n (drop i l)).
+Proof. by unfold sublist_lookup; intros; simplify_option_equality. Qed.
+Lemma sublist_lookup_None l i n :
+ length l < i + n → sublist_lookup i n l = None.
+Proof. by unfold sublist_lookup; intros; simplify_option_equality by lia. Qed.
+Lemma sublist_eq l k n :
+ (n | length l) → (n | length k) →
+ (∀ i, sublist_lookup (i * n) n l = sublist_lookup (i * n) n k) → l = k.
+Proof.
+ revert l k. assert (∀ l i,
+ n ≠0 → (n | length l) → ¬n * i `div` n + n ≤ length l → length l ≤ i).
+ { intros l i ? [j ->] Hjn. apply Nat.nlt_ge; contradict Hjn.
+ rewrite <-Nat.mul_succ_r, (Nat.mul_comm n).
+ apply Nat.mul_le_mono_r, Nat.le_succ_l, Nat.div_lt_upper_bound; lia. }
+ intros l k Hl Hk Hlookup. destruct (decide (n = 0)) as [->|].
+ { by rewrite (nil_length_inv l),
+ (nil_length_inv k) by eauto using Nat.divide_0_l. }
+ apply list_eq; intros i. specialize (Hlookup (i `div` n)).
+ rewrite (Nat.mul_comm _ n) in Hlookup.
+ unfold sublist_lookup in *; simplify_option_equality;
+ [|by rewrite !lookup_ge_None_2 by auto].
+ apply (f_equal (!! i `mod` n)) in Hlookup.
+ by rewrite !lookup_take, !lookup_drop, <-!Nat.div_mod in Hlookup
+ by (auto using Nat.mod_upper_bound with lia).
+Qed.
+Lemma sublist_eq_same_length l k j n :
+ length l = j * n → length k = j * n →
+ (∀ i,i < j → sublist_lookup (i * n) n l = sublist_lookup (i * n) n k) → l = k.
+Proof.
+ intros Hl Hk ?. destruct (decide (n = 0)) as [->|].
+ { by rewrite (nil_length_inv l), (nil_length_inv k) by lia. }
+ apply sublist_eq with n; [by exists j|by exists j|].
+ intros i. destruct (decide (i < j)); [by auto|].
+ assert (∀ m, m = j * n → m < i * n + n).
+ { intros ? ->. replace (i * n + n) with (S i * n) by lia.
+ apply Nat.mul_lt_mono_pos_r; lia. }
+ by rewrite !sublist_lookup_None by auto.
+Qed.
+Lemma sublist_lookup_reshape l i n m :
+ 0 < n → length l = m * n →
+ reshape (replicate m n) l !! i = sublist_lookup (i * n) n l.
+Proof.
+ intros Hn Hl. unfold sublist_lookup. apply option_eq; intros x; split.
+ * intros Hx. case_option_guard as Hi.
+ { f_equal. clear Hi. revert i l Hl Hx.
+ induction m as [|m IH]; intros [|i] l ??; simplify_equality'; auto.
+ rewrite <-drop_drop. apply IH; rewrite ?drop_length; auto with lia. }
+ destruct Hi. rewrite Hl, <-Nat.mul_succ_l.
+ apply Nat.mul_le_mono_r, Nat.le_succ_l. apply lookup_lt_Some in Hx.
+ by rewrite reshape_length, replicate_length in Hx.
+ * intros Hx. case_option_guard as Hi; simplify_equality'.
+ revert i l Hl Hi. induction m as [|m IH]; [auto with lia|].
+ intros [|i] l ??; simpl; [done|]. rewrite <-drop_drop.
+ rewrite IH; rewrite ?drop_length; auto with lia.
+Qed.
+Lemma sublist_lookup_compose l1 l2 l3 i n j m :
+ sublist_lookup i n l1 = Some l2 → sublist_lookup j m l2 = Some l3 →
+ sublist_lookup (i + j) m l1 = Some l3.
+Proof.
+ unfold sublist_lookup; intros; simplify_option_equality;
+ repeat match goal with
+ | H : _ ≤ length _ |- _ => rewrite take_length, drop_length in H
+ end; rewrite ?take_drop_commute, ?drop_drop, ?take_take,
+ ?Min.min_l, Nat.add_assoc by lia; auto with lia.
+Qed.
+Lemma sublist_alter_length f l i n k :
+ sublist_lookup i n l = Some k → length (f k) = n →
+ length (sublist_alter f i n l) = length l.
+Proof.
+ unfold sublist_alter, sublist_lookup. intros Hk ?; simplify_option_equality.
+ rewrite !app_length, Hk, !take_length, !drop_length; lia.
+Qed.
+Lemma sublist_lookup_alter f l i n k :
+ sublist_lookup i n l = Some k → length (f k) = n →
+ sublist_lookup i n (sublist_alter f i n l) = f <$> sublist_lookup i n l.
+Proof.
+ unfold sublist_lookup. intros Hk ?. erewrite sublist_alter_length by eauto.
+ unfold sublist_alter; simplify_option_equality.
+ by rewrite Hk, drop_app_alt, take_app_alt by (rewrite ?take_length; lia).
+Qed.
+Lemma sublist_lookup_alter_ne f l i j n k :
+ sublist_lookup j n l = Some k → length (f k) = n → i + n ≤ j ∨ j + n ≤ i →
+ sublist_lookup i n (sublist_alter f j n l) = sublist_lookup i n l.
+Proof.
+ unfold sublist_lookup. intros Hk Hi ?. erewrite sublist_alter_length by eauto.
+ unfold sublist_alter; simplify_option_equality; f_equal; rewrite Hk.
+ apply list_eq; intros ii.
+ destruct (decide (ii < length (f k))); [|by rewrite !lookup_take_ge by lia].
+ rewrite !lookup_take, !lookup_drop by done. destruct (decide (i + ii < j)).
+ { by rewrite lookup_app_l, lookup_take by (rewrite ?take_length; lia). }
+ rewrite lookup_app_r by (rewrite take_length; lia).
+ rewrite take_length_le, lookup_app_r, lookup_drop by lia. f_equal; lia.
+Qed.
+Lemma sublist_alter_all f l n : length l = n → sublist_alter f 0 n l = f l.
+Proof.
+ intros <-. unfold sublist_alter; simpl.
+ by rewrite drop_all, (right_id_L [] (++)), take_ge.
+Qed.
+Lemma sublist_alter_compose f g l i n k :
+ sublist_lookup i n l = Some k → length (f k) = n → length (g k) = n →
+ sublist_alter (f ∘ g) i n l = sublist_alter f i n (sublist_alter g i n l).
+Proof.
+ unfold sublist_alter, sublist_lookup. intros Hk ??; simplify_option_equality.
+ by rewrite !take_app_alt, drop_app_alt, !(associative_L (++)), drop_app_alt,
+ take_app_alt by (rewrite ?app_length, ?take_length, ?Hk; lia).
+Qed.
+
+(** ** Properties of the [mask] function *)
+Lemma mask_nil f βs : mask f βs (@nil A) = [].
+Proof. by destruct βs. Qed.
+Lemma mask_length f βs l : length (mask f βs l) = length l.
+Proof. revert βs. induction l; intros [|??]; f_equal'; auto. Qed.
+Lemma mask_true f l n : length l ≤ n → mask f (replicate n true) l = f <$> l.
+Proof. revert n. induction l; intros [|?] ?; f_equal'; auto with lia. Qed.
+Lemma mask_false f l n : mask f (replicate n false) l = l.
+Proof. revert l. induction n; intros [|??]; f_equal'; auto. Qed.
+Lemma mask_app f βs1 βs2 l :
+ mask f (βs1 ++ βs2) l
+ = mask f βs1 (take (length βs1) l) ++ mask f βs2 (drop (length βs1) l).
+Proof. revert l. induction βs1;intros [|??]; f_equal'; auto using mask_nil. Qed.
+Lemma mask_app_2 f βs l1 l2 :
+ mask f βs (l1 ++ l2)
+ = mask f (take (length l1) βs) l1 ++ mask f (drop (length l1) βs) l2.
+Proof. revert βs. induction l1; intros [|??]; f_equal'; auto. Qed.
+Lemma take_mask f βs l n : take n (mask f βs l) = mask f (take n βs) (take n l).
+Proof. revert n βs. induction l; intros [|?] [|[] ?]; f_equal'; auto. Qed.
+Lemma drop_mask f βs l n : drop n (mask f βs l) = mask f (drop n βs) (drop n l).
+Proof.
+ revert n βs. induction l; intros [|?] [|[] ?]; f_equal'; auto using mask_nil.
+Qed.
+Lemma sublist_lookup_mask f βs l i n :
+ sublist_lookup i n (mask f βs l)
+ = mask f (take n (drop i βs)) <$> sublist_lookup i n l.
+Proof.
+ unfold sublist_lookup; rewrite mask_length; simplify_option_equality; auto.
+ by rewrite drop_mask, take_mask.
+Qed.
+Lemma mask_mask f g βs1 βs2 l :
+ (∀ x, f (g x) = f x) → βs1 =.>* βs2 →
+ mask f βs2 (mask g βs1 l) = mask f βs2 l.
+Proof.
+ intros ? Hβs. revert l. by induction Hβs as [|[] []]; intros [|??]; f_equal'.
+Qed.
+Lemma lookup_mask f βs l i :
+ βs !! i = Some true → mask f βs l !! i = f <$> l !! i.
+Proof.
+ revert i βs. induction l; intros [] [] ?; simplify_equality'; f_equal; auto.
+Qed.
+Lemma lookup_mask_notin f βs l i :
+ βs !! i ≠Some true → mask f βs l !! i = l !! i.
+Proof.
+ revert i βs. induction l; intros [] [|[]] ?; simplify_equality'; auto.
+Qed.
+
+(** ** Properties of the [seq] function *)
+Lemma fmap_seq j n : S <$> seq j n = seq (S j) n.
+Proof. revert j. induction n; intros; f_equal'; auto. Qed.
+Lemma lookup_seq j n i : i < n → seq j n !! i = Some (j + i).
+Proof.
+ revert j i. induction n as [|n IH]; intros j [|i] ?; simpl; auto with lia.
+ rewrite IH; auto with lia.
+Qed.
+Lemma lookup_seq_ge j n i : n ≤ i → seq j n !! i = None.
+Proof. revert j i. induction n; intros j [|i] ?; simpl; auto with lia. Qed.
+Lemma lookup_seq_inv j n i j' : seq j n !! i = Some j' → j' = j + i ∧ i < n.
+Proof.
+ destruct (le_lt_dec n i); [by rewrite lookup_seq_ge|].
+ rewrite lookup_seq by done. intuition congruence.
+Qed.
+
+(** ** Properties of the [Permutation] predicate *)
+Lemma Permutation_nil l : l ≡ₚ [] ↔ l = [].
+Proof. split. by intro; apply Permutation_nil. by intros ->. Qed.
+Lemma Permutation_singleton l x : l ≡ₚ [x] ↔ l = [x].
+Proof. split. by intro; apply Permutation_length_1_inv. by intros ->. Qed.
+Definition Permutation_skip := @perm_skip A.
+Definition Permutation_swap := @perm_swap A.
+Definition Permutation_singleton_inj := @Permutation_length_1 A.
+
+Global Existing Instance Permutation_app'.
+Global Instance: Proper ((≡ₚ) ==> (=)) (@length A).
+Proof. induction 1; simpl; auto with lia. Qed.
+Global Instance: Commutative (≡ₚ) (@app A).
+Proof.
+ intros l1. induction l1 as [|x l1 IH]; intros l2; simpl.
+ * by rewrite (right_id_L [] (++)).
+ * rewrite Permutation_middle, IH. simpl. by rewrite Permutation_middle.
+Qed.
+Global Instance: ∀ x : A, Injective (≡ₚ) (≡ₚ) (x ::).
+Proof. red. eauto using Permutation_cons_inv. Qed.
+Global Instance: ∀ k : list A, Injective (≡ₚ) (≡ₚ) (k ++).
+Proof.
+ red. induction k as [|x k IH]; intros l1 l2; simpl; auto.
+ intros. by apply IH, (injective (x ::)).
+Qed.
+Global Instance: ∀ k : list A, Injective (≡ₚ) (≡ₚ) (++ k).
+Proof.
+ intros k l1 l2. rewrite !(commutative (++) _ k). by apply (injective (k ++)).
+Qed.
+Lemma replicate_Permutation n x l : replicate n x ≡ₚ l → replicate n x = l.
+Proof.
+ intros Hl. apply replicate_as_elem_of. split.
+ * by rewrite <-Hl, replicate_length.
+ * intros y. rewrite <-Hl. by apply elem_of_replicate_inv.
+Qed.
+Lemma reverse_Permutation l : reverse l ≡ₚ l.
+Proof.
+ induction l as [|x l IH]; [done|].
+ by rewrite reverse_cons, (commutative (++)), IH.
+Qed.
+Lemma delete_Permutation l i x : l !! i = Some x → l ≡ₚ x :: delete i l.
+Proof.
+ revert i; induction l as [|y l IH]; intros [|i] ?; simplify_equality'; auto.
+ by rewrite Permutation_swap, <-(IH i).
+Qed.
+
+(** ** Properties of the [prefix_of] and [suffix_of] predicates *)
+Global Instance: PreOrder (@prefix_of A).
+Proof.
+ split.
+ * intros ?. eexists []. by rewrite (right_id_L [] (++)).
+ * intros ???[k1->] [k2->]. exists (k1 ++ k2). by rewrite (associative_L (++)).
+Qed.
+Lemma prefix_of_nil l : [] `prefix_of` l.
+Proof. by exists l. Qed.
+Lemma prefix_of_nil_not x l : ¬x :: l `prefix_of` [].
+Proof. by intros [k ?]. Qed.
+Lemma prefix_of_cons x l1 l2 : l1 `prefix_of` l2 → x :: l1 `prefix_of` x :: l2.
+Proof. intros [k ->]. by exists k. Qed.
+Lemma prefix_of_cons_alt x y l1 l2 :
+ x = y → l1 `prefix_of` l2 → x :: l1 `prefix_of` y :: l2.
+Proof. intros ->. apply prefix_of_cons. Qed.
+Lemma prefix_of_cons_inv_1 x y l1 l2 : x :: l1 `prefix_of` y :: l2 → x = y.
+Proof. by intros [k ?]; simplify_equality'. Qed.
+Lemma prefix_of_cons_inv_2 x y l1 l2 :
+ x :: l1 `prefix_of` y :: l2 → l1 `prefix_of` l2.
+Proof. intros [k ?]; simplify_equality'. by exists k. Qed.
+Lemma prefix_of_app k l1 l2 : l1 `prefix_of` l2 → k ++ l1 `prefix_of` k ++ l2.
+Proof. intros [k' ->]. exists k'. by rewrite (associative_L (++)). Qed.
+Lemma prefix_of_app_alt k1 k2 l1 l2 :
+ k1 = k2 → l1 `prefix_of` l2 → k1 ++ l1 `prefix_of` k2 ++ l2.
+Proof. intros ->. apply prefix_of_app. Qed.
+Lemma prefix_of_app_l l1 l2 l3 : l1 ++ l3 `prefix_of` l2 → l1 `prefix_of` l2.
+Proof. intros [k ->]. exists (l3 ++ k). by rewrite (associative_L (++)). Qed.
+Lemma prefix_of_app_r l1 l2 l3 : l1 `prefix_of` l2 → l1 `prefix_of` l2 ++ l3.
+Proof. intros [k ->]. exists (k ++ l3). by rewrite (associative_L (++)). Qed.
+Lemma prefix_of_length l1 l2 : l1 `prefix_of` l2 → length l1 ≤ length l2.
+Proof. intros [? ->]. rewrite app_length. lia. Qed.
+Lemma prefix_of_snoc_not l x : ¬l ++ [x] `prefix_of` l.
+Proof. intros [??]. discriminate_list_equality. Qed.
+Global Instance: PreOrder (@suffix_of A).
+Proof.
+ split.
+ * intros ?. by eexists [].
+ * intros ???[k1->] [k2->]. exists (k2 ++ k1). by rewrite (associative_L (++)).
+Qed.
+Global Instance prefix_of_dec `{∀ x y, Decision (x = y)} : ∀ l1 l2,
+ Decision (l1 `prefix_of` l2) := fix go l1 l2 :=
+ match l1, l2 return { l1 `prefix_of` l2 } + { ¬l1 `prefix_of` l2 } with
+ | [], _ => left (prefix_of_nil _)
+ | _, [] => right (prefix_of_nil_not _ _)
+ | x :: l1, y :: l2 =>
+ match decide_rel (=) x y with
+ | left Hxy =>
+ match go l1 l2 with
+ | left Hl1l2 => left (prefix_of_cons_alt _ _ _ _ Hxy Hl1l2)
+ | right Hl1l2 => right (Hl1l2 ∘ prefix_of_cons_inv_2 _ _ _ _)
+ end
+ | right Hxy => right (Hxy ∘ prefix_of_cons_inv_1 _ _ _ _)
+ end
+ end.
+
+Section prefix_ops.
+ Context `{∀ x y, Decision (x = y)}.
+ Lemma max_prefix_of_fst l1 l2 :
+ l1 = (max_prefix_of l1 l2).2 ++ (max_prefix_of l1 l2).1.1.
+ Proof.
+ revert l2. induction l1; intros [|??]; simpl;
+ repeat case_decide; f_equal'; auto.
+ Qed.
+ Lemma max_prefix_of_fst_alt l1 l2 k1 k2 k3 :
+ max_prefix_of l1 l2 = (k1, k2, k3) → l1 = k3 ++ k1.
+ Proof.
+ intros. pose proof (max_prefix_of_fst l1 l2).
+ by destruct (max_prefix_of l1 l2) as [[]?]; simplify_equality.
+ Qed.
+ Lemma max_prefix_of_fst_prefix l1 l2 : (max_prefix_of l1 l2).2 `prefix_of` l1.
+ Proof. eexists. apply max_prefix_of_fst. Qed.
+ Lemma max_prefix_of_fst_prefix_alt l1 l2 k1 k2 k3 :
+ max_prefix_of l1 l2 = (k1, k2, k3) → k3 `prefix_of` l1.
+ Proof. eexists. eauto using max_prefix_of_fst_alt. Qed.
+ Lemma max_prefix_of_snd l1 l2 :
+ l2 = (max_prefix_of l1 l2).2 ++ (max_prefix_of l1 l2).1.2.
+ Proof.
+ revert l2. induction l1; intros [|??]; simpl;
+ repeat case_decide; f_equal'; auto.
+ Qed.
+ Lemma max_prefix_of_snd_alt l1 l2 k1 k2 k3 :
+ max_prefix_of l1 l2 = (k1, k2, k3) → l2 = k3 ++ k2.
+ Proof.
+ intro. pose proof (max_prefix_of_snd l1 l2).
+ by destruct (max_prefix_of l1 l2) as [[]?]; simplify_equality.
+ Qed.
+ Lemma max_prefix_of_snd_prefix l1 l2 : (max_prefix_of l1 l2).2 `prefix_of` l2.
+ Proof. eexists. apply max_prefix_of_snd. Qed.
+ Lemma max_prefix_of_snd_prefix_alt l1 l2 k1 k2 k3 :
+ max_prefix_of l1 l2 = (k1,k2,k3) → k3 `prefix_of` l2.
+ Proof. eexists. eauto using max_prefix_of_snd_alt. Qed.
+ Lemma max_prefix_of_max l1 l2 k :
+ k `prefix_of` l1 → k `prefix_of` l2 → k `prefix_of` (max_prefix_of l1 l2).2.
+ Proof.
+ intros [l1' ->] [l2' ->]. by induction k; simpl; repeat case_decide;
+ simpl; auto using prefix_of_nil, prefix_of_cons.
+ Qed.
+ Lemma max_prefix_of_max_alt l1 l2 k1 k2 k3 k :
+ max_prefix_of l1 l2 = (k1,k2,k3) →
+ k `prefix_of` l1 → k `prefix_of` l2 → k `prefix_of` k3.
+ Proof.
+ intro. pose proof (max_prefix_of_max l1 l2 k).
+ by destruct (max_prefix_of l1 l2) as [[]?]; simplify_equality.
+ Qed.
+ Lemma max_prefix_of_max_snoc l1 l2 k1 k2 k3 x1 x2 :
+ max_prefix_of l1 l2 = (x1 :: k1, x2 :: k2, k3) → x1 ≠x2.
+ Proof.
+ intros Hl ->. destruct (prefix_of_snoc_not k3 x2).
+ eapply max_prefix_of_max_alt; eauto.
+ * rewrite (max_prefix_of_fst_alt _ _ _ _ _ Hl).
+ apply prefix_of_app, prefix_of_cons, prefix_of_nil.
+ * rewrite (max_prefix_of_snd_alt _ _ _ _ _ Hl).
+ apply prefix_of_app, prefix_of_cons, prefix_of_nil.
+ Qed.
+End prefix_ops.
+
+Lemma prefix_suffix_reverse l1 l2 :
+ l1 `prefix_of` l2 ↔ reverse l1 `suffix_of` reverse l2.
+Proof.
+ split; intros [k E]; exists (reverse k).
+ * by rewrite E, reverse_app.
+ * by rewrite <-(reverse_involutive l2), E, reverse_app, reverse_involutive.
+Qed.
+Lemma suffix_prefix_reverse l1 l2 :
+ l1 `suffix_of` l2 ↔ reverse l1 `prefix_of` reverse l2.
+Proof. by rewrite prefix_suffix_reverse, !reverse_involutive. Qed.
+Lemma suffix_of_nil l : [] `suffix_of` l.
+Proof. exists l. by rewrite (right_id_L [] (++)). Qed.
+Lemma suffix_of_nil_inv l : l `suffix_of` [] → l = [].
+Proof. by intros [[|?] ?]; simplify_list_equality. Qed.
+Lemma suffix_of_cons_nil_inv x l : ¬x :: l `suffix_of` [].
+Proof. by intros [[] ?]. Qed.
+Lemma suffix_of_snoc l1 l2 x :
+ l1 `suffix_of` l2 → l1 ++ [x] `suffix_of` l2 ++ [x].
+Proof. intros [k ->]. exists k. by rewrite (associative_L (++)). Qed.
+Lemma suffix_of_snoc_alt x y l1 l2 :
+ x = y → l1 `suffix_of` l2 → l1 ++ [x] `suffix_of` l2 ++ [y].
+Proof. intros ->. apply suffix_of_snoc. Qed.
+Lemma suffix_of_app l1 l2 k : l1 `suffix_of` l2 → l1 ++ k `suffix_of` l2 ++ k.
+Proof. intros [k' ->]. exists k'. by rewrite (associative_L (++)). Qed.
+Lemma suffix_of_app_alt l1 l2 k1 k2 :
+ k1 = k2 → l1 `suffix_of` l2 → l1 ++ k1 `suffix_of` l2 ++ k2.
+Proof. intros ->. apply suffix_of_app. Qed.
+Lemma suffix_of_snoc_inv_1 x y l1 l2 :
+ l1 ++ [x] `suffix_of` l2 ++ [y] → x = y.
+Proof.
+ intros [k' E]. rewrite (associative_L (++)) in E.
+ by simplify_list_equality.
+Qed.
+Lemma suffix_of_snoc_inv_2 x y l1 l2 :
+ l1 ++ [x] `suffix_of` l2 ++ [y] → l1 `suffix_of` l2.
+Proof.
+ intros [k' E]. exists k'. rewrite (associative_L (++)) in E.
+ by simplify_list_equality.
+Qed.
+Lemma suffix_of_app_inv l1 l2 k :
+ l1 ++ k `suffix_of` l2 ++ k → l1 `suffix_of` l2.
+Proof.
+ intros [k' E]. exists k'. rewrite (associative_L (++)) in E.
+ by simplify_list_equality.
+Qed.
+Lemma suffix_of_cons_l l1 l2 x : x :: l1 `suffix_of` l2 → l1 `suffix_of` l2.
+Proof. intros [k ->]. exists (k ++ [x]). by rewrite <-(associative_L (++)). Qed.
+Lemma suffix_of_app_l l1 l2 l3 : l3 ++ l1 `suffix_of` l2 → l1 `suffix_of` l2.
+Proof. intros [k ->]. exists (k ++ l3). by rewrite <-(associative_L (++)). Qed.
+Lemma suffix_of_cons_r l1 l2 x : l1 `suffix_of` l2 → l1 `suffix_of` x :: l2.
+Proof. intros [k ->]. by exists (x :: k). Qed.
+Lemma suffix_of_app_r l1 l2 l3 : l1 `suffix_of` l2 → l1 `suffix_of` l3 ++ l2.
+Proof. intros [k ->]. exists (l3 ++ k). by rewrite (associative_L (++)). Qed.
+Lemma suffix_of_cons_inv l1 l2 x y :
+ x :: l1 `suffix_of` y :: l2 → x :: l1 = y :: l2 ∨ x :: l1 `suffix_of` l2.
+Proof.
+ intros [[|? k] E]; [by left|].
+ right. simplify_equality'. by apply suffix_of_app_r.
+Qed.
+Lemma suffix_of_length l1 l2 : l1 `suffix_of` l2 → length l1 ≤ length l2.
+Proof. intros [? ->]. rewrite app_length. lia. Qed.
+Lemma suffix_of_cons_not x l : ¬x :: l `suffix_of` l.
+Proof. intros [??]. discriminate_list_equality. Qed.
+Global Instance suffix_of_dec `{∀ x y, Decision (x = y)} l1 l2 :
+ Decision (l1 `suffix_of` l2).
+Proof.
+ refine (cast_if (decide_rel prefix_of (reverse l1) (reverse l2)));
+ abstract (by rewrite suffix_prefix_reverse).
+Defined.
+
+Section max_suffix_of.
+ Context `{∀ x y, Decision (x = y)}.
+
+ Lemma max_suffix_of_fst l1 l2 :
+ l1 = (max_suffix_of l1 l2).1.1 ++ (max_suffix_of l1 l2).2.
+ Proof.
+ rewrite <-(reverse_involutive l1) at 1.
+ rewrite (max_prefix_of_fst (reverse l1) (reverse l2)). unfold max_suffix_of.
+ destruct (max_prefix_of (reverse l1) (reverse l2)) as ((?&?)&?); simpl.
+ by rewrite reverse_app.
+ Qed.
+ Lemma max_suffix_of_fst_alt l1 l2 k1 k2 k3 :
+ max_suffix_of l1 l2 = (k1, k2, k3) → l1 = k1 ++ k3.
+ Proof.
+ intro. pose proof (max_suffix_of_fst l1 l2).
+ by destruct (max_suffix_of l1 l2) as [[]?]; simplify_equality.
+ Qed.
+ Lemma max_suffix_of_fst_suffix l1 l2 : (max_suffix_of l1 l2).2 `suffix_of` l1.
+ Proof. eexists. apply max_suffix_of_fst. Qed.
+ Lemma max_suffix_of_fst_suffix_alt l1 l2 k1 k2 k3 :
+ max_suffix_of l1 l2 = (k1, k2, k3) → k3 `suffix_of` l1.
+ Proof. eexists. eauto using max_suffix_of_fst_alt. Qed.
+ Lemma max_suffix_of_snd l1 l2 :
+ l2 = (max_suffix_of l1 l2).1.2 ++ (max_suffix_of l1 l2).2.
+ Proof.
+ rewrite <-(reverse_involutive l2) at 1.
+ rewrite (max_prefix_of_snd (reverse l1) (reverse l2)). unfold max_suffix_of.
+ destruct (max_prefix_of (reverse l1) (reverse l2)) as ((?&?)&?); simpl.
+ by rewrite reverse_app.
+ Qed.
+ Lemma max_suffix_of_snd_alt l1 l2 k1 k2 k3 :
+ max_suffix_of l1 l2 = (k1,k2,k3) → l2 = k2 ++ k3.
+ Proof.
+ intro. pose proof (max_suffix_of_snd l1 l2).
+ by destruct (max_suffix_of l1 l2) as [[]?]; simplify_equality.
+ Qed.
+ Lemma max_suffix_of_snd_suffix l1 l2 : (max_suffix_of l1 l2).2 `suffix_of` l2.
+ Proof. eexists. apply max_suffix_of_snd. Qed.
+ Lemma max_suffix_of_snd_suffix_alt l1 l2 k1 k2 k3 :
+ max_suffix_of l1 l2 = (k1,k2,k3) → k3 `suffix_of` l2.
+ Proof. eexists. eauto using max_suffix_of_snd_alt. Qed.
+ Lemma max_suffix_of_max l1 l2 k :
+ k `suffix_of` l1 → k `suffix_of` l2 → k `suffix_of` (max_suffix_of l1 l2).2.
+ Proof.
+ generalize (max_prefix_of_max (reverse l1) (reverse l2)).
+ rewrite !suffix_prefix_reverse. unfold max_suffix_of.
+ destruct (max_prefix_of (reverse l1) (reverse l2)) as ((?&?)&?); simpl.
+ rewrite reverse_involutive. auto.
+ Qed.
+ Lemma max_suffix_of_max_alt l1 l2 k1 k2 k3 k :
+ max_suffix_of l1 l2 = (k1, k2, k3) →
+ k `suffix_of` l1 → k `suffix_of` l2 → k `suffix_of` k3.
+ Proof.
+ intro. pose proof (max_suffix_of_max l1 l2 k).
+ by destruct (max_suffix_of l1 l2) as [[]?]; simplify_equality.
+ Qed.
+ Lemma max_suffix_of_max_snoc l1 l2 k1 k2 k3 x1 x2 :
+ max_suffix_of l1 l2 = (k1 ++ [x1], k2 ++ [x2], k3) → x1 ≠x2.
+ Proof.
+ intros Hl ->. destruct (suffix_of_cons_not x2 k3).
+ eapply max_suffix_of_max_alt; eauto.
+ * rewrite (max_suffix_of_fst_alt _ _ _ _ _ Hl).
+ by apply (suffix_of_app [x2]), suffix_of_app_r.
+ * rewrite (max_suffix_of_snd_alt _ _ _ _ _ Hl).
+ by apply (suffix_of_app [x2]), suffix_of_app_r.
+ Qed.
+End max_suffix_of.
+
+(** ** Properties of the [sublist] predicate *)
+Lemma sublist_length l1 l2 : l1 `sublist` l2 → length l1 ≤ length l2.
+Proof. induction 1; simpl; auto with arith. Qed.
+Lemma sublist_nil_l l : [] `sublist` l.
+Proof. induction l; try constructor; auto. Qed.
+Lemma sublist_nil_r l : l `sublist` [] ↔ l = [].
+Proof. split. by inversion 1. intros ->. constructor. Qed.
+Lemma sublist_app l1 l2 k1 k2 :
+ l1 `sublist` l2 → k1 `sublist` k2 → l1 ++ k1 `sublist` l2 ++ k2.
+Proof. induction 1; simpl; try constructor; auto. Qed.
+Lemma sublist_inserts_l k l1 l2 : l1 `sublist` l2 → l1 `sublist` k ++ l2.
+Proof. induction k; try constructor; auto. Qed.
+Lemma sublist_inserts_r k l1 l2 : l1 `sublist` l2 → l1 `sublist` l2 ++ k.
+Proof. induction 1; simpl; try constructor; auto using sublist_nil_l. Qed.
+Lemma sublist_cons_r x l k :
+ l `sublist` x :: k ↔ l `sublist` k ∨ ∃ l', l = x :: l' ∧ l' `sublist` k.
+Proof. split. inversion 1; eauto. intros [?|(?&->&?)]; constructor; auto. Qed.
+Lemma sublist_cons_l x l k :
+ x :: l `sublist` k ↔ ∃ k1 k2, k = k1 ++ x :: k2 ∧ l `sublist` k2.
+Proof.
+ split.
+ * intros Hlk. induction k as [|y k IH]; inversion Hlk.
+ + eexists [], k. by repeat constructor.
+ + destruct IH as (k1&k2&->&?); auto. by exists (y :: k1), k2.
+ * intros (k1&k2&->&?). by apply sublist_inserts_l, sublist_skip.
+Qed.
+Lemma sublist_app_r l k1 k2 :
+ l `sublist` k1 ++ k2 ↔
+ ∃ l1 l2, l = l1 ++ l2 ∧ l1 `sublist` k1 ∧ l2 `sublist` k2.
+Proof.
+ split.
+ * revert l k2. induction k1 as [|y k1 IH]; intros l k2; simpl.
+ { eexists [], l. by repeat constructor. }
+ rewrite sublist_cons_r. intros [?|(l' & ? &?)]; subst.
+ + destruct (IH l k2) as (l1&l2&?&?&?); trivial; subst.
+ exists l1, l2. auto using sublist_cons.
+ + destruct (IH l' k2) as (l1&l2&?&?&?); trivial; subst.
+ exists (y :: l1), l2. auto using sublist_skip.
+ * intros (?&?&?&?&?); subst. auto using sublist_app.
+Qed.
+Lemma sublist_app_l l1 l2 k :
+ l1 ++ l2 `sublist` k ↔
+ ∃ k1 k2, k = k1 ++ k2 ∧ l1 `sublist` k1 ∧ l2 `sublist` k2.
+Proof.
+ split.
+ * revert l2 k. induction l1 as [|x l1 IH]; intros l2 k; simpl.
+ { eexists [], k. by repeat constructor. }
+ rewrite sublist_cons_l. intros (k1 & k2 &?&?); subst.
+ destruct (IH l2 k2) as (h1 & h2 &?&?&?); trivial; subst.
+ exists (k1 ++ x :: h1), h2. rewrite <-(associative_L (++)).
+ auto using sublist_inserts_l, sublist_skip.
+ * intros (?&?&?&?&?); subst. auto using sublist_app.
+Qed.
+Lemma sublist_app_inv_l k l1 l2 : k ++ l1 `sublist` k ++ l2 → l1 `sublist` l2.
+Proof.
+ induction k as [|y k IH]; simpl; [done |].
+ rewrite sublist_cons_r. intros [Hl12|(?&?&?)]; [|simplify_equality; eauto].
+ rewrite sublist_cons_l in Hl12. destruct Hl12 as (k1&k2&Hk&?).
+ apply IH. rewrite Hk. eauto using sublist_inserts_l, sublist_cons.
+Qed.
+Lemma sublist_app_inv_r k l1 l2 : l1 ++ k `sublist` l2 ++ k → l1 `sublist` l2.
+Proof.
+ revert l1 l2. induction k as [|y k IH]; intros l1 l2.
+ { by rewrite !(right_id_L [] (++)). }
+ intros. feed pose proof (IH (l1 ++ [y]) (l2 ++ [y])) as Hl12.
+ { by rewrite <-!(associative_L (++)). }
+ rewrite sublist_app_l in Hl12. destruct Hl12 as (k1&k2&E&?&Hk2).
+ destruct k2 as [|z k2] using rev_ind; [inversion Hk2|].
+ rewrite (associative_L (++)) in E; simplify_list_equality.
+ eauto using sublist_inserts_r.
+Qed.
+Global Instance: PartialOrder (@sublist A).
+Proof.
+ split; [split|].
+ * intros l. induction l; constructor; auto.
+ * intros l1 l2 l3 Hl12. revert l3. induction Hl12.
+ + auto using sublist_nil_l.
+ + intros ?. rewrite sublist_cons_l. intros (?&?&?&?); subst.
+ eauto using sublist_inserts_l, sublist_skip.
+ + intros ?. rewrite sublist_cons_l. intros (?&?&?&?); subst.
+ eauto using sublist_inserts_l, sublist_cons.
+ * intros l1 l2 Hl12 Hl21. apply sublist_length in Hl21.
+ induction Hl12; f_equal'; auto with arith.
+ apply sublist_length in Hl12. lia.
+Qed.
+Lemma sublist_take l i : take i l `sublist` l.
+Proof. rewrite <-(take_drop i l) at 2. by apply sublist_inserts_r. Qed.
+Lemma sublist_drop l i : drop i l `sublist` l.
+Proof. rewrite <-(take_drop i l) at 2. by apply sublist_inserts_l. Qed.
+Lemma sublist_delete l i : delete i l `sublist` l.
+Proof. revert i. by induction l; intros [|?]; simpl; constructor. Qed.
+Lemma sublist_foldr_delete l is : foldr delete l is `sublist` l.
+Proof.
+ induction is as [|i is IH]; simpl; [done |].
+ transitivity (foldr delete l is); auto using sublist_delete.
+Qed.
+Lemma sublist_alt l1 l2 : l1 `sublist` l2 ↔ ∃ is, l1 = foldr delete l2 is.
+Proof.
+ split; [|intros [is ->]; apply sublist_foldr_delete].
+ intros Hl12. cut (∀ k, ∃ is, k ++ l1 = foldr delete (k ++ l2) is).
+ { intros help. apply (help []). }
+ induction Hl12 as [|x l1 l2 _ IH|x l1 l2 _ IH]; intros k.
+ * by eexists [].
+ * destruct (IH (k ++ [x])) as [is His]. exists is.
+ by rewrite <-!(associative_L (++)) in His.
+ * destruct (IH k) as [is His]. exists (is ++ [length k]).
+ rewrite fold_right_app. simpl. by rewrite delete_middle.
+Qed.
+Lemma Permutation_sublist l1 l2 l3 :
+ l1 ≡ₚ l2 → l2 `sublist` l3 → ∃ l4, l1 `sublist` l4 ∧ l4 ≡ₚ l3.
+Proof.
+ intros Hl1l2. revert l3.
+ induction Hl1l2 as [|x l1 l2 ? IH|x y l1|l1 l1' l2 ? IH1 ? IH2].
+ * intros l3. by exists l3.
+ * intros l3. rewrite sublist_cons_l. intros (l3'&l3''&?&?); subst.
+ destruct (IH l3'') as (l4&?&Hl4); auto. exists (l3' ++ x :: l4).
+ split. by apply sublist_inserts_l, sublist_skip. by rewrite Hl4.
+ * intros l3. rewrite sublist_cons_l. intros (l3'&l3''&?& Hl3); subst.
+ rewrite sublist_cons_l in Hl3. destruct Hl3 as (l5'&l5''&?& Hl5); subst.
+ exists (l3' ++ y :: l5' ++ x :: l5''). split.
+ - by do 2 apply sublist_inserts_l, sublist_skip.
+ - by rewrite !Permutation_middle, Permutation_swap.
+ * intros l3 ?. destruct (IH2 l3) as (l3'&?&?); trivial.
+ destruct (IH1 l3') as (l3'' &?&?); trivial. exists l3''.
+ split. done. etransitivity; eauto.
+Qed.
+Lemma sublist_Permutation l1 l2 l3 :
+ l1 `sublist` l2 → l2 ≡ₚ l3 → ∃ l4, l1 ≡ₚ l4 ∧ l4 `sublist` l3.
+Proof.
+ intros Hl1l2 Hl2l3. revert l1 Hl1l2.
+ induction Hl2l3 as [|x l2 l3 ? IH|x y l2|l2 l2' l3 ? IH1 ? IH2].
+ * intros l1. by exists l1.
+ * intros l1. rewrite sublist_cons_r. intros [?|(l1'&l1''&?)]; subst.
+ { destruct (IH l1) as (l4&?&?); trivial.
+ exists l4. split. done. by constructor. }
+ destruct (IH l1') as (l4&?&Hl4); auto. exists (x :: l4).
+ split. by constructor. by constructor.
+ * intros l1. rewrite sublist_cons_r. intros [Hl1|(l1'&l1''&Hl1)]; subst.
+ { exists l1. split; [done|]. rewrite sublist_cons_r in Hl1.
+ destruct Hl1 as [?|(l1'&?&?)]; subst; by repeat constructor. }
+ rewrite sublist_cons_r in Hl1. destruct Hl1 as [?|(l1''&?&?)]; subst.
+ + exists (y :: l1'). by repeat constructor.
+ + exists (x :: y :: l1''). by repeat constructor.
+ * intros l1 ?. destruct (IH1 l1) as (l3'&?&?); trivial.
+ destruct (IH2 l3') as (l3'' &?&?); trivial. exists l3''.
+ split; [|done]. etransitivity; eauto.
+Qed.
+
+(** Properties of the [contains] predicate *)
+Lemma contains_length l1 l2 : l1 `contains` l2 → length l1 ≤ length l2.
+Proof. induction 1; simpl; auto with lia. Qed.
+Lemma contains_nil_l l : [] `contains` l.
+Proof. induction l; constructor; auto. Qed.
+Lemma contains_nil_r l : l `contains` [] ↔ l = [].
+Proof.
+ split; [|intros ->; constructor].
+ intros Hl. apply contains_length in Hl. destruct l; simpl in *; auto with lia.
+Qed.
+Global Instance: PreOrder (@contains A).
+Proof.
+ split.
+ * intros l. induction l; constructor; auto.
+ * red. apply contains_trans.
+Qed.
+Lemma Permutation_contains l1 l2 : l1 ≡ₚ l2 → l1 `contains` l2.
+Proof. induction 1; econstructor; eauto. Qed.
+Lemma sublist_contains l1 l2 : l1 `sublist` l2 → l1 `contains` l2.
+Proof. induction 1; constructor; auto. Qed.
+Lemma contains_Permutation l1 l2 : l1 `contains` l2 → ∃ k, l2 ≡ₚ l1 ++ k.
+Proof.
+ induction 1 as
+ [|x y l ? [k Hk]| |x l1 l2 ? [k Hk]|l1 l2 l3 ? [k Hk] ? [k' Hk']].
+ * by eexists [].
+ * exists k. by rewrite Hk.
+ * eexists []. rewrite (right_id_L [] (++)). by constructor.
+ * exists (x :: k). by rewrite Hk, Permutation_middle.
+ * exists (k ++ k'). by rewrite Hk', Hk, (associative_L (++)).
+Qed.
+Lemma contains_Permutation_length_le l1 l2 :
+ length l2 ≤ length l1 → l1 `contains` l2 → l1 ≡ₚ l2.
+Proof.
+ intros Hl21 Hl12. destruct (contains_Permutation l1 l2) as [[|??] Hk]; auto.
+ * by rewrite Hk, (right_id_L [] (++)).
+ * rewrite Hk, app_length in Hl21; simpl in Hl21; lia.
+Qed.
+Lemma contains_Permutation_length_eq l1 l2 :
+ length l2 = length l1 → l1 `contains` l2 → l1 ≡ₚ l2.
+Proof. intro. apply contains_Permutation_length_le. lia. Qed.
+Global Instance: Proper ((≡ₚ) ==> (≡ₚ) ==> iff) (@contains A).
+Proof.
+ intros l1 l2 ? k1 k2 ?. split; intros.
+ * transitivity l1. by apply Permutation_contains.
+ transitivity k1. done. by apply Permutation_contains.
+ * transitivity l2. by apply Permutation_contains.
+ transitivity k2. done. by apply Permutation_contains.
+Qed.
+Global Instance: AntiSymmetric (≡ₚ) (@contains A).
+Proof. red. auto using contains_Permutation_length_le, contains_length. Qed.
+Lemma contains_take l i : take i l `contains` l.
+Proof. auto using sublist_take, sublist_contains. Qed.
+Lemma contains_drop l i : drop i l `contains` l.
+Proof. auto using sublist_drop, sublist_contains. Qed.
+Lemma contains_delete l i : delete i l `contains` l.
+Proof. auto using sublist_delete, sublist_contains. Qed.
+Lemma contains_foldr_delete l is : foldr delete l is `sublist` l.
+Proof. auto using sublist_foldr_delete, sublist_contains. Qed.
+Lemma contains_sublist_l l1 l3 :
+ l1 `contains` l3 ↔ ∃ l2, l1 `sublist` l2 ∧ l2 ≡ₚ l3.
+Proof.
+ split.
+ { intros Hl13. elim Hl13; clear l1 l3 Hl13.
+ * by eexists [].
+ * intros x l1 l3 ? (l2&?&?). exists (x :: l2). by repeat constructor.
+ * intros x y l. exists (y :: x :: l). by repeat constructor.
+ * intros x l1 l3 ? (l2&?&?). exists (x :: l2). by repeat constructor.
+ * intros l1 l3 l5 ? (l2&?&?) ? (l4&?&?).
+ destruct (Permutation_sublist l2 l3 l4) as (l3'&?&?); trivial.
+ exists l3'. split; etransitivity; eauto. }
+ intros (l2&?&?).
+ transitivity l2; auto using sublist_contains, Permutation_contains.
+Qed.
+Lemma contains_sublist_r l1 l3 :
+ l1 `contains` l3 ↔ ∃ l2, l1 ≡ₚ l2 ∧ l2 `sublist` l3.
+Proof.
+ rewrite contains_sublist_l.
+ split; intros (l2&?&?); eauto using sublist_Permutation, Permutation_sublist.
+Qed.
+Lemma contains_inserts_l k l1 l2 : l1 `contains` l2 → l1 `contains` k ++ l2.
+Proof. induction k; try constructor; auto. Qed.
+Lemma contains_inserts_r k l1 l2 : l1 `contains` l2 → l1 `contains` l2 ++ k.
+Proof. rewrite (commutative (++)). apply contains_inserts_l. Qed.
+Lemma contains_skips_l k l1 l2 : l1 `contains` l2 → k ++ l1 `contains` k ++ l2.
+Proof. induction k; try constructor; auto. Qed.
+Lemma contains_skips_r k l1 l2 : l1 `contains` l2 → l1 ++ k `contains` l2 ++ k.
+Proof. rewrite !(commutative (++) _ k). apply contains_skips_l. Qed.
+Lemma contains_app l1 l2 k1 k2 :
+ l1 `contains` l2 → k1 `contains` k2 → l1 ++ k1 `contains` l2 ++ k2.
+Proof.
+ transitivity (l1 ++ k2); auto using contains_skips_l, contains_skips_r.
+Qed.
+Lemma contains_cons_r x l k :
+ l `contains` x :: k ↔ l `contains` k ∨ ∃ l', l ≡ₚ x :: l' ∧ l' `contains` k.
+Proof.
+ split.
+ * rewrite contains_sublist_r. intros (l'&E&Hl').
+ rewrite sublist_cons_r in Hl'. destruct Hl' as [?|(?&?&?)]; subst.
+ + left. rewrite E. eauto using sublist_contains.
+ + right. eauto using sublist_contains.
+ * intros [?|(?&E&?)]; [|rewrite E]; by constructor.
+Qed.
+Lemma contains_cons_l x l k :
+ x :: l `contains` k ↔ ∃ k', k ≡ₚ x :: k' ∧ l `contains` k'.
+Proof.
+ split.
+ * rewrite contains_sublist_l. intros (l'&Hl'&E).
+ rewrite sublist_cons_l in Hl'. destruct Hl' as (k1&k2&?&?); subst.
+ exists (k1 ++ k2). split; eauto using contains_inserts_l, sublist_contains.
+ by rewrite Permutation_middle.
+ * intros (?&E&?). rewrite E. by constructor.
+Qed.
+Lemma contains_app_r l k1 k2 :
+ l `contains` k1 ++ k2 ↔ ∃ l1 l2,
+ l ≡ₚ l1 ++ l2 ∧ l1 `contains` k1 ∧ l2 `contains` k2.
+Proof.
+ split.
+ * rewrite contains_sublist_r. intros (l'&E&Hl').
+ rewrite sublist_app_r in Hl'. destruct Hl' as (l1&l2&?&?&?); subst.
+ exists l1, l2. eauto using sublist_contains.
+ * intros (?&?&E&?&?). rewrite E. eauto using contains_app.
+Qed.
+Lemma contains_app_l l1 l2 k :
+ l1 ++ l2 `contains` k ↔ ∃ k1 k2,
+ k ≡ₚ k1 ++ k2 ∧ l1 `contains` k1 ∧ l2 `contains` k2.
+Proof.
+ split.
+ * rewrite contains_sublist_l. intros (l'&Hl'&E).
+ rewrite sublist_app_l in Hl'. destruct Hl' as (k1&k2&?&?&?); subst.
+ exists k1, k2. split. done. eauto using sublist_contains.
+ * intros (?&?&E&?&?). rewrite E. eauto using contains_app.
+Qed.
+Lemma contains_app_inv_l l1 l2 k :
+ k ++ l1 `contains` k ++ l2 → l1 `contains` l2.
+Proof.
+ induction k as [|y k IH]; simpl; [done |]. rewrite contains_cons_l.
+ intros (?&E&?). apply Permutation_cons_inv in E. apply IH. by rewrite E.
+Qed.
+Lemma contains_app_inv_r l1 l2 k :
+ l1 ++ k `contains` l2 ++ k → l1 `contains` l2.
+Proof.
+ revert l1 l2. induction k as [|y k IH]; intros l1 l2.
+ { by rewrite !(right_id_L [] (++)). }
+ intros. feed pose proof (IH (l1 ++ [y]) (l2 ++ [y])) as Hl12.
+ { by rewrite <-!(associative_L (++)). }
+ rewrite contains_app_l in Hl12. destruct Hl12 as (k1&k2&E1&?&Hk2).
+ rewrite contains_cons_l in Hk2. destruct Hk2 as (k2'&E2&?).
+ rewrite E2, (Permutation_cons_append k2'), (associative_L (++)) in E1.
+ apply Permutation_app_inv_r in E1. rewrite E1. eauto using contains_inserts_r.
+Qed.
+Lemma contains_cons_middle x l k1 k2 :
+ l `contains` k1 ++ k2 → x :: l `contains` k1 ++ x :: k2.
+Proof. rewrite <-Permutation_middle. by apply contains_skip. Qed.
+Lemma contains_app_middle l1 l2 k1 k2 :
+ l2 `contains` k1 ++ k2 → l1 ++ l2 `contains` k1 ++ l1 ++ k2.
+Proof.
+ rewrite !(associative (++)), (commutative (++) k1 l1), <-(associative_L (++)).
+ by apply contains_skips_l.
+Qed.
+Lemma contains_middle l k1 k2 : l `contains` k1 ++ l ++ k2.
+Proof. by apply contains_inserts_l, contains_inserts_r. Qed.
+
+Lemma Permutation_alt l1 l2 :
+ l1 ≡ₚ l2 ↔ length l1 = length l2 ∧ l1 `contains` l2.
+Proof.
+ split.
+ * by intros Hl; rewrite Hl.
+ * intros [??]; auto using contains_Permutation_length_eq.
+Qed.
+
+Lemma NoDup_contains l k : NoDup l → (∀ x, x ∈ l → x ∈ k) → l `contains` k.
+Proof.
+ intros Hl. revert k. induction Hl as [|x l Hx ? IH].
+ { intros k Hk. by apply contains_nil_l. }
+ intros k Hlk. destruct (elem_of_list_split k x) as (l1&l2&?); subst.
+ { apply Hlk. by constructor. }
+ rewrite <-Permutation_middle. apply contains_skip, IH.
+ intros y Hy. rewrite elem_of_app.
+ specialize (Hlk y). rewrite elem_of_app, !elem_of_cons in Hlk.
+ by destruct Hlk as [?|[?|?]]; subst; eauto.
+Qed.
+Lemma NoDup_Permutation l k : NoDup l → NoDup k → (∀ x, x ∈ l ↔ x ∈ k) → l ≡ₚ k.
+Proof.
+ intros. apply (anti_symmetric contains); apply NoDup_contains; naive_solver.
+Qed.
+
+Section contains_dec.
+ Context `{∀ x y, Decision (x = y)}.
+
+ Lemma list_remove_Permutation l1 l2 k1 x :
+ l1 ≡ₚ l2 → list_remove x l1 = Some k1 →
+ ∃ k2, list_remove x l2 = Some k2 ∧ k1 ≡ₚ k2.
+ Proof.
+ intros Hl. revert k1. induction Hl
+ as [|y l1 l2 ? IH|y1 y2 l|l1 l2 l3 ? IH1 ? IH2]; simpl; intros k1 Hk1.
+ * done.
+ * case_decide; simplify_equality; eauto.
+ destruct (list_remove x l1) as [l|] eqn:?; simplify_equality.
+ destruct (IH l) as (?&?&?); simplify_option_equality; eauto.
+ * simplify_option_equality; eauto using Permutation_swap.
+ * destruct (IH1 k1) as (k2&?&?); trivial.
+ destruct (IH2 k2) as (k3&?&?); trivial.
+ exists k3. split; eauto. by transitivity k2.
+ Qed.
+ Lemma list_remove_Some l k x : list_remove x l = Some k → l ≡ₚ x :: k.
+ Proof.
+ revert k. induction l as [|y l IH]; simpl; intros k ?; [done |].
+ simplify_option_equality; auto. by rewrite Permutation_swap, <-IH.
+ Qed.
+ Lemma list_remove_Some_inv l k x :
+ l ≡ₚ x :: k → ∃ k', list_remove x l = Some k' ∧ k ≡ₚ k'.
+ Proof.
+ intros. destruct (list_remove_Permutation (x :: k) l k x) as (k'&?&?).
+ * done.
+ * simpl; by case_decide.
+ * by exists k'.
+ Qed.
+ Lemma list_remove_list_contains l1 l2 :
+ l1 `contains` l2 ↔ is_Some (list_remove_list l1 l2).
+ Proof.
+ split.
+ * revert l2. induction l1 as [|x l1 IH]; simpl.
+ { intros l2 _. by exists l2. }
+ intros l2. rewrite contains_cons_l. intros (k&Hk&?).
+ destruct (list_remove_Some_inv l2 k x) as (k2&?&Hk2); trivial.
+ simplify_option_equality. apply IH. by rewrite <-Hk2.
+ * intros [k Hk]. revert l2 k Hk.
+ induction l1 as [|x l1 IH]; simpl; intros l2 k.
+ { intros. apply contains_nil_l. }
+ destruct (list_remove x l2) as [k'|] eqn:?; intros; simplify_equality.
+ rewrite contains_cons_l. eauto using list_remove_Some.
+ Qed.
+ Global Instance contains_dec l1 l2 : Decision (l1 `contains` l2).
+ Proof.
+ refine (cast_if (decide (is_Some (list_remove_list l1 l2))));
+ abstract (rewrite list_remove_list_contains; tauto).
+ Defined.
+ Global Instance Permutation_dec l1 l2 : Decision (l1 ≡ₚ l2).
+ Proof.
+ refine (cast_if_and
+ (decide (length l1 = length l2)) (decide (l1 `contains` l2)));
+ abstract (rewrite Permutation_alt; tauto).
+ Defined.
+End contains_dec.
+End more_general_properties.
+
+(** ** Properties of the [Forall] and [Exists] predicate *)
+Lemma Forall_Exists_dec {A} {P Q : A → Prop} (dec : ∀ x, {P x} + {Q x}) :
+ ∀ l, {Forall P l} + {Exists Q l}.
+Proof.
+ refine (
+ fix go l :=
+ match l return {Forall P l} + {Exists Q l} with
+ | [] => left _
+ | x :: l => cast_if_and (dec x) (go l)
+ end); clear go; intuition.
+Defined.
+
+Section Forall_Exists.
+ Context {A} (P : A → Prop).
+
+ Definition Forall_nil_2 := @Forall_nil A.
+ Definition Forall_cons_2 := @Forall_cons A.
+ Lemma Forall_forall l : Forall P l ↔ ∀ x, x ∈ l → P x.
+ Proof.
+ split; [induction 1; inversion 1; subst; auto|].
+ intros Hin; induction l as [|x l IH]; constructor; [apply Hin; constructor|].
+ apply IH. intros ??. apply Hin. by constructor.
+ Qed.
+ Lemma Forall_nil : Forall P [] ↔ True.
+ Proof. done. Qed.
+ Lemma Forall_cons_1 x l : Forall P (x :: l) → P x ∧ Forall P l.
+ Proof. by inversion 1. Qed.
+ Lemma Forall_cons x l : Forall P (x :: l) ↔ P x ∧ Forall P l.
+ Proof. split. by inversion 1. intros [??]. by constructor. Qed.
+ Lemma Forall_singleton x : Forall P [x] ↔ P x.
+ Proof. rewrite Forall_cons, Forall_nil; tauto. Qed.
+ Lemma Forall_app_2 l1 l2 : Forall P l1 → Forall P l2 → Forall P (l1 ++ l2).
+ Proof. induction 1; simpl; auto. Qed.
+ Lemma Forall_app l1 l2 : Forall P (l1 ++ l2) ↔ Forall P l1 ∧ Forall P l2.
+ Proof.
+ split; [induction l1; inversion 1; intuition|].
+ intros [??]; auto using Forall_app_2.
+ Qed.
+ Lemma Forall_true l : (∀ x, P x) → Forall P l.
+ Proof. induction l; auto. Qed.
+ Lemma Forall_impl (Q : A → Prop) l :
+ Forall P l → (∀ x, P x → Q x) → Forall Q l.
+ Proof. intros H ?. induction H; auto. Defined.
+ Global Instance Forall_proper:
+ Proper (pointwise_relation _ (↔) ==> (=) ==> (↔)) (@Forall A).
+ Proof. split; subst; induction 1; constructor; by firstorder auto. Qed.
+ Lemma Forall_iff l (Q : A → Prop) :
+ (∀ x, P x ↔ Q x) → Forall P l ↔ Forall Q l.
+ Proof. intros H. apply Forall_proper. red; apply H. done. Qed.
+ Lemma Forall_not l : length l ≠0 → Forall (not ∘ P) l → ¬Forall P l.
+ Proof. by destruct 2; inversion 1. Qed.
+ Lemma Forall_and {Q} l : Forall (λ x, P x ∧ Q x) l ↔ Forall P l ∧ Forall Q l.
+ Proof.
+ split; [induction 1; constructor; naive_solver|].
+ intros [Hl Hl']; revert Hl'; induction Hl; inversion_clear 1; auto.
+ Qed.
+ Lemma Forall_and_l {Q} l : Forall (λ x, P x ∧ Q x) l → Forall P l.
+ Proof. rewrite Forall_and; tauto. Qed.
+ Lemma Forall_and_r {Q} l : Forall (λ x, P x ∧ Q x) l → Forall Q l.
+ Proof. rewrite Forall_and; tauto. Qed.
+ Lemma Forall_delete l i : Forall P l → Forall P (delete i l).
+ Proof. intros H. revert i. by induction H; intros [|i]; try constructor. Qed.
+ Lemma Forall_lookup l : Forall P l ↔ ∀ i x, l !! i = Some x → P x.
+ Proof.
+ rewrite Forall_forall. setoid_rewrite elem_of_list_lookup. naive_solver.
+ Qed.
+ Lemma Forall_lookup_1 l i x : Forall P l → l !! i = Some x → P x.
+ Proof. rewrite Forall_lookup. eauto. Qed.
+ Lemma Forall_lookup_2 l : (∀ i x, l !! i = Some x → P x) → Forall P l.
+ Proof. by rewrite Forall_lookup. Qed.
+ Lemma Forall_tail l : Forall P l → Forall P (tail l).
+ Proof. destruct 1; simpl; auto. Qed.
+ Lemma Forall_alter f l i :
+ Forall P l → (∀ x, l!!i = Some x → P x → P (f x)) → Forall P (alter f i l).
+ Proof.
+ intros Hl. revert i. induction Hl; simpl; intros [|i]; constructor; auto.
+ Qed.
+ Lemma Forall_alter_inv f l i :
+ Forall P (alter f i l) → (∀ x, l!!i = Some x → P (f x) → P x) → Forall P l.
+ Proof.
+ revert i. induction l; intros [|?]; simpl;
+ inversion_clear 1; constructor; eauto.
+ Qed.
+ Lemma Forall_insert l i x : Forall P l → P x → Forall P (<[i:=x]>l).
+ Proof. rewrite list_insert_alter; auto using Forall_alter. Qed.
+ Lemma Forall_inserts l i k :
+ Forall P l → Forall P k → Forall P (list_inserts i k l).
+ Proof.
+ intros Hl Hk; revert i.
+ induction Hk; simpl; auto using Forall_insert.
+ Qed.
+ Lemma Forall_replicate n x : P x → Forall P (replicate n x).
+ Proof. induction n; simpl; constructor; auto. Qed.
+ Lemma Forall_replicate_eq n (x : A) : Forall (x =) (replicate n x).
+ Proof. induction n; simpl; constructor; auto. Qed.
+ Lemma Forall_take n l : Forall P l → Forall P (take n l).
+ Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed.
+ Lemma Forall_drop n l : Forall P l → Forall P (drop n l).
+ Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed.
+ Lemma Forall_resize n x l : P x → Forall P l → Forall P (resize n x l).
+ Proof.
+ intros ? Hl. revert n.
+ induction Hl; intros [|?]; simpl; auto using Forall_replicate.
+ Qed.
+ Lemma Forall_resize_inv n x l :
+ length l ≤ n → Forall P (resize n x l) → Forall P l.
+ Proof. intros ?. rewrite resize_ge, Forall_app by done. by intros []. Qed.
+ Lemma Forall_sublist_lookup l i n k :
+ sublist_lookup i n l = Some k → Forall P l → Forall P k.
+ Proof.
+ unfold sublist_lookup. intros; simplify_option_equality.
+ auto using Forall_take, Forall_drop.
+ Qed.
+ Lemma Forall_sublist_alter f l i n k :
+ Forall P l → sublist_lookup i n l = Some k → Forall P (f k) →
+ Forall P (sublist_alter f i n l).
+ Proof.
+ unfold sublist_alter, sublist_lookup. intros; simplify_option_equality.
+ auto using Forall_app_2, Forall_drop, Forall_take.
+ Qed.
+ Lemma Forall_sublist_alter_inv f l i n k :
+ sublist_lookup i n l = Some k →
+ Forall P (sublist_alter f i n l) → Forall P (f k).
+ Proof.
+ unfold sublist_alter, sublist_lookup. intros ?; simplify_option_equality.
+ rewrite !Forall_app; tauto.
+ Qed.
+ Lemma Forall_reshape l szs : Forall P l → Forall (Forall P) (reshape szs l).
+ Proof.
+ revert l. induction szs; simpl; auto using Forall_take, Forall_drop.
+ Qed.
+ Lemma Forall_rev_ind (Q : list A → Prop) :
+ Q [] → (∀ x l, P x → Forall P l → Q l → Q (l ++ [x])) →
+ ∀ l, Forall P l → Q l.
+ Proof.
+ intros ?? l. induction l using rev_ind; auto.
+ rewrite Forall_app, Forall_singleton; intros [??]; auto.
+ Qed.
+ Lemma Exists_exists l : Exists P l ↔ ∃ x, x ∈ l ∧ P x.
+ Proof.
+ split.
+ * induction 1 as [x|y ?? [x [??]]]; exists x; by repeat constructor.
+ * intros [x [Hin ?]]. induction l; [by destruct (not_elem_of_nil x)|].
+ inversion Hin; subst. by left. right; auto.
+ Qed.
+ Lemma Exists_inv x l : Exists P (x :: l) → P x ∨ Exists P l.
+ Proof. inversion 1; intuition trivial. Qed.
+ Lemma Exists_app l1 l2 : Exists P (l1 ++ l2) ↔ Exists P l1 ∨ Exists P l2.
+ Proof.
+ split.
+ * induction l1; inversion 1; intuition.
+ * intros [H|H]; [induction H | induction l1]; simpl; intuition.
+ Qed.
+ Lemma Exists_impl (Q : A → Prop) l :
+ Exists P l → (∀ x, P x → Q x) → Exists Q l.
+ Proof. intros H ?. induction H; auto. Defined.
+ Global Instance Exists_proper:
+ Proper (pointwise_relation _ (↔) ==> (=) ==> (↔)) (@Exists A).
+ Proof. split; subst; induction 1; constructor; by firstorder auto. Qed.
+ Lemma Exists_not_Forall l : Exists (not ∘ P) l → ¬Forall P l.
+ Proof. induction 1; inversion_clear 1; contradiction. Qed.
+ Lemma Forall_not_Exists l : Forall (not ∘ P) l → ¬Exists P l.
+ Proof. induction 1; inversion_clear 1; contradiction. Qed.
+
+ Lemma Forall_list_difference `{∀ x y : A, Decision (x = y)} l k :
+ Forall P l → Forall P (list_difference l k).
+ Proof.
+ rewrite !Forall_forall.
+ intros ? x; rewrite elem_of_list_difference; naive_solver.
+ Qed.
+ Lemma Forall_list_union `{∀ x y : A, Decision (x = y)} l k :
+ Forall P l → Forall P k → Forall P (list_union l k).
+ Proof. intros. apply Forall_app; auto using Forall_list_difference. Qed.
+ Lemma Forall_list_intersection `{∀ x y : A, Decision (x = y)} l k :
+ Forall P l → Forall P (list_intersection l k).
+ Proof.
+ rewrite !Forall_forall.
+ intros ? x; rewrite elem_of_list_intersection; naive_solver.
+ Qed.
+
+ Context {dec : ∀ x, Decision (P x)}.
+ Lemma not_Forall_Exists l : ¬Forall P l → Exists (not ∘ P) l.
+ Proof. intro. destruct (Forall_Exists_dec dec l); intuition. Qed.
+ Lemma not_Exists_Forall l : ¬Exists P l → Forall (not ∘ P) l.
+ Proof. by destruct (Forall_Exists_dec (λ x, swap_if (decide (P x))) l). Qed.
+ Global Instance Forall_dec l : Decision (Forall P l) :=
+ match Forall_Exists_dec dec l with
+ | left H => left H
+ | right H => right (Exists_not_Forall _ H)
+ end.
+ Global Instance Exists_dec l : Decision (Exists P l) :=
+ match Forall_Exists_dec (λ x, swap_if (decide (P x))) l with
+ | left H => right (Forall_not_Exists _ H)
+ | right H => left H
+ end.
+End Forall_Exists.
+
+Lemma replicate_as_Forall {A} (x : A) n l :
+ replicate n x = l ↔ length l = n ∧ Forall (x =) l.
+Proof. rewrite replicate_as_elem_of, Forall_forall. naive_solver. Qed.
+Lemma replicate_as_Forall_2 {A} (x : A) n l :
+ length l = n → Forall (x =) l → replicate n x = l.
+Proof. by rewrite replicate_as_Forall. Qed.
+
+Lemma Forall_swap {A B} (Q : A → B → Prop) l1 l2 :
+ Forall (λ y, Forall (Q y) l1) l2 ↔ Forall (λ x, Forall (flip Q x) l2) l1.
+Proof. repeat setoid_rewrite Forall_forall. simpl. split; eauto. Qed.
+Lemma Forall_seq (P : nat → Prop) i n :
+ Forall P (seq i n) ↔ ∀ j, i ≤ j < i + n → P j.
+Proof.
+ rewrite Forall_lookup. split.
+ * intros H j [??]. apply (H (j - i)).
+ rewrite lookup_seq; auto with f_equal lia.
+ * intros H j x Hj. apply lookup_seq_inv in Hj.
+ destruct Hj; subst. auto with lia.
+Qed.
+
+(** ** Properties of the [Forall2] predicate *)
+Section Forall2.
+ Context {A B} (P : A → B → Prop).
+ Implicit Types x : A.
+ Implicit Types y : B.
+ Implicit Types l : list A.
+ Implicit Types k : list B.
+
+ Lemma Forall2_true l k :
+ (∀ x y, P x y) → length l = length k → Forall2 P l k.
+ Proof.
+ intro. revert k. induction l; intros [|??] ?; simplify_equality'; auto.
+ Qed.
+ Lemma Forall2_same_length l k :
+ Forall2 (λ _ _, True) l k ↔ length l = length k.
+ Proof.
+ split; [by induction 1; f_equal'|].
+ revert k. induction l; intros [|??] ?; simplify_equality'; auto.
+ Qed.
+ Lemma Forall2_length l k : Forall2 P l k → length l = length k.
+ Proof. by induction 1; f_equal'. Qed.
+ Lemma Forall2_length_l l k n : Forall2 P l k → length l = n → length k = n.
+ Proof. intros ? <-; symmetry. by apply Forall2_length. Qed.
+ Lemma Forall2_length_r l k n : Forall2 P l k → length k = n → length l = n.
+ Proof. intros ? <-. by apply Forall2_length. Qed.
+ Lemma Forall2_nil_inv_l k : Forall2 P [] k → k = [].
+ Proof. by inversion 1. Qed.
+ Lemma Forall2_nil_inv_r l : Forall2 P l [] → l = [].
+ Proof. by inversion 1. Qed.
+ Lemma Forall2_cons_inv x l y k :
+ Forall2 P (x :: l) (y :: k) → P x y ∧ Forall2 P l k.
+ Proof. by inversion 1. Qed.
+ Lemma Forall2_cons_inv_l x l k :
+ Forall2 P (x :: l) k → ∃ y k', P x y ∧ Forall2 P l k' ∧ k = y :: k'.
+ Proof. inversion 1; subst; eauto. Qed.
+ Lemma Forall2_cons_inv_r l k y :
+ Forall2 P l (y :: k) → ∃ x l', P x y ∧ Forall2 P l' k ∧ l = x :: l'.
+ Proof. inversion 1; subst; eauto. Qed.
+ Lemma Forall2_cons_nil_inv x l : Forall2 P (x :: l) [] → False.
+ Proof. by inversion 1. Qed.
+ Lemma Forall2_nil_cons_inv y k : Forall2 P [] (y :: k) → False.
+ Proof. by inversion 1. Qed.
+ Lemma Forall2_app_l l1 l2 k :
+ Forall2 P l1 (take (length l1) k) → Forall2 P l2 (drop (length l1) k) →
+ Forall2 P (l1 ++ l2) k.
+ Proof. intros. rewrite <-(take_drop (length l1) k). by apply Forall2_app. Qed.
+ Lemma Forall2_app_r l k1 k2 :
+ Forall2 P (take (length k1) l) k1 → Forall2 P (drop (length k1) l) k2 →
+ Forall2 P l (k1 ++ k2).
+ Proof. intros. rewrite <-(take_drop (length k1) l). by apply Forall2_app. Qed.
+ Lemma Forall2_app_inv l1 l2 k1 k2 :
+ length l1 = length k1 →
+ Forall2 P (l1 ++ l2) (k1 ++ k2) → Forall2 P l1 k1 ∧ Forall2 P l2 k2.
+ Proof.
+ rewrite <-Forall2_same_length. induction 1; inversion 1; naive_solver.
+ Qed.
+ Lemma Forall2_app_inv_l l1 l2 k :
+ Forall2 P (l1 ++ l2) k ↔
+ ∃ k1 k2, Forall2 P l1 k1 ∧ Forall2 P l2 k2 ∧ k = k1 ++ k2.
+ Proof.
+ split; [|intros (?&?&?&?&->); by apply Forall2_app].
+ revert k. induction l1; inversion 1; naive_solver.
+ Qed.
+ Lemma Forall2_app_inv_r l k1 k2 :
+ Forall2 P l (k1 ++ k2) ↔
+ ∃ l1 l2, Forall2 P l1 k1 ∧ Forall2 P l2 k2 ∧ l = l1 ++ l2.
+ Proof.
+ split; [|intros (?&?&?&?&->); by apply Forall2_app].
+ revert l. induction k1; inversion 1; naive_solver.
+ Qed.
+ Lemma Forall2_flip l k : Forall2 (flip P) k l ↔ Forall2 P l k.
+ Proof. split; induction 1; constructor; auto. Qed.
+ Lemma Forall2_impl (Q : A → B → Prop) l k :
+ Forall2 P l k → (∀ x y, P x y → Q x y) → Forall2 Q l k.
+ Proof. intros H ?. induction H; auto. Defined.
+ Lemma Forall2_unique l k1 k2 :
+ Forall2 P l k1 → Forall2 P l k2 →
+ (∀ x y1 y2, P x y1 → P x y2 → y1 = y2) → k1 = k2.
+ Proof.
+ intros H. revert k2. induction H; inversion_clear 1; intros; f_equal; eauto.
+ Qed.
+ Lemma Forall2_Forall_l (Q : A → Prop) l k :
+ Forall2 P l k → Forall (λ y, ∀ x, P x y → Q x) k → Forall Q l.
+ Proof. induction 1; inversion_clear 1; eauto. Qed.
+ Lemma Forall2_Forall_r (Q : B → Prop) l k :
+ Forall2 P l k → Forall (λ x, ∀ y, P x y → Q y) l → Forall Q k.
+ Proof. induction 1; inversion_clear 1; eauto. Qed.
+ Lemma Forall2_lookup_lr l k i x y :
+ Forall2 P l k → l !! i = Some x → k !! i = Some y → P x y.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ??; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall2_lookup_l l k i x :
+ Forall2 P l k → l !! i = Some x → ∃ y, k !! i = Some y ∧ P x y.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ?; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall2_lookup_r l k i y :
+ Forall2 P l k → k !! i = Some y → ∃ x, l !! i = Some x ∧ P x y.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ?; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall2_lookup_2 l k :
+ length l = length k →
+ (∀ i x y, l !! i = Some x → k !! i = Some y → P x y) → Forall2 P l k.
+ Proof.
+ rewrite <-Forall2_same_length. intros Hl Hlookup.
+ induction Hl as [|?????? IH]; constructor; [by apply (Hlookup 0)|].
+ apply IH. apply (λ i, Hlookup (S i)).
+ Qed.
+ Lemma Forall2_lookup l k :
+ Forall2 P l k ↔ length l = length k ∧
+ (∀ i x y, l !! i = Some x → k !! i = Some y → P x y).
+ Proof.
+ naive_solver eauto using Forall2_length, Forall2_lookup_lr,Forall2_lookup_2.
+ Qed.
+ Lemma Forall2_tail l k : Forall2 P l k → Forall2 P (tail l) (tail k).
+ Proof. destruct 1; simpl; auto. Qed.
+ Lemma Forall2_alter_l f l k i :
+ Forall2 P l k →
+ (∀ x y, l !! i = Some x → k !! i = Some y → P x y → P (f x) y) →
+ Forall2 P (alter f i l) k.
+ Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed.
+ Lemma Forall2_alter_r f l k i :
+ Forall2 P l k →
+ (∀ x y, l !! i = Some x → k !! i = Some y → P x y → P x (f y)) →
+ Forall2 P l (alter f i k).
+ Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed.
+ Lemma Forall2_alter f g l k i :
+ Forall2 P l k →
+ (∀ x y, l !! i = Some x → k !! i = Some y → P x y → P (f x) (g y)) →
+ Forall2 P (alter f i l) (alter g i k).
+ Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed.
+ Lemma Forall2_insert l k x y i :
+ Forall2 P l k → P x y → Forall2 P (<[i:=x]> l) (<[i:=y]> k).
+ Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed.
+ Lemma Forall2_delete l k i :
+ Forall2 P l k → Forall2 P (delete i l) (delete i k).
+ Proof. intros Hl. revert i. induction Hl; intros [|]; simpl; intuition. Qed.
+ Lemma Forall2_replicate_l k n x :
+ length k = n → Forall (P x) k → Forall2 P (replicate n x) k.
+ Proof. intros <-. induction 1; simpl; auto. Qed.
+ Lemma Forall2_replicate_r l n y :
+ length l = n → Forall (flip P y) l → Forall2 P l (replicate n y).
+ Proof. intros <-. induction 1; simpl; auto. Qed.
+ Lemma Forall2_replicate n x y :
+ P x y → Forall2 P (replicate n x) (replicate n y).
+ Proof. induction n; simpl; constructor; auto. Qed.
+ Lemma Forall2_take l k n : Forall2 P l k → Forall2 P (take n l) (take n k).
+ Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed.
+ Lemma Forall2_drop l k n : Forall2 P l k → Forall2 P (drop n l) (drop n k).
+ Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed.
+ Lemma Forall2_resize l k x y n :
+ P x y → Forall2 P l k → Forall2 P (resize n x l) (resize n y k).
+ Proof.
+ intros. rewrite !resize_spec, (Forall2_length l k) by done.
+ auto using Forall2_app, Forall2_take, Forall2_replicate.
+ Qed.
+ Lemma Forall2_resize_l l k x y n m :
+ P x y → Forall (flip P y) l →
+ Forall2 P (resize n x l) k → Forall2 P (resize m x l) (resize m y k).
+ Proof.
+ intros. destruct (decide (m ≤ n)).
+ { rewrite <-(resize_resize l m n) by done. by apply Forall2_resize. }
+ intros. assert (n = length k); subst.
+ { by rewrite <-(Forall2_length (resize n x l) k), resize_length. }
+ rewrite (le_plus_minus (length k) m), !resize_plus,
+ resize_all, drop_all, resize_nil by lia.
+ auto using Forall2_app, Forall2_replicate_r,
+ Forall_resize, Forall_drop, resize_length.
+ Qed.
+ Lemma Forall2_resize_r l k x y n m :
+ P x y → Forall (P x) k →
+ Forall2 P l (resize n y k) → Forall2 P (resize m x l) (resize m y k).
+ Proof.
+ intros. destruct (decide (m ≤ n)).
+ { rewrite <-(resize_resize k m n) by done. by apply Forall2_resize. }
+ assert (n = length l); subst.
+ { by rewrite (Forall2_length l (resize n y k)), resize_length. }
+ rewrite (le_plus_minus (length l) m), !resize_plus,
+ resize_all, drop_all, resize_nil by lia.
+ auto using Forall2_app, Forall2_replicate_l,
+ Forall_resize, Forall_drop, resize_length.
+ Qed.
+ Lemma Forall2_resize_r_flip l k x y n m :
+ P x y → Forall (P x) k →
+ length k = m → Forall2 P l (resize n y k) → Forall2 P (resize m x l) k.
+ Proof.
+ intros ?? <- ?. rewrite <-(resize_all k y) at 2.
+ apply Forall2_resize_r with n; auto using Forall_true.
+ Qed.
+ Lemma Forall2_sublist_lookup_l l k n i l' :
+ Forall2 P l k → sublist_lookup n i l = Some l' →
+ ∃ k', sublist_lookup n i k = Some k' ∧ Forall2 P l' k'.
+ Proof.
+ unfold sublist_lookup. intros Hlk Hl.
+ exists (take i (drop n k)); simplify_option_equality.
+ * auto using Forall2_take, Forall2_drop.
+ * apply Forall2_length in Hlk; lia.
+ Qed.
+ Lemma Forall2_sublist_lookup_r l k n i k' :
+ Forall2 P l k → sublist_lookup n i k = Some k' →
+ ∃ l', sublist_lookup n i l = Some l' ∧ Forall2 P l' k'.
+ Proof.
+ intro. unfold sublist_lookup.
+ erewrite Forall2_length by eauto; intros; simplify_option_equality.
+ eauto using Forall2_take, Forall2_drop.
+ Qed.
+ Lemma Forall2_sublist_alter f g l k i n l' k' :
+ Forall2 P l k → sublist_lookup i n l = Some l' →
+ sublist_lookup i n k = Some k' → Forall2 P (f l') (g k') →
+ Forall2 P (sublist_alter f i n l) (sublist_alter g i n k).
+ Proof.
+ intro. unfold sublist_alter, sublist_lookup.
+ erewrite Forall2_length by eauto; intros; simplify_option_equality.
+ auto using Forall2_app, Forall2_drop, Forall2_take.
+ Qed.
+ Lemma Forall2_sublist_alter_l f l k i n l' k' :
+ Forall2 P l k → sublist_lookup i n l = Some l' →
+ sublist_lookup i n k = Some k' → Forall2 P (f l') k' →
+ Forall2 P (sublist_alter f i n l) k.
+ Proof.
+ intro. unfold sublist_lookup, sublist_alter.
+ erewrite <-Forall2_length by eauto; intros; simplify_option_equality.
+ apply Forall2_app_l;
+ rewrite ?take_length_le by lia; auto using Forall2_take.
+ apply Forall2_app_l; erewrite Forall2_length, take_length,
+ drop_length, <-Forall2_length, Min.min_l by eauto with lia; [done|].
+ rewrite drop_drop; auto using Forall2_drop.
+ Qed.
+ Lemma Forall2_transitive {C} (Q : B → C → Prop) (R : A → C → Prop) l k lC :
+ (∀ x y z, P x y → Q y z → R x z) →
+ Forall2 P l k → Forall2 Q k lC → Forall2 R l lC.
+ Proof. intros ? Hl. revert lC. induction Hl; inversion_clear 1; eauto. Qed.
+ Lemma Forall2_Forall (Q : A → A → Prop) l :
+ Forall (λ x, Q x x) l → Forall2 Q l l.
+ Proof. induction 1; constructor; auto. Qed.
+ Global Instance Forall2_dec `{dec : ∀ x y, Decision (P x y)} :
+ ∀ l k, Decision (Forall2 P l k).
+ Proof.
+ refine (
+ fix go l k : Decision (Forall2 P l k) :=
+ match l, k with
+ | [], [] => left _
+ | x :: l, y :: k => cast_if_and (decide (P x y)) (go l k)
+ | _, _ => right _
+ end); clear dec go; abstract first [by constructor | by inversion 1].
+ Defined.
+End Forall2.
+
+Section Forall2_order.
+ Context {A} (R : relation A).
+ Global Instance: Reflexive R → Reflexive (Forall2 R).
+ Proof. intros ? l. induction l; by constructor. Qed.
+ Global Instance: Symmetric R → Symmetric (Forall2 R).
+ Proof. intros. induction 1; constructor; auto. Qed.
+ Global Instance: Transitive R → Transitive (Forall2 R).
+ Proof. intros ????. apply Forall2_transitive. by apply @transitivity. Qed.
+ Global Instance: Equivalence R → Equivalence (Forall2 R).
+ Proof. split; apply _. Qed.
+ Global Instance: PreOrder R → PreOrder (Forall2 R).
+ Proof. split; apply _. Qed.
+ Global Instance: AntiSymmetric (=) R → AntiSymmetric (=) (Forall2 R).
+ Proof. induction 2; inversion_clear 1; f_equal; auto. Qed.
+ Global Instance: Proper (R ==> Forall2 R ==> Forall2 R) (::).
+ Proof. by constructor. Qed.
+ Global Instance: Proper (Forall2 R ==> Forall2 R ==> Forall2 R) (++).
+ Proof. repeat intro. eauto using Forall2_app. Qed.
+ Global Instance: Proper (Forall2 R ==> Forall2 R) (delete i).
+ Proof. repeat intro. eauto using Forall2_delete. Qed.
+ Global Instance: Proper (R ==> Forall2 R) (replicate n).
+ Proof. repeat intro. eauto using Forall2_replicate. Qed.
+ Global Instance: Proper (Forall2 R ==> Forall2 R) (take n).
+ Proof. repeat intro. eauto using Forall2_take. Qed.
+ Global Instance: Proper (Forall2 R ==> Forall2 R) (drop n).
+ Proof. repeat intro. eauto using Forall2_drop. Qed.
+ Global Instance: Proper (R ==> Forall2 R ==> Forall2 R) (resize n).
+ Proof. repeat intro. eauto using Forall2_resize. Qed.
+End Forall2_order.
+
+Section Forall3.
+ Context {A B C} (P : A → B → C → Prop).
+ Hint Extern 0 (Forall3 _ _ _ _) => constructor.
+ Lemma Forall3_app l1 l2 k1 k2 k1' k2' :
+ Forall3 P l1 k1 k1' → Forall3 P l2 k2 k2' →
+ Forall3 P (l1 ++ l2) (k1 ++ k2) (k1' ++ k2').
+ Proof. induction 1; simpl; auto. Qed.
+ Lemma Forall3_cons_inv_l x l k k' :
+ Forall3 P (x :: l) k k' → ∃ y k2 z k2',
+ k = y :: k2 ∧ k' = z :: k2' ∧ P x y z ∧ Forall3 P l k2 k2'.
+ Proof. inversion_clear 1; naive_solver. Qed.
+ Lemma Forall3_app_inv_l l1 l2 k k' :
+ Forall3 P (l1 ++ l2) k k' → ∃ k1 k2 k1' k2',
+ k = k1 ++ k2 ∧ k' = k1' ++ k2' ∧ Forall3 P l1 k1 k1' ∧ Forall3 P l2 k2 k2'.
+ Proof.
+ revert k k'. induction l1 as [|x l1 IH]; simpl; inversion_clear 1.
+ * by repeat eexists; eauto.
+ * by repeat eexists; eauto.
+ * edestruct IH as (?&?&?&?&?&?&?&?); eauto; naive_solver.
+ Qed.
+ Lemma Forall3_cons_inv_m l y k k' :
+ Forall3 P l (y :: k) k' → ∃ x l2 z k2',
+ l = x :: l2 ∧ k' = z :: k2' ∧ P x y z ∧ Forall3 P l2 k k2'.
+ Proof. inversion_clear 1; naive_solver. Qed.
+ Lemma Forall3_app_inv_m l k1 k2 k' :
+ Forall3 P l (k1 ++ k2) k' → ∃ l1 l2 k1' k2',
+ l = l1 ++ l2 ∧ k' = k1' ++ k2' ∧ Forall3 P l1 k1 k1' ∧ Forall3 P l2 k2 k2'.
+ Proof.
+ revert l k'. induction k1 as [|x k1 IH]; simpl; inversion_clear 1.
+ * by repeat eexists; eauto.
+ * by repeat eexists; eauto.
+ * edestruct IH as (?&?&?&?&?&?&?&?); eauto; naive_solver.
+ Qed.
+ Lemma Forall3_cons_inv_r l k z k' :
+ Forall3 P l k (z :: k') → ∃ x l2 y k2,
+ l = x :: l2 ∧ k = y :: k2 ∧ P x y z ∧ Forall3 P l2 k2 k'.
+ Proof. inversion_clear 1; naive_solver. Qed.
+ Lemma Forall3_app_inv_r l k k1' k2' :
+ Forall3 P l k (k1' ++ k2') → ∃ l1 l2 k1 k2,
+ l = l1 ++ l2 ∧ k = k1 ++ k2 ∧ Forall3 P l1 k1 k1' ∧ Forall3 P l2 k2 k2'.
+ Proof.
+ revert l k. induction k1' as [|x k1' IH]; simpl; inversion_clear 1.
+ * by repeat eexists; eauto.
+ * by repeat eexists; eauto.
+ * edestruct IH as (?&?&?&?&?&?&?&?); eauto; naive_solver.
+ Qed.
+ Lemma Forall3_impl (Q : A → B → C → Prop) l k k' :
+ Forall3 P l k k' → (∀ x y z, P x y z → Q x y z) → Forall3 Q l k k'.
+ Proof. intros Hl ?; induction Hl; auto. Defined.
+ Lemma Forall3_length_lm l k k' : Forall3 P l k k' → length l = length k.
+ Proof. by induction 1; f_equal'. Qed.
+ Lemma Forall3_length_lr l k k' : Forall3 P l k k' → length l = length k'.
+ Proof. by induction 1; f_equal'. Qed.
+ Lemma Forall3_lookup_lmr l k k' i x y z :
+ Forall3 P l k k' →
+ l !! i = Some x → k !! i = Some y → k' !! i = Some z → P x y z.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ???; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall3_lookup_l l k k' i x :
+ Forall3 P l k k' → l !! i = Some x →
+ ∃ y z, k !! i = Some y ∧ k' !! i = Some z ∧ P x y z.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ?; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall3_lookup_m l k k' i y :
+ Forall3 P l k k' → k !! i = Some y →
+ ∃ x z, l !! i = Some x ∧ k' !! i = Some z ∧ P x y z.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ?; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall3_lookup_r l k k' i z :
+ Forall3 P l k k' → k' !! i = Some z →
+ ∃ x y, l !! i = Some x ∧ k !! i = Some y ∧ P x y z.
+ Proof.
+ intros H. revert i. induction H; intros [|?] ?; simplify_equality'; eauto.
+ Qed.
+ Lemma Forall3_alter_lm f g l k k' i :
+ Forall3 P l k k' →
+ (∀ x y z, l !! i = Some x → k !! i = Some y → k' !! i = Some z →
+ P x y z → P (f x) (g y) z) →
+ Forall3 P (alter f i l) (alter g i k) k'.
+ Proof. intros Hl. revert i. induction Hl; intros [|]; auto. Qed.
+End Forall3.
+
+(** * Properties of the monadic operations *)
+Section fmap.
+ Context {A B : Type} (f : A → B).
+
+ Lemma list_fmap_id (l : list A) : id <$> l = l.
+ Proof. induction l; f_equal'; auto. Qed.
+ Lemma list_fmap_compose {C} (g : B → C) l : g ∘ f <$> l = g <$> f <$> l.
+ Proof. induction l; f_equal'; auto. Qed.
+ Lemma list_fmap_ext (g : A → B) (l1 l2 : list A) :
+ (∀ x, f x = g x) → l1 = l2 → fmap f l1 = fmap g l2.
+ Proof. intros ? <-. induction l1; f_equal'; auto. Qed.
+ Global Instance: Injective (=) (=) f → Injective (=) (=) (fmap f).
+ Proof.
+ intros ? l1. induction l1 as [|x l1 IH]; [by intros [|??]|].
+ intros [|??]; intros; f_equal'; simplify_equality; auto.
+ Qed.
+ Definition fmap_nil : f <$> [] = [] := eq_refl.
+ Definition fmap_cons x l : f <$> x :: l = f x :: f <$> l := eq_refl.
+ Lemma fmap_app l1 l2 : f <$> l1 ++ l2 = (f <$> l1) ++ (f <$> l2).
+ Proof. by induction l1; f_equal'. Qed.
+ Lemma fmap_nil_inv k : f <$> k = [] → k = [].
+ Proof. by destruct k. Qed.
+ Lemma fmap_cons_inv y l k :
+ f <$> l = y :: k → ∃ x l', y = f x ∧ k = f <$> l' ∧ l = x :: l'.
+ Proof. intros. destruct l; simplify_equality'; eauto. Qed.
+ Lemma fmap_app_inv l k1 k2 :
+ f <$> l = k1 ++ k2 → ∃ l1 l2, k1 = f <$> l1 ∧ k2 = f <$> l2 ∧ l = l1 ++ l2.
+ Proof.
+ revert l. induction k1 as [|y k1 IH]; simpl; [intros l ?; by eexists [],l|].
+ intros [|x l] ?; simplify_equality'.
+ destruct (IH l) as (l1&l2&->&->&->); [done|]. by exists (x :: l1), l2.
+ Qed.
+ Lemma fmap_length l : length (f <$> l) = length l.
+ Proof. by induction l; f_equal'. Qed.
+ Lemma fmap_reverse l : f <$> reverse l = reverse (f <$> l).
+ Proof.
+ induction l as [|?? IH]; csimpl; by rewrite ?reverse_cons, ?fmap_app, ?IH.
+ Qed.
+ Lemma fmap_tail l : f <$> tail l = tail (f <$> l).
+ Proof. by destruct l. Qed.
+ Lemma fmap_last l : last (f <$> l) = f <$> last l.
+ Proof. induction l as [|? []]; simpl; auto. Qed.
+ Lemma fmap_replicate n x : f <$> replicate n x = replicate n (f x).
+ Proof. by induction n; f_equal'. Qed.
+ Lemma fmap_take n l : f <$> take n l = take n (f <$> l).
+ Proof. revert n. by induction l; intros [|?]; f_equal'. Qed.
+ Lemma fmap_drop n l : f <$> drop n l = drop n (f <$> l).
+ Proof. revert n. by induction l; intros [|?]; f_equal'. Qed.
+ Lemma fmap_resize n x l : f <$> resize n x l = resize n (f x) (f <$> l).
+ Proof.
+ revert n. induction l; intros [|?]; f_equal'; auto using fmap_replicate.
+ Qed.
+ Lemma const_fmap (l : list A) (y : B) :
+ (∀ x, f x = y) → f <$> l = replicate (length l) y.
+ Proof. intros; induction l; f_equal'; auto. Qed.
+ Lemma list_lookup_fmap l i : (f <$> l) !! i = f <$> (l !! i).
+ Proof. revert i. induction l; by intros [|]. Qed.
+ Lemma list_lookup_fmap_inv l i x :
+ (f <$> l) !! i = Some x → ∃ y, x = f y ∧ l !! i = Some y.
+ Proof.
+ intros Hi. rewrite list_lookup_fmap in Hi.
+ destruct (l !! i) eqn:?; simplify_equality'; eauto.
+ Qed.
+ Lemma list_alter_fmap (g : A → A) (h : B → B) l i :
+ Forall (λ x, f (g x) = h (f x)) l → f <$> alter g i l = alter h i (f <$> l).
+ Proof. intros Hl. revert i. by induction Hl; intros [|i]; f_equal'. Qed.
+ Lemma elem_of_list_fmap_1 l x : x ∈ l → f x ∈ f <$> l.
+ Proof. induction 1; csimpl; rewrite elem_of_cons; intuition. Qed.
+ Lemma elem_of_list_fmap_1_alt l x y : x ∈ l → y = f x → y ∈ f <$> l.
+ Proof. intros. subst. by apply elem_of_list_fmap_1. Qed.
+ Lemma elem_of_list_fmap_2 l x : x ∈ f <$> l → ∃ y, x = f y ∧ y ∈ l.
+ Proof.
+ induction l as [|y l IH]; simpl; inversion_clear 1.
+ * exists y. split; [done | by left].
+ * destruct IH as [z [??]]. done. exists z. split; [done | by right].
+ Qed.
+ Lemma elem_of_list_fmap l x : x ∈ f <$> l ↔ ∃ y, x = f y ∧ y ∈ l.
+ Proof.
+ naive_solver eauto using elem_of_list_fmap_1_alt, elem_of_list_fmap_2.
+ Qed.
+ Lemma NoDup_fmap_1 l : NoDup (f <$> l) → NoDup l.
+ Proof.
+ induction l; simpl; inversion_clear 1; constructor; auto.
+ rewrite elem_of_list_fmap in *. naive_solver.
+ Qed.
+ Lemma NoDup_fmap_2 `{!Injective (=) (=) f} l : NoDup l → NoDup (f <$> l).
+ Proof.
+ induction 1; simpl; constructor; trivial. rewrite elem_of_list_fmap.
+ intros [y [Hxy ?]]. apply (injective f) in Hxy. by subst.
+ Qed.
+ Lemma NoDup_fmap `{!Injective (=) (=) f} l : NoDup (f <$> l) ↔ NoDup l.
+ Proof. split; auto using NoDup_fmap_1, NoDup_fmap_2. Qed.
+ Global Instance fmap_sublist: Proper (sublist ==> sublist) (fmap f).
+ Proof. induction 1; simpl; econstructor; eauto. Qed.
+ Global Instance fmap_contains: Proper (contains ==> contains) (fmap f).
+ Proof. induction 1; simpl; econstructor; eauto. Qed.
+ Global Instance fmap_Permutation: Proper ((≡ₚ) ==> (≡ₚ)) (fmap f).
+ Proof. induction 1; simpl; econstructor; eauto. Qed.
+ Lemma Forall_fmap_ext_1 (g : A → B) (l : list A) :
+ Forall (λ x, f x = g x) l → fmap f l = fmap g l.
+ Proof. by induction 1; f_equal'. Qed.
+ Lemma Forall_fmap_ext (g : A → B) (l : list A) :
+ Forall (λ x, f x = g x) l ↔ fmap f l = fmap g l.
+ Proof.
+ split; [auto using Forall_fmap_ext_1|].
+ induction l; simpl; constructor; simplify_equality; auto.
+ Qed.
+ Lemma Forall_fmap (P : B → Prop) l : Forall P (f <$> l) ↔ Forall (P ∘ f) l.
+ Proof. split; induction l; inversion_clear 1; constructor; auto. Qed.
+ Lemma Exists_fmap (P : B → Prop) l : Exists P (f <$> l) ↔ Exists (P ∘ f) l.
+ Proof. split; induction l; inversion 1; constructor; by auto. Qed.
+ Lemma Forall2_fmap_l {C} (P : B → C → Prop) l1 l2 :
+ Forall2 P (f <$> l1) l2 ↔ Forall2 (P ∘ f) l1 l2.
+ Proof.
+ split; revert l2; induction l1; inversion_clear 1; constructor; auto.
+ Qed.
+ Lemma Forall2_fmap_r {C} (P : C → B → Prop) l1 l2 :
+ Forall2 P l1 (f <$> l2) ↔ Forall2 (λ x, P x ∘ f) l1 l2.
+ Proof.
+ split; revert l1; induction l2; inversion_clear 1; constructor; auto.
+ Qed.
+ Lemma Forall2_fmap_1 {C D} (g : C → D) (P : B → D → Prop) l1 l2 :
+ Forall2 P (f <$> l1) (g <$> l2) → Forall2 (λ x1 x2, P (f x1) (g x2)) l1 l2.
+ Proof. revert l2; induction l1; intros [|??]; inversion_clear 1; auto. Qed.
+ Lemma Forall2_fmap_2 {C D} (g : C → D) (P : B → D → Prop) l1 l2 :
+ Forall2 (λ x1 x2, P (f x1) (g x2)) l1 l2 → Forall2 P (f <$> l1) (g <$> l2).
+ Proof. induction 1; csimpl; auto. Qed.
+ Lemma Forall2_fmap {C D} (g : C → D) (P : B → D → Prop) l1 l2 :
+ Forall2 P (f <$> l1) (g <$> l2) ↔ Forall2 (λ x1 x2, P (f x1) (g x2)) l1 l2.
+ Proof. split; auto using Forall2_fmap_1, Forall2_fmap_2. Qed.
+ Lemma list_fmap_bind {C} (g : B → list C) l : (f <$> l) ≫= g = l ≫= g ∘ f.
+ Proof. by induction l; f_equal'. Qed.
+End fmap.
+
+Lemma list_alter_fmap_mono {A} (f : A → A) (g : A → A) l i :
+ Forall (λ x, f (g x) = g (f x)) l → f <$> alter g i l = alter g i (f <$> l).
+Proof. auto using list_alter_fmap. Qed.
+Lemma NoDup_fmap_fst {A B} (l : list (A * B)) :
+ (∀ x y1 y2, (x,y1) ∈ l → (x,y2) ∈ l → y1 = y2) → NoDup l → NoDup (l.*1).
+Proof.
+ intros Hunique. induction 1 as [|[x1 y1] l Hin Hnodup IH]; csimpl; constructor.
+ * rewrite elem_of_list_fmap.
+ intros [[x2 y2] [??]]; simpl in *; subst. destruct Hin.
+ rewrite (Hunique x2 y1 y2); rewrite ?elem_of_cons; auto.
+ * apply IH. intros. eapply Hunique; rewrite ?elem_of_cons; eauto.
+Qed.
+
+Section bind.
+ Context {A B : Type} (f : A → list B).
+
+ Lemma list_bind_ext (g : A → list B) l1 l2 :
+ (∀ x, f x = g x) → l1 = l2 → l1 ≫= f = l2 ≫= g.
+ Proof. intros ? <-. by induction l1; f_equal'. Qed.
+ Lemma Forall_bind_ext (g : A → list B) (l : list A) :
+ Forall (λ x, f x = g x) l → l ≫= f = l ≫= g.
+ Proof. by induction 1; f_equal'. Qed.
+ Global Instance bind_sublist: Proper (sublist ==> sublist) (mbind f).
+ Proof.
+ induction 1; simpl; auto;
+ [by apply sublist_app|by apply sublist_inserts_l].
+ Qed.
+ Global Instance bind_contains: Proper (contains ==> contains) (mbind f).
+ Proof.
+ induction 1; csimpl; auto.
+ * by apply contains_app.
+ * by rewrite !(associative_L (++)), (commutative (++) (f _)).
+ * by apply contains_inserts_l.
+ * etransitivity; eauto.
+ Qed.
+ Global Instance bind_Permutation: Proper ((≡ₚ) ==> (≡ₚ)) (mbind f).
+ Proof.
+ induction 1; csimpl; auto.
+ * by f_equiv.
+ * by rewrite !(associative_L (++)), (commutative (++) (f _)).
+ * etransitivity; eauto.
+ Qed.
+ Lemma bind_cons x l : (x :: l) ≫= f = f x ++ l ≫= f.
+ Proof. done. Qed.
+ Lemma bind_singleton x : [x] ≫= f = f x.
+ Proof. csimpl. by rewrite (right_id_L _ (++)). Qed.
+ Lemma bind_app l1 l2 : (l1 ++ l2) ≫= f = (l1 ≫= f) ++ (l2 ≫= f).
+ Proof. by induction l1; csimpl; rewrite <-?(associative_L (++)); f_equal. Qed.
+ Lemma elem_of_list_bind (x : B) (l : list A) :
+ x ∈ l ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ l.
+ Proof.
+ split.
+ * induction l as [|y l IH]; csimpl; [inversion 1|].
+ rewrite elem_of_app. intros [?|?].
+ + exists y. split; [done | by left].
+ + destruct IH as [z [??]]. done. exists z. split; [done | by right].
+ * intros [y [Hx Hy]]. induction Hy; csimpl; rewrite elem_of_app; intuition.
+ Qed.
+ Lemma Forall_bind (P : B → Prop) l :
+ Forall P (l ≫= f) ↔ Forall (Forall P ∘ f) l.
+ Proof.
+ split.
+ * induction l; csimpl; rewrite ?Forall_app; constructor; csimpl; intuition.
+ * induction 1; csimpl; rewrite ?Forall_app; auto.
+ Qed.
+ Lemma Forall2_bind {C D} (g : C → list D) (P : B → D → Prop) l1 l2 :
+ Forall2 (λ x1 x2, Forall2 P (f x1) (g x2)) l1 l2 →
+ Forall2 P (l1 ≫= f) (l2 ≫= g).
+ Proof. induction 1; csimpl; auto using Forall2_app. Qed.
+End bind.
+
+Section ret_join.
+ Context {A : Type}.
+
+ Lemma list_join_bind (ls : list (list A)) : mjoin ls = ls ≫= id.
+ Proof. by induction ls; f_equal'. Qed.
+ Global Instance mjoin_Permutation:
+ Proper (@Permutation (list A) ==> (≡ₚ)) mjoin.
+ Proof. intros ?? E. by rewrite !list_join_bind, E. Qed.
+ Lemma elem_of_list_ret (x y : A) : x ∈ @mret list _ A y ↔ x = y.
+ Proof. apply elem_of_list_singleton. Qed.
+ Lemma elem_of_list_join (x : A) (ls : list (list A)) :
+ x ∈ mjoin ls ↔ ∃ l, x ∈ l ∧ l ∈ ls.
+ Proof. by rewrite list_join_bind, elem_of_list_bind. Qed.
+ Lemma join_nil (ls : list (list A)) : mjoin ls = [] ↔ Forall (= []) ls.
+ Proof.
+ split; [|by induction 1 as [|[|??] ?]].
+ by induction ls as [|[|??] ?]; constructor; auto.
+ Qed.
+ Lemma join_nil_1 (ls : list (list A)) : mjoin ls = [] → Forall (= []) ls.
+ Proof. by rewrite join_nil. Qed.
+ Lemma join_nil_2 (ls : list (list A)) : Forall (= []) ls → mjoin ls = [].
+ Proof. by rewrite join_nil. Qed.
+ Lemma Forall_join (P : A → Prop) (ls: list (list A)) :
+ Forall (Forall P) ls → Forall P (mjoin ls).
+ Proof. induction 1; simpl; auto using Forall_app_2. Qed.
+ Lemma Forall2_join {B} (P : A → B → Prop) ls1 ls2 :
+ Forall2 (Forall2 P) ls1 ls2 → Forall2 P (mjoin ls1) (mjoin ls2).
+ Proof. induction 1; simpl; auto using Forall2_app. Qed.
+End ret_join.
+
+Section mapM.
+ Context {A B : Type} (f : A → option B).
+
+ Lemma mapM_ext (g : A → option B) l : (∀ x, f x = g x) → mapM f l = mapM g l.
+ Proof. intros Hfg. by induction l; simpl; rewrite ?Hfg, ?IHl. Qed.
+ Lemma Forall2_mapM_ext (g : A → option B) l k :
+ Forall2 (λ x y, f x = g y) l k → mapM f l = mapM g k.
+ Proof. induction 1 as [|???? Hfg ? IH]; simpl. done. by rewrite Hfg, IH. Qed.
+ Lemma Forall_mapM_ext (g : A → option B) l :
+ Forall (λ x, f x = g x) l → mapM f l = mapM g l.
+ Proof. induction 1 as [|?? Hfg ? IH]; simpl. done. by rewrite Hfg, IH. Qed.
+ Lemma mapM_Some_1 l k : mapM f l = Some k → Forall2 (λ x y, f x = Some y) l k.
+ Proof.
+ revert k. induction l as [|x l]; intros [|y k]; simpl; try done.
+ * destruct (f x); simpl; [|discriminate]. by destruct (mapM f l).
+ * destruct (f x) eqn:?; intros; simplify_option_equality; auto.
+ Qed.
+ Lemma mapM_Some_2 l k : Forall2 (λ x y, f x = Some y) l k → mapM f l = Some k.
+ Proof.
+ induction 1 as [|???? Hf ? IH]; simpl; [done |].
+ rewrite Hf. simpl. by rewrite IH.
+ Qed.
+ Lemma mapM_Some l k : mapM f l = Some k ↔ Forall2 (λ x y, f x = Some y) l k.
+ Proof. split; auto using mapM_Some_1, mapM_Some_2. Qed.
+ Lemma mapM_length l k : mapM f l = Some k → length l = length k.
+ Proof. intros. by eapply Forall2_length, mapM_Some_1. Qed.
+ Lemma mapM_None_1 l : mapM f l = None → Exists (λ x, f x = None) l.
+ Proof.
+ induction l as [|x l IH]; simpl; [done|].
+ destruct (f x) eqn:?; simpl; eauto. by destruct (mapM f l); eauto.
+ Qed.
+ Lemma mapM_None_2 l : Exists (λ x, f x = None) l → mapM f l = None.
+ Proof.
+ induction 1 as [x l Hx|x l ? IH]; simpl; [by rewrite Hx|].
+ by destruct (f x); simpl; rewrite ?IH.
+ Qed.
+ Lemma mapM_None l : mapM f l = None ↔ Exists (λ x, f x = None) l.
+ Proof. split; auto using mapM_None_1, mapM_None_2. Qed.
+ Lemma mapM_is_Some_1 l : is_Some (mapM f l) → Forall (is_Some ∘ f) l.
+ Proof.
+ unfold compose. setoid_rewrite <-not_eq_None_Some.
+ rewrite mapM_None. apply (not_Exists_Forall _).
+ Qed.
+ Lemma mapM_is_Some_2 l : Forall (is_Some ∘ f) l → is_Some (mapM f l).
+ Proof.
+ unfold compose. setoid_rewrite <-not_eq_None_Some.
+ rewrite mapM_None. apply (Forall_not_Exists _).
+ Qed.
+ Lemma mapM_is_Some l : is_Some (mapM f l) ↔ Forall (is_Some ∘ f) l.
+ Proof. split; auto using mapM_is_Some_1, mapM_is_Some_2. Qed.
+ Lemma mapM_fmap_Some (g : B → A) (l : list B) :
+ (∀ x, f (g x) = Some x) → mapM f (g <$> l) = Some l.
+ Proof. intros. by induction l; simpl; simplify_option_equality. Qed.
+ Lemma mapM_fmap_Some_inv (g : B → A) (l : list B) (k : list A) :
+ (∀ x y, f y = Some x → y = g x) → mapM f k = Some l → k = g <$> l.
+ Proof.
+ intros Hgf. revert l; induction k as [|??]; intros [|??] ?;
+ simplify_option_equality; f_equiv; eauto.
+ Qed.
+End mapM.
+
+(** ** Properties of the [permutations] function *)
+Section permutations.
+ Context {A : Type}.
+ Implicit Types x y z : A.
+ Implicit Types l : list A.
+
+ Lemma interleave_cons x l : x :: l ∈ interleave x l.
+ Proof. destruct l; simpl; rewrite elem_of_cons; auto. Qed.
+ Lemma interleave_Permutation x l l' : l' ∈ interleave x l → l' ≡ₚ x :: l.
+ Proof.
+ revert l'. induction l as [|y l IH]; intros l'; simpl.
+ * rewrite elem_of_list_singleton. by intros ->.
+ * rewrite elem_of_cons, elem_of_list_fmap. intros [->|[? [-> H]]]; [done|].
+ rewrite (IH _ H). constructor.
+ Qed.
+ Lemma permutations_refl l : l ∈ permutations l.
+ Proof.
+ induction l; simpl; [by apply elem_of_list_singleton|].
+ apply elem_of_list_bind. eauto using interleave_cons.
+ Qed.
+ Lemma permutations_skip x l l' :
+ l ∈ permutations l' → x :: l ∈ permutations (x :: l').
+ Proof. intro. apply elem_of_list_bind; eauto using interleave_cons. Qed.
+ Lemma permutations_swap x y l : y :: x :: l ∈ permutations (x :: y :: l).
+ Proof.
+ simpl. apply elem_of_list_bind. exists (y :: l). split; simpl.
+ * destruct l; csimpl; rewrite !elem_of_cons; auto.
+ * apply elem_of_list_bind. simpl.
+ eauto using interleave_cons, permutations_refl.
+ Qed.
+ Lemma permutations_nil l : l ∈ permutations [] ↔ l = [].
+ Proof. simpl. by rewrite elem_of_list_singleton. Qed.
+ Lemma interleave_interleave_toggle x1 x2 l1 l2 l3 :
+ l1 ∈ interleave x1 l2 → l2 ∈ interleave x2 l3 → ∃ l4,
+ l1 ∈ interleave x2 l4 ∧ l4 ∈ interleave x1 l3.
+ Proof.
+ revert l1 l2. induction l3 as [|y l3 IH]; intros l1 l2; simpl.
+ { rewrite !elem_of_list_singleton. intros ? ->. exists [x1].
+ change (interleave x2 [x1]) with ([[x2; x1]] ++ [[x1; x2]]).
+ by rewrite (commutative (++)), elem_of_list_singleton. }
+ rewrite elem_of_cons, elem_of_list_fmap.
+ intros Hl1 [? | [l2' [??]]]; simplify_equality'.
+ * rewrite !elem_of_cons, elem_of_list_fmap in Hl1.
+ destruct Hl1 as [? | [? | [l4 [??]]]]; subst.
+ + exists (x1 :: y :: l3). csimpl. rewrite !elem_of_cons. tauto.
+ + exists (x1 :: y :: l3). csimpl. rewrite !elem_of_cons. tauto.
+ + exists l4. simpl. rewrite elem_of_cons. auto using interleave_cons.
+ * rewrite elem_of_cons, elem_of_list_fmap in Hl1.
+ destruct Hl1 as [? | [l1' [??]]]; subst.
+ + exists (x1 :: y :: l3). csimpl.
+ rewrite !elem_of_cons, !elem_of_list_fmap.
+ split; [| by auto]. right. right. exists (y :: l2').
+ rewrite elem_of_list_fmap. naive_solver.
+ + destruct (IH l1' l2') as [l4 [??]]; auto. exists (y :: l4). simpl.
+ rewrite !elem_of_cons, !elem_of_list_fmap. naive_solver.
+ Qed.
+ Lemma permutations_interleave_toggle x l1 l2 l3 :
+ l1 ∈ permutations l2 → l2 ∈ interleave x l3 → ∃ l4,
+ l1 ∈ interleave x l4 ∧ l4 ∈ permutations l3.
+ Proof.
+ revert l1 l2. induction l3 as [|y l3 IH]; intros l1 l2; simpl.
+ { rewrite elem_of_list_singleton. intros Hl1 ->. eexists [].
+ by rewrite elem_of_list_singleton. }
+ rewrite elem_of_cons, elem_of_list_fmap.
+ intros Hl1 [? | [l2' [? Hl2']]]; simplify_equality'.
+ * rewrite elem_of_list_bind in Hl1.
+ destruct Hl1 as [l1' [??]]. by exists l1'.
+ * rewrite elem_of_list_bind in Hl1. setoid_rewrite elem_of_list_bind.
+ destruct Hl1 as [l1' [??]]. destruct (IH l1' l2') as (l1''&?&?); auto.
+ destruct (interleave_interleave_toggle y x l1 l1' l1'') as (?&?&?); eauto.
+ Qed.
+ Lemma permutations_trans l1 l2 l3 :
+ l1 ∈ permutations l2 → l2 ∈ permutations l3 → l1 ∈ permutations l3.
+ Proof.
+ revert l1 l2. induction l3 as [|x l3 IH]; intros l1 l2; simpl.
+ * rewrite !elem_of_list_singleton. intros Hl1 ->; simpl in *.
+ by rewrite elem_of_list_singleton in Hl1.
+ * rewrite !elem_of_list_bind. intros Hl1 [l2' [Hl2 Hl2']].
+ destruct (permutations_interleave_toggle x l1 l2 l2') as [? [??]]; eauto.
+ Qed.
+ Lemma permutations_Permutation l l' : l' ∈ permutations l ↔ l ≡ₚ l'.
+ Proof.
+ split.
+ * revert l'. induction l; simpl; intros l''.
+ + rewrite elem_of_list_singleton. by intros ->.
+ + rewrite elem_of_list_bind. intros [l' [Hl'' ?]].
+ rewrite (interleave_Permutation _ _ _ Hl''). constructor; auto.
+ * induction 1; eauto using permutations_refl,
+ permutations_skip, permutations_swap, permutations_trans.
+ Qed.
+End permutations.
+
+(** ** Properties of the folding functions *)
+Definition foldr_app := @fold_right_app.
+Lemma foldl_app {A B} (f : A → B → A) (l k : list B) (a : A) :
+ foldl f a (l ++ k) = foldl f (foldl f a l) k.
+Proof. revert a. induction l; simpl; auto. Qed.
+Lemma foldr_permutation {A B} (R : relation B) `{!Equivalence R}
+ (f : A → B → B) (b : B) `{!Proper ((=) ==> R ==> R) f}
+ (Hf : ∀ a1 a2 b, R (f a1 (f a2 b)) (f a2 (f a1 b))) :
+ Proper ((≡ₚ) ==> R) (foldr f b).
+Proof. induction 1; simpl; [done|by f_equiv|apply Hf|etransitivity; eauto]. Qed.
+
+(** ** Properties of the [zip_with] and [zip] functions *)
+Section zip_with.
+ Context {A B C : Type} (f : A → B → C).
+ Implicit Types x : A.
+ Implicit Types y : B.
+ Implicit Types l : list A.
+ Implicit Types k : list B.
+
+ Lemma zip_with_nil_r l : zip_with f l [] = [].
+ Proof. by destruct l. Qed.
+ Lemma zip_with_app l1 l2 k1 k2 :
+ length l1 = length k1 →
+ zip_with f (l1 ++ l2) (k1 ++ k2) = zip_with f l1 k1 ++ zip_with f l2 k2.
+ Proof. rewrite <-Forall2_same_length. induction 1; f_equal'; auto. Qed.
+ Lemma zip_with_app_l l1 l2 k :
+ zip_with f (l1 ++ l2) k
+ = zip_with f l1 (take (length l1) k) ++ zip_with f l2 (drop (length l1) k).
+ Proof.
+ revert k. induction l1; intros [|??]; f_equal'; auto. by destruct l2.
+ Qed.
+ Lemma zip_with_app_r l k1 k2 :
+ zip_with f l (k1 ++ k2)
+ = zip_with f (take (length k1) l) k1 ++ zip_with f (drop (length k1) l) k2.
+ Proof. revert l. induction k1; intros [|??]; f_equal'; auto. Qed.
+ Lemma zip_with_flip l k : zip_with (flip f) k l = zip_with f l k.
+ Proof. revert k. induction l; intros [|??]; f_equal'; auto. Qed.
+ Lemma zip_with_ext (g : A → B → C) l1 l2 k1 k2 :
+ (∀ x y, f x y = g x y) → l1 = l2 → k1 = k2 →
+ zip_with f l1 k1 = zip_with g l2 k2.
+ Proof. intros ? <-<-. revert k1. by induction l1; intros [|??]; f_equal'. Qed.
+ Lemma Forall_zip_with_ext_l (g : A → B → C) l k1 k2 :
+ Forall (λ x, ∀ y, f x y = g x y) l → k1 = k2 →
+ zip_with f l k1 = zip_with g l k2.
+ Proof. intros Hl <-. revert k1. by induction Hl; intros [|??]; f_equal'. Qed.
+ Lemma Forall_zip_with_ext_r (g : A → B → C) l1 l2 k :
+ l1 = l2 → Forall (λ y, ∀ x, f x y = g x y) k →
+ zip_with f l1 k = zip_with g l2 k.
+ Proof. intros <- Hk. revert l1. by induction Hk; intros [|??]; f_equal'. Qed.
+ Lemma zip_with_fmap_l {D} (g : D → A) lD k :
+ zip_with f (g <$> lD) k = zip_with (λ z, f (g z)) lD k.
+ Proof. revert k. by induction lD; intros [|??]; f_equal'. Qed.
+ Lemma zip_with_fmap_r {D} (g : D → B) l kD :
+ zip_with f l (g <$> kD) = zip_with (λ x z, f x (g z)) l kD.
+ Proof. revert kD. by induction l; intros [|??]; f_equal'. Qed.
+ Lemma zip_with_nil_inv l k : zip_with f l k = [] → l = [] ∨ k = [].
+ Proof. destruct l, k; intros; simplify_equality'; auto. Qed.
+ Lemma zip_with_cons_inv l k z lC :
+ zip_with f l k = z :: lC →
+ ∃ x y l' k', z = f x y ∧ lC = zip_with f l' k' ∧ l = x :: l' ∧ k = y :: k'.
+ Proof. intros. destruct l, k; simplify_equality'; repeat eexists. Qed.
+ Lemma zip_with_app_inv l k lC1 lC2 :
+ zip_with f l k = lC1 ++ lC2 →
+ ∃ l1 k1 l2 k2, lC1 = zip_with f l1 k1 ∧ lC2 = zip_with f l2 k2 ∧
+ l = l1 ++ l2 ∧ k = k1 ++ k2 ∧ length l1 = length k1.
+ Proof.
+ revert l k. induction lC1 as [|z lC1 IH]; simpl.
+ { intros l k ?. by eexists [], [], l, k. }
+ intros [|x l] [|y k] ?; simplify_equality'.
+ destruct (IH l k) as (l1&k1&l2&k2&->&->&->&->&?); [done |].
+ exists (x :: l1), (y :: k1), l2, k2; simpl; auto with congruence.
+ Qed.
+ Lemma zip_with_inj `{!Injective2 (=) (=) (=) f} l1 l2 k1 k2 :
+ length l1 = length k1 → length l2 = length k2 →
+ zip_with f l1 k1 = zip_with f l2 k2 → l1 = l2 ∧ k1 = k2.
+ Proof.
+ rewrite <-!Forall2_same_length. intros Hl. revert l2 k2.
+ induction Hl; intros ?? [] ?; f_equal; naive_solver.
+ Qed.
+ Lemma zip_with_length l k :
+ length (zip_with f l k) = min (length l) (length k).
+ Proof. revert k. induction l; intros [|??]; simpl; auto with lia. Qed.
+ Lemma zip_with_length_l l k :
+ length l ≤ length k → length (zip_with f l k) = length l.
+ Proof. rewrite zip_with_length; lia. Qed.
+ Lemma zip_with_length_l_eq l k :
+ length l = length k → length (zip_with f l k) = length l.
+ Proof. rewrite zip_with_length; lia. Qed.
+ Lemma zip_with_length_r l k :
+ length k ≤ length l → length (zip_with f l k) = length k.
+ Proof. rewrite zip_with_length; lia. Qed.
+ Lemma zip_with_length_r_eq l k :
+ length k = length l → length (zip_with f l k) = length k.
+ Proof. rewrite zip_with_length; lia. Qed.
+ Lemma zip_with_length_same_l P l k :
+ Forall2 P l k → length (zip_with f l k) = length l.
+ Proof. induction 1; simpl; auto. Qed.
+ Lemma zip_with_length_same_r P l k :
+ Forall2 P l k → length (zip_with f l k) = length k.
+ Proof. induction 1; simpl; auto. Qed.
+ Lemma lookup_zip_with l k i :
+ zip_with f l k !! i = x ↠l !! i; y ↠k !! i; Some (f x y).
+ Proof.
+ revert k i. induction l; intros [|??] [|?]; f_equal'; auto.
+ by destruct (_ !! _).
+ Qed.
+ Lemma insert_zip_with l k i x y :
+ <[i:=f x y]>(zip_with f l k) = zip_with f (<[i:=x]>l) (<[i:=y]>k).
+ Proof. revert i k. induction l; intros [|?] [|??]; f_equal'; auto. Qed.
+ Lemma fmap_zip_with_l (g : C → A) l k :
+ (∀ x y, g (f x y) = x) → length l ≤ length k → g <$> zip_with f l k = l.
+ Proof. revert k. induction l; intros [|??] ??; f_equal'; auto with lia. Qed.
+ Lemma fmap_zip_with_r (g : C → B) l k :
+ (∀ x y, g (f x y) = y) → length k ≤ length l → g <$> zip_with f l k = k.
+ Proof. revert l. induction k; intros [|??] ??; f_equal'; auto with lia. Qed.
+ Lemma zip_with_zip l k : zip_with f l k = curry f <$> zip l k.
+ Proof. revert k. by induction l; intros [|??]; f_equal'. Qed.
+ Lemma zip_with_fst_snd lk : zip_with f (lk.*1) (lk.*2) = curry f <$> lk.
+ Proof. by induction lk as [|[]]; f_equal'. Qed.
+ Lemma zip_with_replicate n x y :
+ zip_with f (replicate n x) (replicate n y) = replicate n (f x y).
+ Proof. by induction n; f_equal'. Qed.
+ Lemma zip_with_replicate_l n x k :
+ length k ≤ n → zip_with f (replicate n x) k = f x <$> k.
+ Proof. revert n. induction k; intros [|?] ?; f_equal'; auto with lia. Qed.
+ Lemma zip_with_replicate_r n y l :
+ length l ≤ n → zip_with f l (replicate n y) = flip f y <$> l.
+ Proof. revert n. induction l; intros [|?] ?; f_equal'; auto with lia. Qed.
+ Lemma zip_with_replicate_r_eq n y l :
+ length l = n → zip_with f l (replicate n y) = flip f y <$> l.
+ Proof. intros; apply zip_with_replicate_r; lia. Qed.
+ Lemma zip_with_take n l k :
+ take n (zip_with f l k) = zip_with f (take n l) (take n k).
+ Proof. revert n k. by induction l; intros [|?] [|??]; f_equal'. Qed.
+ Lemma zip_with_drop n l k :
+ drop n (zip_with f l k) = zip_with f (drop n l) (drop n k).
+ Proof.
+ revert n k. induction l; intros [] []; f_equal'; auto using zip_with_nil_r.
+ Qed.
+ Lemma zip_with_take_l n l k :
+ length k ≤ n → zip_with f (take n l) k = zip_with f l k.
+ Proof. revert n k. induction l; intros [] [] ?; f_equal'; auto with lia. Qed.
+ Lemma zip_with_take_r n l k :
+ length l ≤ n → zip_with f l (take n k) = zip_with f l k.
+ Proof. revert n k. induction l; intros [] [] ?; f_equal'; auto with lia. Qed.
+ Lemma Forall_zip_with_fst (P : A → Prop) (Q : C → Prop) l k :
+ Forall P l → Forall (λ y, ∀ x, P x → Q (f x y)) k →
+ Forall Q (zip_with f l k).
+ Proof. intros Hl. revert k. induction Hl; destruct 1; simpl in *; auto. Qed.
+ Lemma Forall_zip_with_snd (P : B → Prop) (Q : C → Prop) l k :
+ Forall (λ x, ∀ y, P y → Q (f x y)) l → Forall P k →
+ Forall Q (zip_with f l k).
+ Proof. intros Hl. revert k. induction Hl; destruct 1; simpl in *; auto. Qed.
+End zip_with.
+
+Lemma zip_with_sublist_alter {A B} (f : A → B → A) g l k i n l' k' :
+ length l = length k →
+ sublist_lookup i n l = Some l' → sublist_lookup i n k = Some k' →
+ length (g l') = length k' → zip_with f (g l') k' = g (zip_with f l' k') →
+ zip_with f (sublist_alter g i n l) k = sublist_alter g i n (zip_with f l k).
+Proof.
+ unfold sublist_lookup, sublist_alter. intros Hlen; rewrite Hlen.
+ intros ?? Hl' Hk'. simplify_option_equality.
+ by rewrite !zip_with_app_l, !zip_with_drop, Hl', drop_drop, !zip_with_take,
+ !take_length_le, Hk' by (rewrite ?drop_length; auto with lia).
+Qed.
+
+Section zip.
+ Context {A B : Type}.
+ Implicit Types l : list A.
+ Implicit Types k : list B.
+ Lemma fst_zip l k : length l ≤ length k → (zip l k).*1 = l.
+ Proof. by apply fmap_zip_with_l. Qed.
+ Lemma snd_zip l k : length k ≤ length l → (zip l k).*2 = k.
+ Proof. by apply fmap_zip_with_r. Qed.
+ Lemma zip_fst_snd (lk : list (A * B)) : zip (lk.*1) (lk.*2) = lk.
+ Proof. by induction lk as [|[]]; f_equal'. Qed.
+ Lemma Forall2_fst P l1 l2 k1 k2 :
+ length l2 = length k2 → Forall2 P l1 k1 →
+ Forall2 (λ x y, P (x.1) (y.1)) (zip l1 l2) (zip k1 k2).
+ Proof.
+ rewrite <-Forall2_same_length. intros Hlk2 Hlk1. revert l2 k2 Hlk2.
+ induction Hlk1; intros ?? [|??????]; simpl; auto.
+ Qed.
+ Lemma Forall2_snd P l1 l2 k1 k2 :
+ length l1 = length k1 → Forall2 P l2 k2 →
+ Forall2 (λ x y, P (x.2) (y.2)) (zip l1 l2) (zip k1 k2).
+ Proof.
+ rewrite <-Forall2_same_length. intros Hlk1 Hlk2. revert l1 k1 Hlk1.
+ induction Hlk2; intros ?? [|??????]; simpl; auto.
+ Qed.
+End zip.
+
+Lemma elem_of_zipped_map {A B} (f : list A → list A → A → B) l k x :
+ x ∈ zipped_map f l k ↔
+ ∃ k' k'' y, k = k' ++ [y] ++ k'' ∧ x = f (reverse k' ++ l) k'' y.
+Proof.
+ split.
+ * revert l. induction k as [|z k IH]; simpl; intros l; inversion_clear 1.
+ { by eexists [], k, z. }
+ destruct (IH (z :: l)) as (k'&k''&y&->&->); [done |].
+ eexists (z :: k'), k'', y. by rewrite reverse_cons, <-(associative_L (++)).
+ * intros (k'&k''&y&->&->). revert l. induction k' as [|z k' IH]; [by left|].
+ intros l; right. by rewrite reverse_cons, <-!(associative_L (++)).
+Qed.
+Section zipped_list_ind.
+ Context {A} (P : list A → list A → Prop).
+ Context (Pnil : ∀ l, P l []) (Pcons : ∀ l k x, P (x :: l) k → P l (x :: k)).
+ Fixpoint zipped_list_ind l k : P l k :=
+ match k with
+ | [] => Pnil _ | x :: k => Pcons _ _ _ (zipped_list_ind (x :: l) k)
+ end.
+End zipped_list_ind.
+Lemma zipped_Forall_app {A} (P : list A → list A → A → Prop) l k k' :
+ zipped_Forall P l (k ++ k') → zipped_Forall P (reverse k ++ l) k'.
+Proof.
+ revert l. induction k as [|x k IH]; simpl; [done |].
+ inversion_clear 1. rewrite reverse_cons, <-(associative_L (++)). by apply IH.
+Qed.
+
+(** * Relection over lists *)
+(** We define a simple data structure [rlist] to capture a syntactic
+representation of lists consisting of constants, applications and the nil list.
+Note that we represent [(x ::)] as [rapp (rnode [x])]. For now, we abstract
+over the type of constants, but later we use [nat]s and a list representing
+a corresponding environment. *)
+Inductive rlist (A : Type) :=
+ rnil : rlist A | rnode : A → rlist A | rapp : rlist A → rlist A → rlist A.
+Arguments rnil {_}.
+Arguments rnode {_} _.
+Arguments rapp {_} _ _.
+
+Module rlist.
+Fixpoint to_list {A} (t : rlist A) : list A :=
+ match t with
+ | rnil => [] | rnode l => [l] | rapp t1 t2 => to_list t1 ++ to_list t2
+ end.
+Notation env A := (list (list A)) (only parsing).
+Definition eval {A} (E : env A) : rlist nat → list A :=
+ fix go t :=
+ match t with
+ | rnil => []
+ | rnode i => from_option [] (E !! i)
+ | rapp t1 t2 => go t1 ++ go t2
+ end.
+
+(** A simple quoting mechanism using type classes. [QuoteLookup E1 E2 x i]
+means: starting in environment [E1], look up the index [i] corresponding to the
+constant [x]. In case [x] has a corresponding index [i] in [E1], the original
+environment is given back as [E2]. Otherwise, the environment [E2] is extended
+with a binding [i] for [x]. *)
+Section quote_lookup.
+ Context {A : Type}.
+ Class QuoteLookup (E1 E2 : list A) (x : A) (i : nat) := {}.
+ Global Instance quote_lookup_here E x : QuoteLookup (x :: E) (x :: E) x 0.
+ Global Instance quote_lookup_end x : QuoteLookup [] [x] x 0.
+ Global Instance quote_lookup_further E1 E2 x i y :
+ QuoteLookup E1 E2 x i → QuoteLookup (y :: E1) (y :: E2) x (S i) | 1000.
+End quote_lookup.
+
+Section quote.
+ Context {A : Type}.
+ Class Quote (E1 E2 : env A) (l : list A) (t : rlist nat) := {}.
+ Global Instance quote_nil: Quote E1 E1 [] rnil.
+ Global Instance quote_node E1 E2 l i:
+ QuoteLookup E1 E2 l i → Quote E1 E2 l (rnode i) | 1000.
+ Global Instance quote_cons E1 E2 E3 x l i t :
+ QuoteLookup E1 E2 [x] i →
+ Quote E2 E3 l t → Quote E1 E3 (x :: l) (rapp (rnode i) t).
+ Global Instance quote_app E1 E2 E3 l1 l2 t1 t2 :
+ Quote E1 E2 l1 t1 → Quote E2 E3 l2 t2 → Quote E1 E3 (l1 ++ l2) (rapp t1 t2).
+End quote.
+
+Section eval.
+ Context {A} (E : env A).
+
+ Lemma eval_alt t : eval E t = to_list t ≫= from_option [] ∘ (E !!).
+ Proof.
+ induction t; csimpl.
+ * done.
+ * by rewrite (right_id_L [] (++)).
+ * rewrite bind_app. by f_equal.
+ Qed.
+ Lemma eval_eq t1 t2 : to_list t1 = to_list t2 → eval E t1 = eval E t2.
+ Proof. intros Ht. by rewrite !eval_alt, Ht. Qed.
+ Lemma eval_Permutation t1 t2 :
+ to_list t1 ≡ₚ to_list t2 → eval E t1 ≡ₚ eval E t2.
+ Proof. intros Ht. by rewrite !eval_alt, Ht. Qed.
+ Lemma eval_contains t1 t2 :
+ to_list t1 `contains` to_list t2 → eval E t1 `contains` eval E t2.
+ Proof. intros Ht. by rewrite !eval_alt, Ht. Qed.
+End eval.
+End rlist.
+
+(** * Tactics *)
+Ltac quote_Permutation :=
+ match goal with
+ | |- ?l1 ≡ₚ ?l2 =>
+ match type of (_ : rlist.Quote [] _ l1 _) with rlist.Quote _ ?E2 _ ?t1 =>
+ match type of (_ : rlist.Quote E2 _ l2 _) with rlist.Quote _ ?E3 _ ?t2 =>
+ change (rlist.eval E3 t1 ≡ₚ rlist.eval E3 t2)
+ end end
+ end.
+Ltac solve_Permutation :=
+ quote_Permutation; apply rlist.eval_Permutation;
+ apply (bool_decide_unpack _); by vm_compute.
+
+Ltac quote_contains :=
+ match goal with
+ | |- ?l1 `contains` ?l2 =>
+ match type of (_ : rlist.Quote [] _ l1 _) with rlist.Quote _ ?E2 _ ?t1 =>
+ match type of (_ : rlist.Quote E2 _ l2 _) with rlist.Quote _ ?E3 _ ?t2 =>
+ change (rlist.eval E3 t1 `contains` rlist.eval E3 t2)
+ end end
+ end.
+Ltac solve_contains :=
+ quote_contains; apply rlist.eval_contains;
+ apply (bool_decide_unpack _); by vm_compute.
+
+Ltac decompose_elem_of_list := repeat
+ match goal with
+ | H : ?x ∈ [] |- _ => by destruct (not_elem_of_nil x)
+ | H : _ ∈ _ :: _ |- _ => apply elem_of_cons in H; destruct H
+ | H : _ ∈ _ ++ _ |- _ => apply elem_of_app in H; destruct H
+ end.
+Ltac solve_length :=
+ simplify_equality';
+ repeat (rewrite fmap_length || rewrite app_length);
+ repeat match goal with
+ | H : @eq (list _) _ _ |- _ => apply (f_equal length) in H
+ | H : Forall2 _ _ _ |- _ => apply Forall2_length in H
+ | H : context[length (_ <$> _)] |- _ => rewrite fmap_length in H
+ end; done || congruence.
+Ltac simplify_list_equality ::= repeat
+ match goal with
+ | _ => progress simplify_equality'
+ | H : [?x] !! ?i = Some ?y |- _ =>
+ destruct i; [change (Some x = Some y) in H | discriminate]
+ | H : _ <$> _ = [] |- _ => apply fmap_nil_inv in H
+ | H : [] = _ <$> _ |- _ => symmetry in H; apply fmap_nil_inv in H
+ | H : zip_with _ _ _ = [] |- _ => apply zip_with_nil_inv in H; destruct H
+ | H : [] = zip_with _ _ _ |- _ => symmetry in H
+ | |- context [(_ ++ _) ++ _] => rewrite <-(associative_L (++))
+ | H : context [(_ ++ _) ++ _] |- _ => rewrite <-(associative_L (++)) in H
+ | H : context [_ <$> (_ ++ _)] |- _ => rewrite fmap_app in H
+ | |- context [_ <$> (_ ++ _)] => rewrite fmap_app
+ | |- context [_ ++ []] => rewrite (right_id_L [] (++))
+ | H : context [_ ++ []] |- _ => rewrite (right_id_L [] (++)) in H
+ | |- context [take _ (_ <$> _)] => rewrite <-fmap_take
+ | H : context [take _ (_ <$> _)] |- _ => rewrite <-fmap_take in H
+ | |- context [drop _ (_ <$> _)] => rewrite <-fmap_drop
+ | H : context [drop _ (_ <$> _)] |- _ => rewrite <-fmap_drop in H
+ | H : _ ++ _ = _ ++ _ |- _ =>
+ repeat (rewrite <-app_comm_cons in H || rewrite <-(associative_L (++)) in H);
+ apply app_injective_1 in H; [destruct H|solve_length]
+ | H : _ ++ _ = _ ++ _ |- _ =>
+ repeat (rewrite app_comm_cons in H || rewrite (associative_L (++)) in H);
+ apply app_injective_2 in H; [destruct H|solve_length]
+ | |- context [zip_with _ (_ ++ _) (_ ++ _)] =>
+ rewrite zip_with_app by solve_length
+ | |- context [take _ (_ ++ _)] => rewrite take_app_alt by solve_length
+ | |- context [drop _ (_ ++ _)] => rewrite drop_app_alt by solve_length
+ | H : context [zip_with _ (_ ++ _) (_ ++ _)] |- _ =>
+ rewrite zip_with_app in H by solve_length
+ | H : context [take _ (_ ++ _)] |- _ =>
+ rewrite take_app_alt in H by solve_length
+ | H : context [drop _ (_ ++ _)] |- _ =>
+ rewrite drop_app_alt in H by solve_length
+ | H : ?l !! ?i = _, H2 : context [(_ <$> ?l) !! ?i] |- _ =>
+ rewrite list_lookup_fmap, H in H2
+ end.
+Ltac decompose_Forall_hyps :=
+ repeat match goal with
+ | H : Forall _ [] |- _ => clear H
+ | H : Forall _ (_ :: _) |- _ => rewrite Forall_cons in H; destruct H
+ | H : Forall _ (_ ++ _) |- _ => rewrite Forall_app in H; destruct H
+ | H : Forall2 _ [] [] |- _ => clear H
+ | H : Forall2 _ (_ :: _) [] |- _ => destruct (Forall2_cons_nil_inv _ _ _ H)
+ | H : Forall2 _ [] (_ :: _) |- _ => destruct (Forall2_nil_cons_inv _ _ _ H)
+ | H : Forall2 _ [] ?k |- _ => apply Forall2_nil_inv_l in H
+ | H : Forall2 _ ?l [] |- _ => apply Forall2_nil_inv_r in H
+ | H : Forall2 _ (_ :: _) (_ :: _) |- _ =>
+ apply Forall2_cons_inv in H; destruct H
+ | H : Forall2 _ (_ :: _) ?k |- _ =>
+ let k_hd := fresh k "_hd" in let k_tl := fresh k "_tl" in
+ apply Forall2_cons_inv_l in H; destruct H as (k_hd&k_tl&?&?&->);
+ rename k_tl into k
+ | H : Forall2 _ ?l (_ :: _) |- _ =>
+ let l_hd := fresh l "_hd" in let l_tl := fresh l "_tl" in
+ apply Forall2_cons_inv_r in H; destruct H as (l_hd&l_tl&?&?&->);
+ rename l_tl into l
+ | H : Forall2 _ (_ ++ _) ?k |- _ =>
+ let k1 := fresh k "_1" in let k2 := fresh k "_2" in
+ apply Forall2_app_inv_l in H; destruct H as (k1&k2&?&?&->)
+ | H : Forall2 _ ?l (_ ++ _) |- _ =>
+ let l1 := fresh l "_1" in let l2 := fresh l "_2" in
+ apply Forall2_app_inv_r in H; destruct H as (l1&l2&?&?&->)
+ | _ => progress simplify_equality'
+ | H : Forall3 _ _ (_ :: _) _ |- _ =>
+ apply Forall3_cons_inv_m in H; destruct H as (?&?&?&?&?&?&?&?)
+ | H : Forall2 _ (_ :: _) ?k |- _ =>
+ apply Forall2_cons_inv_l in H; destruct H as (?&?&?&?&?)
+ | H : Forall2 _ ?l (_ :: _) |- _ =>
+ apply Forall2_cons_inv_r in H; destruct H as (?&?&?&?&?)
+ | H : Forall2 _ (_ ++ _) (_ ++ _) |- _ =>
+ apply Forall2_app_inv in H; [destruct H|solve_length]
+ | H : Forall2 _ ?l (_ ++ _) |- _ =>
+ apply Forall2_app_inv_r in H; destruct H as (?&?&?&?&?)
+ | H : Forall2 _ (_ ++ _) ?k |- _ =>
+ apply Forall2_app_inv_l in H; destruct H as (?&?&?&?&?)
+ | H : Forall3 _ _ (_ ++ _) _ |- _ =>
+ apply Forall3_app_inv_m in H; destruct H as (?&?&?&?&?&?&?&?)
+ | H : Forall ?P ?l, H1 : ?l !! _ = Some ?x |- _ =>
+ (* to avoid some stupid loops, not fool proof *)
+ unless (P x) by auto using Forall_app_2, Forall_nil_2;
+ let E := fresh in
+ assert (P x) as E by (apply (Forall_lookup_1 P _ _ _ H H1)); lazy beta in E
+ | H : Forall2 ?P ?l ?k |- _ =>
+ match goal with
+ | H1 : l !! ?i = Some ?x, H2 : k !! ?i = Some ?y |- _ =>
+ unless (P x y) by done; let E := fresh in
+ assert (P x y) as E by (by apply (Forall2_lookup_lr P l k i x y));
+ lazy beta in E
+ | H1 : l !! ?i = Some ?x |- _ =>
+ try (match goal with _ : k !! i = Some _ |- _ => fail 2 end);
+ destruct (Forall2_lookup_l P _ _ _ _ H H1) as (?&?&?)
+ | H2 : k !! ?i = Some ?y |- _ =>
+ try (match goal with _ : l !! i = Some _ |- _ => fail 2 end);
+ destruct (Forall2_lookup_r P _ _ _ _ H H2) as (?&?&?)
+ end
+ | H : Forall3 ?P ?l ?l' ?k |- _ =>
+ lazymatch goal with
+ | H1:l !! ?i = Some ?x, H2:l' !! ?i = Some ?y, H3:k !! ?i = Some ?z |- _ =>
+ unless (P x y z) by done; let E := fresh in
+ assert (P x y z) as E by (by apply (Forall3_lookup_lmr P l l' k i x y z));
+ lazy beta in E
+ | H1 : l !! _ = Some ?x |- _ =>
+ destruct (Forall3_lookup_l P _ _ _ _ _ H H1) as (?&?&?&?&?)
+ | H2 : l' !! _ = Some ?y |- _ =>
+ destruct (Forall3_lookup_m P _ _ _ _ _ H H2) as (?&?&?&?&?)
+ | H3 : k !! _ = Some ?z |- _ =>
+ destruct (Forall3_lookup_r P _ _ _ _ _ H H3) as (?&?&?&?&?)
+ end
+ end.
+Ltac list_simplifier :=
+ simplify_equality';
+ repeat match goal with
+ | _ => progress decompose_Forall_hyps
+ | _ => progress simplify_list_equality
+ | H : _ <$> _ = _ :: _ |- _ =>
+ apply fmap_cons_inv in H; destruct H as (?&?&?&?&?)
+ | H : _ :: _ = _ <$> _ |- _ => symmetry in H
+ | H : _ <$> _ = _ ++ _ |- _ =>
+ apply fmap_app_inv in H; destruct H as (?&?&?&?&?)
+ | H : _ ++ _ = _ <$> _ |- _ => symmetry in H
+ | H : zip_with _ _ _ = _ :: _ |- _ =>
+ apply zip_with_cons_inv in H; destruct H as (?&?&?&?&?&?&?&?)
+ | H : _ :: _ = zip_with _ _ _ |- _ => symmetry in H
+ | H : zip_with _ _ _ = _ ++ _ |- _ =>
+ apply zip_with_app_inv in H; destruct H as (?&?&?&?&?&?&?&?&?)
+ | H : _ ++ _ = zip_with _ _ _ |- _ => symmetry in H
+ end.
+Ltac decompose_Forall := repeat
+ match goal with
+ | |- Forall _ _ => by apply Forall_true
+ | |- Forall _ [] => constructor
+ | |- Forall _ (_ :: _) => constructor
+ | |- Forall _ (_ ++ _) => apply Forall_app_2
+ | |- Forall _ (_ <$> _) => apply Forall_fmap
+ | |- Forall _ (_ ≫= _) => apply Forall_bind
+ | |- Forall2 _ _ _ => apply Forall2_Forall
+ | |- Forall2 _ [] [] => constructor
+ | |- Forall2 _ (_ :: _) (_ :: _) => constructor
+ | |- Forall2 _ (_ ++ _) (_ ++ _) => first
+ [ apply Forall2_app; [by decompose_Forall |]
+ | apply Forall2_app; [| by decompose_Forall]]
+ | |- Forall2 _ (_ <$> _) _ => apply Forall2_fmap_l
+ | |- Forall2 _ _ (_ <$> _) => apply Forall2_fmap_r
+ | _ => progress decompose_Forall_hyps
+ | H : Forall _ (_ <$> _) |- _ => rewrite Forall_fmap in H
+ | H : Forall _ (_ ≫= _) |- _ => rewrite Forall_bind in H
+ | |- Forall _ _ =>
+ apply Forall_lookup_2; intros ???; progress decompose_Forall_hyps
+ | |- Forall2 _ _ _ =>
+ apply Forall2_lookup_2; [solve_length|];
+ intros ?????; progress decompose_Forall_hyps
+ end.
+
+(** The [simplify_suffix_of] tactic removes [suffix_of] hypotheses that are
+tautologies, and simplifies [suffix_of] hypotheses involving [(::)] and
+[(++)]. *)
+Ltac simplify_suffix_of := repeat
+ match goal with
+ | H : suffix_of (_ :: _) _ |- _ => destruct (suffix_of_cons_not _ _ H)
+ | H : suffix_of (_ :: _) [] |- _ => apply suffix_of_nil_inv in H
+ | H : suffix_of (_ ++ _) (_ ++ _) |- _ => apply suffix_of_app_inv in H
+ | H : suffix_of (_ :: _) (_ :: _) |- _ =>
+ destruct (suffix_of_cons_inv _ _ _ _ H); clear H
+ | H : suffix_of ?x ?x |- _ => clear H
+ | H : suffix_of ?x (_ :: ?x) |- _ => clear H
+ | H : suffix_of ?x (_ ++ ?x) |- _ => clear H
+ | _ => progress simplify_equality'
+ end.
+
+(** The [solve_suffix_of] tactic tries to solve goals involving [suffix_of]. It
+uses [simplify_suffix_of] to simplify hypotheses and tries to solve [suffix_of]
+conclusions. This tactic either fails or proves the goal. *)
+Ltac solve_suffix_of := by intuition (repeat
+ match goal with
+ | _ => done
+ | _ => progress simplify_suffix_of
+ | |- suffix_of [] _ => apply suffix_of_nil
+ | |- suffix_of _ _ => reflexivity
+ | |- suffix_of _ (_ :: _) => apply suffix_of_cons_r
+ | |- suffix_of _ (_ ++ _) => apply suffix_of_app_r
+ | H : suffix_of _ _ → False |- _ => destruct H
+ end).
+Hint Extern 0 (PropHolds (suffix_of _ _)) =>
+ unfold PropHolds; solve_suffix_of : typeclass_instances.
diff --git a/prelude/listset.v b/prelude/listset.v
new file mode 100644
index 0000000000000000000000000000000000000000..147715aa2814890804fbbccc81cffc867f46ca6f
--- /dev/null
+++ b/prelude/listset.v
@@ -0,0 +1,111 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file implements finite set as unordered lists without duplicates
+removed. This implementation forms a monad. *)
+Require Export prelude.base prelude.decidable prelude.collections prelude.list.
+
+Record listset A := Listset { listset_car: list A }.
+Arguments listset_car {_} _.
+Arguments Listset {_} _.
+
+Section listset.
+Context {A : Type}.
+
+Instance listset_elem_of: ElemOf A (listset A) := λ x l, x ∈ listset_car l.
+Instance listset_empty: Empty (listset A) := Listset [].
+Instance listset_singleton: Singleton A (listset A) := λ x, Listset [x].
+Instance listset_union: Union (listset A) := λ l k,
+ let (l') := l in let (k') := k in Listset (l' ++ k').
+Global Opaque listset_singleton listset_empty.
+
+Global Instance: SimpleCollection A (listset A).
+Proof.
+ split.
+ * by apply not_elem_of_nil.
+ * by apply elem_of_list_singleton.
+ * intros [?] [?]. apply elem_of_app.
+Qed.
+Lemma listset_empty_alt X : X ≡ ∅ ↔ listset_car X = [].
+Proof.
+ destruct X as [l]; split; [|by intros; simplify_equality'].
+ intros [Hl _]; destruct l as [|x l]; [done|]. feed inversion (Hl x); left.
+Qed.
+Global Instance listset_empty_dec (X : listset A) : Decision (X ≡ ∅).
+Proof.
+ refine (cast_if (decide (listset_car X = [])));
+ abstract (by rewrite listset_empty_alt).
+Defined.
+
+Context `{∀ x y : A, Decision (x = y)}.
+
+Instance listset_intersection: Intersection (listset A) := λ l k,
+ let (l') := l in let (k') := k in Listset (list_intersection l' k').
+Instance listset_difference: Difference (listset A) := λ l k,
+ let (l') := l in let (k') := k in Listset (list_difference l' k').
+Instance listset_intersection_with: IntersectionWith A (listset A) := λ f l k,
+ let (l') := l in let (k') := k in Listset (list_intersection_with f l' k').
+Instance listset_filter: Filter A (listset A) := λ P _ l,
+ let (l') := l in Listset (filter P l').
+
+Instance: Collection A (listset A).
+Proof.
+ split.
+ * apply _.
+ * intros [?] [?]. apply elem_of_list_intersection.
+ * intros [?] [?]. apply elem_of_list_difference.
+Qed.
+Instance listset_elems: Elements A (listset A) := remove_dups ∘ listset_car.
+Global Instance: FinCollection A (listset A).
+Proof.
+ split.
+ * apply _.
+ * intros. apply elem_of_remove_dups.
+ * intros. apply NoDup_remove_dups.
+Qed.
+Global Instance: CollectionOps A (listset A).
+Proof.
+ split.
+ * apply _.
+ * intros ? [?] [?]. apply elem_of_list_intersection_with.
+ * intros [?] ??. apply elem_of_list_filter.
+Qed.
+End listset.
+
+(** These instances are declared using [Hint Extern] to avoid too
+eager type class search. *)
+Hint Extern 1 (ElemOf _ (listset _)) =>
+ eapply @listset_elem_of : typeclass_instances.
+Hint Extern 1 (Empty (listset _)) =>
+ eapply @listset_empty : typeclass_instances.
+Hint Extern 1 (Singleton _ (listset _)) =>
+ eapply @listset_singleton : typeclass_instances.
+Hint Extern 1 (Union (listset _)) =>
+ eapply @listset_union : typeclass_instances.
+Hint Extern 1 (Intersection (listset _)) =>
+ eapply @listset_intersection : typeclass_instances.
+Hint Extern 1 (IntersectionWith _ (listset _)) =>
+ eapply @listset_intersection_with : typeclass_instances.
+Hint Extern 1 (Difference (listset _)) =>
+ eapply @listset_difference : typeclass_instances.
+Hint Extern 1 (Elements _ (listset _)) =>
+ eapply @listset_elems : typeclass_instances.
+Hint Extern 1 (Filter _ (listset _)) =>
+ eapply @listset_filter : typeclass_instances.
+
+Instance listset_ret: MRet listset := λ A x, {[ x ]}.
+Instance listset_fmap: FMap listset := λ A B f l,
+ let (l') := l in Listset (f <$> l').
+Instance listset_bind: MBind listset := λ A B f l,
+ let (l') := l in Listset (mbind (listset_car ∘ f) l').
+Instance listset_join: MJoin listset := λ A, mbind id.
+
+Instance: CollectionMonad listset.
+Proof.
+ split.
+ * intros. apply _.
+ * intros ??? [?] ?. apply elem_of_list_bind.
+ * intros. apply elem_of_list_ret.
+ * intros ??? [?]. apply elem_of_list_fmap.
+ * intros ? [?] ?. unfold mjoin, listset_join, elem_of, listset_elem_of.
+ simpl. by rewrite elem_of_list_bind.
+Qed.
diff --git a/prelude/listset_nodup.v b/prelude/listset_nodup.v
new file mode 100644
index 0000000000000000000000000000000000000000..ab4341a837bcff16421b1dc8a2958a5ca10fa5ed
--- /dev/null
+++ b/prelude/listset_nodup.v
@@ -0,0 +1,78 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file implements finite as unordered lists without duplicates.
+Although this implementation is slow, it is very useful as decidable equality
+is the only constraint on the carrier set. *)
+Require Export prelude.base prelude.decidable prelude.collections prelude.list.
+
+Record listset_nodup A := ListsetNoDup {
+ listset_nodup_car : list A; listset_nodup_prf : NoDup listset_nodup_car
+}.
+Arguments ListsetNoDup {_} _ _.
+Arguments listset_nodup_car {_} _.
+Arguments listset_nodup_prf {_} _.
+
+Section list_collection.
+Context {A : Type} `{∀ x y : A, Decision (x = y)}.
+Notation C := (listset_nodup A).
+
+Instance listset_nodup_elem_of: ElemOf A C := λ x l, x ∈ listset_nodup_car l.
+Instance listset_nodup_empty: Empty C := ListsetNoDup [] (@NoDup_nil_2 _).
+Instance listset_nodup_singleton: Singleton A C := λ x,
+ ListsetNoDup [x] (NoDup_singleton x).
+Instance listset_nodup_union: Union C := λ l k,
+ let (l',Hl) := l in let (k',Hk) := k
+ in ListsetNoDup _ (NoDup_list_union _ _ Hl Hk).
+Instance listset_nodup_intersection: Intersection C := λ l k,
+ let (l',Hl) := l in let (k',Hk) := k
+ in ListsetNoDup _ (NoDup_list_intersection _ k' Hl).
+Instance listset_nodup_difference: Difference C := λ l k,
+ let (l',Hl) := l in let (k',Hk) := k
+ in ListsetNoDup _ (NoDup_list_difference _ k' Hl).
+Instance listset_nodup_intersection_with: IntersectionWith A C := λ f l k,
+ let (l',Hl) := l in let (k',Hk) := k
+ in ListsetNoDup
+ (remove_dups (list_intersection_with f l' k')) (NoDup_remove_dups _).
+Instance listset_nodup_filter: Filter A C := λ P _ l,
+ let (l',Hl) := l in ListsetNoDup _ (NoDup_filter P _ Hl).
+
+Instance: Collection A C.
+Proof.
+ split; [split | | ].
+ * by apply not_elem_of_nil.
+ * by apply elem_of_list_singleton.
+ * intros [??] [??] ?. apply elem_of_list_union.
+ * intros [??] [??] ?. apply elem_of_list_intersection.
+ * intros [??] [??] ?. apply elem_of_list_difference.
+Qed.
+
+Global Instance listset_nodup_elems: Elements A C := listset_nodup_car.
+Global Instance: FinCollection A C.
+Proof. split. apply _. done. by intros [??]. Qed.
+Global Instance: CollectionOps A C.
+Proof.
+ split.
+ * apply _.
+ * intros ? [??] [??] ?. unfold intersection_with, elem_of,
+ listset_nodup_intersection_with, listset_nodup_elem_of; simpl.
+ rewrite elem_of_remove_dups. by apply elem_of_list_intersection_with.
+ * intros [??] ???. apply elem_of_list_filter.
+Qed.
+End list_collection.
+
+Hint Extern 1 (ElemOf _ (listset_nodup _)) =>
+ eapply @listset_nodup_elem_of : typeclass_instances.
+Hint Extern 1 (Empty (listset_nodup _)) =>
+ eapply @listset_nodup_empty : typeclass_instances.
+Hint Extern 1 (Singleton _ (listset_nodup _)) =>
+ eapply @listset_nodup_singleton : typeclass_instances.
+Hint Extern 1 (Union (listset_nodup _)) =>
+ eapply @listset_nodup_union : typeclass_instances.
+Hint Extern 1 (Intersection (listset_nodup _)) =>
+ eapply @listset_nodup_intersection : typeclass_instances.
+Hint Extern 1 (Difference (listset_nodup _)) =>
+ eapply @listset_nodup_difference : typeclass_instances.
+Hint Extern 1 (Elements _ (listset_nodup _)) =>
+ eapply @listset_nodup_elems : typeclass_instances.
+Hint Extern 1 (Filter _ (listset_nodup _)) =>
+ eapply @listset_nodup_filter : typeclass_instances.
diff --git a/prelude/mapset.v b/prelude/mapset.v
new file mode 100644
index 0000000000000000000000000000000000000000..317b6fc7b7295ee1a802e1ffb8fe5803de9ee3a0
--- /dev/null
+++ b/prelude/mapset.v
@@ -0,0 +1,131 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files gives an implementation of finite sets using finite maps with
+elements of the unit type. Since maps enjoy extensional equality, the
+constructed finite sets do so as well. *)
+Require Export prelude.fin_map_dom.
+
+Record mapset (M : Type → Type) : Type :=
+ Mapset { mapset_car: M (unit : Type) }.
+Arguments Mapset {_} _.
+Arguments mapset_car {_} _.
+
+Section mapset.
+Context `{FinMap K M}.
+
+Instance mapset_elem_of: ElemOf K (mapset M) := λ x X,
+ mapset_car X !! x = Some ().
+Instance mapset_empty: Empty (mapset M) := Mapset ∅.
+Instance mapset_singleton: Singleton K (mapset M) := λ x,
+ Mapset {[ x ↦ () ]}.
+Instance mapset_union: Union (mapset M) := λ X1 X2,
+ let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∪ m2).
+Instance mapset_intersection: Intersection (mapset M) := λ X1 X2,
+ let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∩ m2).
+Instance mapset_difference: Difference (mapset M) := λ X1 X2,
+ let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∖ m2).
+Instance mapset_elems: Elements K (mapset M) := λ X,
+ let (m) := X in (map_to_list m).*1.
+
+Lemma mapset_eq (X1 X2 : mapset M) : X1 = X2 ↔ ∀ x, x ∈ X1 ↔ x ∈ X2.
+Proof.
+ split; [by intros ->|].
+ destruct X1 as [m1], X2 as [m2]. simpl. intros E.
+ f_equal. apply map_eq. intros i. apply option_eq. intros []. by apply E.
+Qed.
+
+Global Instance mapset_eq_dec `{∀ m1 m2 : M unit, Decision (m1 = m2)}
+ (X1 X2 : mapset M) : Decision (X1 = X2) | 1.
+Proof.
+ refine
+ match X1, X2 with Mapset m1, Mapset m2 => cast_if (decide (m1 = m2)) end;
+ abstract congruence.
+Defined.
+Global Instance mapset_elem_of_dec x (X : mapset M) : Decision (x ∈ X) | 1.
+Proof. solve_decision. Defined.
+
+Instance: Collection K (mapset M).
+Proof.
+ split; [split | | ].
+ * unfold empty, elem_of, mapset_empty, mapset_elem_of.
+ simpl. intros. by simpl_map.
+ * unfold singleton, elem_of, mapset_singleton, mapset_elem_of.
+ simpl. by split; intros; simplify_map_equality.
+ * unfold union, elem_of, mapset_union, mapset_elem_of.
+ intros [m1] [m2] ?. simpl. rewrite lookup_union_Some_raw.
+ destruct (m1 !! x) as [[]|]; tauto.
+ * unfold intersection, elem_of, mapset_intersection, mapset_elem_of.
+ intros [m1] [m2] ?. simpl. rewrite lookup_intersection_Some.
+ assert (is_Some (m2 !! x) ↔ m2 !! x = Some ()).
+ { split; eauto. by intros [[] ?]. }
+ naive_solver.
+ * unfold difference, elem_of, mapset_difference, mapset_elem_of.
+ intros [m1] [m2] ?. simpl. rewrite lookup_difference_Some.
+ destruct (m2 !! x) as [[]|]; intuition congruence.
+Qed.
+Global Instance: PartialOrder (@subseteq (mapset M) _).
+Proof. split; try apply _. intros ????. apply mapset_eq. intuition. Qed.
+Global Instance: FinCollection K (mapset M).
+Proof.
+ split.
+ * apply _.
+ * unfold elements, elem_of at 2, mapset_elems, mapset_elem_of.
+ intros [m] x. simpl. rewrite elem_of_list_fmap. split.
+ + intros ([y []] &?& Hy). subst. by rewrite <-elem_of_map_to_list.
+ + intros. exists (x, ()). by rewrite elem_of_map_to_list.
+ * unfold elements, mapset_elems. intros [m]. simpl.
+ apply NoDup_fst_map_to_list.
+Qed.
+
+Definition mapset_map_with {A B} (f : bool → A → option B)
+ (X : mapset M) : M A → M B :=
+ let (mX) := X in merge (λ x y,
+ match x, y with
+ | Some _, Some a => f true a | None, Some a => f false a | _, None => None
+ end) mX.
+Definition mapset_dom_with {A} (f : A → bool) (m : M A) : mapset M :=
+ Mapset $ merge (λ x _,
+ match x with
+ | Some a => if f a then Some () else None | None => None
+ end) m (@empty (M A) _).
+
+Lemma lookup_mapset_map_with {A B} (f : bool → A → option B) X m i :
+ mapset_map_with f X m !! i = m !! i ≫= f (bool_decide (i ∈ X)).
+Proof.
+ destruct X as [mX]. unfold mapset_map_with, elem_of, mapset_elem_of.
+ rewrite lookup_merge by done. simpl.
+ by case_bool_decide; destruct (mX !! i) as [[]|], (m !! i).
+Qed.
+Lemma elem_of_mapset_dom_with {A} (f : A → bool) m i :
+ i ∈ mapset_dom_with f m ↔ ∃ x, m !! i = Some x ∧ f x.
+Proof.
+ unfold mapset_dom_with, elem_of, mapset_elem_of.
+ simpl. rewrite lookup_merge by done. destruct (m !! i) as [a|].
+ * destruct (Is_true_reflect (f a)); naive_solver.
+ * naive_solver.
+Qed.
+Instance mapset_dom {A} : Dom (M A) (mapset M) := mapset_dom_with (λ _, true).
+Instance mapset_dom_spec: FinMapDom K M (mapset M).
+Proof.
+ split; try apply _. intros. unfold dom, mapset_dom, is_Some.
+ rewrite elem_of_mapset_dom_with; naive_solver.
+Qed.
+End mapset.
+
+(** These instances are declared using [Hint Extern] to avoid too
+eager type class search. *)
+Hint Extern 1 (ElemOf _ (mapset _)) =>
+ eapply @mapset_elem_of : typeclass_instances.
+Hint Extern 1 (Empty (mapset _)) =>
+ eapply @mapset_empty : typeclass_instances.
+Hint Extern 1 (Singleton _ (mapset _)) =>
+ eapply @mapset_singleton : typeclass_instances.
+Hint Extern 1 (Union (mapset _)) =>
+ eapply @mapset_union : typeclass_instances.
+Hint Extern 1 (Intersection (mapset _)) =>
+ eapply @mapset_intersection : typeclass_instances.
+Hint Extern 1 (Difference (mapset _)) =>
+ eapply @mapset_difference : typeclass_instances.
+Hint Extern 1 (Elements _ (mapset _)) =>
+ eapply @mapset_elems : typeclass_instances.
+Arguments mapset_eq_dec _ _ _ _ : simpl never.
diff --git a/prelude/natmap.v b/prelude/natmap.v
new file mode 100644
index 0000000000000000000000000000000000000000..309520af7969a9d98a271d83bfc578680560edb6
--- /dev/null
+++ b/prelude/natmap.v
@@ -0,0 +1,360 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files implements a type [natmap A] of finite maps whose keys range
+over Coq's data type of unary natural numbers [nat]. The implementation equips
+a list with a proof of canonicity. *)
+Require Import prelude.fin_maps prelude.mapset.
+
+Notation natmap_raw A := (list (option A)).
+Definition natmap_wf {A} (l : natmap_raw A) :=
+ match last l with None => True | Some x => is_Some x end.
+Instance natmap_wf_pi {A} (l : natmap_raw A) : ProofIrrel (natmap_wf l).
+Proof. unfold natmap_wf. case_match; apply _. Qed.
+
+Lemma natmap_wf_inv {A} (o : option A) (l : natmap_raw A) :
+ natmap_wf (o :: l) → natmap_wf l.
+Proof. by destruct l. Qed.
+Lemma natmap_wf_lookup {A} (l : natmap_raw A) :
+ natmap_wf l → l ≠[] → ∃ i x, mjoin (l !! i) = Some x.
+Proof.
+ intros Hwf Hl. induction l as [|[x|] l IH]; simpl; [done| |].
+ { exists 0. simpl. eauto. }
+ destruct IH as (i&x&?); eauto using natmap_wf_inv; [|by exists (S i), x].
+ intros ->. by destruct Hwf.
+Qed.
+
+Record natmap (A : Type) : Type := NatMap {
+ natmap_car : natmap_raw A;
+ natmap_prf : natmap_wf natmap_car
+}.
+Arguments NatMap {_} _ _.
+Arguments natmap_car {_} _.
+Arguments natmap_prf {_} _.
+Lemma natmap_eq {A} (m1 m2 : natmap A) :
+ m1 = m2 ↔ natmap_car m1 = natmap_car m2.
+Proof.
+ split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?].
+ simplify_equality'; f_equal; apply proof_irrel.
+Qed.
+Global Instance natmap_eq_dec `{∀ x y : A, Decision (x = y)}
+ (m1 m2 : natmap A) : Decision (m1 = m2) :=
+ match decide (natmap_car m1 = natmap_car m2) with
+ | left H => left (proj2 (natmap_eq m1 m2) H)
+ | right H => right (H ∘ proj1 (natmap_eq m1 m2))
+ end.
+
+Instance natmap_empty {A} : Empty (natmap A) := NatMap [] I.
+Instance natmap_lookup {A} : Lookup nat A (natmap A) := λ i m,
+ let (l,_) := m in mjoin (l !! i).
+
+Fixpoint natmap_singleton_raw {A} (i : nat) (x : A) : natmap_raw A :=
+ match i with 0 => [Some x]| S i => None :: natmap_singleton_raw i x end.
+Lemma natmap_singleton_wf {A} (i : nat) (x : A) :
+ natmap_wf (natmap_singleton_raw i x).
+Proof. unfold natmap_wf. induction i as [|[]]; simplify_equality'; eauto. Qed.
+Lemma natmap_lookup_singleton_raw {A} (i : nat) (x : A) :
+ mjoin (natmap_singleton_raw i x !! i) = Some x.
+Proof. induction i; simpl; auto. Qed.
+Lemma natmap_lookup_singleton_raw_ne {A} (i j : nat) (x : A) :
+ i ≠j → mjoin (natmap_singleton_raw i x !! j) = None.
+Proof. revert j; induction i; intros [|?]; simpl; auto with congruence. Qed.
+Hint Rewrite @natmap_lookup_singleton_raw : natmap.
+
+Definition natmap_cons_canon {A} (o : option A) (l : natmap_raw A) :=
+ match o, l with None, [] => [] | _, _ => o :: l end.
+Lemma natmap_cons_canon_wf {A} (o : option A) (l : natmap_raw A) :
+ natmap_wf l → natmap_wf (natmap_cons_canon o l).
+Proof. unfold natmap_wf, last. destruct o, l; simpl; eauto. Qed.
+Lemma natmap_cons_canon_O {A} (o : option A) (l : natmap_raw A) :
+ mjoin (natmap_cons_canon o l !! 0) = o.
+Proof. by destruct o, l. Qed.
+Lemma natmap_cons_canon_S {A} (o : option A) (l : natmap_raw A) i :
+ natmap_cons_canon o l !! S i = l !! i.
+Proof. by destruct o, l. Qed.
+Hint Rewrite @natmap_cons_canon_O @natmap_cons_canon_S : natmap.
+
+Definition natmap_alter_raw {A} (f : option A → option A) :
+ nat → natmap_raw A → natmap_raw A :=
+ fix go i l {struct l} :=
+ match l with
+ | [] =>
+ match f None with
+ | Some x => natmap_singleton_raw i x | None => []
+ end
+ | o :: l =>
+ match i with
+ | 0 => natmap_cons_canon (f o) l | S i => natmap_cons_canon o (go i l)
+ end
+ end.
+Lemma natmap_alter_wf {A} (f : option A → option A) i l :
+ natmap_wf l → natmap_wf (natmap_alter_raw f i l).
+Proof.
+ revert i. induction l; [intro | intros [|?]]; simpl; repeat case_match;
+ eauto using natmap_singleton_wf, natmap_cons_canon_wf, natmap_wf_inv.
+Qed.
+Instance natmap_alter {A} : PartialAlter nat A (natmap A) := λ f i m,
+ let (l,Hl) := m in NatMap _ (natmap_alter_wf f i l Hl).
+Lemma natmap_lookup_alter_raw {A} (f : option A → option A) i l :
+ mjoin (natmap_alter_raw f i l !! i) = f (mjoin (l !! i)).
+Proof.
+ revert i. induction l; intros [|?]; simpl; repeat case_match; simpl;
+ autorewrite with natmap; auto.
+Qed.
+Lemma natmap_lookup_alter_raw_ne {A} (f : option A → option A) i j l :
+ i ≠j → mjoin (natmap_alter_raw f i l !! j) = mjoin (l !! j).
+Proof.
+ revert i j. induction l; intros [|?] [|?] ?; simpl;
+ repeat case_match; simpl; autorewrite with natmap; auto with congruence.
+ rewrite natmap_lookup_singleton_raw_ne; congruence.
+Qed.
+
+Definition natmap_omap_raw {A B} (f : A → option B) :
+ natmap_raw A → natmap_raw B :=
+ fix go l :=
+ match l with [] => [] | o :: l => natmap_cons_canon (o ≫= f) (go l) end.
+Lemma natmap_omap_raw_wf {A B} (f : A → option B) l :
+ natmap_wf l → natmap_wf (natmap_omap_raw f l).
+Proof. induction l; simpl; eauto using natmap_cons_canon_wf, natmap_wf_inv. Qed.
+Lemma natmap_lookup_omap_raw {A B} (f : A → option B) l i :
+ mjoin (natmap_omap_raw f l !! i) = mjoin (l !! i) ≫= f.
+Proof.
+ revert i. induction l; intros [|?]; simpl; autorewrite with natmap; auto.
+Qed.
+Hint Rewrite @natmap_lookup_omap_raw : natmap.
+Global Instance natmap_omap: OMap natmap := λ A B f m,
+ let (l,Hl) := m in NatMap _ (natmap_omap_raw_wf f _ Hl).
+
+Definition natmap_merge_raw {A B C} (f : option A → option B → option C) :
+ natmap_raw A → natmap_raw B → natmap_raw C :=
+ fix go l1 l2 :=
+ match l1, l2 with
+ | [], l2 => natmap_omap_raw (f None ∘ Some) l2
+ | l1, [] => natmap_omap_raw (flip f None ∘ Some) l1
+ | o1 :: l1, o2 :: l2 => natmap_cons_canon (f o1 o2) (go l1 l2)
+ end.
+Lemma natmap_merge_wf {A B C} (f : option A → option B → option C) l1 l2 :
+ natmap_wf l1 → natmap_wf l2 → natmap_wf (natmap_merge_raw f l1 l2).
+Proof.
+ revert l2. induction l1; intros [|??]; simpl;
+ eauto using natmap_omap_raw_wf, natmap_cons_canon_wf, natmap_wf_inv.
+Qed.
+Lemma natmap_lookup_merge_raw {A B C} (f : option A → option B → option C)
+ l1 l2 i : f None None = None →
+ mjoin (natmap_merge_raw f l1 l2 !! i) = f (mjoin (l1 !! i)) (mjoin (l2 !! i)).
+Proof.
+ intros. revert i l2. induction l1; intros [|?] [|??]; simpl;
+ autorewrite with natmap; auto;
+ match goal with |- context [?o ≫= _] => by destruct o end.
+Qed.
+Instance natmap_merge: Merge natmap := λ A B C f m1 m2,
+ let (l1, Hl1) := m1 in let (l2, Hl2) := m2 in
+ NatMap (natmap_merge_raw f l1 l2) (natmap_merge_wf _ _ _ Hl1 Hl2).
+
+Fixpoint natmap_to_list_raw {A} (i : nat) (l : natmap_raw A) : list (nat * A) :=
+ match l with
+ | [] => []
+ | None :: l => natmap_to_list_raw (S i) l
+ | Some x :: l => (i,x) :: natmap_to_list_raw (S i) l
+ end.
+Lemma natmap_elem_of_to_list_raw_aux {A} j (l : natmap_raw A) i x :
+ (i,x) ∈ natmap_to_list_raw j l ↔ ∃ i', i = i' + j ∧ mjoin (l !! i') = Some x.
+Proof.
+ split.
+ * revert j. induction l as [|[y|] l IH]; intros j; simpl.
+ + by rewrite elem_of_nil.
+ + rewrite elem_of_cons. intros [?|?]; simplify_equality.
+ - by exists 0.
+ - destruct (IH (S j)) as (i'&?&?); auto.
+ exists (S i'); simpl; auto with lia.
+ + intros. destruct (IH (S j)) as (i'&?&?); auto.
+ exists (S i'); simpl; auto with lia.
+ * intros (i'&?&Hi'). subst. revert i' j Hi'.
+ induction l as [|[y|] l IH]; intros i j ?; simpl.
+ + done.
+ + destruct i as [|i]; simplify_equality'; [left|].
+ right. rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
+ + destruct i as [|i]; simplify_equality'.
+ rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
+Qed.
+Lemma natmap_elem_of_to_list_raw {A} (l : natmap_raw A) i x :
+ (i,x) ∈ natmap_to_list_raw 0 l ↔ mjoin (l !! i) = Some x.
+Proof.
+ rewrite natmap_elem_of_to_list_raw_aux. setoid_rewrite Nat.add_0_r.
+ naive_solver.
+Qed.
+Lemma natmap_to_list_raw_nodup {A} i (l : natmap_raw A) :
+ NoDup (natmap_to_list_raw i l).
+Proof.
+ revert i. induction l as [|[?|] ? IH]; simpl; try constructor; auto.
+ rewrite natmap_elem_of_to_list_raw_aux. intros (?&?&?). lia.
+Qed.
+Instance natmap_to_list {A} : FinMapToList nat A (natmap A) := λ m,
+ let (l,_) := m in natmap_to_list_raw 0 l.
+
+Definition natmap_map_raw {A B} (f : A → B) : natmap_raw A → natmap_raw B :=
+ fmap (fmap f).
+Lemma natmap_map_wf {A B} (f : A → B) l :
+ natmap_wf l → natmap_wf (natmap_map_raw f l).
+Proof.
+ unfold natmap_map_raw, natmap_wf. rewrite fmap_last.
+ destruct (last l). by apply fmap_is_Some. done.
+Qed.
+Lemma natmap_lookup_map_raw {A B} (f : A → B) i l :
+ mjoin (natmap_map_raw f l !! i) = f <$> mjoin (l !! i).
+Proof.
+ unfold natmap_map_raw. rewrite list_lookup_fmap. by destruct (l !! i).
+Qed.
+Instance natmap_map: FMap natmap := λ A B f m,
+ let (l,Hl) := m in NatMap (natmap_map_raw f l) (natmap_map_wf _ _ Hl).
+
+Instance: FinMap nat natmap.
+Proof.
+ split.
+ * unfold lookup, natmap_lookup. intros A [l1 Hl1] [l2 Hl2] E.
+ apply natmap_eq. revert l2 Hl1 Hl2 E. simpl.
+ induction l1 as [|[x|] l1 IH]; intros [|[y|] l2] Hl1 Hl2 E; simpl in *.
+ + done.
+ + by specialize (E 0).
+ + destruct (natmap_wf_lookup (None :: l2)) as (i&?&?); auto with congruence.
+ + by specialize (E 0).
+ + f_equal. apply (E 0). apply IH; eauto using natmap_wf_inv.
+ intros i. apply (E (S i)).
+ + by specialize (E 0).
+ + destruct (natmap_wf_lookup (None :: l1)) as (i&?&?); auto with congruence.
+ + by specialize (E 0).
+ + f_equal. apply IH; eauto using natmap_wf_inv. intros i. apply (E (S i)).
+ * done.
+ * intros ?? [??] ?. apply natmap_lookup_alter_raw.
+ * intros ?? [??] ??. apply natmap_lookup_alter_raw_ne.
+ * intros ??? [??] ?. apply natmap_lookup_map_raw.
+ * intros ? [??]. by apply natmap_to_list_raw_nodup.
+ * intros ? [??] ??. by apply natmap_elem_of_to_list_raw.
+ * intros ??? [??] ?. by apply natmap_lookup_omap_raw.
+ * intros ????? [??] [??] ?. by apply natmap_lookup_merge_raw.
+Qed.
+
+Fixpoint strip_Nones {A} (l : list (option A)) : list (option A) :=
+ match l with None :: l => strip_Nones l | _ => l end.
+
+Lemma list_to_natmap_wf {A} (l : list (option A)) :
+ natmap_wf (reverse (strip_Nones (reverse l))).
+Proof.
+ unfold natmap_wf. rewrite last_reverse.
+ induction (reverse l) as [|[]]; simpl; eauto.
+Qed.
+Definition list_to_natmap {A} (l : list (option A)) : natmap A :=
+ NatMap (reverse (strip_Nones (reverse l))) (list_to_natmap_wf l).
+Lemma list_to_natmap_spec {A} (l : list (option A)) i :
+ list_to_natmap l !! i = mjoin (l !! i).
+Proof.
+ unfold lookup at 1, natmap_lookup, list_to_natmap; simpl.
+ rewrite <-(reverse_involutive l) at 2. revert i.
+ induction (reverse l) as [|[x|] l' IH]; intros i; simpl; auto.
+ rewrite reverse_cons, IH. clear IH. revert i.
+ induction (reverse l'); intros [|?]; simpl; auto.
+Qed.
+
+(** Finally, we can construct sets of [nat]s satisfying extensional equality. *)
+Notation natset := (mapset natmap).
+Instance natmap_dom {A} : Dom (natmap A) natset := mapset_dom.
+Instance: FinMapDom nat natmap natset := mapset_dom_spec.
+
+(* Fixpoint avoids this definition from being unfolded *)
+Fixpoint of_bools (βs : list bool) : natset :=
+ let f (β : bool) := if β then Some () else None in
+ Mapset $ list_to_natmap $ f <$> βs.
+Definition to_bools (sz : nat) (X : natset) : list bool :=
+ let f (mu : option ()) := match mu with Some _ => true | None => false end in
+ resize sz false $ f <$> natmap_car (mapset_car X).
+
+Lemma of_bools_unfold βs :
+ let f (β : bool) := if β then Some () else None in
+ of_bools βs = Mapset $ list_to_natmap $ f <$> βs.
+Proof. by destruct βs. Qed.
+Lemma elem_of_of_bools βs i : i ∈ of_bools βs ↔ βs !! i = Some true.
+Proof.
+ rewrite of_bools_unfold; unfold elem_of, mapset_elem_of; simpl.
+ rewrite list_to_natmap_spec, list_lookup_fmap.
+ destruct (βs !! i) as [[]|]; compute; intuition congruence.
+Qed.
+Lemma of_bools_union βs1 βs2 :
+ length βs1 = length βs2 →
+ of_bools (βs1 ||* βs2) = of_bools βs1 ∪ of_bools βs2.
+Proof.
+ rewrite <-Forall2_same_length; intros Hβs.
+ apply elem_of_equiv_L. intros i. rewrite elem_of_union, !elem_of_of_bools.
+ revert i. induction Hβs as [|[] []]; intros [|?]; naive_solver.
+Qed.
+Lemma to_bools_length (X : natset) sz : length (to_bools sz X) = sz.
+Proof. apply resize_length. Qed.
+Lemma lookup_to_bools_ge sz X i : sz ≤ i → to_bools sz X !! i = None.
+Proof. by apply lookup_resize_old. Qed.
+Lemma lookup_to_bools sz X i β :
+ i < sz → to_bools sz X !! i = Some β ↔ (i ∈ X ↔ β = true).
+Proof.
+ unfold to_bools, elem_of, mapset_elem_of, lookup at 2, natmap_lookup; simpl.
+ intros. destruct (mapset_car X) as [l ?]; simpl.
+ destruct (l !! i) as [mu|] eqn:Hmu; simpl.
+ { rewrite lookup_resize, list_lookup_fmap, Hmu
+ by (rewrite ?fmap_length; eauto using lookup_lt_Some).
+ destruct mu as [[]|], β; simpl; intuition congruence. }
+ rewrite lookup_resize_new by (rewrite ?fmap_length;
+ eauto using lookup_ge_None_1); destruct β; intuition congruence.
+Qed.
+Lemma lookup_to_bools_true sz X i :
+ i < sz → to_bools sz X !! i = Some true ↔ i ∈ X.
+Proof. intros. rewrite lookup_to_bools by done. intuition. Qed.
+Lemma lookup_to_bools_false sz X i :
+ i < sz → to_bools sz X !! i = Some false ↔ i ∉ X.
+Proof. intros. rewrite lookup_to_bools by done. naive_solver. Qed.
+Lemma to_bools_union sz X1 X2 :
+ to_bools sz (X1 ∪ X2) = to_bools sz X1 ||* to_bools sz X2.
+Proof.
+ apply list_eq; intros i; rewrite lookup_zip_with.
+ destruct (decide (i < sz)); [|by rewrite !lookup_to_bools_ge by lia].
+ apply option_eq; intros β.
+ rewrite lookup_to_bools, elem_of_union by done; intros.
+ destruct (decide (i ∈ X1)), (decide (i ∈ X2)); repeat first
+ [ rewrite (λ X H, proj2 (lookup_to_bools_true sz X i H)) by done
+ | rewrite (λ X H, proj2 (lookup_to_bools_false sz X i H)) by done];
+ destruct β; naive_solver.
+Qed.
+Lemma to_of_bools βs sz : to_bools sz (of_bools βs) = resize sz false βs.
+Proof.
+ apply list_eq; intros i. destruct (decide (i < sz));
+ [|by rewrite lookup_to_bools_ge, lookup_resize_old by lia].
+ apply option_eq; intros β.
+ rewrite lookup_to_bools, elem_of_of_bools by done.
+ destruct (decide (i < length βs)).
+ { rewrite lookup_resize by done.
+ destruct (lookup_lt_is_Some_2 βs i) as [[]]; destruct β; naive_solver. }
+ rewrite lookup_resize_new, lookup_ge_None_2 by lia. destruct β; naive_solver.
+Qed.
+
+(** A [natmap A] forms a stack with elements of type [A] and possible holes *)
+Definition natmap_push {A} (o : option A) (m : natmap A) : natmap A :=
+ let (l,Hl) := m in NatMap _ (natmap_cons_canon_wf o l Hl).
+
+Definition natmap_pop_raw {A} (l : natmap_raw A) : natmap_raw A := tail l.
+Lemma natmap_pop_wf {A} (l : natmap_raw A) :
+ natmap_wf l → natmap_wf (natmap_pop_raw l).
+Proof. destruct l; simpl; eauto using natmap_wf_inv. Qed.
+Definition natmap_pop {A} (m : natmap A) : natmap A :=
+ let (l,Hl) := m in NatMap _ (natmap_pop_wf _ Hl).
+
+Lemma lookup_natmap_push_O {A} o (m : natmap A) : natmap_push o m !! 0 = o.
+Proof. by destruct o, m as [[|??]]. Qed.
+Lemma lookup_natmap_push_S {A} o (m : natmap A) i :
+ natmap_push o m !! S i = m !! i.
+Proof. by destruct o, m as [[|??]]. Qed.
+Lemma lookup_natmap_pop {A} (m : natmap A) i : natmap_pop m !! i = m !! S i.
+Proof. by destruct m as [[|??]]. Qed.
+Lemma natmap_push_pop {A} (m : natmap A) :
+ natmap_push (m !! 0) (natmap_pop m) = m.
+Proof.
+ apply map_eq. intros i. destruct i.
+ * by rewrite lookup_natmap_push_O.
+ * by rewrite lookup_natmap_push_S, lookup_natmap_pop.
+Qed.
+Lemma natmap_pop_push {A} o (m : natmap A) : natmap_pop (natmap_push o m) = m.
+Proof. apply natmap_eq. by destruct o, m as [[|??]]. Qed.
diff --git a/prelude/nmap.v b/prelude/nmap.v
new file mode 100644
index 0000000000000000000000000000000000000000..1adc1a636600c5cf8f45062e781b11b323879092
--- /dev/null
+++ b/prelude/nmap.v
@@ -0,0 +1,103 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files extends the implementation of finite over [positive] to finite
+maps whose keys range over Coq's data type of binary naturals [N]. *)
+Require Import prelude.pmap prelude.mapset.
+Require Export prelude.prelude prelude.fin_maps.
+
+Local Open Scope N_scope.
+
+Record Nmap (A : Type) : Type := NMap { Nmap_0 : option A; Nmap_pos : Pmap A }.
+Arguments Nmap_0 {_} _.
+Arguments Nmap_pos {_} _.
+Arguments NMap {_} _ _.
+
+Instance Nmap_eq_dec `{∀ x y : A, Decision (x = y)} (t1 t2 : Nmap A) :
+ Decision (t1 = t2).
+Proof.
+ refine
+ match t1, t2 with
+ | NMap x t1, NMap y t2 => cast_if_and (decide (x = y)) (decide (t1 = t2))
+ end; abstract congruence.
+Defined.
+Instance Nempty {A} : Empty (Nmap A) := NMap None ∅.
+Global Opaque Nempty.
+Instance Nlookup {A} : Lookup N A (Nmap A) := λ i t,
+ match i with
+ | N0 => Nmap_0 t
+ | Npos p => Nmap_pos t !! p
+ end.
+Instance Npartial_alter {A} : PartialAlter N A (Nmap A) := λ f i t,
+ match i, t with
+ | N0, NMap o t => NMap (f o) t
+ | Npos p, NMap o t => NMap o (partial_alter f p t)
+ end.
+Instance Nto_list {A} : FinMapToList N A (Nmap A) := λ t,
+ match t with
+ | NMap o t =>
+ default [] o (λ x, [(0,x)]) ++ (prod_map Npos id <$> map_to_list t)
+ end.
+Instance Nomap: OMap Nmap := λ A B f t,
+ match t with NMap o t => NMap (o ≫= f) (omap f t) end.
+Instance Nmerge: Merge Nmap := λ A B C f t1 t2,
+ match t1, t2 with
+ | NMap o1 t1, NMap o2 t2 => NMap (f o1 o2) (merge f t1 t2)
+ end.
+Instance Nfmap: FMap Nmap := λ A B f t,
+ match t with NMap o t => NMap (f <$> o) (f <$> t) end.
+
+Instance: FinMap N Nmap.
+Proof.
+ split.
+ * intros ? [??] [??] H. f_equal; [apply (H 0)|].
+ apply map_eq. intros i. apply (H (Npos i)).
+ * by intros ? [|?].
+ * intros ? f [? t] [|i]; simpl; [done |]. apply lookup_partial_alter.
+ * intros ? f [? t] [|i] [|j]; simpl; try intuition congruence.
+ intros. apply lookup_partial_alter_ne. congruence.
+ * intros ??? [??] []; simpl. done. apply lookup_fmap.
+ * intros ? [[x|] t]; unfold map_to_list; simpl.
+ + constructor.
+ - rewrite elem_of_list_fmap. by intros [[??] [??]].
+ - by apply (NoDup_fmap _), NoDup_map_to_list.
+ + apply (NoDup_fmap _), NoDup_map_to_list.
+ * intros ? t i x. unfold map_to_list. split.
+ + destruct t as [[y|] t]; simpl.
+ - rewrite elem_of_cons, elem_of_list_fmap.
+ intros [? | [[??] [??]]]; simplify_equality'; [done |].
+ by apply elem_of_map_to_list.
+ - rewrite elem_of_list_fmap; intros [[??] [??]]; simplify_equality'.
+ by apply elem_of_map_to_list.
+ + destruct t as [[y|] t]; simpl.
+ - rewrite elem_of_cons, elem_of_list_fmap.
+ destruct i as [|i]; simpl; [intuition congruence |].
+ intros. right. exists (i, x). by rewrite elem_of_map_to_list.
+ - rewrite elem_of_list_fmap.
+ destruct i as [|i]; simpl; [done |].
+ intros. exists (i, x). by rewrite elem_of_map_to_list.
+ * intros ?? f [??] [|?]; simpl; [done|]; apply (lookup_omap f).
+ * intros ??? f ? [??] [??] [|?]; simpl; [done|]; apply (lookup_merge f).
+Qed.
+
+(** * Finite sets *)
+(** We construct sets of [N]s satisfying extensional equality. *)
+Notation Nset := (mapset Nmap).
+Instance Nmap_dom {A} : Dom (Nmap A) Nset := mapset_dom.
+Instance: FinMapDom N Nmap Nset := mapset_dom_spec.
+
+(** * Fresh numbers *)
+Definition Nfresh {A} (m : Nmap A) : N :=
+ match m with NMap None _ => 0 | NMap _ m => Npos (Pfresh m) end.
+Lemma Nfresh_fresh {A} (m : Nmap A) : m !! Nfresh m = None.
+Proof. destruct m as [[]]. apply Pfresh_fresh. done. Qed.
+
+Instance Nset_fresh : Fresh N Nset := λ X,
+ let (m) := X in Nfresh m.
+Instance Nset_fresh_spec : FreshSpec N Nset.
+Proof.
+ split.
+ * apply _.
+ * intros X Y; rewrite <-elem_of_equiv_L. by intros ->.
+ * unfold elem_of, mapset_elem_of, fresh; intros [m]; simpl.
+ by rewrite Nfresh_fresh.
+Qed.
diff --git a/prelude/numbers.v b/prelude/numbers.v
new file mode 100644
index 0000000000000000000000000000000000000000..65b9621e9377f9720ca2ba31bcf158a03ac2c302
--- /dev/null
+++ b/prelude/numbers.v
@@ -0,0 +1,467 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects some trivial facts on the Coq types [nat] and [N] for
+natural numbers, and the type [Z] for integers. It also declares some useful
+notations. *)
+Require Export Eqdep PArith NArith ZArith NPeano.
+Require Import QArith Qcanon.
+Require Export prelude.base prelude.decidable prelude.option.
+Open Scope nat_scope.
+
+Coercion Z.of_nat : nat >-> Z.
+
+(** * Notations and properties of [nat] *)
+Arguments minus !_ !_ /.
+Reserved Notation "x ≤ y ≤ z" (at level 70, y at next level).
+Reserved Notation "x ≤ y < z" (at level 70, y at next level).
+Reserved Notation "x < y < z" (at level 70, y at next level).
+Reserved Notation "x < y ≤ z" (at level 70, y at next level).
+Reserved Notation "x ≤ y ≤ z ≤ z'"
+ (at level 70, y at next level, z at next level).
+
+Infix "≤" := le : nat_scope.
+Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z)%nat : nat_scope.
+Notation "x ≤ y < z" := (x ≤ y ∧ y < z)%nat : nat_scope.
+Notation "x < y < z" := (x < y ∧ y < z)%nat : nat_scope.
+Notation "x < y ≤ z" := (x < y ∧ y ≤ z)%nat : nat_scope.
+Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z')%nat : nat_scope.
+Notation "(≤)" := le (only parsing) : nat_scope.
+Notation "(<)" := lt (only parsing) : nat_scope.
+
+Infix "`div`" := Nat.div (at level 35) : nat_scope.
+Infix "`mod`" := Nat.modulo (at level 35) : nat_scope.
+
+Instance nat_eq_dec: ∀ x y : nat, Decision (x = y) := eq_nat_dec.
+Instance nat_le_dec: ∀ x y : nat, Decision (x ≤ y) := le_dec.
+Instance nat_lt_dec: ∀ x y : nat, Decision (x < y) := lt_dec.
+Instance nat_inhabited: Inhabited nat := populate 0%nat.
+Instance: Injective (=) (=) S.
+Proof. by injection 1. Qed.
+Instance: PartialOrder (≤).
+Proof. repeat split; repeat intro; auto with lia. Qed.
+
+Instance nat_le_pi: ∀ x y : nat, ProofIrrel (x ≤ y).
+Proof.
+ assert (∀ x y (p : x ≤ y) y' (q : x ≤ y'),
+ y = y' → eq_dep nat (le x) y p y' q) as aux.
+ { fix 3. intros x ? [|y p] ? [|y' q].
+ * done.
+ * clear nat_le_pi. intros; exfalso; auto with lia.
+ * clear nat_le_pi. intros; exfalso; auto with lia.
+ * injection 1. intros Hy. by case (nat_le_pi x y p y' q Hy). }
+ intros x y p q.
+ by apply (eq_dep_eq_dec (λ x y, decide (x = y))), aux.
+Qed.
+Instance nat_lt_pi: ∀ x y : nat, ProofIrrel (x < y).
+Proof. apply _. Qed.
+
+Definition sum_list_with {A} (f : A → nat) : list A → nat :=
+ fix go l :=
+ match l with
+ | [] => 0
+ | x :: l => f x + go l
+ end.
+Notation sum_list := (sum_list_with id).
+
+Lemma Nat_lt_succ_succ n : n < S (S n).
+Proof. auto with arith. Qed.
+Lemma Nat_mul_split_l n x1 x2 y1 y2 :
+ x2 < n → y2 < n → x1 * n + x2 = y1 * n + y2 → x1 = y1 ∧ x2 = y2.
+Proof.
+ intros Hx2 Hy2 E. cut (x1 = y1); [intros; subst;lia |].
+ revert y1 E. induction x1; simpl; intros [|?]; simpl; auto with lia.
+Qed.
+Lemma Nat_mul_split_r n x1 x2 y1 y2 :
+ x1 < n → y1 < n → x1 + x2 * n = y1 + y2 * n → x1 = y1 ∧ x2 = y2.
+Proof. intros. destruct (Nat_mul_split_l n x2 x1 y2 y1); auto with lia. Qed.
+
+Notation lcm := Nat.lcm.
+Notation divide := Nat.divide.
+Notation "( x | y )" := (divide x y) : nat_scope.
+Instance divide_dec x y : Decision (x | y).
+Proof.
+ refine (cast_if (decide (lcm x y = y))); by rewrite Nat.divide_lcm_iff.
+Defined.
+Instance: PartialOrder divide.
+Proof.
+ repeat split; try apply _. intros ??. apply Nat.divide_antisym_nonneg; lia.
+Qed.
+Hint Extern 0 (_ | _) => reflexivity.
+Lemma Nat_divide_ne_0 x y : (x | y) → y ≠0 → x ≠0.
+Proof. intros Hxy Hy ->. by apply Hy, Nat.divide_0_l. Qed.
+
+(** * Notations and properties of [positive] *)
+Open Scope positive_scope.
+
+Infix "≤" := Pos.le : positive_scope.
+Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) : positive_scope.
+Notation "x ≤ y < z" := (x ≤ y ∧ y < z) : positive_scope.
+Notation "x < y < z" := (x < y ∧ y < z) : positive_scope.
+Notation "x < y ≤ z" := (x < y ∧ y ≤ z) : positive_scope.
+Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z') : positive_scope.
+Notation "(≤)" := Pos.le (only parsing) : positive_scope.
+Notation "(<)" := Pos.lt (only parsing) : positive_scope.
+Notation "(~0)" := xO (only parsing) : positive_scope.
+Notation "(~1)" := xI (only parsing) : positive_scope.
+
+Arguments Pos.of_nat _ : simpl never.
+Instance positive_eq_dec: ∀ x y : positive, Decision (x = y) := Pos.eq_dec.
+Instance positive_inhabited: Inhabited positive := populate 1.
+
+Instance maybe_xO : Maybe xO := λ p, match p with p~0 => Some p | _ => None end.
+Instance maybe_x1 : Maybe xI := λ p, match p with p~1 => Some p | _ => None end.
+Instance: Injective (=) (=) (~0).
+Proof. by injection 1. Qed.
+Instance: Injective (=) (=) (~1).
+Proof. by injection 1. Qed.
+
+(** Since [positive] represents lists of bits, we define list operations
+on it. These operations are in reverse, as positives are treated as snoc
+lists instead of cons lists. *)
+Fixpoint Papp (p1 p2 : positive) : positive :=
+ match p2 with
+ | 1 => p1
+ | p2~0 => (Papp p1 p2)~0
+ | p2~1 => (Papp p1 p2)~1
+ end.
+Infix "++" := Papp : positive_scope.
+Notation "(++)" := Papp (only parsing) : positive_scope.
+Notation "( p ++)" := (Papp p) (only parsing) : positive_scope.
+Notation "(++ q )" := (λ p, Papp p q) (only parsing) : positive_scope.
+
+Fixpoint Preverse_go (p1 p2 : positive) : positive :=
+ match p2 with
+ | 1 => p1
+ | p2~0 => Preverse_go (p1~0) p2
+ | p2~1 => Preverse_go (p1~1) p2
+ end.
+Definition Preverse : positive → positive := Preverse_go 1.
+
+Global Instance: LeftId (=) 1 (++).
+Proof. intros p. by induction p; intros; f_equal'. Qed.
+Global Instance: RightId (=) 1 (++).
+Proof. done. Qed.
+Global Instance: Associative (=) (++).
+Proof. intros ?? p. by induction p; intros; f_equal'. Qed.
+Global Instance: ∀ p : positive, Injective (=) (=) (++ p).
+Proof. intros p ???. induction p; simplify_equality; auto. Qed.
+
+Lemma Preverse_go_app p1 p2 p3 :
+ Preverse_go p1 (p2 ++ p3) = Preverse_go p1 p3 ++ Preverse_go 1 p2.
+Proof.
+ revert p3 p1 p2.
+ cut (∀ p1 p2 p3, Preverse_go (p2 ++ p3) p1 = p2 ++ Preverse_go p3 p1).
+ { by intros go p3; induction p3; intros p1 p2; simpl; auto; rewrite <-?go. }
+ intros p1; induction p1 as [p1 IH|p1 IH|]; intros p2 p3; simpl; auto.
+ * apply (IH _ (_~1)).
+ * apply (IH _ (_~0)).
+Qed.
+Lemma Preverse_app p1 p2 : Preverse (p1 ++ p2) = Preverse p2 ++ Preverse p1.
+Proof. unfold Preverse. by rewrite Preverse_go_app. Qed.
+Lemma Preverse_xO p : Preverse (p~0) = (1~0) ++ Preverse p.
+Proof Preverse_app p (1~0).
+Lemma Preverse_xI p : Preverse (p~1) = (1~1) ++ Preverse p.
+Proof Preverse_app p (1~1).
+
+Fixpoint Plength (p : positive) : nat :=
+ match p with 1 => 0%nat | p~0 | p~1 => S (Plength p) end.
+Lemma Papp_length p1 p2 : Plength (p1 ++ p2) = (Plength p2 + Plength p1)%nat.
+Proof. by induction p2; f_equal'. Qed.
+
+Close Scope positive_scope.
+
+(** * Notations and properties of [N] *)
+Infix "≤" := N.le : N_scope.
+Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z)%N : N_scope.
+Notation "x ≤ y < z" := (x ≤ y ∧ y < z)%N : N_scope.
+Notation "x < y < z" := (x < y ∧ y < z)%N : N_scope.
+Notation "x < y ≤ z" := (x < y ∧ y ≤ z)%N : N_scope.
+Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z')%N : N_scope.
+Notation "(≤)" := N.le (only parsing) : N_scope.
+Notation "(<)" := N.lt (only parsing) : N_scope.
+Infix "`div`" := N.div (at level 35) : N_scope.
+Infix "`mod`" := N.modulo (at level 35) : N_scope.
+
+Arguments N.add _ _ : simpl never.
+
+Instance: Injective (=) (=) Npos.
+Proof. by injection 1. Qed.
+
+Instance N_eq_dec: ∀ x y : N, Decision (x = y) := N.eq_dec.
+Program Instance N_le_dec (x y : N) : Decision (x ≤ y)%N :=
+ match Ncompare x y with Gt => right _ | _ => left _ end.
+Solve Obligations with naive_solver.
+Program Instance N_lt_dec (x y : N) : Decision (x < y)%N :=
+ match Ncompare x y with Lt => left _ | _ => right _ end.
+Solve Obligations with naive_solver.
+Instance N_inhabited: Inhabited N := populate 1%N.
+Instance: PartialOrder (≤)%N.
+Proof.
+ repeat split; red. apply N.le_refl. apply N.le_trans. apply N.le_antisymm.
+Qed.
+Hint Extern 0 (_ ≤ _)%N => reflexivity.
+
+(** * Notations and properties of [Z] *)
+Open Scope Z_scope.
+
+Infix "≤" := Z.le : Z_scope.
+Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) : Z_scope.
+Notation "x ≤ y < z" := (x ≤ y ∧ y < z) : Z_scope.
+Notation "x < y < z" := (x < y ∧ y < z) : Z_scope.
+Notation "x < y ≤ z" := (x < y ∧ y ≤ z) : Z_scope.
+Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z') : Z_scope.
+Notation "(≤)" := Z.le (only parsing) : Z_scope.
+Notation "(<)" := Z.lt (only parsing) : Z_scope.
+
+Infix "`div`" := Z.div (at level 35) : Z_scope.
+Infix "`mod`" := Z.modulo (at level 35) : Z_scope.
+Infix "`quot`" := Z.quot (at level 35) : Z_scope.
+Infix "`rem`" := Z.rem (at level 35) : Z_scope.
+Infix "≪" := Z.shiftl (at level 35) : Z_scope.
+Infix "≫" := Z.shiftr (at level 35) : Z_scope.
+
+Instance: Injective (=) (=) Zpos.
+Proof. by injection 1. Qed.
+Instance: Injective (=) (=) Zneg.
+Proof. by injection 1. Qed.
+
+Instance Z_eq_dec: ∀ x y : Z, Decision (x = y) := Z.eq_dec.
+Instance Z_le_dec: ∀ x y : Z, Decision (x ≤ y) := Z_le_dec.
+Instance Z_lt_dec: ∀ x y : Z, Decision (x < y) := Z_lt_dec.
+Instance Z_inhabited: Inhabited Z := populate 1.
+Instance: PartialOrder (≤).
+Proof.
+ repeat split; red. apply Z.le_refl. apply Z.le_trans. apply Z.le_antisymm.
+Qed.
+
+Lemma Z_pow_pred_r n m : 0 < m → n * n ^ (Z.pred m) = n ^ m.
+Proof.
+ intros. rewrite <-Z.pow_succ_r, Z.succ_pred. done. by apply Z.lt_le_pred.
+Qed.
+Lemma Z_quot_range_nonneg k x y : 0 ≤ x < k → 0 < y → 0 ≤ x `quot` y < k.
+Proof.
+ intros [??] ?.
+ destruct (decide (y = 1)); subst; [rewrite Z.quot_1_r; auto |].
+ destruct (decide (x = 0)); subst; [rewrite Z.quot_0_l; auto with lia |].
+ split. apply Z.quot_pos; lia. transitivity x; auto. apply Z.quot_lt; lia.
+Qed.
+
+(* Note that we cannot disable simpl for [Z.of_nat] as that would break
+tactics as [lia]. *)
+Arguments Z.to_nat _ : simpl never.
+Arguments Z.mul _ _ : simpl never.
+Arguments Z.add _ _ : simpl never.
+Arguments Z.opp _ : simpl never.
+Arguments Z.pow _ _ : simpl never.
+Arguments Z.div _ _ : simpl never.
+Arguments Z.modulo _ _ : simpl never.
+Arguments Z.quot _ _ : simpl never.
+Arguments Z.rem _ _ : simpl never.
+
+Lemma Z_to_nat_neq_0_pos x : Z.to_nat x ≠0%nat → 0 < x.
+Proof. by destruct x. Qed.
+Lemma Z_to_nat_neq_0_nonneg x : Z.to_nat x ≠0%nat → 0 ≤ x.
+Proof. by destruct x. Qed.
+Lemma Z_mod_pos x y : 0 < y → 0 ≤ x `mod` y.
+Proof. apply Z.mod_pos_bound. Qed.
+
+Hint Resolve Z.lt_le_incl : zpos.
+Hint Resolve Z.add_nonneg_pos Z.add_pos_nonneg Z.add_nonneg_nonneg : zpos.
+Hint Resolve Z.mul_nonneg_nonneg Z.mul_pos_pos : zpos.
+Hint Resolve Z.pow_pos_nonneg Z.pow_nonneg: zpos.
+Hint Resolve Z_mod_pos Z.div_pos : zpos.
+Hint Extern 1000 => lia : zpos.
+
+Lemma Z_to_nat_nonpos x : x ≤ 0 → Z.to_nat x = 0%nat.
+Proof. destruct x; simpl; auto using Z2Nat.inj_neg. by intros []. Qed.
+Lemma Z2Nat_inj_pow (x y : nat) : Z.of_nat (x ^ y) = x ^ y.
+Proof.
+ induction y as [|y IH]; [by rewrite Z.pow_0_r, Nat.pow_0_r|].
+ by rewrite Nat.pow_succ_r, Nat2Z.inj_succ, Z.pow_succ_r,
+ Nat2Z.inj_mul, IH by auto with zpos.
+Qed.
+Lemma Nat2Z_divide n m : (Z.of_nat n | Z.of_nat m) ↔ (n | m)%nat.
+Proof.
+ split.
+ * rewrite <-(Nat2Z.id m) at 2; intros [i ->]; exists (Z.to_nat i).
+ destruct (decide (0 ≤ i)%Z).
+ { by rewrite Z2Nat.inj_mul, Nat2Z.id by lia. }
+ by rewrite !Z_to_nat_nonpos by auto using Z.mul_nonpos_nonneg with lia.
+ * intros [i ->]. exists (Z.of_nat i). by rewrite Nat2Z.inj_mul.
+Qed.
+Lemma Z2Nat_divide n m :
+ 0 ≤ n → 0 ≤ m → (Z.to_nat n | Z.to_nat m)%nat ↔ (n | m).
+Proof. intros. by rewrite <-Nat2Z_divide, !Z2Nat.id by done. Qed.
+Lemma Z2Nat_inj_div x y : Z.of_nat (x `div` y) = x `div` y.
+Proof.
+ destruct (decide (y = 0%nat)); [by subst; destruct x |].
+ apply Z.div_unique with (x `mod` y)%nat.
+ { left. rewrite <-(Nat2Z.inj_le 0), <-Nat2Z.inj_lt.
+ apply Nat.mod_bound_pos; lia. }
+ by rewrite <-Nat2Z.inj_mul, <-Nat2Z.inj_add, <-Nat.div_mod.
+Qed.
+Lemma Z2Nat_inj_mod x y : Z.of_nat (x `mod` y) = x `mod` y.
+Proof.
+ destruct (decide (y = 0%nat)); [by subst; destruct x |].
+ apply Z.mod_unique with (x `div` y)%nat.
+ { left. rewrite <-(Nat2Z.inj_le 0), <-Nat2Z.inj_lt.
+ apply Nat.mod_bound_pos; lia. }
+ by rewrite <-Nat2Z.inj_mul, <-Nat2Z.inj_add, <-Nat.div_mod.
+Qed.
+Close Scope Z_scope.
+
+(** * Notations and properties of [Qc] *)
+Open Scope Qc_scope.
+Delimit Scope Qc_scope with Qc.
+Notation "1" := (Q2Qc 1) : Qc_scope.
+Notation "2" := (1+1) : Qc_scope.
+Notation "- 1" := (Qcopp 1) : Qc_scope.
+Notation "- 2" := (Qcopp 2) : Qc_scope.
+Notation "x - y" := (x + -y) : Qc_scope.
+Notation "x / y" := (x * /y) : Qc_scope.
+Infix "≤" := Qcle : Qc_scope.
+Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) : Qc_scope.
+Notation "x ≤ y < z" := (x ≤ y ∧ y < z) : Qc_scope.
+Notation "x < y < z" := (x < y ∧ y < z) : Qc_scope.
+Notation "x < y ≤ z" := (x < y ∧ y ≤ z) : Qc_scope.
+Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z') : Qc_scope.
+Notation "(≤)" := Qcle (only parsing) : Qc_scope.
+Notation "(<)" := Qclt (only parsing) : Qc_scope.
+
+Hint Extern 1 (_ ≤ _) => reflexivity || discriminate.
+Arguments Qred _ : simpl never.
+
+Instance Qc_eq_dec: ∀ x y : Qc, Decision (x = y) := Qc_eq_dec.
+Program Instance Qc_le_dec (x y : Qc) : Decision (x ≤ y) :=
+ if Qclt_le_dec y x then right _ else left _.
+Next Obligation. intros x y; apply Qclt_not_le. Qed.
+Next Obligation. done. Qed.
+Program Instance Qc_lt_dec (x y : Qc) : Decision (x < y) :=
+ if Qclt_le_dec x y then left _ else right _.
+Solve Obligations with done.
+Next Obligation. intros x y; apply Qcle_not_lt. Qed.
+
+Instance: PartialOrder (≤).
+Proof.
+ repeat split; red. apply Qcle_refl. apply Qcle_trans. apply Qcle_antisym.
+Qed.
+Instance: StrictOrder (<).
+Proof.
+ split; red. intros x Hx. by destruct (Qclt_not_eq x x). apply Qclt_trans.
+Qed.
+Lemma Qcmult_0_l x : 0 * x = 0.
+Proof. ring. Qed.
+Lemma Qcmult_0_r x : x * 0 = 0.
+Proof. ring. Qed.
+Lemma Qcle_ngt (x y : Qc) : x ≤ y ↔ ¬y < x.
+Proof. split; auto using Qcle_not_lt, Qcnot_lt_le. Qed.
+Lemma Qclt_nge (x y : Qc) : x < y ↔ ¬y ≤ x.
+Proof. split; auto using Qclt_not_le, Qcnot_le_lt. Qed.
+Lemma Qcplus_le_mono_l (x y z : Qc) : x ≤ y ↔ z + x ≤ z + y.
+Proof.
+ split; intros.
+ * by apply Qcplus_le_compat.
+ * replace x with ((0 - z) + (z + x)) by ring.
+ replace y with ((0 - z) + (z + y)) by ring.
+ by apply Qcplus_le_compat.
+Qed.
+Lemma Qcplus_le_mono_r (x y z : Qc) : x ≤ y ↔ x + z ≤ y + z.
+Proof. rewrite !(Qcplus_comm _ z). apply Qcplus_le_mono_l. Qed.
+Lemma Qcplus_lt_mono_l (x y z : Qc) : x < y ↔ z + x < z + y.
+Proof. by rewrite !Qclt_nge, <-Qcplus_le_mono_l. Qed.
+Lemma Qcplus_lt_mono_r (x y z : Qc) : x < y ↔ x + z < y + z.
+Proof. by rewrite !Qclt_nge, <-Qcplus_le_mono_r. Qed.
+Instance: Injective (=) (=) Qcopp.
+Proof.
+ intros x y H. by rewrite <-(Qcopp_involutive x), H, Qcopp_involutive.
+Qed.
+Instance: ∀ z, Injective (=) (=) (Qcplus z).
+Proof.
+ intros z x y H. by apply (anti_symmetric (≤));
+ rewrite (Qcplus_le_mono_l _ _ z), H.
+Qed.
+Instance: ∀ z, Injective (=) (=) (λ x, x + z).
+Proof.
+ intros z x y H. by apply (anti_symmetric (≤));
+ rewrite (Qcplus_le_mono_r _ _ z), H.
+Qed.
+Lemma Qcplus_pos_nonneg (x y : Qc) : 0 < x → 0 ≤ y → 0 < x + y.
+Proof.
+ intros. apply Qclt_le_trans with (x + 0); [by rewrite Qcplus_0_r|].
+ by apply Qcplus_le_mono_l.
+Qed.
+Lemma Qcplus_nonneg_pos (x y : Qc) : 0 ≤ x → 0 < y → 0 < x + y.
+Proof. rewrite (Qcplus_comm x). auto using Qcplus_pos_nonneg. Qed.
+Lemma Qcplus_pos_pos (x y : Qc) : 0 < x → 0 < y → 0 < x + y.
+Proof. auto using Qcplus_pos_nonneg, Qclt_le_weak. Qed.
+Lemma Qcplus_nonneg_nonneg (x y : Qc) : 0 ≤ x → 0 ≤ y → 0 ≤ x + y.
+Proof.
+ intros. transitivity (x + 0); [by rewrite Qcplus_0_r|].
+ by apply Qcplus_le_mono_l.
+Qed.
+Lemma Qcplus_neg_nonpos (x y : Qc) : x < 0 → y ≤ 0 → x + y < 0.
+Proof.
+ intros. apply Qcle_lt_trans with (x + 0); [|by rewrite Qcplus_0_r].
+ by apply Qcplus_le_mono_l.
+Qed.
+Lemma Qcplus_nonpos_neg (x y : Qc) : x ≤ 0 → y < 0 → x + y < 0.
+Proof. rewrite (Qcplus_comm x). auto using Qcplus_neg_nonpos. Qed.
+Lemma Qcplus_neg_neg (x y : Qc) : x < 0 → y < 0 → x + y < 0.
+Proof. auto using Qcplus_nonpos_neg, Qclt_le_weak. Qed.
+Lemma Qcplus_nonpos_nonpos (x y : Qc) : x ≤ 0 → y ≤ 0 → x + y ≤ 0.
+Proof.
+ intros. transitivity (x + 0); [|by rewrite Qcplus_0_r].
+ by apply Qcplus_le_mono_l.
+Qed.
+Lemma Qcmult_le_mono_nonneg_l x y z : 0 ≤ z → x ≤ y → z * x ≤ z * y.
+Proof. intros. rewrite !(Qcmult_comm z). by apply Qcmult_le_compat_r. Qed.
+Lemma Qcmult_le_mono_nonneg_r x y z : 0 ≤ z → x ≤ y → x * z ≤ y * z.
+Proof. intros. by apply Qcmult_le_compat_r. Qed.
+Lemma Qcmult_le_mono_pos_l x y z : 0 < z → x ≤ y ↔ z * x ≤ z * y.
+Proof.
+ split; auto using Qcmult_le_mono_nonneg_l, Qclt_le_weak.
+ rewrite !Qcle_ngt, !(Qcmult_comm z).
+ intuition auto using Qcmult_lt_compat_r.
+Qed.
+Lemma Qcmult_le_mono_pos_r x y z : 0 < z → x ≤ y ↔ x * z ≤ y * z.
+Proof. rewrite !(Qcmult_comm _ z). by apply Qcmult_le_mono_pos_l. Qed.
+Lemma Qcmult_lt_mono_pos_l x y z : 0 < z → x < y ↔ z * x < z * y.
+Proof. intros. by rewrite !Qclt_nge, <-Qcmult_le_mono_pos_l. Qed.
+Lemma Qcmult_lt_mono_pos_r x y z : 0 < z → x < y ↔ x * z < y * z.
+Proof. intros. by rewrite !Qclt_nge, <-Qcmult_le_mono_pos_r. Qed.
+Lemma Qcmult_pos_pos x y : 0 < x → 0 < y → 0 < x * y.
+Proof.
+ intros. apply Qcle_lt_trans with (0 * y); [by rewrite Qcmult_0_l|].
+ by apply Qcmult_lt_mono_pos_r.
+Qed.
+Lemma Qcmult_nonneg_nonneg x y : 0 ≤ x → 0 ≤ y → 0 ≤ x * y.
+Proof.
+ intros. transitivity (0 * y); [by rewrite Qcmult_0_l|].
+ by apply Qcmult_le_mono_nonneg_r.
+Qed.
+
+Lemma inject_Z_Qred n : Qred (inject_Z n) = inject_Z n.
+Proof. apply Qred_identity; auto using Z.gcd_1_r. Qed.
+Coercion Qc_of_Z (n : Z) : Qc := Qcmake _ (inject_Z_Qred n).
+Lemma Z2Qc_inj_0 : Qc_of_Z 0 = 0.
+Proof. by apply Qc_is_canon. Qed.
+Lemma Z2Qc_inj n m : Qc_of_Z n = Qc_of_Z m → n = m.
+Proof. by injection 1. Qed.
+Lemma Z2Qc_inj_iff n m : Qc_of_Z n = Qc_of_Z m ↔ n = m.
+Proof. split. auto using Z2Qc_inj. by intros ->. Qed.
+Lemma Z2Qc_inj_le n m : (n ≤ m)%Z ↔ Qc_of_Z n ≤ Qc_of_Z m.
+Proof. by rewrite Zle_Qle. Qed.
+Lemma Z2Qc_inj_lt n m : (n < m)%Z ↔ Qc_of_Z n < Qc_of_Z m.
+Proof. by rewrite Zlt_Qlt. Qed.
+Lemma Z2Qc_inj_add n m : Qc_of_Z (n + m) = Qc_of_Z n + Qc_of_Z m.
+Proof. apply Qc_is_canon; simpl. by rewrite Qred_correct, inject_Z_plus. Qed.
+Lemma Z2Qc_inj_mul n m : Qc_of_Z (n * m) = Qc_of_Z n * Qc_of_Z m.
+Proof. apply Qc_is_canon; simpl. by rewrite Qred_correct, inject_Z_mult. Qed.
+Lemma Z2Qc_inj_opp n : Qc_of_Z (-n) = -Qc_of_Z n.
+Proof. apply Qc_is_canon; simpl. by rewrite Qred_correct, inject_Z_opp. Qed.
+Lemma Z2Qc_inj_sub n m : Qc_of_Z (n - m) = Qc_of_Z n - Qc_of_Z m.
+Proof.
+ apply Qc_is_canon; simpl.
+ by rewrite !Qred_correct, <-inject_Z_opp, <-inject_Z_plus.
+Qed.
+Close Scope Qc_scope.
diff --git a/prelude/option.v b/prelude/option.v
new file mode 100644
index 0000000000000000000000000000000000000000..bf66ba9724d9c55d0c3c949e22c15615ee76b6af
--- /dev/null
+++ b/prelude/option.v
@@ -0,0 +1,346 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects general purpose definitions and theorems on the option
+data type that are not in the Coq standard library. *)
+Require Export prelude.base prelude.tactics prelude.decidable.
+
+Inductive option_reflect {A} (P : A → Prop) (Q : Prop) : option A → Type :=
+ | ReflectSome x : P x → option_reflect P Q (Some x)
+ | ReflectNone : Q → option_reflect P Q None.
+
+(** * General definitions and theorems *)
+(** Basic properties about equality. *)
+Lemma None_ne_Some {A} (a : A) : None ≠Some a.
+Proof. congruence. Qed.
+Lemma Some_ne_None {A} (a : A) : Some a ≠None.
+Proof. congruence. Qed.
+Lemma eq_None_ne_Some {A} (x : option A) a : x = None → x ≠Some a.
+Proof. congruence. Qed.
+Instance Some_inj {A} : Injective (=) (=) (@Some A).
+Proof. congruence. Qed.
+
+(** The non dependent elimination principle on the option type. *)
+Definition default {A B} (b : B) (x : option A) (f : A → B) : B :=
+ match x with None => b | Some a => f a end.
+
+(** The [from_option] function allows us to get the value out of the option
+type by specifying a default value. *)
+Definition from_option {A} (a : A) (x : option A) : A :=
+ match x with None => a | Some b => b end.
+
+(** An alternative, but equivalent, definition of equality on the option
+data type. This theorem is useful to prove that two options are the same. *)
+Lemma option_eq {A} (x y : option A) : x = y ↔ ∀ a, x = Some a ↔ y = Some a.
+Proof. split; [by intros; by subst |]. destruct x, y; naive_solver. Qed.
+Lemma option_eq_1 {A} (x y : option A) a : x = y → x = Some a → y = Some a.
+Proof. congruence. Qed.
+Lemma option_eq_1_alt {A} (x y : option A) a : x = y → y = Some a → x = Some a.
+Proof. congruence. Qed.
+
+Definition is_Some {A} (x : option A) := ∃ y, x = Some y.
+Lemma mk_is_Some {A} (x : option A) y : x = Some y → is_Some x.
+Proof. intros; red; subst; eauto. Qed.
+Hint Resolve mk_is_Some.
+Lemma is_Some_None {A} : ¬is_Some (@None A).
+Proof. by destruct 1. Qed.
+Hint Resolve is_Some_None.
+
+Instance is_Some_pi {A} (x : option A) : ProofIrrel (is_Some x).
+Proof.
+ set (P (y : option A) := match y with Some _ => True | _ => False end).
+ set (f x := match x return P x → is_Some x with
+ Some _ => λ _, ex_intro _ _ eq_refl | None => False_rect _ end).
+ set (g x (H : is_Some x) :=
+ match H return P x with ex_intro _ p => eq_rect _ _ I _ (eq_sym p) end).
+ assert (∀ x H, f x (g x H) = H) as f_g by (by intros ? [??]; subst).
+ intros p1 p2. rewrite <-(f_g _ p1), <-(f_g _ p2). by destruct x, p1.
+Qed.
+Instance is_Some_dec {A} (x : option A) : Decision (is_Some x) :=
+ match x with
+ | Some x => left (ex_intro _ x eq_refl)
+ | None => right is_Some_None
+ end.
+
+Definition is_Some_proj {A} {x : option A} : is_Some x → A :=
+ match x with Some a => λ _, a | None => False_rect _ ∘ is_Some_None end.
+Definition Some_dec {A} (x : option A) : { a | x = Some a } + { x = None } :=
+ match x return { a | x = Some a } + { x = None } with
+ | Some a => inleft (a ↾ eq_refl _)
+ | None => inright eq_refl
+ end.
+
+Lemma eq_None_not_Some {A} (x : option A) : x = None ↔ ¬is_Some x.
+Proof. destruct x; unfold is_Some; naive_solver. Qed.
+Lemma not_eq_None_Some `(x : option A) : x ≠None ↔ is_Some x.
+Proof. rewrite eq_None_not_Some. split. apply dec_stable. tauto. Qed.
+
+(** Lifting a relation point-wise to option *)
+Inductive option_Forall2 {A B} (P: A → B → Prop) : option A → option B → Prop :=
+ | Some_Forall2 x y : P x y → option_Forall2 P (Some x) (Some y)
+ | None_Forall2 : option_Forall2 P None None.
+Definition option_relation {A B} (R: A → B → Prop) (P: A → Prop) (Q: B → Prop)
+ (mx : option A) (my : option B) : Prop :=
+ match mx, my with
+ | Some x, Some y => R x y
+ | Some x, None => P x
+ | None, Some y => Q y
+ | None, None => True
+ end.
+
+(** Setoids *)
+Section setoids.
+ Context `{Equiv A} `{!Equivalence ((≡) : relation A)}.
+ Global Instance option_equiv : Equiv (option A) := option_Forall2 (≡).
+ Global Instance option_equivalence : Equivalence ((≡) : relation (option A)).
+ Proof.
+ split.
+ * by intros []; constructor.
+ * by destruct 1; constructor.
+ * destruct 1; inversion 1; constructor; etransitivity; eauto.
+ Qed.
+ Global Instance Some_proper : Proper ((≡) ==> (≡)) (@Some A).
+ Proof. by constructor. Qed.
+ Global Instance option_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (option A).
+ Proof. intros x y; destruct 1; fold_leibniz; congruence. Qed.
+ Lemma equiv_None (mx : option A) : mx ≡ None ↔ mx = None.
+ Proof. split; [by inversion_clear 1|by intros ->]. Qed.
+ Lemma equiv_Some (mx my : option A) x :
+ mx ≡ my → mx = Some x → ∃ y, my = Some y ∧ x ≡ y.
+ Proof. destruct 1; naive_solver. Qed.
+ Global Instance is_Some_proper : Proper ((≡) ==> iff) (@is_Some A).
+ Proof. inversion_clear 1; split; eauto. Qed.
+End setoids.
+
+(** Equality on [option] is decidable. *)
+Instance option_eq_None_dec {A} (x : option A) : Decision (x = None) :=
+ match x with Some _ => right (Some_ne_None _) | None => left eq_refl end.
+Instance option_None_eq_dec {A} (x : option A) : Decision (None = x) :=
+ match x with Some _ => right (None_ne_Some _) | None => left eq_refl end.
+Instance option_eq_dec `{dec : ∀ x y : A, Decision (x = y)}
+ (x y : option A) : Decision (x = y).
+Proof.
+ refine
+ match x, y with
+ | Some a, Some b => cast_if (decide (a = b))
+ | None, None => left _ | _, _ => right _
+ end; clear dec; abstract congruence.
+Defined.
+
+(** * Monadic operations *)
+Instance option_ret: MRet option := @Some.
+Instance option_bind: MBind option := λ A B f x,
+ match x with Some a => f a | None => None end.
+Instance option_join: MJoin option := λ A x,
+ match x with Some x => x | None => None end.
+Instance option_fmap: FMap option := @option_map.
+Instance option_guard: MGuard option := λ P dec A x,
+ match dec with left H => x H | _ => None end.
+
+Lemma fmap_is_Some {A B} (f : A → B) x : is_Some (f <$> x) ↔ is_Some x.
+Proof. unfold is_Some; destruct x; naive_solver. Qed.
+Lemma fmap_Some {A B} (f : A → B) x y :
+ f <$> x = Some y ↔ ∃ x', x = Some x' ∧ y = f x'.
+Proof. destruct x; naive_solver. Qed.
+Lemma fmap_None {A B} (f : A → B) x : f <$> x = None ↔ x = None.
+Proof. by destruct x. Qed.
+Lemma option_fmap_id {A} (x : option A) : id <$> x = x.
+Proof. by destruct x. Qed.
+Lemma option_fmap_compose {A B} (f : A → B) {C} (g : B → C) x :
+ g ∘ f <$> x = g <$> f <$> x.
+Proof. by destruct x. Qed.
+Lemma option_fmap_bind {A B C} (f : A → B) (g : B → option C) x :
+ (f <$> x) ≫= g = x ≫= g ∘ f.
+Proof. by destruct x. Qed.
+Lemma option_bind_assoc {A B C} (f : A → option B)
+ (g : B → option C) (x : option A) : (x ≫= f) ≫= g = x ≫= (mbind g ∘ f).
+Proof. by destruct x; simpl. Qed.
+Lemma option_bind_ext {A B} (f g : A → option B) x y :
+ (∀ a, f a = g a) → x = y → x ≫= f = y ≫= g.
+Proof. intros. destruct x, y; simplify_equality; csimpl; auto. Qed.
+Lemma option_bind_ext_fun {A B} (f g : A → option B) x :
+ (∀ a, f a = g a) → x ≫= f = x ≫= g.
+Proof. intros. by apply option_bind_ext. Qed.
+Lemma bind_Some {A B} (f : A → option B) (x : option A) b :
+ x ≫= f = Some b ↔ ∃ a, x = Some a ∧ f a = Some b.
+Proof. split. by destruct x as [a|]; [exists a|]. by intros (?&->&?). Qed.
+Lemma bind_None {A B} (f : A → option B) (x : option A) :
+ x ≫= f = None ↔ x = None ∨ ∃ a, x = Some a ∧ f a = None.
+Proof.
+ split; [|by intros [->|(?&->&?)]].
+ destruct x; intros; simplify_equality'; eauto.
+Qed.
+Lemma bind_with_Some {A} (x : option A) : x ≫= Some = x.
+Proof. by destruct x. Qed.
+
+(** ** Inverses of constructors *)
+(** We can do this in a fancy way using dependent types, but rewrite does
+not particularly like type level reductions. *)
+Class Maybe {A B : Type} (c : A → B) :=
+ maybe : B → option A.
+Arguments maybe {_ _} _ {_} !_ /.
+Class Maybe2 {A1 A2 B : Type} (c : A1 → A2 → B) :=
+ maybe2 : B → option (A1 * A2).
+Arguments maybe2 {_ _ _} _ {_} !_ /.
+Class Maybe3 {A1 A2 A3 B : Type} (c : A1 → A2 → A3 → B) :=
+ maybe3 : B → option (A1 * A2 * A3).
+Arguments maybe3 {_ _ _ _} _ {_} !_ /.
+Class Maybe4 {A1 A2 A3 A4 B : Type} (c : A1 → A2 → A3 → A4 → B) :=
+ maybe4 : B → option (A1 * A2 * A3 * A4).
+Arguments maybe4 {_ _ _ _ _} _ {_} !_ /.
+
+Instance maybe_comp `{Maybe B C c1, Maybe A B c2} : Maybe (c1 ∘ c2) := λ x,
+ maybe c1 x ≫= maybe c2.
+Arguments maybe_comp _ _ _ _ _ _ _ !_ /.
+
+Instance maybe_inl {A B} : Maybe (@inl A B) := λ xy,
+ match xy with inl x => Some x | _ => None end.
+Instance maybe_inr {A B} : Maybe (@inr A B) := λ xy,
+ match xy with inr y => Some y | _ => None end.
+Instance maybe_Some {A} : Maybe (@Some A) := id.
+Arguments maybe_Some _ !_ /.
+
+(** * Union, intersection and difference *)
+Instance option_union_with {A} : UnionWith A (option A) := λ f x y,
+ match x, y with
+ | Some a, Some b => f a b
+ | Some a, None => Some a
+ | None, Some b => Some b
+ | None, None => None
+ end.
+Instance option_intersection_with {A} : IntersectionWith A (option A) :=
+ λ f x y, match x, y with Some a, Some b => f a b | _, _ => None end.
+Instance option_difference_with {A} : DifferenceWith A (option A) := λ f x y,
+ match x, y with
+ | Some a, Some b => f a b
+ | Some a, None => Some a
+ | None, _ => None
+ end.
+Instance option_union {A} : Union (option A) := union_with (λ x _, Some x).
+Lemma option_union_Some {A} (x y : option A) z :
+ x ∪ y = Some z → x = Some z ∨ y = Some z.
+Proof. destruct x, y; intros; simplify_equality; auto. Qed.
+
+Section option_union_intersection_difference.
+ Context {A} (f : A → A → option A).
+ Global Instance: LeftId (=) None (union_with f).
+ Proof. by intros [?|]. Qed.
+ Global Instance: RightId (=) None (union_with f).
+ Proof. by intros [?|]. Qed.
+ Global Instance: Commutative (=) f → Commutative (=) (union_with f).
+ Proof. by intros ? [?|] [?|]; compute; rewrite 1?(commutative f). Qed.
+ Global Instance: LeftAbsorb (=) None (intersection_with f).
+ Proof. by intros [?|]. Qed.
+ Global Instance: RightAbsorb (=) None (intersection_with f).
+ Proof. by intros [?|]. Qed.
+ Global Instance: Commutative (=) f → Commutative (=) (intersection_with f).
+ Proof. by intros ? [?|] [?|]; compute; rewrite 1?(commutative f). Qed.
+ Global Instance: RightId (=) None (difference_with f).
+ Proof. by intros [?|]. Qed.
+End option_union_intersection_difference.
+
+(** * Tactics *)
+Tactic Notation "case_option_guard" "as" ident(Hx) :=
+ match goal with
+ | H : appcontext C [@mguard option _ ?P ?dec] |- _ =>
+ change (@mguard option _ P dec) with (λ A (x : P → option A),
+ match @decide P dec with left H' => x H' | _ => None end) in *;
+ destruct_decide (@decide P dec) as Hx
+ | |- appcontext C [@mguard option _ ?P ?dec] =>
+ change (@mguard option _ P dec) with (λ A (x : P → option A),
+ match @decide P dec with left H' => x H' | _ => None end) in *;
+ destruct_decide (@decide P dec) as Hx
+ end.
+Tactic Notation "case_option_guard" :=
+ let H := fresh in case_option_guard as H.
+
+Lemma option_guard_True {A} P `{Decision P} (x : option A) :
+ P → guard P; x = x.
+Proof. intros. by case_option_guard. Qed.
+Lemma option_guard_False {A} P `{Decision P} (x : option A) :
+ ¬P → guard P; x = None.
+Proof. intros. by case_option_guard. Qed.
+Lemma option_guard_iff {A} P Q `{Decision P, Decision Q} (x : option A) :
+ (P ↔ Q) → guard P; x = guard Q; x.
+Proof. intros [??]. repeat case_option_guard; intuition. Qed.
+
+Tactic Notation "simpl_option" "by" tactic3(tac) :=
+ let assert_Some_None A o H := first
+ [ let x := fresh in evar (x:A); let x' := eval unfold x in x in clear x;
+ assert (o = Some x') as H by tac
+ | assert (o = None) as H by tac ]
+ in repeat match goal with
+ | H : appcontext [@mret _ _ ?A] |- _ =>
+ change (@mret _ _ A) with (@Some A) in H
+ | |- appcontext [@mret _ _ ?A] => change (@mret _ _ A) with (@Some A)
+ | H : context [mbind (M:=option) (A:=?A) ?f ?o] |- _ =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx in H; clear Hx
+ | H : context [fmap (M:=option) (A:=?A) ?f ?o] |- _ =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx in H; clear Hx
+ | H : context [default (A:=?A) _ ?o _] |- _ =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx in H; clear Hx
+ | H : context [from_option (A:=?A) _ ?o] |- _ =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx in H; clear Hx
+ | H : context [ match ?o with _ => _ end ] |- _ =>
+ match type of o with
+ | option ?A =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx in H; clear Hx
+ end
+ | |- context [mbind (M:=option) (A:=?A) ?f ?o] =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx; clear Hx
+ | |- context [fmap (M:=option) (A:=?A) ?f ?o] =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx; clear Hx
+ | |- context [default (A:=?A) _ ?o _] =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx; clear Hx
+ | |- context [from_option (A:=?A) _ ?o] =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx; clear Hx
+ | |- context [ match ?o with _ => _ end ] =>
+ match type of o with
+ | option ?A =>
+ let Hx := fresh in assert_Some_None A o Hx; rewrite Hx; clear Hx
+ end
+ | H : context [decide _] |- _ => rewrite decide_True in H by tac
+ | H : context [decide _] |- _ => rewrite decide_False in H by tac
+ | H : context [mguard _ _] |- _ => rewrite option_guard_False in H by tac
+ | H : context [mguard _ _] |- _ => rewrite option_guard_True in H by tac
+ | _ => rewrite decide_True by tac
+ | _ => rewrite decide_False by tac
+ | _ => rewrite option_guard_True by tac
+ | _ => rewrite option_guard_False by tac
+ | H : context [None ∪ _] |- _ => rewrite (left_id_L None (∪)) in H
+ | H : context [_ ∪ None] |- _ => rewrite (right_id_L None (∪)) in H
+ | |- context [None ∪ _] => rewrite (left_id_L None (∪))
+ | |- context [_ ∪ None] => rewrite (right_id_L None (∪))
+ end.
+Tactic Notation "simplify_option_equality" "by" tactic3(tac) :=
+ repeat match goal with
+ | _ => progress simplify_equality'
+ | _ => progress simpl_option by tac
+ | _ : maybe _ ?x = Some _ |- _ => is_var x; destruct x
+ | _ : maybe2 _ ?x = Some _ |- _ => is_var x; destruct x
+ | _ : maybe3 _ ?x = Some _ |- _ => is_var x; destruct x
+ | _ : maybe4 _ ?x = Some _ |- _ => is_var x; destruct x
+ | H : _ ∪ _ = Some _ |- _ => apply option_union_Some in H; destruct H
+ | H : mbind (M:=option) ?f ?o = ?x |- _ =>
+ match o with Some _ => fail 1 | None => fail 1 | _ => idtac end;
+ match x with Some _ => idtac | None => idtac | _ => fail 1 end;
+ let y := fresh in destruct o as [y|] eqn:?;
+ [change (f y = x) in H|change (None = x) in H]
+ | H : ?x = mbind (M:=option) ?f ?o |- _ =>
+ match o with Some _ => fail 1 | None => fail 1 | _ => idtac end;
+ match x with Some _ => idtac | None => idtac | _ => fail 1 end;
+ let y := fresh in destruct o as [y|] eqn:?;
+ [change (x = f y) in H|change (x = None) in H]
+ | H : fmap (M:=option) ?f ?o = ?x |- _ =>
+ match o with Some _ => fail 1 | None => fail 1 | _ => idtac end;
+ match x with Some _ => idtac | None => idtac | _ => fail 1 end;
+ let y := fresh in destruct o as [y|] eqn:?;
+ [change (Some (f y) = x) in H|change (None = x) in H]
+ | H : ?x = fmap (M:=option) ?f ?o |- _ =>
+ match o with Some _ => fail 1 | None => fail 1 | _ => idtac end;
+ match x with Some _ => idtac | None => idtac | _ => fail 1 end;
+ let y := fresh in destruct o as [y|] eqn:?;
+ [change (x = Some (f y)) in H|change (x = None) in H]
+ | _ => progress case_decide
+ | _ => progress case_option_guard
+ end.
+Tactic Notation "simplify_option_equality" := simplify_option_equality by eauto.
diff --git a/prelude/orders.v b/prelude/orders.v
new file mode 100644
index 0000000000000000000000000000000000000000..0dd57462b40c49e54521da8409918aac0cab8397
--- /dev/null
+++ b/prelude/orders.v
@@ -0,0 +1,602 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects common properties of pre-orders and semi lattices. This
+theory will mainly be used for the theory on collections and finite maps. *)
+Require Export Sorted.
+Require Export prelude.base prelude.decidable prelude.tactics prelude.list.
+
+(** * Arbitrary pre-, parial and total orders *)
+(** Properties about arbitrary pre-, partial, and total orders. We do not use
+the relation [⊆] because we often have multiple orders on the same structure *)
+Section orders.
+ Context {A} {R : relation A}.
+ Implicit Types X Y : A.
+ Infix "⊆" := R.
+ Notation "X ⊈ Y" := (¬X ⊆ Y).
+ Infix "⊂" := (strict R).
+
+ Lemma reflexive_eq `{!Reflexive R} X Y : X = Y → X ⊆ Y.
+ Proof. by intros <-. Qed.
+ Lemma anti_symmetric_iff `{!PartialOrder R} X Y : X = Y ↔ R X Y ∧ R Y X.
+ Proof. split. by intros ->. by intros [??]; apply (anti_symmetric _). Qed.
+ Lemma strict_spec X Y : X ⊂ Y ↔ X ⊆ Y ∧ Y ⊈ X.
+ Proof. done. Qed.
+ Lemma strict_include X Y : X ⊂ Y → X ⊆ Y.
+ Proof. by intros [? _]. Qed.
+ Lemma strict_ne X Y : X ⊂ Y → X ≠Y.
+ Proof. by intros [??] <-. Qed.
+ Lemma strict_ne_sym X Y : X ⊂ Y → Y ≠X.
+ Proof. by intros [??] <-. Qed.
+ Lemma strict_transitive_l `{!Transitive R} X Y Z : X ⊂ Y → Y ⊆ Z → X ⊂ Z.
+ Proof.
+ intros [? HXY] ?. split; [by transitivity Y|].
+ contradict HXY. by transitivity Z.
+ Qed.
+ Lemma strict_transitive_r `{!Transitive R} X Y Z : X ⊆ Y → Y ⊂ Z → X ⊂ Z.
+ Proof.
+ intros ? [? HYZ]. split; [by transitivity Y|].
+ contradict HYZ. by transitivity X.
+ Qed.
+ Global Instance: Irreflexive (strict R).
+ Proof. firstorder. Qed.
+ Global Instance: Transitive R → StrictOrder (strict R).
+ Proof.
+ split; try apply _.
+ eauto using strict_transitive_r, strict_include.
+ Qed.
+ Global Instance preorder_subset_dec_slow `{∀ X Y, Decision (X ⊆ Y)}
+ (X Y : A) : Decision (X ⊂ Y) | 100 := _.
+ Lemma strict_spec_alt `{!AntiSymmetric (=) R} X Y : X ⊂ Y ↔ X ⊆ Y ∧ X ≠Y.
+ Proof.
+ split.
+ * intros [? HYX]. split. done. by intros <-.
+ * intros [? HXY]. split. done. by contradict HXY; apply (anti_symmetric R).
+ Qed.
+ Lemma po_eq_dec `{!PartialOrder R, ∀ X Y, Decision (X ⊆ Y)} (X Y : A) :
+ Decision (X = Y).
+ Proof.
+ refine (cast_if_and (decide (X ⊆ Y)) (decide (Y ⊆ X)));
+ abstract (rewrite anti_symmetric_iff; tauto).
+ Defined.
+ Lemma total_not `{!Total R} X Y : X ⊈ Y → Y ⊆ X.
+ Proof. intros. destruct (total R X Y); tauto. Qed.
+ Lemma total_not_strict `{!Total R} X Y : X ⊈ Y → Y ⊂ X.
+ Proof. red; auto using total_not. Qed.
+ Global Instance trichotomy_total
+ `{!Trichotomy (strict R), !Reflexive R} : Total R.
+ Proof.
+ intros X Y.
+ destruct (trichotomy (strict R) X Y) as [[??]|[<-|[??]]]; intuition.
+ Qed.
+End orders.
+
+Section strict_orders.
+ Context {A} {R : relation A}.
+ Implicit Types X Y : A.
+ Infix "⊂" := R.
+
+ Lemma irreflexive_eq `{!Irreflexive R} X Y : X = Y → ¬X ⊂ Y.
+ Proof. intros ->. apply (irreflexivity R). Qed.
+ Lemma strict_anti_symmetric `{!StrictOrder R} X Y :
+ X ⊂ Y → Y ⊂ X → False.
+ Proof. intros. apply (irreflexivity R X). by transitivity Y. Qed.
+ Global Instance trichotomyT_dec `{!TrichotomyT R, !StrictOrder R} X Y :
+ Decision (X ⊂ Y) :=
+ match trichotomyT R X Y with
+ | inleft (left H) => left H
+ | inleft (right H) => right (irreflexive_eq _ _ H)
+ | inright H => right (strict_anti_symmetric _ _ H)
+ end.
+ Global Instance trichotomyT_trichotomy `{!TrichotomyT R} : Trichotomy R.
+ Proof. intros X Y. destruct (trichotomyT R X Y) as [[|]|]; tauto. Qed.
+End strict_orders.
+
+Ltac simplify_order := repeat
+ match goal with
+ | _ => progress simplify_equality
+ | H : ?R ?x ?x |- _ => by destruct (irreflexivity _ _ H)
+ | H1 : ?R ?x ?y |- _ =>
+ match goal with
+ | H2 : R y x |- _ =>
+ assert (x = y) by (by apply (anti_symmetric R)); clear H1 H2
+ | H2 : R y ?z |- _ =>
+ unless (R x z) by done;
+ assert (R x z) by (by transitivity y)
+ end
+ end.
+
+(** * Sorting *)
+(** Merge sort. Adapted from the implementation of Hugo Herbelin in the Coq
+standard library, but without using the module system. *)
+Section merge_sort.
+ Context {A} (R : relation A) `{∀ x y, Decision (R x y)}.
+
+ Fixpoint list_merge (l1 : list A) : list A → list A :=
+ fix list_merge_aux l2 :=
+ match l1, l2 with
+ | [], _ => l2
+ | _, [] => l1
+ | x1 :: l1, x2 :: l2 =>
+ if decide_rel R x1 x2 then x1 :: list_merge l1 (x2 :: l2)
+ else x2 :: list_merge_aux l2
+ end.
+ Global Arguments list_merge !_ !_ /.
+
+ Local Notation stack := (list (option (list A))).
+ Fixpoint merge_list_to_stack (st : stack) (l : list A) : stack :=
+ match st with
+ | [] => [Some l]
+ | None :: st => Some l :: st
+ | Some l' :: st => None :: merge_list_to_stack st (list_merge l' l)
+ end.
+ Fixpoint merge_stack (st : stack) : list A :=
+ match st with
+ | [] => []
+ | None :: st => merge_stack st
+ | Some l :: st => list_merge l (merge_stack st)
+ end.
+ Fixpoint merge_sort_aux (st : stack) (l : list A) : list A :=
+ match l with
+ | [] => merge_stack st
+ | x :: l => merge_sort_aux (merge_list_to_stack st [x]) l
+ end.
+ Definition merge_sort : list A → list A := merge_sort_aux [].
+End merge_sort.
+
+(** ** Properties of the [Sorted] and [StronglySorted] predicate *)
+Section sorted.
+ Context {A} (R : relation A).
+
+ Lemma Sorted_StronglySorted `{!Transitive R} l :
+ Sorted R l → StronglySorted R l.
+ Proof. by apply Sorted.Sorted_StronglySorted. Qed.
+ Lemma StronglySorted_unique `{!AntiSymmetric (=) R} l1 l2 :
+ StronglySorted R l1 → StronglySorted R l2 → l1 ≡ₚ l2 → l1 = l2.
+ Proof.
+ intros Hl1; revert l2. induction Hl1 as [|x1 l1 ? IH Hx1]; intros l2 Hl2 E.
+ { symmetry. by apply Permutation_nil. }
+ destruct Hl2 as [|x2 l2 ? Hx2].
+ { by apply Permutation_nil in E. }
+ assert (x1 = x2); subst.
+ { rewrite Forall_forall in Hx1, Hx2.
+ assert (x2 ∈ x1 :: l1) as Hx2' by (by rewrite E; left).
+ assert (x1 ∈ x2 :: l2) as Hx1' by (by rewrite <-E; left).
+ inversion Hx1'; inversion Hx2'; simplify_equality; auto. }
+ f_equal. by apply IH, (injective (x2 ::)).
+ Qed.
+ Lemma Sorted_unique `{!Transitive R, !AntiSymmetric (=) R} l1 l2 :
+ Sorted R l1 → Sorted R l2 → l1 ≡ₚ l2 → l1 = l2.
+ Proof. auto using StronglySorted_unique, Sorted_StronglySorted. Qed.
+
+ Global Instance HdRel_dec x `{∀ y, Decision (R x y)} l :
+ Decision (HdRel R x l).
+ Proof.
+ refine
+ match l with
+ | [] => left _
+ | y :: l => cast_if (decide (R x y))
+ end; abstract first [by constructor | by inversion 1].
+ Defined.
+ Global Instance Sorted_dec `{∀ x y, Decision (R x y)} : ∀ l,
+ Decision (Sorted R l).
+ Proof.
+ refine
+ (fix go l :=
+ match l return Decision (Sorted R l) with
+ | [] => left _
+ | x :: l => cast_if_and (decide (HdRel R x l)) (go l)
+ end); clear go; abstract first [by constructor | by inversion 1].
+ Defined.
+ Global Instance StronglySorted_dec `{∀ x y, Decision (R x y)} : ∀ l,
+ Decision (StronglySorted R l).
+ Proof.
+ refine
+ (fix go l :=
+ match l return Decision (StronglySorted R l) with
+ | [] => left _
+ | x :: l => cast_if_and (decide (Forall (R x) l)) (go l)
+ end); clear go; abstract first [by constructor | by inversion 1].
+ Defined.
+
+ Context {B} (f : A → B).
+ Lemma HdRel_fmap (R1 : relation A) (R2 : relation B) x l :
+ (∀ y, R1 x y → R2 (f x) (f y)) → HdRel R1 x l → HdRel R2 (f x) (f <$> l).
+ Proof. destruct 2; constructor; auto. Qed.
+ Lemma Sorted_fmap (R1 : relation A) (R2 : relation B) l :
+ (∀ x y, R1 x y → R2 (f x) (f y)) → Sorted R1 l → Sorted R2 (f <$> l).
+ Proof. induction 2; simpl; constructor; eauto using HdRel_fmap. Qed.
+ Lemma StronglySorted_fmap (R1 : relation A) (R2 : relation B) l :
+ (∀ x y, R1 x y → R2 (f x) (f y)) →
+ StronglySorted R1 l → StronglySorted R2 (f <$> l).
+ Proof.
+ induction 2; csimpl; constructor;
+ rewrite ?Forall_fmap; eauto using Forall_impl.
+ Qed.
+End sorted.
+
+(** ** Correctness of merge sort *)
+Section merge_sort_correct.
+ Context {A} (R : relation A) `{∀ x y, Decision (R x y)} `{!Total R}.
+
+ Lemma list_merge_cons x1 x2 l1 l2 :
+ list_merge R (x1 :: l1) (x2 :: l2) =
+ if decide (R x1 x2) then x1 :: list_merge R l1 (x2 :: l2)
+ else x2 :: list_merge R (x1 :: l1) l2.
+ Proof. done. Qed.
+ Lemma HdRel_list_merge x l1 l2 :
+ HdRel R x l1 → HdRel R x l2 → HdRel R x (list_merge R l1 l2).
+ Proof.
+ destruct 1 as [|x1 l1 IH1], 1 as [|x2 l2 IH2];
+ rewrite ?list_merge_cons; simpl; repeat case_decide; auto.
+ Qed.
+ Lemma Sorted_list_merge l1 l2 :
+ Sorted R l1 → Sorted R l2 → Sorted R (list_merge R l1 l2).
+ Proof.
+ intros Hl1. revert l2. induction Hl1 as [|x1 l1 IH1];
+ induction 1 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl;
+ repeat case_decide;
+ constructor; eauto using HdRel_list_merge, HdRel_cons, total_not.
+ Qed.
+ Lemma merge_Permutation l1 l2 : list_merge R l1 l2 ≡ₚ l1 ++ l2.
+ Proof.
+ revert l2. induction l1 as [|x1 l1 IH1]; intros l2;
+ induction l2 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl;
+ repeat case_decide; auto.
+ * by rewrite (right_id_L [] (++)).
+ * by rewrite IH2, Permutation_middle.
+ Qed.
+
+ Local Notation stack := (list (option (list A))).
+ Inductive merge_stack_Sorted : stack → Prop :=
+ | merge_stack_Sorted_nil : merge_stack_Sorted []
+ | merge_stack_Sorted_cons_None st :
+ merge_stack_Sorted st → merge_stack_Sorted (None :: st)
+ | merge_stack_Sorted_cons_Some l st :
+ Sorted R l → merge_stack_Sorted st → merge_stack_Sorted (Some l :: st).
+ Fixpoint merge_stack_flatten (st : stack) : list A :=
+ match st with
+ | [] => []
+ | None :: st => merge_stack_flatten st
+ | Some l :: st => l ++ merge_stack_flatten st
+ end.
+
+ Lemma Sorted_merge_list_to_stack st l :
+ merge_stack_Sorted st → Sorted R l →
+ merge_stack_Sorted (merge_list_to_stack R st l).
+ Proof.
+ intros Hst. revert l.
+ induction Hst; repeat constructor; naive_solver auto using Sorted_list_merge.
+ Qed.
+ Lemma merge_list_to_stack_Permutation st l :
+ merge_stack_flatten (merge_list_to_stack R st l) ≡ₚ
+ l ++ merge_stack_flatten st.
+ Proof.
+ revert l. induction st as [|[l'|] st IH]; intros l; simpl; auto.
+ by rewrite IH, merge_Permutation, (associative_L _), (commutative (++) l).
+ Qed.
+ Lemma Sorted_merge_stack st :
+ merge_stack_Sorted st → Sorted R (merge_stack R st).
+ Proof. induction 1; simpl; auto using Sorted_list_merge. Qed.
+ Lemma merge_stack_Permutation st : merge_stack R st ≡ₚ merge_stack_flatten st.
+ Proof.
+ induction st as [|[] ? IH]; intros; simpl; auto.
+ by rewrite merge_Permutation, IH.
+ Qed.
+ Lemma Sorted_merge_sort_aux st l :
+ merge_stack_Sorted st → Sorted R (merge_sort_aux R st l).
+ Proof.
+ revert st. induction l; simpl;
+ auto using Sorted_merge_stack, Sorted_merge_list_to_stack.
+ Qed.
+ Lemma merge_sort_aux_Permutation st l :
+ merge_sort_aux R st l ≡ₚ merge_stack_flatten st ++ l.
+ Proof.
+ revert st. induction l as [|?? IH]; simpl; intros.
+ * by rewrite (right_id_L [] (++)), merge_stack_Permutation.
+ * rewrite IH, merge_list_to_stack_Permutation; simpl.
+ by rewrite Permutation_middle.
+ Qed.
+ Lemma Sorted_merge_sort l : Sorted R (merge_sort R l).
+ Proof. apply Sorted_merge_sort_aux. by constructor. Qed.
+ Lemma merge_sort_Permutation l : merge_sort R l ≡ₚ l.
+ Proof. unfold merge_sort. by rewrite merge_sort_aux_Permutation. Qed.
+ Lemma StronglySorted_merge_sort `{!Transitive R} l :
+ StronglySorted R (merge_sort R l).
+ Proof. auto using Sorted_StronglySorted, Sorted_merge_sort. Qed.
+End merge_sort_correct.
+
+(** * Canonical pre and partial orders *)
+(** We extend the canonical pre-order [⊆] to a partial order by defining setoid
+equality as [λ X Y, X ⊆ Y ∧ Y ⊆ X]. We prove that this indeed gives rise to a
+setoid. *)
+Instance preorder_equiv `{SubsetEq A} : Equiv A | 20 := λ X Y, X ⊆ Y ∧ Y ⊆ X.
+
+Section preorder.
+ Context `{SubsetEq A, !PreOrder (@subseteq A _)}.
+
+ Instance preorder_equivalence: @Equivalence A (≡).
+ Proof.
+ split.
+ * done.
+ * by intros ?? [??].
+ * by intros X Y Z [??] [??]; split; transitivity Y.
+ Qed.
+ Global Instance: Proper ((≡) ==> (≡) ==> iff) ((⊆) : relation A).
+ Proof.
+ unfold equiv, preorder_equiv. intros X1 Y1 ? X2 Y2 ?. split; intro.
+ * transitivity X1. tauto. transitivity X2; tauto.
+ * transitivity Y1. tauto. transitivity Y2; tauto.
+ Qed.
+ Lemma subset_spec (X Y : A) : X ⊂ Y ↔ X ⊆ Y ∧ X ≢ Y.
+ Proof.
+ split.
+ * intros [? HYX]. split. done. contradict HYX. by rewrite <-HYX.
+ * intros [? HXY]. split. done. by contradict HXY.
+ Qed.
+
+ Section dec.
+ Context `{∀ X Y : A, Decision (X ⊆ Y)}.
+ Global Instance preorder_equiv_dec_slow (X Y : A) :
+ Decision (X ≡ Y) | 100 := _.
+ Lemma subseteq_inv X Y : X ⊆ Y → X ⊂ Y ∨ X ≡ Y.
+ Proof. rewrite subset_spec. destruct (decide (X ≡ Y)); tauto. Qed.
+ Lemma not_subset_inv X Y : X ⊄ Y → X ⊈ Y ∨ X ≡ Y.
+ Proof. rewrite subset_spec. destruct (decide (X ≡ Y)); tauto. Qed.
+ End dec.
+
+ Section leibniz.
+ Context `{!LeibnizEquiv A}.
+ Lemma subset_spec_L X Y : X ⊂ Y ↔ X ⊆ Y ∧ X ≠Y.
+ Proof. unfold_leibniz. apply subset_spec. Qed.
+ Context `{∀ X Y : A, Decision (X ⊆ Y)}.
+ Lemma subseteq_inv_L X Y : X ⊆ Y → X ⊂ Y ∨ X = Y.
+ Proof. unfold_leibniz. apply subseteq_inv. Qed.
+ Lemma not_subset_inv_L X Y : X ⊄ Y → X ⊈ Y ∨ X = Y.
+ Proof. unfold_leibniz. apply not_subset_inv. Qed.
+ End leibniz.
+End preorder.
+
+Typeclasses Opaque preorder_equiv.
+Hint Extern 0 (@Equivalence _ (≡)) =>
+ class_apply preorder_equivalence : typeclass_instances.
+
+(** * Partial orders *)
+Section partial_order.
+ Context `{SubsetEq A, !PartialOrder (@subseteq A _)}.
+ Global Instance: LeibnizEquiv A.
+ Proof. intros ?? [??]; by apply (anti_symmetric (⊆)). Qed.
+End partial_order.
+
+(** * Join semi lattices *)
+(** General purpose theorems on join semi lattices. *)
+Section join_semi_lattice.
+ Context `{Empty A, JoinSemiLattice A, !EmptySpec A}.
+ Implicit Types X Y : A.
+ Implicit Types Xs Ys : list A.
+
+ Hint Resolve subseteq_empty union_subseteq_l union_subseteq_r union_least.
+ Lemma union_subseteq_l_transitive X1 X2 Y : X1 ⊆ X2 → X1 ⊆ X2 ∪ Y.
+ Proof. intros. transitivity X2; auto. Qed.
+ Lemma union_subseteq_r_transitive X1 X2 Y : X1 ⊆ X2 → X1 ⊆ Y ∪ X2.
+ Proof. intros. transitivity X2; auto. Qed.
+ Hint Resolve union_subseteq_l_transitive union_subseteq_r_transitive.
+ Lemma union_preserving_l X Y1 Y2 : Y1 ⊆ Y2 → X ∪ Y1 ⊆ X ∪ Y2.
+ Proof. auto. Qed.
+ Lemma union_preserving_r X1 X2 Y : X1 ⊆ X2 → X1 ∪ Y ⊆ X2 ∪ Y.
+ Proof. auto. Qed.
+ Lemma union_preserving X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∪ Y1 ⊆ X2 ∪ Y2.
+ Proof. auto. Qed.
+ Lemma union_empty X : X ∪ ∅ ⊆ X.
+ Proof. by apply union_least. Qed.
+ Global Instance union_proper : Proper ((≡) ==> (≡) ==> (≡)) (@union A _).
+ Proof.
+ unfold equiv, preorder_equiv.
+ split; apply union_preserving; simpl in *; tauto.
+ Qed.
+ Global Instance: Idempotent ((≡) : relation A) (∪).
+ Proof. split; eauto. Qed.
+ Global Instance: LeftId ((≡) : relation A) ∅ (∪).
+ Proof. split; eauto. Qed.
+ Global Instance: RightId ((≡) : relation A) ∅ (∪).
+ Proof. split; eauto. Qed.
+ Global Instance: Commutative ((≡) : relation A) (∪).
+ Proof. split; auto. Qed.
+ Global Instance: Associative ((≡) : relation A) (∪).
+ Proof. split; auto. Qed.
+ Lemma subseteq_union X Y : X ⊆ Y ↔ X ∪ Y ≡ Y.
+ Proof. repeat split; eauto. intros HXY. rewrite <-HXY. auto. Qed.
+ Lemma subseteq_union_1 X Y : X ⊆ Y → X ∪ Y ≡ Y.
+ Proof. apply subseteq_union. Qed.
+ Lemma subseteq_union_2 X Y : X ∪ Y ≡ Y → X ⊆ Y.
+ Proof. apply subseteq_union. Qed.
+ Lemma equiv_empty X : X ⊆ ∅ → X ≡ ∅.
+ Proof. split; eauto. Qed.
+ Global Instance union_list_proper: Proper ((≡) ==> (≡)) (union_list (A:=A)).
+ Proof. by induction 1; simpl; try apply union_proper. Qed.
+ Lemma union_list_nil : ⋃ @nil A = ∅.
+ Proof. done. Qed.
+ Lemma union_list_cons X Xs : ⋃ (X :: Xs) = X ∪ ⋃ Xs.
+ Proof. done. Qed.
+ Lemma union_list_singleton X : ⋃ [X] ≡ X.
+ Proof. simpl. by rewrite (right_id ∅ _). Qed.
+ Lemma union_list_app Xs1 Xs2 : ⋃ (Xs1 ++ Xs2) ≡ ⋃ Xs1 ∪ ⋃ Xs2.
+ Proof.
+ induction Xs1 as [|X Xs1 IH]; simpl; [by rewrite (left_id ∅ _)|].
+ by rewrite IH, (associative _).
+ Qed.
+ Lemma union_list_reverse Xs : ⋃ (reverse Xs) ≡ ⋃ Xs.
+ Proof.
+ induction Xs as [|X Xs IH]; simpl; [done |].
+ by rewrite reverse_cons, union_list_app,
+ union_list_singleton, (commutative _), IH.
+ Qed.
+ Lemma union_list_preserving Xs Ys : Xs ⊆* Ys → ⋃ Xs ⊆ ⋃ Ys.
+ Proof. induction 1; simpl; auto using union_preserving. Qed.
+ Lemma empty_union X Y : X ∪ Y ≡ ∅ ↔ X ≡ ∅ ∧ Y ≡ ∅.
+ Proof.
+ split.
+ * intros HXY. split; apply equiv_empty;
+ by transitivity (X ∪ Y); [auto | rewrite HXY].
+ * intros [HX HY]. by rewrite HX, HY, (left_id _ _).
+ Qed.
+ Lemma empty_union_list Xs : ⋃ Xs ≡ ∅ ↔ Forall (≡ ∅) Xs.
+ Proof.
+ split.
+ * induction Xs; simpl; rewrite ?empty_union; intuition.
+ * induction 1 as [|?? E1 ? E2]; simpl. done. by apply empty_union.
+ Qed.
+
+ Section leibniz.
+ Context `{!LeibnizEquiv A}.
+ Global Instance: Idempotent (=) (∪).
+ Proof. intros ?. unfold_leibniz. apply (idempotent _). Qed.
+ Global Instance: LeftId (=) ∅ (∪).
+ Proof. intros ?. unfold_leibniz. apply (left_id _ _). Qed.
+ Global Instance: RightId (=) ∅ (∪).
+ Proof. intros ?. unfold_leibniz. apply (right_id _ _). Qed.
+ Global Instance: Commutative (=) (∪).
+ Proof. intros ??. unfold_leibniz. apply (commutative _). Qed.
+ Global Instance: Associative (=) (∪).
+ Proof. intros ???. unfold_leibniz. apply (associative _). Qed.
+ Lemma subseteq_union_L X Y : X ⊆ Y ↔ X ∪ Y = Y.
+ Proof. unfold_leibniz. apply subseteq_union. Qed.
+ Lemma subseteq_union_1_L X Y : X ⊆ Y → X ∪ Y = Y.
+ Proof. unfold_leibniz. apply subseteq_union_1. Qed.
+ Lemma subseteq_union_2_L X Y : X ∪ Y = Y → X ⊆ Y.
+ Proof. unfold_leibniz. apply subseteq_union_2. Qed.
+ Lemma equiv_empty_L X : X ⊆ ∅ → X = ∅.
+ Proof. unfold_leibniz. apply equiv_empty. Qed.
+ Lemma union_list_singleton_L (X : A) : ⋃ [X] = X.
+ Proof. unfold_leibniz. apply union_list_singleton. Qed.
+ Lemma union_list_app_L (Xs1 Xs2 : list A) : ⋃ (Xs1 ++ Xs2) = ⋃ Xs1 ∪ ⋃ Xs2.
+ Proof. unfold_leibniz. apply union_list_app. Qed.
+ Lemma union_list_reverse_L (Xs : list A) : ⋃ (reverse Xs) = ⋃ Xs.
+ Proof. unfold_leibniz. apply union_list_reverse. Qed.
+ Lemma empty_union_L X Y : X ∪ Y = ∅ ↔ X = ∅ ∧ Y = ∅.
+ Proof. unfold_leibniz. apply empty_union. Qed.
+ Lemma empty_union_list_L Xs : ⋃ Xs = ∅ ↔ Forall (= ∅) Xs.
+ Proof. unfold_leibniz. by rewrite empty_union_list. Qed.
+ End leibniz.
+
+ Section dec.
+ Context `{∀ X Y : A, Decision (X ⊆ Y)}.
+ Lemma non_empty_union X Y : X ∪ Y ≢ ∅ ↔ X ≢ ∅ ∨ Y ≢ ∅.
+ Proof. rewrite empty_union. destruct (decide (X ≡ ∅)); intuition. Qed.
+ Lemma non_empty_union_list Xs : ⋃ Xs ≢ ∅ → Exists (≢ ∅) Xs.
+ Proof. rewrite empty_union_list. apply (not_Forall_Exists _). Qed.
+ Context `{!LeibnizEquiv A}.
+ Lemma non_empty_union_L X Y : X ∪ Y ≠∅ ↔ X ≠∅ ∨ Y ≠∅.
+ Proof. unfold_leibniz. apply non_empty_union. Qed.
+ Lemma non_empty_union_list_L Xs : ⋃ Xs ≠∅ → Exists (≠∅) Xs.
+ Proof. unfold_leibniz. apply non_empty_union_list. Qed.
+ End dec.
+End join_semi_lattice.
+
+(** * Meet semi lattices *)
+(** The dual of the above section, but now for meet semi lattices. *)
+Section meet_semi_lattice.
+ Context `{MeetSemiLattice A}.
+ Implicit Types X Y : A.
+ Implicit Types Xs Ys : list A.
+
+ Hint Resolve intersection_subseteq_l intersection_subseteq_r
+ intersection_greatest.
+ Lemma intersection_subseteq_l_transitive X1 X2 Y : X1 ⊆ X2 → X1 ∩ Y ⊆ X2.
+ Proof. intros. transitivity X1; auto. Qed.
+ Lemma intersection_subseteq_r_transitive X1 X2 Y : X1 ⊆ X2 → Y ∩ X1 ⊆ X2.
+ Proof. intros. transitivity X1; auto. Qed.
+ Hint Resolve intersection_subseteq_l_transitive
+ intersection_subseteq_r_transitive.
+ Lemma intersection_preserving_l X Y1 Y2 : Y1 ⊆ Y2 → X ∩ Y1 ⊆ X ∩ Y2.
+ Proof. auto. Qed.
+ Lemma intersection_preserving_r X1 X2 Y : X1 ⊆ X2 → X1 ∩ Y ⊆ X2 ∩ Y.
+ Proof. auto. Qed.
+ Lemma intersection_preserving X1 X2 Y1 Y2 :
+ X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∩ Y1 ⊆ X2 ∩ Y2.
+ Proof. auto. Qed.
+ Global Instance: Proper ((≡) ==> (≡) ==> (≡)) (@intersection A _).
+ Proof.
+ unfold equiv, preorder_equiv. split;
+ apply intersection_preserving; simpl in *; tauto.
+ Qed.
+ Global Instance: Idempotent ((≡) : relation A) (∩).
+ Proof. split; eauto. Qed.
+ Global Instance: Commutative ((≡) : relation A) (∩).
+ Proof. split; auto. Qed.
+ Global Instance: Associative ((≡) : relation A) (∩).
+ Proof. split; auto. Qed.
+ Lemma subseteq_intersection X Y : X ⊆ Y ↔ X ∩ Y ≡ X.
+ Proof. repeat split; eauto. intros HXY. rewrite <-HXY. auto. Qed.
+ Lemma subseteq_intersection_1 X Y : X ⊆ Y → X ∩ Y ≡ X.
+ Proof. apply subseteq_intersection. Qed.
+ Lemma subseteq_intersection_2 X Y : X ∩ Y ≡ X → X ⊆ Y.
+ Proof. apply subseteq_intersection. Qed.
+
+ Section leibniz.
+ Context `{!LeibnizEquiv A}.
+ Global Instance: Idempotent (=) (∩).
+ Proof. intros ?. unfold_leibniz. apply (idempotent _). Qed.
+ Global Instance: Commutative (=) (∩).
+ Proof. intros ??. unfold_leibniz. apply (commutative _). Qed.
+ Global Instance: Associative (=) (∩).
+ Proof. intros ???. unfold_leibniz. apply (associative _). Qed.
+ Lemma subseteq_intersection_L X Y : X ⊆ Y ↔ X ∩ Y = X.
+ Proof. unfold_leibniz. apply subseteq_intersection. Qed.
+ Lemma subseteq_intersection_1_L X Y : X ⊆ Y → X ∩ Y = X.
+ Proof. unfold_leibniz. apply subseteq_intersection_1. Qed.
+ Lemma subseteq_intersection_2_L X Y : X ∩ Y = X → X ⊆ Y.
+ Proof. unfold_leibniz. apply subseteq_intersection_2. Qed.
+ End leibniz.
+End meet_semi_lattice.
+
+(** * Lower bounded lattices *)
+Section lattice.
+ Context `{Empty A, Lattice A, !EmptySpec A}.
+
+ Global Instance: LeftAbsorb ((≡) : relation A) ∅ (∩).
+ Proof. split. by apply intersection_subseteq_l. by apply subseteq_empty. Qed.
+ Global Instance: RightAbsorb ((≡) : relation A) ∅ (∩).
+ Proof. intros ?. by rewrite (commutative _), (left_absorb _ _). Qed.
+ Lemma union_intersection_l (X Y Z : A) : X ∪ (Y ∩ Z) ≡ (X ∪ Y) ∩ (X ∪ Z).
+ Proof.
+ split; [apply union_least|apply lattice_distr].
+ { apply intersection_greatest; auto using union_subseteq_l. }
+ apply intersection_greatest.
+ * apply union_subseteq_r_transitive, intersection_subseteq_l.
+ * apply union_subseteq_r_transitive, intersection_subseteq_r.
+ Qed.
+ Lemma union_intersection_r (X Y Z : A) : (X ∩ Y) ∪ Z ≡ (X ∪ Z) ∩ (Y ∪ Z).
+ Proof. by rewrite !(commutative _ _ Z), union_intersection_l. Qed.
+ Lemma intersection_union_l (X Y Z : A) : X ∩ (Y ∪ Z) ≡ (X ∩ Y) ∪ (X ∩ Z).
+ Proof.
+ split.
+ * rewrite union_intersection_l.
+ apply intersection_greatest.
+ { apply union_subseteq_r_transitive, intersection_subseteq_l. }
+ rewrite union_intersection_r.
+ apply intersection_preserving; auto using union_subseteq_l.
+ * apply intersection_greatest.
+ { apply union_least; auto using intersection_subseteq_l. }
+ apply union_least.
+ + apply intersection_subseteq_r_transitive, union_subseteq_l.
+ + apply intersection_subseteq_r_transitive, union_subseteq_r.
+ Qed.
+ Lemma intersection_union_r (X Y Z : A) : (X ∪ Y) ∩ Z ≡ (X ∩ Z) ∪ (Y ∩ Z).
+ Proof. by rewrite !(commutative _ _ Z), intersection_union_l. Qed.
+
+ Section leibniz.
+ Context `{!LeibnizEquiv A}.
+ Global Instance: LeftAbsorb (=) ∅ (∩).
+ Proof. intros ?. unfold_leibniz. apply (left_absorb _ _). Qed.
+ Global Instance: RightAbsorb (=) ∅ (∩).
+ Proof. intros ?. unfold_leibniz. apply (right_absorb _ _). Qed.
+ Lemma union_intersection_l_L (X Y Z : A) : X ∪ (Y ∩ Z) = (X ∪ Y) ∩ (X ∪ Z).
+ Proof. unfold_leibniz; apply union_intersection_l. Qed.
+ Lemma union_intersection_r_L (X Y Z : A) : (X ∩ Y) ∪ Z = (X ∪ Z) ∩ (Y ∪ Z).
+ Proof. unfold_leibniz; apply union_intersection_r. Qed.
+ Lemma intersection_union_l_L (X Y Z : A) : X ∩ (Y ∪ Z) ≡ (X ∩ Y) ∪ (X ∩ Z).
+ Proof. unfold_leibniz; apply intersection_union_l. Qed.
+ Lemma intersection_union_r_L (X Y Z : A) : (X ∪ Y) ∩ Z ≡ (X ∩ Z) ∪ (Y ∩ Z).
+ Proof. unfold_leibniz; apply intersection_union_r. Qed.
+ End leibniz.
+End lattice.
diff --git a/prelude/pmap.v b/prelude/pmap.v
new file mode 100644
index 0000000000000000000000000000000000000000..ec91cd490a96c06daf0604f7c7ef86f2e850d07f
--- /dev/null
+++ b/prelude/pmap.v
@@ -0,0 +1,371 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files implements an efficient implementation of finite maps whose keys
+range over Coq's data type of positive binary naturals [positive]. The
+implementation is based on Xavier Leroy's implementation of radix-2 search
+trees (uncompressed Patricia trees) and guarantees logarithmic-time operations.
+However, we extend Leroy's implementation by packing the trees into a Sigma
+type such that canonicity of representation is ensured. This is necesarry for
+Leibniz equality to become extensional. *)
+Require Import PArith prelude.mapset.
+Require Export prelude.fin_maps.
+
+Local Open Scope positive_scope.
+Local Hint Extern 0 (@eq positive _ _) => congruence.
+Local Hint Extern 0 (¬@eq positive _ _) => congruence.
+
+(** * The tree data structure *)
+(** The data type [Pmap_raw] specifies radix-2 search trees. These trees do
+not ensure canonical representations of maps. For example the empty map can
+be represented as a binary tree of an arbitrary size that contains [None] at
+all nodes. *)
+Inductive Pmap_raw (A : Type) : Type :=
+ | PLeaf: Pmap_raw A
+ | PNode: option A → Pmap_raw A → Pmap_raw A → Pmap_raw A.
+Arguments PLeaf {_}.
+Arguments PNode {_} _ _ _.
+
+Instance Pmap_raw_eq_dec `{∀ x y : A, Decision (x = y)} (x y : Pmap_raw A) :
+ Decision (x = y).
+Proof. solve_decision. Defined.
+
+Fixpoint Pmap_wf {A} (t : Pmap_raw A) : bool :=
+ match t with
+ | PLeaf => true
+ | PNode None PLeaf PLeaf => false
+ | PNode _ l r => Pmap_wf l && Pmap_wf r
+ end.
+Arguments Pmap_wf _ !_ / : simpl nomatch.
+Lemma Pmap_wf_l {A} o (l r : Pmap_raw A) : Pmap_wf (PNode o l r) → Pmap_wf l.
+Proof. destruct o, l, r; simpl; rewrite ?andb_True; tauto. Qed.
+Lemma Pmap_wf_r {A} o (l r : Pmap_raw A) : Pmap_wf (PNode o l r) → Pmap_wf r.
+Proof. destruct o, l, r; simpl; rewrite ?andb_True; tauto. Qed.
+Local Hint Immediate Pmap_wf_l Pmap_wf_r.
+Definition PNode' {A} (o : option A) (l r : Pmap_raw A) :=
+ match l, o, r with PLeaf, None, PLeaf => PLeaf | _, _, _ => PNode o l r end.
+Arguments PNode' _ _ _ _ : simpl never.
+Lemma PNode_wf {A} o (l r : Pmap_raw A) :
+ Pmap_wf l → Pmap_wf r → Pmap_wf (PNode' o l r).
+Proof. destruct o, l, r; simpl; auto. Qed.
+Local Hint Resolve PNode_wf.
+
+(** Operations *)
+Instance Pempty_raw {A} : Empty (Pmap_raw A) := PLeaf.
+Instance Plookup_raw {A} : Lookup positive A (Pmap_raw A) :=
+ fix go (i : positive) (t : Pmap_raw A) {struct t} : option A :=
+ let _ : Lookup _ _ _ := @go in
+ match t with
+ | PLeaf => None
+ | PNode o l r => match i with 1 => o | i~0 => l !! i | i~1 => r !! i end
+ end.
+Local Arguments lookup _ _ _ _ _ !_ / : simpl nomatch.
+Fixpoint Psingleton_raw {A} (i : positive) (x : A) : Pmap_raw A :=
+ match i with
+ | 1 => PNode (Some x) PLeaf PLeaf
+ | i~0 => PNode None (Psingleton_raw i x) PLeaf
+ | i~1 => PNode None PLeaf (Psingleton_raw i x)
+ end.
+Fixpoint Ppartial_alter_raw {A} (f : option A → option A)
+ (i : positive) (t : Pmap_raw A) {struct t} : Pmap_raw A :=
+ match t with
+ | PLeaf => match f None with None => PLeaf | Some x => Psingleton_raw i x end
+ | PNode o l r =>
+ match i with
+ | 1 => PNode' (f o) l r
+ | i~0 => PNode' o (Ppartial_alter_raw f i l) r
+ | i~1 => PNode' o l (Ppartial_alter_raw f i r)
+ end
+ end.
+Fixpoint Pfmap_raw {A B} (f : A → B) (t : Pmap_raw A) : Pmap_raw B :=
+ match t with
+ | PLeaf => PLeaf
+ | PNode o l r => PNode (f <$> o) (Pfmap_raw f l) (Pfmap_raw f r)
+ end.
+Fixpoint Pto_list_raw {A} (j : positive) (t : Pmap_raw A)
+ (acc : list (positive * A)) : list (positive * A) :=
+ match t with
+ | PLeaf => acc
+ | PNode o l r => default [] o (λ x, [(Preverse j, x)]) ++
+ Pto_list_raw (j~0) l (Pto_list_raw (j~1) r acc)
+ end%list.
+Fixpoint Pomap_raw {A B} (f : A → option B) (t : Pmap_raw A) : Pmap_raw B :=
+ match t with
+ | PLeaf => PLeaf
+ | PNode o l r => PNode' (o ≫= f) (Pomap_raw f l) (Pomap_raw f r)
+ end.
+Fixpoint Pmerge_raw {A B C} (f : option A → option B → option C)
+ (t1 : Pmap_raw A) (t2 : Pmap_raw B) : Pmap_raw C :=
+ match t1, t2 with
+ | PLeaf, t2 => Pomap_raw (f None ∘ Some) t2
+ | t1, PLeaf => Pomap_raw (flip f None ∘ Some) t1
+ | PNode o1 l1 r1, PNode o2 l2 r2 =>
+ PNode' (f o1 o2) (Pmerge_raw f l1 l2) (Pmerge_raw f r1 r2)
+ end.
+
+(** Proofs *)
+Lemma Pmap_wf_canon {A} (t : Pmap_raw A) :
+ (∀ i, t !! i = None) → Pmap_wf t → t = PLeaf.
+Proof.
+ induction t as [|o l IHl r IHr]; intros Ht ?; auto.
+ assert (o = None) as -> by (apply (Ht 1)).
+ assert (l = PLeaf) as -> by (apply IHl; try apply (λ i, Ht (i~0)); eauto).
+ by assert (r = PLeaf) as -> by (apply IHr; try apply (λ i, Ht (i~1)); eauto).
+Qed.
+Lemma Pmap_wf_eq {A} (t1 t2 : Pmap_raw A) :
+ (∀ i, t1 !! i = t2 !! i) → Pmap_wf t1 → Pmap_wf t2 → t1 = t2.
+Proof.
+ revert t2.
+ induction t1 as [|o1 l1 IHl r1 IHr]; intros [|o2 l2 r2] Ht ??; simpl; auto.
+ * discriminate (Pmap_wf_canon (PNode o2 l2 r2)); eauto.
+ * discriminate (Pmap_wf_canon (PNode o1 l1 r1)); eauto.
+ * f_equal; [apply (Ht 1)| |].
+ + apply IHl; try apply (λ x, Ht (x~0)); eauto.
+ + apply IHr; try apply (λ x, Ht (x~1)); eauto.
+Qed.
+Lemma PNode_lookup {A} o (l r : Pmap_raw A) i :
+ PNode' o l r !! i = PNode o l r !! i.
+Proof. by destruct i, o, l, r. Qed.
+
+Lemma Psingleton_wf {A} i (x : A) : Pmap_wf (Psingleton_raw i x).
+Proof. induction i as [[]|[]|]; simpl; rewrite ?andb_true_r; auto. Qed.
+Lemma Ppartial_alter_wf {A} f i (t : Pmap_raw A) :
+ Pmap_wf t → Pmap_wf (Ppartial_alter_raw f i t).
+Proof.
+ revert i; induction t as [|o l IHl r IHr]; intros i ?; simpl.
+ * destruct (f None); auto using Psingleton_wf.
+ * destruct i; simpl; eauto.
+Qed.
+Lemma Pfmap_wf {A B} (f : A → B) t : Pmap_wf t → Pmap_wf (Pfmap_raw f t).
+Proof.
+ induction t as [|[x|] [] ? [] ?]; simpl in *; rewrite ?andb_True; intuition.
+Qed.
+Lemma Pomap_wf {A B} (f : A → option B) t : Pmap_wf t → Pmap_wf (Pomap_raw f t).
+Proof. induction t; simpl; eauto. Qed.
+Lemma Pmerge_wf {A B C} (f : option A → option B → option C) t1 t2 :
+ Pmap_wf t1 → Pmap_wf t2 → Pmap_wf (Pmerge_raw f t1 t2).
+Proof. revert t2. induction t1; intros []; simpl; eauto using Pomap_wf. Qed.
+
+Lemma Plookup_empty {A} i : (∅ : Pmap_raw A) !! i = None.
+Proof. by destruct i. Qed.
+Lemma Plookup_singleton {A} i (x : A) : Psingleton_raw i x !! i = Some x.
+Proof. by induction i. Qed.
+Lemma Plookup_singleton_ne {A} i j (x : A) :
+ i ≠j → Psingleton_raw i x !! j = None.
+Proof. revert j. induction i; intros [?|?|]; simpl; auto with congruence. Qed.
+Lemma Plookup_alter {A} f i (t : Pmap_raw A) :
+ Ppartial_alter_raw f i t !! i = f (t !! i).
+Proof.
+ revert i; induction t as [|o l IHl r IHr]; intros i; simpl.
+ * by destruct (f None); rewrite ?Plookup_singleton.
+ * destruct i; simpl; rewrite PNode_lookup; simpl; auto.
+Qed.
+Lemma Plookup_alter_ne {A} f i j (t : Pmap_raw A) :
+ i ≠j → Ppartial_alter_raw f i t !! j = t !! j.
+Proof.
+ revert i j; induction t as [|o l IHl r IHr]; simpl.
+ * by intros; destruct (f None); rewrite ?Plookup_singleton_ne.
+ * by intros [?|?|] [?|?|] ?; simpl; rewrite ?PNode_lookup; simpl; auto.
+Qed.
+Lemma Plookup_fmap {A B} (f : A → B) t i : (Pfmap_raw f t) !! i = f <$> t !! i.
+Proof. revert i. by induction t; intros [?|?|]; simpl. Qed.
+Lemma Pelem_of_to_list {A} (t : Pmap_raw A) j i acc x :
+ (i,x) ∈ Pto_list_raw j t acc ↔
+ (∃ i', i = i' ++ Preverse j ∧ t !! i' = Some x) ∨ (i,x) ∈ acc.
+Proof.
+ split.
+ { revert j acc. induction t as [|[y|] l IHl r IHr]; intros j acc; simpl.
+ * by right.
+ * rewrite elem_of_cons. intros [?|?]; simplify_equality.
+ { left; exists 1. by rewrite (left_id_L 1 (++))%positive. }
+ destruct (IHl (j~0) (Pto_list_raw j~1 r acc)) as [(i'&->&?)|?]; auto.
+ { left; exists (i' ~ 0). by rewrite Preverse_xO, (associative_L _). }
+ destruct (IHr (j~1) acc) as [(i'&->&?)|?]; auto.
+ left; exists (i' ~ 1). by rewrite Preverse_xI, (associative_L _).
+ * intros.
+ destruct (IHl (j~0) (Pto_list_raw j~1 r acc)) as [(i'&->&?)|?]; auto.
+ { left; exists (i' ~ 0). by rewrite Preverse_xO, (associative_L _). }
+ destruct (IHr (j~1) acc) as [(i'&->&?)|?]; auto.
+ left; exists (i' ~ 1). by rewrite Preverse_xI, (associative_L _). }
+ revert t j i acc. assert (∀ t j i acc,
+ (i, x) ∈ acc → (i, x) ∈ Pto_list_raw j t acc) as help.
+ { intros t; induction t as [|[y|] l IHl r IHr]; intros j i acc;
+ simpl; rewrite ?elem_of_cons; auto. }
+ intros t j ? acc [(i&->&Hi)|?]; [|by auto]. revert j i acc Hi.
+ induction t as [|[y|] l IHl r IHr]; intros j i acc ?; simpl.
+ * done.
+ * rewrite elem_of_cons. destruct i as [i|i|]; simplify_equality'.
+ + right. apply help. specialize (IHr (j~1) i).
+ rewrite Preverse_xI, (associative_L _) in IHr. by apply IHr.
+ + right. specialize (IHl (j~0) i).
+ rewrite Preverse_xO, (associative_L _) in IHl. by apply IHl.
+ + left. by rewrite (left_id_L 1 (++))%positive.
+ * destruct i as [i|i|]; simplify_equality'.
+ + apply help. specialize (IHr (j~1) i).
+ rewrite Preverse_xI, (associative_L _) in IHr. by apply IHr.
+ + specialize (IHl (j~0) i).
+ rewrite Preverse_xO, (associative_L _) in IHl. by apply IHl.
+Qed.
+Lemma Pto_list_nodup {A} j (t : Pmap_raw A) acc :
+ (∀ i x, (i ++ Preverse j, x) ∈ acc → t !! i = None) →
+ NoDup acc → NoDup (Pto_list_raw j t acc).
+Proof.
+ revert j acc. induction t as [|[y|] l IHl r IHr]; simpl; intros j acc Hin ?.
+ * done.
+ * repeat constructor.
+ { rewrite Pelem_of_to_list. intros [(i&Hi&?)|Hj].
+ { apply (f_equal Plength) in Hi.
+ rewrite Preverse_xO, !Papp_length in Hi; simpl in *; lia. }
+ rewrite Pelem_of_to_list in Hj. destruct Hj as [(i&Hi&?)|Hj].
+ { apply (f_equal Plength) in Hi.
+ rewrite Preverse_xI, !Papp_length in Hi; simpl in *; lia. }
+ specialize (Hin 1 y). rewrite (left_id_L 1 (++))%positive in Hin.
+ discriminate (Hin Hj). }
+ apply IHl.
+ { intros i x. rewrite Pelem_of_to_list. intros [(?&Hi&?)|Hi].
+ + rewrite Preverse_xO, Preverse_xI, !(associative_L _) in Hi.
+ by apply (injective (++ _)) in Hi.
+ + apply (Hin (i~0) x). by rewrite Preverse_xO, (associative_L _) in Hi. }
+ apply IHr; auto. intros i x Hi.
+ apply (Hin (i~1) x). by rewrite Preverse_xI, (associative_L _) in Hi.
+ * apply IHl.
+ { intros i x. rewrite Pelem_of_to_list. intros [(?&Hi&?)|Hi].
+ + rewrite Preverse_xO, Preverse_xI, !(associative_L _) in Hi.
+ by apply (injective (++ _)) in Hi.
+ + apply (Hin (i~0) x). by rewrite Preverse_xO, (associative_L _) in Hi. }
+ apply IHr; auto. intros i x Hi.
+ apply (Hin (i~1) x). by rewrite Preverse_xI, (associative_L _) in Hi.
+Qed.
+Lemma Pomap_lookup {A B} (f : A → option B) t i :
+ Pomap_raw f t !! i = t !! i ≫= f.
+Proof.
+ revert i. induction t as [|o l IHl r IHr]; intros [i|i|]; simpl;
+ rewrite ?PNode_lookup; simpl; auto.
+Qed.
+Lemma Pmerge_lookup {A B C} (f : option A → option B → option C)
+ (Hf : f None None = None) t1 t2 i :
+ Pmerge_raw f t1 t2 !! i = f (t1 !! i) (t2 !! i).
+Proof.
+ revert t2 i; induction t1 as [|o1 l1 IHl1 r1 IHr1]; intros t2 i; simpl.
+ { rewrite Pomap_lookup. by destruct (t2 !! i). }
+ unfold compose, flip.
+ destruct t2 as [|l2 o2 r2]; rewrite PNode_lookup.
+ * by destruct i; rewrite ?Pomap_lookup; simpl; rewrite ?Pomap_lookup;
+ match goal with |- ?o ≫= _ = _ => destruct o end.
+ * destruct i; rewrite ?Pomap_lookup; simpl; auto.
+Qed.
+
+(** Packed version and instance of the finite map type class *)
+Inductive Pmap (A : Type) : Type :=
+ PMap { pmap_car : Pmap_raw A; pmap_prf : Pmap_wf pmap_car }.
+Arguments PMap {_} _ _.
+Arguments pmap_car {_} _.
+Arguments pmap_prf {_} _.
+Lemma Pmap_eq {A} (m1 m2 : Pmap A) : m1 = m2 ↔ pmap_car m1 = pmap_car m2.
+Proof.
+ split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?].
+ simplify_equality'; f_equal; apply proof_irrel.
+Qed.
+Instance Pmap_eq_dec `{∀ x y : A, Decision (x = y)}
+ (m1 m2 : Pmap A) : Decision (m1 = m2) :=
+ match Pmap_raw_eq_dec (pmap_car m1) (pmap_car m2) with
+ | left H => left (proj2 (Pmap_eq m1 m2) H)
+ | right H => right (H ∘ proj1 (Pmap_eq m1 m2))
+ end.
+Instance Pempty {A} : Empty (Pmap A) := PMap ∅ I.
+Instance Plookup {A} : Lookup positive A (Pmap A) := λ i m, pmap_car m !! i.
+Instance Ppartial_alter {A} : PartialAlter positive A (Pmap A) := λ f i m,
+ let (t,Ht) := m in PMap (partial_alter f i t) (Ppartial_alter_wf f i _ Ht).
+Instance Pfmap : FMap Pmap := λ A B f m,
+ let (t,Ht) := m in PMap (f <$> t) (Pfmap_wf f _ Ht).
+Instance Pto_list {A} : FinMapToList positive A (Pmap A) := λ m,
+ let (t,Ht) := m in Pto_list_raw 1 t [].
+Instance Pomap : OMap Pmap := λ A B f m,
+ let (t,Ht) := m in PMap (omap f t) (Pomap_wf f _ Ht).
+Instance Pmerge : Merge Pmap := λ A B C f m1 m2,
+ let (t1,Ht1) := m1 in let (t2,Ht2) := m2 in PMap _ (Pmerge_wf f _ _ Ht1 Ht2).
+
+Instance Pmap_finmap : FinMap positive Pmap.
+Proof.
+ split.
+ * by intros ? [t1 ?] [t2 ?] ?; apply Pmap_eq, Pmap_wf_eq.
+ * by intros ? [].
+ * intros ?? [??] ?. by apply Plookup_alter.
+ * intros ?? [??] ??. by apply Plookup_alter_ne.
+ * intros ??? [??]. by apply Plookup_fmap.
+ * intros ? [??]. apply Pto_list_nodup; [|constructor].
+ intros ??. by rewrite elem_of_nil.
+ * intros ? [??] i x; unfold map_to_list, Pto_list.
+ rewrite Pelem_of_to_list, elem_of_nil.
+ split. by intros [(?&->&?)|]. by left; exists i.
+ * intros ?? ? [??] ?. by apply Pomap_lookup.
+ * intros ??? ?? [??] [??] ?. by apply Pmerge_lookup.
+Qed.
+
+(** * Finite sets *)
+(** We construct sets of [positives]s satisfying extensional equality. *)
+Notation Pset := (mapset Pmap).
+Instance Pmap_dom {A} : Dom (Pmap A) Pset := mapset_dom.
+Instance: FinMapDom positive Pmap Pset := mapset_dom_spec.
+
+(** * Fresh numbers *)
+Fixpoint Pdepth {A} (m : Pmap_raw A) : nat :=
+ match m with
+ | PLeaf | PNode None _ _ => O | PNode _ l _ => S (Pdepth l)
+ end.
+Fixpoint Pfresh_at_depth {A} (m : Pmap_raw A) (d : nat) : option positive :=
+ match d, m with
+ | O, (PLeaf | PNode None _ _) => Some 1
+ | S d, PNode _ l r =>
+ match Pfresh_at_depth l d with
+ | Some i => Some (i~0) | None => (~1) <$> Pfresh_at_depth r d
+ end
+ | _, _ => None
+ end.
+Fixpoint Pfresh_go {A} (m : Pmap_raw A) (d : nat) : option positive :=
+ match d with
+ | O => None
+ | S d =>
+ match Pfresh_go m d with
+ | Some i => Some i | None => Pfresh_at_depth m d
+ end
+ end.
+Definition Pfresh {A} (m : Pmap A) : positive :=
+ let d := Pdepth (pmap_car m) in
+ match Pfresh_go (pmap_car m) d with
+ | Some i => i | None => Pos.shiftl_nat 1 d
+ end.
+
+Lemma Pfresh_at_depth_fresh {A} (m : Pmap_raw A) d i :
+ Pfresh_at_depth m d = Some i → m !! i = None.
+Proof.
+ revert i m; induction d as [|d IH].
+ { intros i [|[] l r] ?; naive_solver. }
+ intros i [|o l r] ?; simplify_equality'.
+ destruct (Pfresh_at_depth l d) as [i'|] eqn:?,
+ (Pfresh_at_depth r d) as [i''|] eqn:?; simplify_equality'; auto.
+Qed.
+Lemma Pfresh_go_fresh {A} (m : Pmap_raw A) d i :
+ Pfresh_go m d = Some i → m !! i = None.
+Proof.
+ induction d as [|d IH]; intros; simplify_equality'.
+ destruct (Pfresh_go m d); eauto using Pfresh_at_depth_fresh.
+Qed.
+Lemma Pfresh_depth {A} (m : Pmap_raw A) :
+ m !! Pos.shiftl_nat 1 (Pdepth m) = None.
+Proof. induction m as [|[x|] l IHl r IHr]; auto. Qed.
+Lemma Pfresh_fresh {A} (m : Pmap A) : m !! Pfresh m = None.
+Proof.
+ destruct m as [m ?]; unfold lookup, Plookup, Pfresh; simpl.
+ destruct (Pfresh_go m _) eqn:?; eauto using Pfresh_go_fresh, Pfresh_depth.
+Qed.
+
+Instance Pset_fresh : Fresh positive Pset := λ X,
+ let (m) := X in Pfresh m.
+Instance Pset_fresh_spec : FreshSpec positive Pset.
+Proof.
+ split.
+ * apply _.
+ * intros X Y; rewrite <-elem_of_equiv_L. by intros ->.
+ * unfold elem_of, mapset_elem_of, fresh; intros [m]; simpl.
+ by rewrite Pfresh_fresh.
+Qed.
diff --git a/prelude/prelude.v b/prelude/prelude.v
new file mode 100644
index 0000000000000000000000000000000000000000..020b6535b59d0ef3cb41240e9b465d2c2c36fa3d
--- /dev/null
+++ b/prelude/prelude.v
@@ -0,0 +1,16 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Export
+ prelude.base
+ prelude.tactics
+ prelude.decidable
+ prelude.orders
+ prelude.option
+ prelude.vector
+ prelude.numbers
+ prelude.relations
+ prelude.collections
+ prelude.fin_collections
+ prelude.listset
+ prelude.list
+ prelude.lexico.
diff --git a/prelude/pretty.v b/prelude/pretty.v
new file mode 100644
index 0000000000000000000000000000000000000000..dbd0311de05aea0cfe6c1f044dc6ad51081db88a
--- /dev/null
+++ b/prelude/pretty.v
@@ -0,0 +1,67 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Export prelude.strings.
+Require Import prelude.relations.
+Require Import Ascii.
+
+Class Pretty A := pretty : A → string.
+Definition pretty_N_char (x : N) : ascii :=
+ match x with
+ | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4"
+ | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
+ end%char%N.
+Fixpoint pretty_N_go_help (x : N) (acc : Acc (<)%N x) (s : string) : string :=
+ match decide (0 < x)%N with
+ | left H => pretty_N_go_help (x `div` 10)%N
+ (Acc_inv acc (N.div_lt x 10 H eq_refl))
+ (String (pretty_N_char (x `mod` 10)) s)
+ | right _ => s
+ end.
+Definition pretty_N_go (x : N) : string → string :=
+ pretty_N_go_help x (wf_guard 32 N.lt_wf_0 x).
+Lemma pretty_N_go_0 s : pretty_N_go 0 s = s.
+Proof. done. Qed.
+Lemma pretty_N_go_help_irrel x acc1 acc2 s :
+ pretty_N_go_help x acc1 s = pretty_N_go_help x acc2 s.
+Proof.
+ revert x acc1 acc2 s; fix 2; intros x [acc1] [acc2] s; simpl.
+ destruct (decide (0 < x)%N); auto.
+Qed.
+Lemma pretty_N_go_step x s :
+ (0 < x)%N → pretty_N_go x s
+ = pretty_N_go (x `div` 10) (String (pretty_N_char (x `mod` 10)) s).
+Proof.
+ unfold pretty_N_go; intros; destruct (wf_guard 32 N.lt_wf_0 x).
+ unfold pretty_N_go_help; fold pretty_N_go_help.
+ by destruct (decide (0 < x)%N); auto using pretty_N_go_help_irrel.
+Qed.
+Instance pretty_N : Pretty N := λ x, pretty_N_go x ""%string.
+Instance pretty_N_injective : Injective (@eq N) (=) pretty.
+Proof.
+ assert (∀ x y, x < 10 → y < 10 →
+ pretty_N_char x = pretty_N_char y → x = y)%N.
+ { compute; intros. by repeat (discriminate || case_match). }
+ cut (∀ x y s s', pretty_N_go x s = pretty_N_go y s' →
+ String.length s = String.length s' → x = y ∧ s = s').
+ { intros help x y ?. eapply help; eauto. }
+ assert (∀ x s, ¬String.length (pretty_N_go x s) < String.length s) as help.
+ { setoid_rewrite <-Nat.le_ngt.
+ intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros s.
+ assert (x = 0 ∨ 0 < x)%N as [->|?] by lia; [by rewrite pretty_N_go_0|].
+ rewrite pretty_N_go_step by done.
+ etransitivity; [|by eapply IH, N.div_lt]; simpl; lia. }
+ intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros y s s'.
+ assert ((x = 0 ∨ 0 < x) ∧ (y = 0 ∨ 0 < y))%N as [[->|?] [->|?]] by lia;
+ rewrite ?pretty_N_go_0, ?pretty_N_go_step, ?(pretty_N_go_step y) by done.
+ { done. }
+ { intros -> Hlen; edestruct help; rewrite Hlen; simpl; lia. }
+ { intros <- Hlen; edestruct help; rewrite <-Hlen; simpl; lia. }
+ intros Hs Hlen; apply IH in Hs; destruct Hs;
+ simplify_equality'; split_ands'; auto using N.div_lt_upper_bound with lia.
+ rewrite (N.div_mod x 10), (N.div_mod y 10) by done.
+ auto using N.mod_lt with f_equal.
+Qed.
+Instance pretty_Z : Pretty Z := λ x,
+ match x with
+ | Z0 => "" | Zpos x => pretty (Npos x) | Zneg x => "-" +:+ pretty (Npos x)
+ end%string.
diff --git a/prelude/proof_irrel.v b/prelude/proof_irrel.v
new file mode 100644
index 0000000000000000000000000000000000000000..d1eab74108d6ae67712723a6bbbc4dbcd1eea6a2
--- /dev/null
+++ b/prelude/proof_irrel.v
@@ -0,0 +1,35 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects facts on proof irrelevant types/propositions. *)
+Require Export Eqdep_dec prelude.tactics.
+
+Hint Extern 200 (ProofIrrel _) => progress (lazy beta) : typeclass_instances.
+
+Instance: ProofIrrel True.
+Proof. by intros [] []. Qed.
+Instance: ProofIrrel False.
+Proof. by intros []. Qed.
+Instance and_pi (A B : Prop) :
+ ProofIrrel A → ProofIrrel B → ProofIrrel (A ∧ B).
+Proof. intros ?? [??] [??]. by f_equal. Qed.
+Instance prod_pi (A B : Type) :
+ ProofIrrel A → ProofIrrel B → ProofIrrel (A * B).
+Proof. intros ?? [??] [??]. by f_equal. Qed.
+Instance eq_pi {A} `{∀ x y : A, Decision (x = y)} (x y : A) :
+ ProofIrrel (x = y).
+Proof.
+ intros ??. apply eq_proofs_unicity.
+ intros x' y'. destruct (decide (x' = y')); tauto.
+Qed.
+Instance Is_true_pi (b : bool) : ProofIrrel (Is_true b).
+Proof. destruct b; simpl; apply _. Qed.
+Lemma sig_eq_pi `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
+ (x y : sig P) : x = y ↔ `x = `y.
+Proof.
+ split; [by intros <- |].
+ destruct x as [x Hx], y as [y Hy]; simpl; intros; subst.
+ f_equal. apply proof_irrel.
+Qed.
+Lemma exists_proj1_pi `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
+ (x : sig P) p : `x ↾ p = x.
+Proof. by apply (sig_eq_pi _). Qed.
diff --git a/prelude/relations.v b/prelude/relations.v
new file mode 100644
index 0000000000000000000000000000000000000000..cd81c198f12413881742bf04fc758313e5ca68bc
--- /dev/null
+++ b/prelude/relations.v
@@ -0,0 +1,223 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects definitions and theorems on abstract rewriting systems.
+These are particularly useful as we define the operational semantics as a
+small step semantics. This file defines a hint database [ars] containing
+some theorems on abstract rewriting systems. *)
+Require Import Wf_nat.
+Require Export prelude.tactics prelude.base.
+
+(** * Definitions *)
+Section definitions.
+ Context `(R : relation A).
+
+ (** An element is reducible if a step is possible. *)
+ Definition red (x : A) := ∃ y, R x y.
+
+ (** An element is in normal form if no further steps are possible. *)
+ Definition nf (x : A) := ¬red x.
+
+ (** The reflexive transitive closure. *)
+ Inductive rtc : relation A :=
+ | rtc_refl x : rtc x x
+ | rtc_l x y z : R x y → rtc y z → rtc x z.
+
+ (** The reflexive transitive closure for setoids. *)
+ Inductive rtcS `{Equiv A} : relation A :=
+ | rtcS_refl x y : x ≡ y → rtcS x y
+ | rtcS_l x y z : R x y → rtcS y z → rtcS x z.
+
+ (** Reductions of exactly [n] steps. *)
+ Inductive nsteps : nat → relation A :=
+ | nsteps_O x : nsteps 0 x x
+ | nsteps_l n x y z : R x y → nsteps n y z → nsteps (S n) x z.
+
+ (** Reduction of at most [n] steps. *)
+ Inductive bsteps : nat → relation A :=
+ | bsteps_refl n x : bsteps n x x
+ | bsteps_l n x y z : R x y → bsteps n y z → bsteps (S n) x z.
+
+ (** The transitive closure. *)
+ Inductive tc : relation A :=
+ | tc_once x y : R x y → tc x y
+ | tc_l x y z : R x y → tc y z → tc x z.
+
+ (** An element [x] is universally looping if all paths starting at [x]
+ are infinite. *)
+ CoInductive all_loop : A → Prop :=
+ | all_loop_do_step x : red x → (∀ y, R x y → all_loop y) → all_loop x.
+
+ (** An element [x] is existentally looping if some path starting at [x]
+ is infinite. *)
+ CoInductive ex_loop : A → Prop :=
+ | ex_loop_do_step x y : R x y → ex_loop y → ex_loop x.
+End definitions.
+
+Hint Unfold nf red.
+
+(** * General theorems *)
+Section rtc.
+ Context `{R : relation A}.
+
+ Hint Constructors rtc nsteps bsteps tc.
+
+ Global Instance rtc_reflexive: Reflexive (rtc R).
+ Proof. exact (@rtc_refl A R). Qed.
+ Lemma rtc_transitive x y z : rtc R x y → rtc R y z → rtc R x z.
+ Proof. induction 1; eauto. Qed.
+ Global Instance: Transitive (rtc R).
+ Proof. exact rtc_transitive. Qed.
+ Lemma rtc_once x y : R x y → rtc R x y.
+ Proof. eauto. Qed.
+ Lemma rtc_r x y z : rtc R x y → R y z → rtc R x z.
+ Proof. intros. etransitivity; eauto. Qed.
+ Lemma rtc_inv x z : rtc R x z → x = z ∨ ∃ y, R x y ∧ rtc R y z.
+ Proof. inversion_clear 1; eauto. Qed.
+ Lemma rtc_ind_l (P : A → Prop) (z : A)
+ (Prefl : P z) (Pstep : ∀ x y, R x y → rtc R y z → P y → P x) :
+ ∀ x, rtc R x z → P x.
+ Proof. induction 1; eauto. Qed.
+ Lemma rtc_ind_r_weak (P : A → A → Prop)
+ (Prefl : ∀ x, P x x) (Pstep : ∀ x y z, rtc R x y → R y z → P x y → P x z) :
+ ∀ x z, rtc R x z → P x z.
+ Proof.
+ cut (∀ y z, rtc R y z → ∀ x, rtc R x y → P x y → P x z).
+ { eauto using rtc_refl. }
+ induction 1; eauto using rtc_r.
+ Qed.
+ Lemma rtc_ind_r (P : A → Prop) (x : A)
+ (Prefl : P x) (Pstep : ∀ y z, rtc R x y → R y z → P y → P z) :
+ ∀ z, rtc R x z → P z.
+ Proof.
+ intros z p. revert x z p Prefl Pstep. refine (rtc_ind_r_weak _ _ _); eauto.
+ Qed.
+ Lemma rtc_inv_r x z : rtc R x z → x = z ∨ ∃ y, rtc R x y ∧ R y z.
+ Proof. revert z. apply rtc_ind_r; eauto. Qed.
+
+ Lemma nsteps_once x y : R x y → nsteps R 1 x y.
+ Proof. eauto. Qed.
+ Lemma nsteps_trans n m x y z :
+ nsteps R n x y → nsteps R m y z → nsteps R (n + m) x z.
+ Proof. induction 1; simpl; eauto. Qed.
+ Lemma nsteps_r n x y z : nsteps R n x y → R y z → nsteps R (S n) x z.
+ Proof. induction 1; eauto. Qed.
+ Lemma nsteps_rtc n x y : nsteps R n x y → rtc R x y.
+ Proof. induction 1; eauto. Qed.
+ Lemma rtc_nsteps x y : rtc R x y → ∃ n, nsteps R n x y.
+ Proof. induction 1; firstorder eauto. Qed.
+
+ Lemma bsteps_once n x y : R x y → bsteps R (S n) x y.
+ Proof. eauto. Qed.
+ Lemma bsteps_plus_r n m x y :
+ bsteps R n x y → bsteps R (n + m) x y.
+ Proof. induction 1; simpl; eauto. Qed.
+ Lemma bsteps_weaken n m x y :
+ n ≤ m → bsteps R n x y → bsteps R m x y.
+ Proof.
+ intros. rewrite (Minus.le_plus_minus n m); auto using bsteps_plus_r.
+ Qed.
+ Lemma bsteps_plus_l n m x y :
+ bsteps R n x y → bsteps R (m + n) x y.
+ Proof. apply bsteps_weaken. auto with arith. Qed.
+ Lemma bsteps_S n x y : bsteps R n x y → bsteps R (S n) x y.
+ Proof. apply bsteps_weaken. lia. Qed.
+ Lemma bsteps_trans n m x y z :
+ bsteps R n x y → bsteps R m y z → bsteps R (n + m) x z.
+ Proof. induction 1; simpl; eauto using bsteps_plus_l. Qed.
+ Lemma bsteps_r n x y z : bsteps R n x y → R y z → bsteps R (S n) x z.
+ Proof. induction 1; eauto. Qed.
+ Lemma bsteps_rtc n x y : bsteps R n x y → rtc R x y.
+ Proof. induction 1; eauto. Qed.
+ Lemma rtc_bsteps x y : rtc R x y → ∃ n, bsteps R n x y.
+ Proof. induction 1; [exists 0; constructor|]. naive_solver eauto. Qed.
+ Lemma bsteps_ind_r (P : nat → A → Prop) (x : A)
+ (Prefl : ∀ n, P n x)
+ (Pstep : ∀ n y z, bsteps R n x y → R y z → P n y → P (S n) z) :
+ ∀ n z, bsteps R n x z → P n z.
+ Proof.
+ cut (∀ m y z, bsteps R m y z → ∀ n,
+ bsteps R n x y → (∀ m', n ≤ m' ∧ m' ≤ n + m → P m' y) → P (n + m) z).
+ { intros help ?. change n with (0 + n). eauto. }
+ induction 1 as [|m x' y z p2 p3 IH]; [by eauto with arith|].
+ intros n p1 H. rewrite <-plus_n_Sm.
+ apply (IH (S n)); [by eauto using bsteps_r |].
+ intros [|m'] [??]; [lia |]. apply Pstep with x'.
+ * apply bsteps_weaken with n; intuition lia.
+ * done.
+ * apply H; intuition lia.
+ Qed.
+
+ Lemma tc_transitive x y z : tc R x y → tc R y z → tc R x z.
+ Proof. induction 1; eauto. Qed.
+ Global Instance: Transitive (tc R).
+ Proof. exact tc_transitive. Qed.
+ Lemma tc_r x y z : tc R x y → R y z → tc R x z.
+ Proof. intros. etransitivity; eauto. Qed.
+ Lemma tc_rtc_l x y z : rtc R x y → tc R y z → tc R x z.
+ Proof. induction 1; eauto. Qed.
+ Lemma tc_rtc_r x y z : tc R x y → rtc R y z → tc R x z.
+ Proof. intros Hxy Hyz. revert x Hxy. induction Hyz; eauto using tc_r. Qed.
+ Lemma tc_rtc x y : tc R x y → rtc R x y.
+ Proof. induction 1; eauto. Qed.
+
+ Lemma all_loop_red x : all_loop R x → red R x.
+ Proof. destruct 1; auto. Qed.
+ Lemma all_loop_step x y : all_loop R x → R x y → all_loop R y.
+ Proof. destruct 1; auto. Qed.
+ Lemma all_loop_rtc x y : all_loop R x → rtc R x y → all_loop R y.
+ Proof. induction 2; eauto using all_loop_step. Qed.
+ Lemma all_loop_alt x :
+ all_loop R x ↔ ∀ y, rtc R x y → red R y.
+ Proof.
+ split; [eauto using all_loop_red, all_loop_rtc|].
+ intros H. cut (∀ z, rtc R x z → all_loop R z); [eauto|].
+ cofix FIX. constructor; eauto using rtc_r.
+ Qed.
+End rtc.
+
+Hint Constructors rtc nsteps bsteps tc : ars.
+Hint Resolve rtc_once rtc_r tc_r rtc_transitive tc_rtc_l tc_rtc_r
+ tc_rtc bsteps_once bsteps_r bsteps_refl bsteps_trans : ars.
+
+(** * Theorems on sub relations *)
+Section subrel.
+ Context {A} (R1 R2 : relation A).
+ Notation subrel := (∀ x y, R1 x y → R2 x y).
+ Lemma red_subrel x : subrel → red R1 x → red R2 x.
+ Proof. intros ? [y ?]; eauto. Qed.
+ Lemma nf_subrel x : subrel → nf R2 x → nf R1 x.
+ Proof. intros ? H1 H2; destruct H1; by apply red_subrel. Qed.
+End subrel.
+
+(** * Theorems on well founded relations *)
+Notation wf := well_founded.
+
+Section wf.
+ Context `{R : relation A}.
+
+ (** A trick by Thomas Braibant to compute with well-founded recursions:
+ it lazily adds [2^n] [Acc_intro] constructors in front of a well foundedness
+ proof, so that the actual proof is never reached in practise. *)
+ Fixpoint wf_guard (n : nat) (wfR : wf R) : wf R :=
+ match n with
+ | 0 => wfR
+ | S n => λ x, Acc_intro x (λ y _, wf_guard n (wf_guard n wfR) y)
+ end.
+
+ Lemma wf_projected `(R2 : relation B) (f : A → B) :
+ (∀ x y, R x y → R2 (f x) (f y)) →
+ wf R2 → wf R.
+ Proof.
+ intros Hf Hwf.
+ cut (∀ y, Acc R2 y → ∀ x, y = f x → Acc R x).
+ { intros aux x. apply (aux (f x)); auto. }
+ induction 1 as [y _ IH]. intros x ?. subst.
+ constructor. intros. apply (IH (f y)); auto.
+ Qed.
+End wf.
+
+(* Generally we do not want [wf_guard] to be expanded (neither by tactics,
+nor by conversion tests in the kernel), but in some cases we do need it for
+computation (that is, we cannot make it opaque). We use the [Strategy]
+command to make its expanding behavior less eager. *)
+Strategy 100 [wf_guard].
diff --git a/prelude/sets.v b/prelude/sets.v
new file mode 100644
index 0000000000000000000000000000000000000000..bd80b8eeb58b3374962750361f4591785cf0210d
--- /dev/null
+++ b/prelude/sets.v
@@ -0,0 +1,31 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file implements sets as functions into Prop. *)
+Require Export prelude.prelude.
+
+Record set (A : Type) : Type := mkSet { set_car : A → Prop }.
+Arguments mkSet {_} _.
+Arguments set_car {_} _ _.
+Definition set_all {A} : set A := mkSet (λ _, True).
+Instance set_empty {A} : Empty (set A) := mkSet (λ _, False).
+Instance set_singleton {A} : Singleton A (set A) := λ x, mkSet (x =).
+Instance set_elem_of {A} : ElemOf A (set A) := λ x X, set_car X x.
+Instance set_union {A} : Union (set A) := λ X1 X2, mkSet (λ x, x ∈ X1 ∨ x ∈ X2).
+Instance set_intersection {A} : Intersection (set A) := λ X1 X2,
+ mkSet (λ x, x ∈ X1 ∧ x ∈ X2).
+Instance set_difference {A} : Difference (set A) := λ X1 X2,
+ mkSet (λ x, x ∈ X1 ∧ x ∉ X2).
+Instance set_collection : Collection A (set A).
+Proof. by split; [split | |]; repeat intro. Qed.
+
+Instance set_ret : MRet set := λ A (x : A), {[ x ]}.
+Instance set_bind : MBind set := λ A B (f : A → set B) (X : set A),
+ mkSet (λ b, ∃ a, b ∈ f a ∧ a ∈ X).
+Instance set_fmap : FMap set := λ A B (f : A → B) (X : set A),
+ mkSet (λ b, ∃ a, b = f a ∧ a ∈ X).
+Instance set_join : MJoin set := λ A (XX : set (set A)),
+ mkSet (λ a, ∃ X, a ∈ X ∧ X ∈ XX).
+Instance set_collection_monad : CollectionMonad set.
+Proof. by split; try apply _. Qed.
+
+Global Opaque set_union set_intersection.
diff --git a/prelude/streams.v b/prelude/streams.v
new file mode 100644
index 0000000000000000000000000000000000000000..c660562cf3debb5545aaa6f1b901877e30cd7e5d
--- /dev/null
+++ b/prelude/streams.v
@@ -0,0 +1,55 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Export prelude.tactics.
+
+CoInductive stream (A : Type) : Type := scons : A → stream A → stream A.
+Arguments scons {_} _ _.
+Delimit Scope stream_scope with stream.
+Bind Scope stream_scope with stream.
+Open Scope stream_scope.
+Infix ":.:" := scons (at level 60, right associativity) : stream_scope.
+
+Definition shead {A} (s : stream A) : A := match s with x :.: _ => x end.
+Definition stail {A} (s : stream A) : stream A := match s with _ :.: s => s end.
+
+CoInductive stream_equiv' {A} (s1 s2 : stream A) : Prop :=
+ scons_equiv' :
+ shead s1 = shead s2 → stream_equiv' (stail s1) (stail s2) →
+ stream_equiv' s1 s2.
+Instance stream_equiv {A} : Equiv (stream A) := stream_equiv'.
+
+Reserved Infix "!.!" (at level 20).
+Fixpoint slookup {A} (i : nat) (s : stream A) : A :=
+ match i with O => shead s | S i => stail s !.! i end
+where "s !.! i" := (slookup i s).
+
+Global Instance stream_fmap : FMap stream := λ A B f,
+ cofix go s := f (shead s) :.: go (stail s).
+
+Fixpoint stake {A} (n : nat) (s : stream A) :=
+ match n with 0 => [] | S n => shead s :: stake n (stail s) end.
+CoFixpoint srepeat {A} (x : A) : stream A := x :.: srepeat x.
+
+Section stream_properties.
+Context {A : Type}.
+Implicit Types x y : A.
+Implicit Types s t : stream A.
+
+Lemma scons_equiv s1 s2 : shead s1 = shead s2 → stail s1 ≡ stail s2 → s1 ≡ s2.
+Proof. by constructor. Qed.
+Global Instance equal_equivalence : Equivalence (@equiv (stream A) _).
+Proof.
+ split.
+ * now cofix; intros [??]; constructor.
+ * now cofix; intros ?? [??]; constructor.
+ * cofix; intros ??? [??] [??]; constructor; etransitivity; eauto.
+Qed.
+Global Instance scons_proper x : Proper ((≡) ==> (≡)) (scons x).
+Proof. by constructor. Qed.
+Global Instance shead_proper : Proper ((≡) ==> (=)) (@shead A).
+Proof. by intros ?? [??]. Qed.
+Global Instance stail_proper : Proper ((≡) ==> (≡)) (@stail A).
+Proof. by intros ?? [??]. Qed.
+Global Instance slookup_proper : Proper ((≡) ==> eq) (@slookup A i).
+Proof. by induction i as [|i IH]; intros s1 s2 Hs; simpl; rewrite Hs. Qed.
+End stream_properties.
diff --git a/prelude/stringmap.v b/prelude/stringmap.v
new file mode 100644
index 0000000000000000000000000000000000000000..58c8862db6ee2fa19e0fa0622f26ffc496b49bd6
--- /dev/null
+++ b/prelude/stringmap.v
@@ -0,0 +1,61 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files implements an efficient implementation of finite maps whose keys
+range over Coq's data type of strings [string]. The implementation uses radix-2
+search trees (uncompressed Patricia trees) as implemented in the file [pmap]
+and guarantees logarithmic-time operations. *)
+Require Export prelude.fin_maps prelude.pretty.
+Require Import prelude.gmap.
+
+Notation stringmap := (gmap string).
+Notation stringset := (gset string).
+
+(** * Generating fresh strings *)
+Local Open Scope N_scope.
+Let R {A} (s : string) (m : stringmap A) (n1 n2 : N) :=
+ n2 < n1 ∧ is_Some (m !! (s +:+ pretty (n1 - 1))).
+Lemma fresh_string_step {A} s (m : stringmap A) n x :
+ m !! (s +:+ pretty n) = Some x → R s m (1 + n) n.
+Proof. split; [lia|]. replace (1 + n - 1) with n by lia; eauto. Qed.
+Lemma fresh_string_R_wf {A} s (m : stringmap A) : wf (R s m).
+Proof.
+ induction (map_wf m) as [m _ IH]. intros n1; constructor; intros n2 [Hn Hs].
+ specialize (IH _ (delete_subset m (s +:+ pretty (n2 - 1)) Hs) n2).
+ cut (n2 - 1 < n2); [|lia]. clear n1 Hn Hs; revert IH; generalize (n2 - 1).
+ intros n1. induction 1 as [n2 _ IH]; constructor; intros n3 [??].
+ apply IH; [|lia]; split; [lia|].
+ by rewrite lookup_delete_ne by (intros ?; simplify_equality'; lia).
+Qed.
+Definition fresh_string_go {A} (s : string) (m : stringmap A) (n : N)
+ (go : ∀ n', R s m n' n → string) : string :=
+ let s' := s +:+ pretty n in
+ match Some_dec (m !! s') with
+ | inleft (_↾Hs') => go (1 + n)%N (fresh_string_step s m n _ Hs')
+ | inright _ => s'
+ end.
+Definition fresh_string {A} (s : string) (m : stringmap A) : string :=
+ match m !! s with
+ | None => s
+ | Some _ =>
+ Fix_F _ (fresh_string_go s m) (wf_guard 32 (fresh_string_R_wf s m) 0)
+ end.
+Lemma fresh_string_fresh {A} (m : stringmap A) s : m !! fresh_string s m = None.
+Proof.
+ unfold fresh_string. destruct (m !! s) as [a|] eqn:Hs; [clear a Hs|done].
+ generalize 0 (wf_guard 32 (fresh_string_R_wf s m) 0); revert m.
+ fix 3; intros m n [?]; simpl; unfold fresh_string_go at 1; simpl.
+ destruct (Some_dec (m !! _)) as [[??]|?]; auto.
+Qed.
+Definition fresh_string_of_set (s : string) (X : stringset) : string :=
+ fresh_string s (mapset.mapset_car X).
+Lemma fresh_string_of_set_fresh (X : stringset) s : fresh_string_of_set s X ∉ X.
+Proof. apply eq_None_ne_Some, fresh_string_fresh. Qed.
+
+Fixpoint fresh_strings_of_set
+ (s : string) (n : nat) (X : stringset) : list string :=
+ match n with
+ | 0 => []
+ | S n =>
+ let x := fresh_string_of_set s X in
+ x :: fresh_strings_of_set s n ({[ x ]} ∪ X)
+ end%nat.
\ No newline at end of file
diff --git a/prelude/strings.v b/prelude/strings.v
new file mode 100644
index 0000000000000000000000000000000000000000..fd41ea2dee75363cae661bdb916fdc8aa5fe871d
--- /dev/null
+++ b/prelude/strings.v
@@ -0,0 +1,73 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+Require Import Ascii.
+Require Export String prelude.countable.
+
+(** * Fix scopes *)
+Open Scope string_scope.
+Open Scope list_scope.
+Infix "+:+" := String.append (at level 60, right associativity) : C_scope.
+Arguments String.append _ _ : simpl never.
+
+(** * Decision of equality *)
+Instance assci_eq_dec : ∀ a1 a2, Decision (a1 = a2) := ascii_dec.
+Instance string_eq_dec (s1 s2 : string) : Decision (s1 = s2).
+Proof. solve_decision. Defined.
+Instance: Injective (=) (=) (String.append s1).
+Proof. intros s1 ???. induction s1; simplify_equality'; f_equal'; auto. Qed.
+
+(* Reverse *)
+Fixpoint string_rev_app (s1 s2 : string) : string :=
+ match s1 with
+ | "" => s2
+ | String a s1 => string_rev_app s1 (String a s2)
+ end.
+Definition string_rev (s : string) : string := string_rev_app s "".
+
+(** * Encoding and decoding *)
+(** In order to reuse or existing implementation of radix-2 search trees over
+positive binary naturals [positive], we define an injection [string_to_pos]
+from [string] into [positive]. *)
+Fixpoint digits_to_pos (βs : list bool) : positive :=
+ match βs with
+ | [] => xH
+ | false :: βs => (digits_to_pos βs)~0
+ | true :: βs => (digits_to_pos βs)~1
+ end%positive.
+Definition ascii_to_digits (a : Ascii.ascii) : list bool :=
+ match a with
+ | Ascii.Ascii β1 β2 β3 β4 β5 β6 β7 β8 => [β1;β2;β3;β4;β5;β6;β7;β8]
+ end.
+Fixpoint string_to_pos (s : string) : positive :=
+ match s with
+ | EmptyString => xH
+ | String a s => string_to_pos s ++ digits_to_pos (ascii_to_digits a)
+ end%positive.
+Fixpoint digits_of_pos (p : positive) : list bool :=
+ match p with
+ | xH => []
+ | p~0 => false :: digits_of_pos p
+ | p~1 => true :: digits_of_pos p
+ end%positive.
+Fixpoint ascii_of_digits (βs : list bool) : ascii :=
+ match βs with
+ | [] => zero
+ | β :: βs => Ascii.shift β (ascii_of_digits βs)
+ end.
+Fixpoint string_of_digits (βs : list bool) : string :=
+ match βs with
+ | β1 :: β2 :: β3 :: β4 :: β5 :: β6 :: β7 :: β8 :: βs =>
+ String (ascii_of_digits [β1;β2;β3;β4;β5;β6;β7;β8]) (string_of_digits βs)
+ | _ => EmptyString
+ end.
+Definition string_of_pos (p : positive) : string :=
+ string_of_digits (digits_of_pos p).
+Lemma string_of_to_pos s : string_of_pos (string_to_pos s) = s.
+Proof.
+ unfold string_of_pos. by induction s as [|[[][][][][][][][]]]; f_equal'.
+Qed.
+Program Instance string_countable : Countable string := {|
+ encode := string_to_pos; decode p := Some (string_of_pos p)
+|}.
+Solve Obligations with naive_solver eauto using string_of_to_pos with f_equal.
+
diff --git a/prelude/tactics.v b/prelude/tactics.v
new file mode 100644
index 0000000000000000000000000000000000000000..d5867ab6d90799e057fcc031ce9dc682005944e1
--- /dev/null
+++ b/prelude/tactics.v
@@ -0,0 +1,376 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects general purpose tactics that are used throughout
+the development. *)
+Require Import Omega.
+Require Export Psatz.
+Require Export prelude.base.
+
+Lemma f_equal_dep {A B} (f g : ∀ x : A, B x) x : f = g → f x = g x.
+Proof. intros ->; reflexivity. Qed.
+Lemma f_equal_help {A B} (f g : A → B) x y : f = g → x = y → f x = g y.
+Proof. intros -> ->; reflexivity. Qed.
+Ltac f_equal :=
+ let rec go :=
+ match goal with
+ | _ => reflexivity
+ | _ => apply f_equal_help; [go|try reflexivity]
+ | |- ?f ?x = ?g ?x => apply (f_equal_dep f g); go
+ end in
+ try go.
+
+(** We declare hint databases [f_equal], [congruence] and [lia] and containing
+solely the tactic corresponding to its name. These hint database are useful in
+to be combined in combination with other hint database. *)
+Hint Extern 998 (_ = _) => f_equal : f_equal.
+Hint Extern 999 => congruence : congruence.
+Hint Extern 1000 => lia : lia.
+Hint Extern 1000 => omega : omega.
+
+(** The tactic [intuition] expands to [intuition auto with *] by default. This
+is rather efficient when having big hint databases, or expensive [Hint Extern]
+declarations as the above. *)
+Tactic Notation "intuition" := intuition auto.
+
+(** A slightly modified version of Ssreflect's finishing tactic [done]. It
+also performs [reflexivity] and uses symmetry of negated equalities. Compared
+to Ssreflect's [done], it does not compute the goal's [hnf] so as to avoid
+unfolding setoid equalities. Note that this tactic performs much better than
+Coq's [easy] tactic as it does not perform [inversion]. *)
+Ltac done :=
+ trivial; intros; solve
+ [ repeat first
+ [ solve [trivial]
+ | solve [symmetry; trivial]
+ | reflexivity
+ | discriminate
+ | contradiction
+ | solve [apply not_symmetry; trivial]
+ | split ]
+ | match goal with H : ¬_ |- _ => solve [destruct H; trivial] end ].
+Tactic Notation "by" tactic(tac) :=
+ tac; done.
+
+(** Whereas the [split] tactic splits any inductive with one constructor, the
+tactic [split_and] only splits a conjunction. *)
+Ltac split_and := match goal with |- _ ∧ _ => split end.
+Ltac split_ands := repeat split_and.
+Ltac split_ands' := repeat (hnf; split_and).
+
+(** The tactic [case_match] destructs an arbitrary match in the conclusion or
+assumptions, and generates a corresponding equality. This tactic is best used
+together with the [repeat] tactical. *)
+Ltac case_match :=
+ match goal with
+ | H : context [ match ?x with _ => _ end ] |- _ => destruct x eqn:?
+ | |- context [ match ?x with _ => _ end ] => destruct x eqn:?
+ end.
+
+(** The tactic [unless T by tac_fail] succeeds if [T] is not provable by
+the tactic [tac_fail]. *)
+Tactic Notation "unless" constr(T) "by" tactic3(tac_fail) :=
+ first [assert T by tac_fail; fail 1 | idtac].
+
+(** The tactic [repeat_on_hyps tac] repeatedly applies [tac] in unspecified
+order on all hypotheses until it cannot be applied to any hypothesis anymore. *)
+Tactic Notation "repeat_on_hyps" tactic3(tac) :=
+ repeat match goal with H : _ |- _ => progress tac H end.
+
+(** The tactic [clear dependent H1 ... Hn] clears the hypotheses [Hi] and
+their dependencies. *)
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) :=
+ clear dependent H1; clear dependent H2.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) :=
+ clear dependent H1 H2; clear dependent H3.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) :=
+ clear dependent H1 H2 H3; clear dependent H4.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4)
+ hyp(H5) := clear dependent H1 H2 H3 H4; clear dependent H5.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5)
+ hyp (H6) := clear dependent H1 H2 H3 H4 H5; clear dependent H6.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5)
+ hyp (H6) hyp(H7) := clear dependent H1 H2 H3 H4 H5 H6; clear dependent H7.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5)
+ hyp (H6) hyp(H7) hyp(H8) :=
+ clear dependent H1 H2 H3 H4 H5 H6 H7; clear dependent H8.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5)
+ hyp (H6) hyp(H7) hyp(H8) hyp(H9) :=
+ clear dependent H1 H2 H3 H4 H5 H6 H7 H8; clear dependent H9.
+Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5)
+ hyp (H6) hyp(H7) hyp(H8) hyp(H9) hyp(H10) :=
+ clear dependent H1 H2 H3 H4 H5 H6 H7 H8 H9; clear dependent H10.
+
+(** The tactic [is_non_dependent H] determines whether the goal's conclusion or
+hypotheses depend on [H]. *)
+Tactic Notation "is_non_dependent" constr(H) :=
+ match goal with
+ | _ : context [ H ] |- _ => fail 1
+ | |- context [ H ] => fail 1
+ | _ => idtac
+ end.
+
+(** The tactic [var_eq x y] fails if [x] and [y] are unequal, and [var_neq]
+does the converse. *)
+Ltac var_eq x1 x2 := match x1 with x2 => idtac | _ => fail 1 end.
+Ltac var_neq x1 x2 := match x1 with x2 => fail 1 | _ => idtac end.
+
+(** The tactics [block_hyps] and [unblock_hyps] can be used to temporarily mark
+certain hypothesis as being blocked. The tactic changes all hypothesis [H: T]
+into [H: blocked T], where [blocked] is the identity function. If a hypothesis
+is already blocked, it will not be blocked again. The tactic [unblock_hyps]
+removes [blocked] everywhere. *)
+
+Ltac block_hyp H :=
+ lazymatch type of H with
+ | block _ => idtac | ?T => change T with (block T) in H
+ end.
+Ltac block_hyps := repeat_on_hyps (fun H =>
+ match type of H with block _ => idtac | ?T => change (block T) in H end).
+Ltac unblock_hyps := unfold block in * |-.
+
+(** The tactic [injection' H] is a variant of injection that introduces the
+generated equalities. *)
+Ltac injection' H :=
+ block_goal; injection H; clear H; intros H; intros; unblock_goal.
+
+(** The tactic [simplify_equality] repeatedly substitutes, discriminates,
+and injects equalities, and tries to contradict impossible inequalities. *)
+Ltac fold_classes :=
+ repeat match goal with
+ | |- appcontext [ ?F ] =>
+ progress match type of F with
+ | FMap _ =>
+ change F with (@fmap _ F);
+ repeat change (@fmap _ (@fmap _ F)) with (@fmap _ F)
+ | MBind _ =>
+ change F with (@mbind _ F);
+ repeat change (@mbind _ (@mbind _ F)) with (@mbind _ F)
+ | OMap _ =>
+ change F with (@omap _ F);
+ repeat change (@omap _ (@omap _ F)) with (@omap _ F)
+ | Alter _ _ _ =>
+ change F with (@alter _ _ _ F);
+ repeat change (@alter _ _ _ (@alter _ _ _ F)) with (@alter _ _ _ F)
+ end
+ end.
+Ltac fold_classes_hyps H :=
+ repeat match type of H with
+ | appcontext [ ?F ] =>
+ progress match type of F with
+ | FMap _ =>
+ change F with (@fmap _ F) in H;
+ repeat change (@fmap _ (@fmap _ F)) with (@fmap _ F) in H
+ | MBind _ =>
+ change F with (@mbind _ F) in H;
+ repeat change (@mbind _ (@mbind _ F)) with (@mbind _ F) in H
+ | OMap _ =>
+ change F with (@omap _ F) in H;
+ repeat change (@omap _ (@omap _ F)) with (@omap _ F) in H
+ | Alter _ _ _ =>
+ change F with (@alter _ _ _ F) in H;
+ repeat change (@alter _ _ _ (@alter _ _ _ F)) with (@alter _ _ _ F) in H
+ end
+ end.
+Tactic Notation "csimpl" "in" hyp(H) :=
+ try (progress simpl in H; fold_classes_hyps H).
+Tactic Notation "csimpl" := try (progress simpl; fold_classes).
+Tactic Notation "csimpl" "in" "*" :=
+ repeat_on_hyps (fun H => csimpl in H); csimpl.
+
+Ltac simplify_equality := repeat
+ match goal with
+ | H : _ ≠_ |- _ => by destruct H
+ | H : _ = _ → False |- _ => by destruct H
+ | H : ?x = _ |- _ => subst x
+ | H : _ = ?x |- _ => subst x
+ | H : _ = _ |- _ => discriminate H
+ | H : ?f _ = ?f _ |- _ => apply (injective f) in H
+ | H : ?f _ _ = ?f _ _ |- _ => apply (injective2 f) in H; destruct H
+ (* before [injection'] to circumvent bug #2939 in some situations *)
+ | H : ?f _ = ?f _ |- _ => injection' H
+ | H : ?f _ _ = ?f _ _ |- _ => injection' H
+ | H : ?f _ _ _ = ?f _ _ _ |- _ => injection' H
+ | H : ?f _ _ _ _ = ?f _ _ _ _ |- _ => injection' H
+ | H : ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _ => injection' H
+ | H : ?f _ _ _ _ _ _ = ?f _ _ _ _ _ _ |- _ => injection' H
+ | H : ?x = ?x |- _ => clear H
+ (* unclear how to generalize the below *)
+ | H1 : ?o = Some ?x, H2 : ?o = Some ?y |- _ =>
+ assert (y = x) by congruence; clear H2
+ | H1 : ?o = Some ?x, H2 : ?o = None |- _ => congruence
+ end.
+Ltac simplify_equality' := repeat (progress csimpl in * || simplify_equality).
+Ltac f_equal' := csimpl in *; f_equal.
+Ltac f_lia :=
+ repeat lazymatch goal with
+ | |- @eq BinNums.Z _ _ => lia
+ | |- @eq nat _ _ => lia
+ | |- _ => f_equal
+ end.
+Ltac f_lia' := csimpl in *; f_lia.
+
+Ltac setoid_subst_aux R x :=
+ match goal with
+ | H : R x ?y |- _ =>
+ is_var x;
+ try match y with x _ => fail 2 end;
+ repeat match goal with
+ | |- context [ x ] => setoid_rewrite H
+ | H' : context [ x ] |- _ =>
+ try match H' with H => fail 2 end;
+ setoid_rewrite H in H'
+ end;
+ clear x H
+ end.
+Ltac setoid_subst :=
+ repeat match goal with
+ | _ => progress simplify_equality'
+ | H : @equiv ?A ?e ?x _ |- _ => setoid_subst_aux (@equiv A e) x
+ | H : @equiv ?A ?e _ ?x |- _ => symmetry in H; setoid_subst_aux (@equiv A e) x
+ end.
+
+(** Given a tactic [tac2] generating a list of terms, [iter tac1 tac2]
+runs [tac x] for each element [x] until [tac x] succeeds. If it does not
+suceed for any element of the generated list, the whole tactic wil fail. *)
+Tactic Notation "iter" tactic(tac) tactic(l) :=
+ let rec go l :=
+ match l with ?x :: ?l => tac x || go l end in go l.
+
+(** Given H : [A_1 → ... → A_n → B] (where each [A_i] is non-dependent), the
+tactic [feed tac H tac_by] creates a subgoal for each [A_i] and calls [tac p]
+with the generated proof [p] of [B]. *)
+Tactic Notation "feed" tactic(tac) constr(H) :=
+ let rec go H :=
+ let T := type of H in
+ lazymatch eval hnf in T with
+ | ?T1 → ?T2 =>
+ (* Use a separate counter for fresh names to make it more likely that
+ the generated name is "fresh" with respect to those generated before
+ calling the [feed] tactic. In particular, this hack makes sure that
+ tactics like [let H' := fresh in feed (fun p => pose proof p as H') H] do
+ not break. *)
+ let HT1 := fresh "feed" in assert T1 as HT1;
+ [| go (H HT1); clear HT1 ]
+ | ?T1 => tac H
+ end in go H.
+
+(** The tactic [efeed tac H] is similar to [feed], but it also instantiates
+dependent premises of [H] with evars. *)
+Tactic Notation "efeed" constr(H) "using" tactic3(tac) "by" tactic3 (bytac) :=
+ let rec go H :=
+ let T := type of H in
+ lazymatch eval hnf in T with
+ | ?T1 → ?T2 =>
+ let HT1 := fresh "feed" in assert T1 as HT1;
+ [bytac | go (H HT1); clear HT1 ]
+ | ?T1 → _ =>
+ let e := fresh "feed" in evar (e:T1);
+ let e' := eval unfold e in e in
+ clear e; go (H e')
+ | ?T1 => tac H
+ end in go H.
+Tactic Notation "efeed" constr(H) "using" tactic3(tac) :=
+ efeed H using tac by idtac.
+
+(** The following variants of [pose proof], [specialize], [inversion], and
+[destruct], use the [feed] tactic before invoking the actual tactic. *)
+Tactic Notation "feed" "pose" "proof" constr(H) "as" ident(H') :=
+ feed (fun p => pose proof p as H') H.
+Tactic Notation "feed" "pose" "proof" constr(H) :=
+ feed (fun p => pose proof p) H.
+
+Tactic Notation "efeed" "pose" "proof" constr(H) "as" ident(H') :=
+ efeed H using (fun p => pose proof p as H').
+Tactic Notation "efeed" "pose" "proof" constr(H) :=
+ efeed H using (fun p => pose proof p).
+
+Tactic Notation "feed" "specialize" hyp(H) :=
+ feed (fun p => specialize p) H.
+Tactic Notation "efeed" "specialize" hyp(H) :=
+ efeed H using (fun p => specialize p).
+
+Tactic Notation "feed" "inversion" constr(H) :=
+ feed (fun p => let H':=fresh in pose proof p as H'; inversion H') H.
+Tactic Notation "feed" "inversion" constr(H) "as" simple_intropattern(IP) :=
+ feed (fun p => let H':=fresh in pose proof p as H'; inversion H' as IP) H.
+
+Tactic Notation "feed" "destruct" constr(H) :=
+ feed (fun p => let H':=fresh in pose proof p as H'; destruct H') H.
+Tactic Notation "feed" "destruct" constr(H) "as" simple_intropattern(IP) :=
+ feed (fun p => let H':=fresh in pose proof p as H'; destruct H' as IP) H.
+
+(** Coq's [firstorder] tactic fails or loops on rather small goals already. In
+particular, on those generated by the tactic [unfold_elem_ofs] which is used
+to solve propositions on collections. The [naive_solver] tactic implements an
+ad-hoc and incomplete [firstorder]-like solver using Ltac's backtracking
+mechanism. The tactic suffers from the following limitations:
+- It might leave unresolved evars as Ltac provides no way to detect that.
+- To avoid the tactic becoming too slow, we allow a universally quantified
+ hypothesis to be instantiated only once during each search path.
+- It does not perform backtracking on instantiation of universally quantified
+ assumptions.
+
+We use a counter to make the search breath first. Breath first search ensures
+that a minimal number of hypotheses is instantiated, and thus reduced the
+posibility that an evar remains unresolved.
+
+Despite these limitations, it works much better than Coq's [firstorder] tactic
+for the purposes of this development. This tactic either fails or proves the
+goal. *)
+Lemma forall_and_distr (A : Type) (P Q : A → Prop) :
+ (∀ x, P x ∧ Q x) ↔ (∀ x, P x) ∧ (∀ x, Q x).
+Proof. firstorder. Qed.
+
+Tactic Notation "naive_solver" tactic(tac) :=
+ unfold iff, not in *;
+ repeat match goal with
+ | H : context [∀ _, _ ∧ _ ] |- _ =>
+ repeat setoid_rewrite forall_and_distr in H; revert H
+ end;
+ let rec go n :=
+ repeat match goal with
+ (**i intros *)
+ | |- ∀ _, _ => intro
+ (**i simplification of assumptions *)
+ | H : False |- _ => destruct H
+ | H : _ ∧ _ |- _ => destruct H
+ | H : ∃ _, _ |- _ => destruct H
+ | H : ?P → ?Q, H2 : ?P |- _ => specialize (H H2)
+ (**i simplify and solve equalities *)
+ | |- _ => progress simplify_equality'
+ (**i solve the goal *)
+ | |- _ =>
+ solve
+ [ eassumption
+ | symmetry; eassumption
+ | apply not_symmetry; eassumption
+ | reflexivity ]
+ (**i operations that generate more subgoals *)
+ | |- _ ∧ _ => split
+ | H : _ ∨ _ |- _ => destruct H
+ (**i solve the goal using the user supplied tactic *)
+ | |- _ => solve [tac]
+ end;
+ (**i use recursion to enable backtracking on the following clauses. *)
+ match goal with
+ (**i instantiation of the conclusion *)
+ | |- ∃ x, _ => eexists; go n
+ | |- _ ∨ _ => first [left; go n | right; go n]
+ | _ =>
+ (**i instantiations of assumptions. *)
+ lazymatch n with
+ | S ?n' =>
+ (**i we give priority to assumptions that fit on the conclusion. *)
+ match goal with
+ | H : _ → _ |- _ =>
+ is_non_dependent H;
+ eapply H; clear H; go n'
+ | H : _ → _ |- _ =>
+ is_non_dependent H;
+ try (eapply H; fail 2);
+ efeed pose proof H; clear H; go n'
+ end
+ end
+ end
+ in iter (fun n' => go n') (eval compute in (seq 0 6)).
+Tactic Notation "naive_solver" := naive_solver eauto.
diff --git a/prelude/vector.v b/prelude/vector.v
new file mode 100644
index 0000000000000000000000000000000000000000..da77f8fd936010db1d0f13fb1ec49117126231e1
--- /dev/null
+++ b/prelude/vector.v
@@ -0,0 +1,330 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This file collects general purpose definitions and theorems on vectors
+(lists of fixed length) and the fin type (bounded naturals). It uses the
+definitions from the standard library, but renames or changes their notations,
+so that it becomes more consistent with the naming conventions in this
+development. *)
+Require Import prelude.list prelude.finite.
+Open Scope vector_scope.
+
+(** * The fin type *)
+(** The type [fin n] represents natural numbers [i] with [0 ≤ i < n]. We
+define a scope [fin], in which we declare notations for small literals of the
+[fin] type. Whereas the standard library starts counting at [1], we start
+counting at [0]. This way, the embedding [fin_to_nat] preserves [0], and allows
+us to define [fin_to_nat] as a coercion without introducing notational
+ambiguity. *)
+Notation fin := Fin.t.
+Notation FS := Fin.FS.
+
+Delimit Scope fin_scope with fin.
+Arguments Fin.FS _ _%fin.
+
+Notation "0" := Fin.F1 : fin_scope. Notation "1" := (FS 0) : fin_scope.
+Notation "2" := (FS 1) : fin_scope. Notation "3" := (FS 2) : fin_scope.
+Notation "4" := (FS 3) : fin_scope. Notation "5" := (FS 4) : fin_scope.
+Notation "6" := (FS 5) : fin_scope. Notation "7" := (FS 6) : fin_scope.
+Notation "8" := (FS 7) : fin_scope. Notation "9" := (FS 8) : fin_scope.
+Notation "10" := (FS 9) : fin_scope.
+
+Fixpoint fin_to_nat {n} (i : fin n) : nat :=
+ match i with 0%fin => 0 | FS _ i => S (fin_to_nat i) end.
+Coercion fin_to_nat : fin >-> nat.
+
+Notation fin_of_nat := Fin.of_nat_lt.
+Notation fin_rect2 := Fin.rect2.
+
+Instance fin_dec {n} : ∀ i j : fin n, Decision (i = j).
+Proof.
+ refine (fin_rect2
+ (λ n (i j : fin n), { i = j } + { i ≠j })
+ (λ _, left _)
+ (λ _ _, right _)
+ (λ _ _, right _)
+ (λ _ _ _ H, cast_if H));
+ abstract (f_equal; by auto using Fin.FS_inj).
+Defined.
+
+(** The inversion principle [fin_S_inv] is more convenient than its variant
+[Fin.caseS] in the standard library, as we keep the parameter [n] fixed.
+In the tactic [inv_fin i] to perform dependent case analysis on [i], we
+therefore do not have to generalize over the index [n] and all assumptions
+depending on it. Notice that contrary to [dependent destruction], which uses
+the [JMeq_eq] axiom, the tactic [inv_fin] produces axiom free proofs.*)
+Notation fin_0_inv := Fin.case0.
+
+Definition fin_S_inv {n} (P : fin (S n) → Type)
+ (H0 : P 0%fin) (HS : ∀ i, P (FS i)) (i : fin (S n)) : P i.
+Proof.
+ revert P H0 HS.
+ refine match i with 0%fin => λ _ H0 _, H0 | FS _ i => λ _ _ HS, HS i end.
+Defined.
+
+Ltac inv_fin i :=
+ match type of i with
+ | fin 0 =>
+ revert dependent i; match goal with |- ∀ i, @?P i => apply (fin_0_inv P) end
+ | fin (S ?n) =>
+ revert dependent i; match goal with |- ∀ i, @?P i => apply (fin_S_inv P) end
+ end.
+
+Instance: Injective (=) (=) (@FS n).
+Proof. intros n i j. apply Fin.FS_inj. Qed.
+Instance: Injective (=) (=) (@fin_to_nat n).
+Proof.
+ intros n i. induction i; intros j; inv_fin j; intros; f_equal'; auto with lia.
+Qed.
+Lemma fin_to_nat_lt {n} (i : fin n) : fin_to_nat i < n.
+Proof. induction i; simpl; lia. Qed.
+Lemma fin_to_of_nat n m (H : n < m) : fin_to_nat (Fin.of_nat_lt H) = n.
+Proof.
+ revert m H. induction n; intros [|?]; simpl; auto; intros; exfalso; lia.
+Qed.
+
+Fixpoint fin_enum (n : nat) : list (fin n) :=
+ match n with 0 => [] | S n => 0%fin :: FS <$> fin_enum n end.
+Program Instance fin_finite n : Finite (fin n) := {| enum := fin_enum n |}.
+Next Obligation.
+ intros n. induction n; simpl; constructor.
+ * rewrite elem_of_list_fmap. by intros (?&?&?).
+ * by apply (NoDup_fmap _).
+Qed.
+Next Obligation.
+ intros n i. induction i as [|n i IH]; simpl;
+ rewrite elem_of_cons, ?elem_of_list_fmap; eauto.
+Qed.
+Lemma fin_card n : card (fin n) = n.
+Proof. unfold card; simpl. induction n; simpl; rewrite ?fmap_length; auto. Qed.
+
+(** * Vectors *)
+(** The type [vec n] represents lists of consisting of exactly [n] elements.
+Whereas the standard library declares exactly the same notations for vectors as
+used for lists, we use slightly different notations so it becomes easier to use
+lists and vectors together. *)
+Notation vec := Vector.t.
+Notation vnil := Vector.nil.
+Arguments vnil {_}.
+Notation vcons := Vector.cons.
+Notation vapp := Vector.append.
+Arguments vcons {_} _ {_} _.
+
+Infix ":::" := vcons (at level 60, right associativity) : vector_scope.
+Notation "(:::)" := vcons (only parsing) : vector_scope.
+Notation "( x :::)" := (vcons x) (only parsing) : vector_scope.
+Notation "(::: v )" := (λ x, vcons x v) (only parsing) : vector_scope.
+Notation "[# ] " := vnil : vector_scope.
+Notation "[# x ] " := (vcons x vnil) : vector_scope.
+Notation "[# x ; .. ; y ] " := (vcons x .. (vcons y vnil) ..) : vector_scope.
+Infix "+++" := vapp (at level 60, right associativity) : vector_scope.
+Notation "(+++)" := vapp (only parsing) : vector_scope.
+Notation "( v +++)" := (vapp v) (only parsing) : vector_scope.
+Notation "(+++ w )" := (λ v, vapp v w) (only parsing) : vector_scope.
+
+(** Notice that we cannot define [Vector.nth] as an instance of our [Lookup]
+type class, as it has a dependent type. *)
+Arguments Vector.nth {_ _} !_ !_%fin /.
+Infix "!!!" := Vector.nth (at level 20) : vector_scope.
+
+(** The tactic [vec_double_ind v1 v2] performs double induction on [v1] and [v2]
+provided that they have the same length. *)
+Notation vec_rect2 := Vector.rect2.
+Ltac vec_double_ind v1 v2 :=
+ match type of v1 with
+ | vec _ ?n =>
+ repeat match goal with
+ | H' : context [ n ] |- _ => var_neq v1 H'; var_neq v2 H'; revert H'
+ end;
+ revert n v1 v2;
+ match goal with |- ∀ n v1 v2, @?P n v1 v2 => apply (vec_rect2 P) end
+ end.
+
+Notation vcons_inj := VectorSpec.cons_inj.
+Lemma vcons_inj_1 {A n} x y (v w : vec A n) : x ::: v = y ::: w → x = y.
+Proof. apply vcons_inj. Qed.
+Lemma vcons_inj_2 {A n} x y (v w : vec A n) : x ::: v = y ::: w → v = w.
+Proof. apply vcons_inj. Qed.
+
+Lemma vec_eq {A n} (v w : vec A n) : (∀ i, v !!! i = w !!! i) → v = w.
+Proof.
+ vec_double_ind v w; [done|]. intros n v w IH x y Hi. f_equal.
+ * apply (Hi 0%fin).
+ * apply IH. intros i. apply (Hi (FS i)).
+Qed.
+
+Instance vec_dec {A} {dec : ∀ x y : A, Decision (x = y)} {n} :
+ ∀ v w : vec A n, Decision (v = w).
+Proof.
+ refine (vec_rect2
+ (λ n (v w : vec A n), { v = w } + { v ≠w })
+ (left _)
+ (λ _ _ _ H x y, cast_if_and (dec x y) H));
+ f_equal; eauto using vcons_inj_1, vcons_inj_2.
+Defined.
+
+(** Similar to [fin], we provide an inversion principle that keeps the length
+fixed. We define a tactic [inv_vec v] to perform case analysis on [v], using
+this inversion principle. *)
+Notation vec_0_inv := Vector.case0.
+Definition vec_S_inv {A n} (P : vec A (S n) → Type)
+ (Hcons : ∀ x v, P (x ::: v)) v : P v.
+Proof.
+ revert P Hcons.
+ refine match v with [#] => tt | x ::: v => λ P Hcons, Hcons x v end.
+Defined.
+
+Ltac inv_vec v :=
+ match type of v with
+ | vec _ 0 =>
+ revert dependent v; match goal with |- ∀ v, @?P v => apply (vec_0_inv P) end
+ | vec _ (S ?n) =>
+ revert dependent v; match goal with |- ∀ v, @?P v => apply (vec_S_inv P) end
+ end.
+
+(** The following tactic performs case analysis on all hypotheses of the shape
+[fin 0], [fin (S n)], [vec A 0] and [vec A (S n)] until no further case
+analyses are possible. *)
+Ltac inv_all_vec_fin := block_goal;
+ repeat match goal with
+ | v : vec _ _ |- _ => inv_vec v; intros
+ | i : fin _ |- _ => inv_fin i; intros
+ end; unblock_goal.
+
+(** We define a coercion from [vec] to [list] and show that it preserves the
+operations on vectors. We also define a function to go in the other way, but
+do not define it as a coercion, as it would otherwise introduce ambiguity. *)
+Fixpoint vec_to_list {A n} (v : vec A n) : list A :=
+ match v with [#] => [] | x ::: v => x :: vec_to_list v end.
+Coercion vec_to_list : vec >-> list.
+Notation list_to_vec := Vector.of_list.
+
+Lemma vec_to_list_cons {A n} x (v : vec A n) :
+ vec_to_list (x ::: v) = x :: vec_to_list v.
+Proof. done. Qed.
+Lemma vec_to_list_app {A n m} (v : vec A n) (w : vec A m) :
+ vec_to_list (v +++ w) = vec_to_list v ++ vec_to_list w.
+Proof. by induction v; f_equal'. Qed.
+Lemma vec_to_list_of_list {A} (l : list A): vec_to_list (list_to_vec l) = l.
+Proof. by induction l; f_equal'. Qed.
+Lemma vec_to_list_length {A n} (v : vec A n) : length (vec_to_list v) = n.
+Proof. induction v; simpl; by f_equal. Qed.
+Lemma vec_to_list_same_length {A B n} (v : vec A n) (w : vec B n) :
+ length v = length w.
+Proof. by rewrite !vec_to_list_length. Qed.
+Lemma vec_to_list_inj1 {A n m} (v : vec A n) (w : vec A m) :
+ vec_to_list v = vec_to_list w → n = m.
+Proof.
+ revert m w. induction v; intros ? [|???] ?;
+ simplify_equality'; f_equal; eauto.
+Qed.
+Lemma vec_to_list_inj2 {A n} (v : vec A n) (w : vec A n) :
+ vec_to_list v = vec_to_list w → v = w.
+Proof.
+ revert w. induction v; intros w; inv_vec w; intros;
+ simplify_equality'; f_equal; eauto.
+Qed.
+Lemma vlookup_middle {A n m} (v : vec A n) (w : vec A m) x :
+ ∃ i : fin (n + S m), x = (v +++ x ::: w) !!! i.
+Proof.
+ induction v; simpl; [by eexists 0%fin|].
+ destruct IHv as [i ?]. by exists (FS i).
+Qed.
+Lemma vec_to_list_lookup_middle {A n} (v : vec A n) (l k : list A) x :
+ vec_to_list v = l ++ x :: k →
+ ∃ i : fin n, l = take i v ∧ x = v !!! i ∧ k = drop (S i) v.
+Proof.
+ intros H.
+ rewrite <-(vec_to_list_of_list l), <-(vec_to_list_of_list k) in H.
+ rewrite <-vec_to_list_cons, <-vec_to_list_app in H.
+ pose proof (vec_to_list_inj1 _ _ H); subst.
+ apply vec_to_list_inj2 in H; subst. induction l. simpl.
+ * eexists 0%fin. simpl. by rewrite vec_to_list_of_list.
+ * destruct IHl as [i ?]. exists (FS i). simpl. intuition congruence.
+Qed.
+Lemma vec_to_list_drop_lookup {A n} (v : vec A n) (i : fin n) :
+ drop i v = v !!! i :: drop (S i) v.
+Proof. induction i; inv_vec v; simpl; intros; [done | by rewrite IHi]. Qed.
+Lemma vec_to_list_take_drop_lookup {A n} (v : vec A n) (i : fin n) :
+ vec_to_list v = take i v ++ v !!! i :: drop (S i) v.
+Proof. rewrite <-(take_drop i v) at 1. by rewrite vec_to_list_drop_lookup. Qed.
+
+Lemma elem_of_vlookup {A n} (v : vec A n) x :
+ x ∈ vec_to_list v ↔ ∃ i, v !!! i = x.
+Proof.
+ split.
+ * induction v; simpl; [by rewrite elem_of_nil |].
+ inversion 1; subst; [by eexists 0%fin|].
+ destruct IHv as [i ?]; trivial. by exists (FS i).
+ * intros [i ?]; subst. induction v as [|??? IH]; inv_fin i; [by left|].
+ right; apply IH.
+Qed.
+Lemma Forall_vlookup {A} (P : A → Prop) {n} (v : vec A n) :
+ Forall P (vec_to_list v) ↔ ∀ i, P (v !!! i).
+Proof. rewrite Forall_forall. setoid_rewrite elem_of_vlookup. naive_solver. Qed.
+Lemma Forall_vlookup_1 {A} (P : A → Prop) {n} (v : vec A n) i :
+ Forall P (vec_to_list v) → P (v !!! i).
+Proof. by rewrite Forall_vlookup. Qed.
+Lemma Forall_vlookup_2 {A} (P : A → Prop) {n} (v : vec A n) :
+ (∀ i, P (v !!! i)) → Forall P (vec_to_list v).
+Proof. by rewrite Forall_vlookup. Qed.
+Lemma Exists_vlookup {A} (P : A → Prop) {n} (v : vec A n) :
+ Exists P (vec_to_list v) ↔ ∃ i, P (v !!! i).
+Proof. rewrite Exists_exists. setoid_rewrite elem_of_vlookup. naive_solver. Qed.
+Lemma Forall2_vlookup {A B} (P : A → B → Prop) {n}
+ (v1 : vec A n) (v2 : vec B n) :
+ Forall2 P (vec_to_list v1) (vec_to_list v2) ↔ ∀ i, P (v1 !!! i) (v2 !!! i).
+Proof.
+ split.
+ * vec_double_ind v1 v2; [intros _ i; inv_fin i |].
+ intros n v1 v2 IH a b; simpl. inversion_clear 1.
+ intros i. inv_fin i; simpl; auto.
+ * vec_double_ind v1 v2; [constructor|].
+ intros ??? IH ?? H. constructor. apply (H 0%fin). apply IH, (λ i, H (FS i)).
+Qed.
+
+(** The function [vmap f v] applies a function [f] element wise to [v]. *)
+Notation vmap := Vector.map.
+
+Lemma vlookup_map `(f : A → B) {n} (v : vec A n) i :
+ vmap f v !!! i = f (v !!! i).
+Proof. by apply Vector.nth_map. Qed.
+Lemma vec_to_list_map `(f : A → B) {n} (v : vec A n) :
+ vec_to_list (vmap f v) = f <$> vec_to_list v.
+Proof. induction v; simpl. done. by rewrite IHv. Qed.
+
+(** The function [vzip_with f v w] combines the vectors [v] and [w] element
+wise using the function [f]. *)
+Notation vzip_with := Vector.map2.
+
+Lemma vlookup_zip_with `(f : A → B → C) {n} (v1 : vec A n) (v2 : vec B n) i :
+ vzip_with f v1 v2 !!! i = f (v1 !!! i) (v2 !!! i).
+Proof. by apply Vector.nth_map2. Qed.
+Lemma vec_to_list_zip_with `(f : A → B → C) {n} (v1 : vec A n) (v2 : vec B n) :
+ vec_to_list (vzip_with f v1 v2) =
+ zip_with f (vec_to_list v1) (vec_to_list v2).
+Proof.
+ revert v2. induction v1; intros v2; inv_vec v2; intros; simpl; [done|].
+ by rewrite IHv1.
+Qed.
+
+(** Similar to vlookup, we cannot define [vinsert] as an instance of the
+[Insert] type class, as it has a dependent type. *)
+Fixpoint vinsert {A n} (i : fin n) (x : A) : vec A n → vec A n :=
+ match i with
+ | 0%fin => vec_S_inv _ (λ _ v, x ::: v)
+ | FS _ i => vec_S_inv _ (λ y v, y ::: vinsert i x v)
+ end.
+
+Lemma vec_to_list_insert {A n} i x (v : vec A n) :
+ vec_to_list (vinsert i x v) = insert (fin_to_nat i) x (vec_to_list v).
+Proof. induction v; inv_fin i. done. simpl. intros. by rewrite IHv. Qed.
+Lemma vlookup_insert {A n} i x (v : vec A n) : vinsert i x v !!! i = x.
+Proof. by induction i; inv_vec v. Qed.
+Lemma vlookup_insert_ne {A n} i j x (v : vec A n) :
+ i ≠j → vinsert i x v !!! j = v !!! j.
+Proof.
+ induction i; inv_fin j; inv_vec v; simpl; try done.
+ intros. apply IHi. congruence.
+Qed.
+Lemma vlookup_insert_self {A n} i (v : vec A n) : vinsert i (v !!! i) v = v.
+Proof. by induction v; inv_fin i; intros; f_equal'. Qed.
diff --git a/prelude/zmap.v b/prelude/zmap.v
new file mode 100644
index 0000000000000000000000000000000000000000..04f016e1d6331c5fa019175a3dd1387a726b3fbf
--- /dev/null
+++ b/prelude/zmap.v
@@ -0,0 +1,97 @@
+(* Copyright (c) 2012-2015, Robbert Krebbers. *)
+(* This file is distributed under the terms of the BSD license. *)
+(** This files extends the implementation of finite over [positive] to finite
+maps whose keys range over Coq's data type of binary naturals [Z]. *)
+Require Import prelude.pmap prelude.mapset.
+Require Export prelude.prelude prelude.fin_maps.
+Local Open Scope Z_scope.
+
+Record Zmap (A : Type) : Type :=
+ ZMap { Zmap_0 : option A; Zmap_pos : Pmap A; Zmap_neg : Pmap A }.
+Arguments Zmap_0 {_} _.
+Arguments Zmap_pos {_} _.
+Arguments Zmap_neg {_} _.
+Arguments ZMap {_} _ _ _.
+
+Instance Zmap_eq_dec `{∀ x y : A, Decision (x = y)} (t1 t2 : Zmap A) :
+ Decision (t1 = t2).
+Proof.
+ refine
+ match t1, t2 with
+ | ZMap x t1 t1', ZMap y t2 t2' =>
+ cast_if_and3 (decide (x = y)) (decide (t1 = t2)) (decide (t1' = t2'))
+ end; abstract congruence.
+Defined.
+Instance Zempty {A} : Empty (Zmap A) := ZMap None ∅ ∅.
+Instance Zlookup {A} : Lookup Z A (Zmap A) := λ i t,
+ match i with
+ | Z0 => Zmap_0 t | Zpos p => Zmap_pos t !! p | Zneg p => Zmap_neg t !! p
+ end.
+Instance Zpartial_alter {A} : PartialAlter Z A (Zmap A) := λ f i t,
+ match i, t with
+ | Z0, ZMap o t t' => ZMap (f o) t t'
+ | Zpos p, ZMap o t t' => ZMap o (partial_alter f p t) t'
+ | Zneg p, ZMap o t t' => ZMap o t (partial_alter f p t')
+ end.
+Instance Zto_list {A} : FinMapToList Z A (Zmap A) := λ t,
+ match t with
+ | ZMap o t t' => default [] o (λ x, [(0,x)]) ++
+ (prod_map Zpos id <$> map_to_list t) ++
+ (prod_map Zneg id <$> map_to_list t')
+ end.
+Instance Zomap: OMap Zmap := λ A B f t,
+ match t with ZMap o t t' => ZMap (o ≫= f) (omap f t) (omap f t') end.
+Instance Zmerge: Merge Zmap := λ A B C f t1 t2,
+ match t1, t2 with
+ | ZMap o1 t1 t1', ZMap o2 t2 t2' =>
+ ZMap (f o1 o2) (merge f t1 t2) (merge f t1' t2')
+ end.
+Instance Nfmap: FMap Zmap := λ A B f t,
+ match t with ZMap o t t' => ZMap (f <$> o) (f <$> t) (f <$> t') end.
+
+Instance: FinMap Z Zmap.
+Proof.
+ split.
+ * intros ? [??] [??] H. f_equal.
+ + apply (H 0).
+ + apply map_eq. intros i. apply (H (Zpos i)).
+ + apply map_eq. intros i. apply (H (Zneg i)).
+ * by intros ? [].
+ * intros ? f [] [|?|?]; simpl; [done| |]; apply lookup_partial_alter.
+ * intros ? f [] [|?|?] [|?|?]; simpl; intuition congruence ||
+ intros; apply lookup_partial_alter_ne; congruence.
+ * intros ??? [??] []; simpl; [done| |]; apply lookup_fmap.
+ * intros ? [o t t']; unfold map_to_list; simpl.
+ assert (NoDup ((prod_map Z.pos id <$> map_to_list t) ++
+ prod_map Z.neg id <$> map_to_list t')).
+ { apply NoDup_app; split_ands.
+ - apply (NoDup_fmap_2 _), NoDup_map_to_list.
+ - intro. rewrite !elem_of_list_fmap. naive_solver.
+ - apply (NoDup_fmap_2 _), NoDup_map_to_list. }
+ destruct o; simpl; auto. constructor; auto.
+ rewrite elem_of_app, !elem_of_list_fmap. naive_solver.
+ * intros ? t i x. unfold map_to_list. split.
+ + destruct t as [[y|] t t']; simpl.
+ - rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap.
+ intros [?|[[[??][??]]|[[??][??]]]]; simplify_equality'; [done| |];
+ by apply elem_of_map_to_list.
+ - rewrite elem_of_app, !elem_of_list_fmap. intros [[[??][??]]|[[??][??]]];
+ simplify_equality'; by apply elem_of_map_to_list.
+ + destruct t as [[y|] t t']; simpl.
+ - rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap.
+ destruct i as [|i|i]; simpl; [intuition congruence| |].
+ { right; left. exists (i, x). by rewrite elem_of_map_to_list. }
+ right; right. exists (i, x). by rewrite elem_of_map_to_list.
+ - rewrite elem_of_app, !elem_of_list_fmap.
+ destruct i as [|i|i]; simpl; [done| |].
+ { left; exists (i, x). by rewrite elem_of_map_to_list. }
+ right; exists (i, x). by rewrite elem_of_map_to_list.
+ * intros ?? f [??] [|?|?]; simpl; [done| |]; apply (lookup_omap f).
+ * intros ??? f ? [??] [??] [|?|?]; simpl; [done| |]; apply (lookup_merge f).
+Qed.
+
+(** * Finite sets *)
+(** We construct sets of [Z]s satisfying extensional equality. *)
+Notation Zset := (mapset Zmap).
+Instance Zmap_dom {A} : Dom (Zmap A) Zset := mapset_dom.
+Instance: FinMapDom Z Zmap Zset := mapset_dom_spec.
diff --git a/program_logic/adequacy.v b/program_logic/adequacy.v
new file mode 100644
index 0000000000000000000000000000000000000000..1efb3abcd050b25f4e5e211fefa584df1769208a
--- /dev/null
+++ b/program_logic/adequacy.v
@@ -0,0 +1,124 @@
+Require Export program_logic.hoare.
+Require Import program_logic.wsat.
+Local Hint Extern 10 (_ ≤ _) => omega.
+Local Hint Extern 100 (@eq coPset _ _) => eassumption || solve_elem_of.
+Local Hint Extern 10 (✓{_} _) =>
+ repeat match goal with H : wsat _ _ _ _ |- _ => apply wsat_valid in H end;
+ solve_validN.
+
+Section adequacy.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types e : expr Λ.
+Implicit Types Q : val Λ → iProp Λ Σ.
+Implicit Types m : iGst Λ Σ.
+Transparent uPred_holds.
+
+Notation wptp n := (Forall3 (λ e Q r, uPred_holds (wp coPset_all e Q) n r)).
+Lemma wptp_le Qs es rs n n' :
+ ✓{n'} (big_op rs) → wptp n es Qs rs → n' ≤ n → wptp n' es Qs rs.
+Proof. induction 2; constructor; eauto using uPred_weaken. Qed.
+Lemma nsteps_wptp Qs k n tσ1 tσ2 rs1 :
+ nsteps step k tσ1 tσ2 →
+ 1 < n → wptp (k + n) (tσ1.1) Qs rs1 →
+ wsat (k + n) coPset_all (tσ1.2) (big_op rs1) →
+ ∃ rs2 Qs', wptp n (tσ2.1) (Qs ++ Qs') rs2 ∧
+ wsat n coPset_all (tσ2.2) (big_op rs2).
+Proof.
+ intros Hsteps Hn; revert Qs rs1.
+ induction Hsteps as [|k ?? tσ3 [e1 σ1 e2 σ2 ef t1 t2 ?? Hstep] Hsteps IH];
+ simplify_equality'; intros Qs rs.
+ { by intros; exists rs, []; rewrite right_id_L. }
+ intros (Qs1&?&rs1&?&->&->&?&
+ (Q&Qs2&r&rs2&->&->&Hwp&?)%Forall3_cons_inv_l)%Forall3_app_inv_l ?.
+ destruct (wp_step_inv coPset_all ∅ Q e1 (k + n) (S (k + n)) σ1 r
+ (big_op (rs1 ++ rs2))) as [_ Hwpstep]; eauto using values_stuck.
+ { by rewrite right_id_L -big_op_cons Permutation_middle. }
+ destruct (Hwpstep e2 σ2 ef) as (r2&r2'&Hwsat&?&?); auto; clear Hwpstep.
+ revert Hwsat; rewrite big_op_app right_id_L=>Hwsat.
+ destruct ef as [e'|].
+ * destruct (IH (Qs1 ++ Q :: Qs2 ++ [λ _, True%I])
+ (rs1 ++ r2 :: rs2 ++ [r2'])) as (rs'&Qs'&?&?).
+ { apply Forall3_app, Forall3_cons,
+ Forall3_app, Forall3_cons, Forall3_nil; eauto using wptp_le. }
+ { by rewrite -Permutation_middle /= (associative (++))
+ (commutative (++)) /= associative big_op_app. }
+ exists rs', ([λ _, True%I] ++ Qs'); split; auto.
+ by rewrite (associative _ _ _ Qs') -(associative _ Qs1).
+ * apply (IH (Qs1 ++ Q :: Qs2) (rs1 ++ r2 â‹… r2' :: rs2)).
+ { rewrite /option_list right_id_L.
+ apply Forall3_app, Forall3_cons; eauto using wptp_le.
+ apply uPred_weaken with r2 (k + n); eauto using cmra_included_l. }
+ by rewrite -Permutation_middle /= big_op_app.
+Qed.
+Lemma ht_adequacy_steps P Q k n e1 t2 σ1 σ2 r1 :
+ {{ P }} e1 @ coPset_all {{ Q }} →
+ nsteps step k ([e1],σ1) (t2,σ2) →
+ 1 < n → wsat (k + n) coPset_all σ1 r1 →
+ P (k + n) r1 →
+ ∃ rs2 Qs', wptp n t2 ((λ v, pvs coPset_all coPset_all (Q v)) :: Qs') rs2 ∧
+ wsat n coPset_all σ2 (big_op rs2).
+Proof.
+ intros Hht ????; apply (nsteps_wptp [pvs coPset_all coPset_all ∘ Q] k n
+ ([e1],σ1) (t2,σ2) [r1]); rewrite /big_op ?right_id; auto.
+ constructor; last constructor.
+ apply Hht with r1 (k + n); eauto using cmra_included_unit.
+ by destruct (k + n).
+Qed.
+Lemma ht_adequacy_own Q e1 t2 σ1 m σ2 :
+ ✓m →
+ {{ ownP σ1 ★ ownG m }} e1 @ coPset_all {{ Q }} →
+ rtc step ([e1],σ1) (t2,σ2) →
+ ∃ rs2 Qs', wptp 3 t2 ((λ v, pvs coPset_all coPset_all (Q v)) :: Qs') rs2 ∧
+ wsat 3 coPset_all σ2 (big_op rs2).
+Proof.
+ intros Hv ? [k ?]%rtc_nsteps.
+ eapply ht_adequacy_steps with (r1 := (Res ∅ (Excl σ1) m)); eauto; [|].
+ { by rewrite Nat.add_comm; apply wsat_init, cmra_valid_validN. }
+ exists (Res ∅ (Excl σ1) ∅), (Res ∅ ∅ m); split_ands.
+ * by rewrite Res_op ?left_id ?right_id.
+ * by rewrite /uPred_holds /=.
+ * by apply ownG_spec.
+Qed.
+Theorem ht_adequacy_result E φ e v t2 σ1 m σ2 :
+ ✓ m →
+ {{ ownP σ1 ★ ownG m }} e @ E {{ λ v', ■φ v' }} →
+ rtc step ([e], σ1) (of_val v :: t2, σ2) →
+ φ v.
+Proof.
+ intros Hv ? Hs.
+ destruct (ht_adequacy_own (λ v', ■φ v')%I e (of_val v :: t2) σ1 m σ2)
+ as (rs2&Qs&Hwptp&?); auto.
+ { by rewrite -(ht_mask_weaken E coPset_all). }
+ inversion Hwptp as [|?? r ?? rs Hwp _]; clear Hwptp; subst.
+ apply wp_value_inv in Hwp; destruct (Hwp (big_op rs) 3 ∅ σ2) as [r' []]; auto.
+ by rewrite right_id_L.
+Qed.
+Lemma ht_adequacy_reducible E Q e1 e2 t2 σ1 m σ2 :
+ ✓ m →
+ {{ ownP σ1 ★ ownG m }} e1 @ E {{ Q }} →
+ rtc step ([e1], σ1) (t2, σ2) →
+ e2 ∈ t2 → to_val e2 = None → reducible e2 σ2.
+Proof.
+ intros Hv ? Hs [i ?]%elem_of_list_lookup He.
+ destruct (ht_adequacy_own Q e1 t2 σ1 m σ2) as (rs2&Qs&?&?); auto.
+ { by rewrite -(ht_mask_weaken E coPset_all). }
+ destruct (Forall3_lookup_l (λ e Q r, wp coPset_all e Q 3 r) t2
+ (pvs coPset_all coPset_all ∘ Q :: Qs) rs2 i e2) as (Q'&r2&?&?&Hwp); auto.
+ destruct (wp_step_inv coPset_all ∅ Q' e2 2 3 σ2 r2 (big_op (delete i rs2)));
+ rewrite ?right_id_L ?big_op_delete; auto.
+Qed.
+Theorem ht_adequacy_safe E Q e1 t2 σ1 m σ2 :
+ ✓ m →
+ {{ ownP σ1 ★ ownG m }} e1 @ E {{ Q }} →
+ rtc step ([e1], σ1) (t2, σ2) →
+ Forall (λ e, is_Some (to_val e)) t2 ∨ ∃ t3 σ3, step (t2, σ2) (t3, σ3).
+Proof.
+ intros.
+ destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|].
+ apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2).
+ destruct (ht_adequacy_reducible E Q e1 e2 t2 σ1 m σ2) as (e3&σ3&ef&?);
+ rewrite ?eq_None_not_Some; auto.
+ destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto.
+ right; exists (t2' ++ e3 :: t2'' ++ option_list ef), σ3; econstructor; eauto.
+Qed.
+End adequacy.
diff --git a/program_logic/functor.v b/program_logic/functor.v
new file mode 100644
index 0000000000000000000000000000000000000000..cecfd67b288516515129a92e4fa5484b7858c7a0
--- /dev/null
+++ b/program_logic/functor.v
@@ -0,0 +1,26 @@
+Require Export algebra.cmra.
+
+Structure iFunctor := IFunctor {
+ ifunctor_car :> cofeT → cmraT;
+ ifunctor_empty A : Empty (ifunctor_car A);
+ ifunctor_identity A : CMRAIdentity (ifunctor_car A);
+ ifunctor_map {A B} (f : A -n> B) : ifunctor_car A -n> ifunctor_car B;
+ ifunctor_map_ne {A B} n : Proper (dist n ==> dist n) (@ifunctor_map A B);
+ ifunctor_map_id {A : cofeT} (x : ifunctor_car A) : ifunctor_map cid x ≡ x;
+ ifunctor_map_compose {A B C} (f : A -n> B) (g : B -n> C) x :
+ ifunctor_map (g ◎ f) x ≡ ifunctor_map g (ifunctor_map f x);
+ ifunctor_map_mono {A B} (f : A -n> B) : CMRAMonotone (ifunctor_map f)
+}.
+Existing Instances ifunctor_empty ifunctor_identity.
+Existing Instances ifunctor_map_ne ifunctor_map_mono.
+
+Lemma ifunctor_map_ext (Σ : iFunctor) {A B} (f g : A -n> B) m :
+ (∀ x, f x ≡ g x) → ifunctor_map Σ f m ≡ ifunctor_map Σ g m.
+Proof.
+ by intros; apply equiv_dist=> n; apply ifunctor_map_ne=> ?; apply equiv_dist.
+Qed.
+
+Program Definition iFunctor_const (icmra : cmraT) {icmra_empty : Empty icmra}
+ {icmra_identity : CMRAIdentity icmra} : iFunctor :=
+ {| ifunctor_car A := icmra; ifunctor_map A B f := cid |}.
+Solve Obligations with done.
\ No newline at end of file
diff --git a/program_logic/hoare.v b/program_logic/hoare.v
new file mode 100644
index 0000000000000000000000000000000000000000..f34281bf7f8f30b1eaa1b744bba761180fe026ec
--- /dev/null
+++ b/program_logic/hoare.v
@@ -0,0 +1,101 @@
+Require Export program_logic.weakestpre program_logic.viewshifts.
+
+Definition ht {Λ Σ} (E : coPset) (P : iProp Λ Σ)
+ (e : expr Λ) (Q : val Λ → iProp Λ Σ) : iProp Λ Σ :=
+ (□ (P → wp E e (λ v, pvs E E (Q v))))%I.
+Instance: Params (@ht) 3.
+
+Notation "{{ P } } e @ E {{ Q } }" := (ht E P e Q)
+ (at level 74, format "{{ P } } e @ E {{ Q } }") : uPred_scope.
+Notation "{{ P } } e @ E {{ Q } }" := (True ⊑ ht E P e Q)
+ (at level 74, format "{{ P } } e @ E {{ Q } }") : C_scope.
+
+Section hoare.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types P : iProp Λ Σ.
+Implicit Types Q : val Λ → iProp Λ Σ.
+Implicit Types v : val Λ.
+Import uPred.
+
+Global Instance ht_ne E n :
+ Proper (dist n ==> eq==>pointwise_relation _ (dist n) ==> dist n) (@ht Λ Σ E).
+Proof. by intros P P' HP e ? <- Q Q' HQ; rewrite /ht HP; setoid_rewrite HQ. Qed.
+Global Instance ht_proper E :
+ Proper ((≡) ==> eq ==> pointwise_relation _ (≡) ==> (≡)) (@ht Λ Σ E).
+Proof. by intros P P' HP e ? <- Q Q' HQ; rewrite /ht HP; setoid_rewrite HQ. Qed.
+Lemma ht_mono E P P' Q Q' e :
+ P ⊑ P' → (∀ v, Q' v ⊑ Q v) → {{ P' }} e @ E {{ Q' }} ⊑ {{ P }} e @ E {{ Q }}.
+Proof. by intros HP HQ; rewrite /ht -HP; setoid_rewrite HQ. Qed.
+Global Instance ht_mono' E :
+ Proper (flip (⊑) ==> eq ==> pointwise_relation _ (⊑) ==> (⊑)) (@ht Λ Σ E).
+Proof. by intros P P' HP e ? <- Q Q' HQ; apply ht_mono. Qed.
+
+Lemma ht_val E v :
+ {{ True : iProp Λ Σ }} of_val v @ E {{ λ v', ■(v = v') }}.
+Proof.
+ apply (always_intro' _ _), impl_intro_l.
+ by rewrite -wp_value -pvs_intro; apply const_intro.
+Qed.
+Lemma ht_vs E P P' Q Q' e :
+ (P >{E}> P' ∧ {{ P' }} e @ E {{ Q' }} ∧ ∀ v, Q' v >{E}> Q v)
+ ⊑ {{ P }} e @ E {{ Q }}.
+Proof.
+ apply (always_intro' _ _), impl_intro_l.
+ rewrite (associative _ P) {1}/vs always_elim impl_elim_r.
+ rewrite (associative _) pvs_impl_r pvs_always_r wp_always_r.
+ rewrite wp_pvs; apply wp_mono=> v.
+ by rewrite (forall_elim v) pvs_impl_r !pvs_trans'.
+Qed.
+Lemma ht_atomic E1 E2 P P' Q Q' e :
+ E2 ⊆ E1 → atomic e →
+ (P >{E1,E2}> P' ∧ {{ P' }} e @ E2 {{ Q' }} ∧ ∀ v, Q' v >{E2,E1}> Q v)
+ ⊑ {{ P }} e @ E1 {{ Q }}.
+Proof.
+ intros ??; apply (always_intro' _ _), impl_intro_l.
+ rewrite (associative _ P) {1}/vs always_elim impl_elim_r.
+ rewrite (associative _) pvs_impl_r pvs_always_r wp_always_r.
+ rewrite -(wp_atomic E1 E2) //; apply pvs_mono, wp_mono=> v.
+ rewrite (forall_elim v) pvs_impl_r -(pvs_intro E1) pvs_trans; solve_elem_of.
+Qed.
+Lemma ht_bind `{LanguageCtx Λ K} E P Q Q' e :
+ ({{ P }} e @ E {{ Q }} ∧ ∀ v, {{ Q v }} K (of_val v) @ E {{ Q' }})
+ ⊑ {{ P }} K e @ E {{ Q' }}.
+Proof.
+ intros; apply (always_intro' _ _), impl_intro_l.
+ rewrite (associative _ P) {1}/ht always_elim impl_elim_r.
+ rewrite wp_always_r -wp_bind //; apply wp_mono=> v.
+ rewrite (forall_elim v) pvs_impl_r wp_pvs; apply wp_mono=> v'.
+ by rewrite pvs_trans'.
+Qed.
+Lemma ht_mask_weaken E1 E2 P Q e :
+ E1 ⊆ E2 → {{ P }} e @ E1 {{ Q }} ⊑ {{ P }} e @ E2 {{ Q }}.
+Proof.
+ intros; apply always_mono, impl_intro_l; rewrite impl_elim_r.
+ by rewrite -(wp_mask_weaken E1) //; apply wp_mono=> v; apply pvs_mask_weaken.
+Qed.
+Lemma ht_frame_l E P Q R e :
+ {{ P }} e @ E {{ Q }} ⊑ {{ R ★ P }} e @ E {{ λ v, R ★ Q v }}.
+Proof.
+ apply always_intro, impl_intro_l.
+ rewrite always_and_sep_r -(associative _) (sep_and P) always_elim impl_elim_r.
+ by rewrite wp_frame_l; apply wp_mono=>v; rewrite pvs_frame_l.
+Qed.
+Lemma ht_frame_r E P Q R e :
+ {{ P }} e @ E {{ Q }} ⊑ {{ P ★ R }} e @ E {{ λ v, Q v ★ R }}.
+Proof. setoid_rewrite (commutative _ _ R); apply ht_frame_l. Qed.
+Lemma ht_frame_later_l E P R e Q :
+ to_val e = None →
+ {{ P }} e @ E {{ Q }} ⊑ {{ ▷ R ★ P }} e @ E {{ λ v, R ★ Q v }}.
+Proof.
+ intros; apply always_intro, impl_intro_l.
+ rewrite always_and_sep_r -(associative _) (sep_and P) always_elim impl_elim_r.
+ by rewrite wp_frame_later_l //; apply wp_mono=>v; rewrite pvs_frame_l.
+Qed.
+Lemma ht_frame_later_r E P R e Q :
+ to_val e = None →
+ {{ P }} e @ E {{ Q }} ⊑ {{ P ★ ▷ R }} e @ E {{ λ v, Q v ★ R }}.
+Proof.
+ rewrite (commutative _ _ (â–· R)%I); setoid_rewrite (commutative _ _ R).
+ apply ht_frame_later_l.
+Qed.
+End hoare.
\ No newline at end of file
diff --git a/program_logic/hoare_lifting.v b/program_logic/hoare_lifting.v
new file mode 100644
index 0000000000000000000000000000000000000000..7ff9d1d7fe1ad19fa96c2a7d4d125bef96227bea
--- /dev/null
+++ b/program_logic/hoare_lifting.v
@@ -0,0 +1,121 @@
+Require Export program_logic.hoare program_logic.lifting.
+
+Local Notation "{{ P } } ef ?@ E {{ Q } }" :=
+ (default True%I ef (λ e, ht E P e Q))
+ (at level 74, format "{{ P } } ef ?@ E {{ Q } }") : uPred_scope.
+Local Notation "{{ P } } ef ?@ E {{ Q } }" :=
+ (True ⊑ default True ef (λ e, ht E P e Q))
+ (at level 74, format "{{ P } } ef ?@ E {{ Q } }") : C_scope.
+
+Section lifting.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types e : expr Λ.
+Implicit Types P : iProp Λ Σ.
+Implicit Types R : val Λ → iProp Λ Σ.
+Import uPred.
+
+Lemma ht_lift_step E1 E2
+ (φ : expr Λ → state Λ → option (expr Λ) → Prop) P P' Q1 Q2 R e1 σ1 :
+ E1 ⊆ E2 → to_val e1 = None →
+ reducible e1 σ1 →
+ (∀ e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef → φ e2 σ2 ef) →
+ (P >{E2,E1}> (ownP σ1 ★ ▷ P') ∧ ∀ e2 σ2 ef,
+ (■φ e2 σ2 ef ★ ownP σ2 ★ P') >{E1,E2}> (Q1 e2 σ2 ef ★ Q2 e2 σ2 ef) ∧
+ {{ Q1 e2 σ2 ef }} e2 @ E2 {{ R }} ∧
+ {{ Q2 e2 σ2 ef }} ef ?@ coPset_all {{ λ _, True }})
+ ⊑ {{ P }} e1 @ E2 {{ R }}.
+Proof.
+ intros ?? Hsafe Hstep; apply (always_intro' _ _), impl_intro_l.
+ rewrite (associative _ P) {1}/vs always_elim impl_elim_r pvs_always_r.
+ rewrite -(wp_lift_step E1 E2 φ _ e1 σ1) //; apply pvs_mono.
+ rewrite always_and_sep_r' -associative; apply sep_mono; first done.
+ rewrite (later_intro (∀ _, _)) -later_sep; apply later_mono.
+ apply forall_intro=>e2; apply forall_intro=>σ2; apply forall_intro=>ef.
+ rewrite (forall_elim e2) (forall_elim σ2) (forall_elim ef).
+ apply wand_intro_l; rewrite !always_and_sep_l'.
+ rewrite (associative _ _ P') -(associative _ _ _ P') associative.
+ rewrite {1}/vs -always_wand_impl always_elim wand_elim_r.
+ rewrite pvs_frame_r; apply pvs_mono.
+ rewrite (commutative _ (Q1 _ _ _)) -associative (associative _ (Q1 _ _ _)).
+ rewrite {1}/ht -always_wand_impl always_elim wand_elim_r.
+ rewrite associative (commutative _ _ (wp _ _ _)) -associative.
+ apply sep_mono; first done.
+ destruct ef as [e'|]; simpl; [|by apply const_intro].
+ rewrite {1}/ht -always_wand_impl always_elim wand_elim_r; apply wp_mono=>v.
+ by apply const_intro.
+Qed.
+
+Lemma ht_lift_atomic_step
+ E (φ : expr Λ → state Λ → option (expr Λ) → Prop) P e1 σ1 :
+ atomic e1 →
+ reducible e1 σ1 →
+ (∀ e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef → φ e2 σ2 ef) →
+ (∀ e2 σ2 ef, {{ ■φ e2 σ2 ef ★ P }} ef ?@ coPset_all {{ λ _, True }}) ⊑
+ {{ ownP σ1 ★ ▷ P }} e1 @ E {{ λ v, ∃ σ2 ef, ownP σ2 ★ ■φ (of_val v) σ2 ef }}.
+Proof.
+ intros ? Hsafe Hstep; set (φ' e σ ef := is_Some (to_val e) ∧ φ e σ ef).
+ rewrite -(ht_lift_step E E φ' _ P
+ (λ e2 σ2 ef, ownP σ2 ★ ■(φ' e2 σ2 ef))%I
+ (λ e2 σ2 ef, ■φ e2 σ2 ef ★ P)%I);
+ try by (rewrite /φ'; eauto using atomic_not_val, atomic_step).
+ apply and_intro; [by rewrite -vs_reflexive; apply const_intro|].
+ apply forall_mono=>e2; apply forall_mono=>σ2; apply forall_mono=>ef.
+ apply and_intro; [|apply and_intro; [|done]].
+ * rewrite -vs_impl; apply (always_intro' _ _),impl_intro_l;rewrite and_elim_l.
+ rewrite !associative; apply sep_mono; last done.
+ rewrite -!always_and_sep_l' -!always_and_sep_r'; apply const_elim_l=>-[??].
+ by repeat apply and_intro; try apply const_intro.
+ * apply (always_intro' _ _), impl_intro_l; rewrite and_elim_l.
+ rewrite -always_and_sep_r'; apply const_elim_r=>-[[v Hv] ?].
+ rewrite -(of_to_val e2 v) // -wp_value -pvs_intro.
+ rewrite -(exist_intro σ2) -(exist_intro ef) (of_to_val e2) //.
+ by rewrite -always_and_sep_r'; apply and_intro; try apply const_intro.
+Qed.
+
+Lemma ht_lift_pure_step E (φ : expr Λ → option (expr Λ) → Prop) P P' Q e1 :
+ to_val e1 = None →
+ (∀ σ1, reducible e1 σ1) →
+ (∀ σ1 e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef → σ1 = σ2 ∧ φ e2 ef) →
+ (∀ e2 ef,
+ {{ ■φ e2 ef ★ P }} e2 @ E {{ Q }} ∧
+ {{ ■φ e2 ef ★ P' }} ef ?@ coPset_all {{ λ _, True }})
+ ⊑ {{ ▷(P ★ P') }} e1 @ E {{ Q }}.
+Proof.
+ intros ? Hsafe Hstep; apply (always_intro' _ _), impl_intro_l.
+ rewrite -(wp_lift_pure_step E φ _ e1) //.
+ rewrite (later_intro (∀ _, _)) -later_and; apply later_mono.
+ apply forall_intro=>e2; apply forall_intro=>ef; apply impl_intro_l.
+ rewrite (forall_elim e2) (forall_elim ef).
+ rewrite always_and_sep_l' !always_and_sep_r' {1}(always_sep_dup' (â– _)).
+ rewrite {1}(associative _ (_ ★ _)%I) -(associative _ (■_)%I).
+ rewrite (associative _ (â– _)%I P) -{1}(commutative _ P) -(associative _ P).
+ rewrite (associative _ (■_)%I) associative -(associative _ (■_ ★ P))%I.
+ rewrite (commutative _ (■_ ★ P'))%I associative.
+ rewrite {1}/ht -always_wand_impl always_elim wand_elim_r.
+ rewrite -associative; apply sep_mono; first done.
+ destruct ef as [e'|]; simpl; [|by apply const_intro].
+ rewrite {1}/ht -always_wand_impl always_elim wand_elim_r; apply wp_mono=>v.
+ by apply const_intro.
+Qed.
+
+Lemma ht_lift_pure_det_step
+ E (φ : expr Λ → option (expr Λ) → Prop) P P' Q e1 e2 ef :
+ to_val e1 = None →
+ (∀ σ1, reducible e1 σ1) →
+ (∀ σ1 e2' σ2 ef', prim_step e1 σ1 e2' σ2 ef' → σ1 = σ2 ∧ e2 = e2' ∧ ef = ef')→
+ ({{ P }} e2 @ E {{ Q }} ∧ {{ P' }} ef ?@ coPset_all {{ λ _, True }})
+ ⊑ {{ ▷(P ★ P') }} e1 @ E {{ Q }}.
+Proof.
+ intros ? Hsafe Hdet.
+ rewrite -(ht_lift_pure_step _ (λ e2' ef', e2 = e2' ∧ ef = ef')); eauto.
+ apply forall_intro=>e2'; apply forall_intro=>ef'; apply and_mono.
+ * apply (always_intro' _ _), impl_intro_l.
+ rewrite -always_and_sep_l' -associative; apply const_elim_l=>-[??]; subst.
+ by rewrite /ht always_elim impl_elim_r.
+ * destruct ef' as [e'|]; simpl; [|by apply const_intro].
+ apply (always_intro' _ _), impl_intro_l.
+ rewrite -always_and_sep_l' -associative; apply const_elim_l=>-[??]; subst.
+ by rewrite /= /ht always_elim impl_elim_r.
+Qed.
+
+End lifting.
diff --git a/program_logic/language.v b/program_logic/language.v
new file mode 100644
index 0000000000000000000000000000000000000000..783ac2a73205c49436b4248d8296ef246af6551e
--- /dev/null
+++ b/program_logic/language.v
@@ -0,0 +1,64 @@
+Require Export algebra.cofe.
+
+Structure language := Language {
+ expr : Type;
+ val : Type;
+ state : Type;
+ of_val : val → expr;
+ to_val : expr → option val;
+ atomic : expr → Prop;
+ prim_step : expr → state → expr → state → option expr → Prop;
+ to_of_val v : to_val (of_val v) = Some v;
+ of_to_val e v : to_val e = Some v → of_val v = e;
+ values_stuck e σ e' σ' ef : prim_step e σ e' σ' ef → to_val e = None;
+ atomic_not_val e : atomic e → to_val e = None;
+ atomic_step e1 σ1 e2 σ2 ef :
+ atomic e1 →
+ prim_step e1 σ1 e2 σ2 ef →
+ is_Some (to_val e2)
+}.
+Arguments of_val {_} _.
+Arguments to_val {_} _.
+Arguments atomic {_} _.
+Arguments prim_step {_} _ _ _ _ _.
+Arguments to_of_val {_} _.
+Arguments of_to_val {_} _ _ _.
+Arguments values_stuck {_} _ _ _ _ _ _.
+Arguments atomic_not_val {_} _ _.
+Arguments atomic_step {_} _ _ _ _ _ _ _.
+
+Canonical Structure istateC Σ := leibnizC (state Σ).
+
+Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.
+
+Section language.
+ Context {Λ : language}.
+ Implicit Types v : val Λ.
+
+ Definition reducible (e : expr Λ) (σ : state Λ) :=
+ ∃ e' σ' ef, prim_step e σ e' σ' ef.
+ Inductive step (Ï1 Ï2 : cfg Λ) : Prop :=
+ | step_atomic e1 σ1 e2 σ2 ef t1 t2 :
+ Ï1 = (t1 ++ e1 :: t2, σ1) →
+ Ï2 = (t1 ++ e2 :: t2 ++ option_list ef, σ2) →
+ prim_step e1 σ1 e2 σ2 ef →
+ step Ï1 Ï2.
+
+ Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
+ Proof. intros (?&?&?&?); eauto using values_stuck. Qed.
+ Lemma atomic_of_val v : ¬atomic (of_val v).
+ Proof. by intros Hat%atomic_not_val; rewrite to_of_val in Hat. Qed.
+ Global Instance: Injective (=) (=) (@of_val Λ).
+ Proof. by intros v v' Hv; apply (injective Some); rewrite -!to_of_val Hv. Qed.
+End language.
+
+Class LanguageCtx (Λ : language) (K : expr Λ → expr Λ) := {
+ fill_not_val e :
+ to_val e = None → to_val (K e) = None;
+ fill_step e1 σ1 e2 σ2 ef :
+ prim_step e1 σ1 e2 σ2 ef →
+ prim_step (K e1) σ1 (K e2) σ2 ef;
+ fill_step_inv e1' σ1 e2 σ2 ef :
+ to_val e1' = None → prim_step (K e1') σ1 e2 σ2 ef →
+ ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 e2' σ2 ef
+}.
diff --git a/program_logic/lifting.v b/program_logic/lifting.v
new file mode 100644
index 0000000000000000000000000000000000000000..c028b22ce684f4742d6937cef16814571536178b
--- /dev/null
+++ b/program_logic/lifting.v
@@ -0,0 +1,115 @@
+Require Export program_logic.weakestpre.
+Require Import program_logic.wsat.
+Local Hint Extern 10 (_ ≤ _) => omega.
+Local Hint Extern 100 (@eq coPset _ _) => solve_elem_of.
+Local Hint Extern 10 (✓{_} _) =>
+ repeat match goal with H : wsat _ _ _ _ |- _ => apply wsat_valid in H end;
+ solve_validN.
+
+Section lifting.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types v : val Λ.
+Implicit Types e : expr Λ.
+Implicit Types σ : state Λ.
+Implicit Types Q : val Λ → iProp Λ Σ.
+Transparent uPred_holds.
+
+Lemma wp_lift_step E1 E2
+ (φ : expr Λ → state Λ → option (expr Λ) → Prop) Q e1 σ1 :
+ E1 ⊆ E2 → to_val e1 = None →
+ reducible e1 σ1 →
+ (∀ e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef → φ e2 σ2 ef) →
+ pvs E2 E1 (ownP σ1 ★ ▷ ∀ e2 σ2 ef, (■φ e2 σ2 ef ∧ ownP σ2) -★
+ pvs E1 E2 (wp E2 e2 Q ★ default True ef (flip (wp coPset_all) (λ _, True))))
+ ⊑ wp E2 e1 Q.
+Proof.
+ intros ? He Hsafe Hstep r n ? Hvs; constructor; auto.
+ intros rf k Ef σ1' ???; destruct (Hvs rf (S k) Ef σ1')
+ as (r'&(r1&r2&?&?&Hwp)&Hws); auto; clear Hvs; cofe_subst r'.
+ destruct (wsat_update_pst k (E1 ∪ Ef) σ1 σ1' r1 (r2 ⋅ rf)) as [-> Hws'].
+ { by apply ownP_spec; auto. }
+ { by rewrite (associative _). }
+ constructor; [done|intros e2 σ2 ef ?; specialize (Hws' σ2)].
+ destruct (λ H1 H2 H3, Hwp e2 σ2 ef (update_pst σ2 r1) k H1 H2 H3 rf k Ef σ2)
+ as (r'&(r1'&r2'&?&?&?)&?); auto; cofe_subst r'.
+ { split. destruct k; try eapply Hstep; eauto. apply ownP_spec; auto. }
+ { rewrite (commutative _ r2) -(associative _); eauto using wsat_le. }
+ by exists r1', r2'; split_ands; [| |by intros ? ->].
+Qed.
+
+Lemma wp_lift_pure_step E (φ : expr Λ → option (expr Λ) → Prop) Q e1 :
+ to_val e1 = None →
+ (∀ σ1, reducible e1 σ1) →
+ (∀ σ1 e2 σ2 ef, prim_step e1 σ1 e2 σ2 ef → σ1 = σ2 ∧ φ e2 ef) →
+ (▷ ∀ e2 ef, ■φ e2 ef →
+ wp E e2 Q ★ default True ef (flip (wp coPset_all) (λ _, True)))
+ ⊑ wp E e1 Q.
+Proof.
+ intros He Hsafe Hstep r [|n] ?; [done|]; intros Hwp; constructor; auto.
+ intros rf k Ef σ1 ???; split; [done|].
+ intros e2 σ2 ef ?; destruct (Hstep σ1 e2 σ2 ef); auto; subst.
+ destruct (Hwp e2 ef r k) as (r1&r2&Hr&?&?); auto; [by destruct k|].
+ exists r1,r2; split_ands; [rewrite -Hr| |by intros ? ->]; eauto using wsat_le.
+Qed.
+
+(** Derived lifting lemmas. *)
+Opaque uPred_holds.
+Import uPred.
+
+Lemma wp_lift_atomic_step {E Q} e1 (φ : val Λ → state Λ → option (expr Λ) → Prop) σ1 :
+ to_val e1 = None →
+ reducible e1 σ1 →
+ (∀ e' σ' ef, prim_step e1 σ1 e' σ' ef → ∃ v', to_val e' = Some v' ∧ φ v' σ' ef) →
+ (ownP σ1 ★ ▷ ∀ v2 σ2 ef, ■φ v2 σ2 ef ∧ ownP σ2 -★
+ Q v2 ★ default True ef (flip (wp coPset_all) (λ _, True)))
+ ⊑ wp E e1 Q.
+Proof.
+ intros He Hsafe Hstep.
+ rewrite -(wp_lift_step E E
+ (λ e' σ' ef, ∃ v', to_val e' = Some v' ∧ φ v' σ' ef) _ e1 σ1) //; [].
+ rewrite -pvs_intro. apply sep_mono, later_mono; first done.
+ apply forall_intro=>e2'; apply forall_intro=>σ2'.
+ apply forall_intro=>ef; apply wand_intro_l.
+ rewrite always_and_sep_l' -associative -always_and_sep_l'.
+ apply const_elim_l=>-[v2' [Hv ?]] /=.
+ rewrite -pvs_intro.
+ rewrite (forall_elim v2') (forall_elim σ2') (forall_elim ef) const_equiv //.
+ rewrite left_id wand_elim_r. apply sep_mono; last done.
+ (* FIXME RJ why can't I do this rewrite before doing sep_mono? *)
+ by rewrite -(wp_value' _ _ e2').
+Qed.
+
+Lemma wp_lift_atomic_det_step {E Q e1} σ1 v2 σ2 ef :
+ to_val e1 = None →
+ reducible e1 σ1 →
+ (∀ e' σ' ef', prim_step e1 σ1 e' σ' ef' → ef' = ef ∧ e' = of_val v2 ∧ σ' = σ2) →
+ (ownP σ1 ★ ▷ (ownP σ2 -★ Q v2 ★
+ default True ef (flip (wp coPset_all) (λ _, True))))
+ ⊑ wp E e1 Q.
+Proof.
+ intros He Hsafe Hstep.
+ rewrite -(wp_lift_atomic_step _ (λ v' σ' ef', v' = v2 ∧ σ' = σ2 ∧ ef' = ef) σ1) //;
+ last first.
+ { intros. exists v2. apply Hstep in H. destruct_conjs; subst.
+ eauto using to_of_val. }
+ apply sep_mono, later_mono; first done.
+ apply forall_intro=>e2'; apply forall_intro=>σ2'; apply forall_intro=>ef'.
+ apply wand_intro_l.
+ rewrite always_and_sep_l' -associative -always_and_sep_l'.
+ apply const_elim_l=>-[-> [-> ->]] /=.
+ by rewrite wand_elim_r.
+Qed.
+
+Lemma wp_lift_pure_det_step {E Q} e1 e2 ef :
+ to_val e1 = None →
+ (∀ σ1, reducible e1 σ1) →
+ (∀ σ1 e' σ' ef', prim_step e1 σ1 e' σ' ef' → σ1 = σ' ∧ ef' = ef ∧ e' = e2) →
+ ▷ (wp E e2 Q ★ default True ef (flip (wp coPset_all) (λ _, True))) ⊑ wp E e1 Q.
+Proof.
+ intros. rewrite -(wp_lift_pure_step E (λ e' ef', ef' = ef ∧ e' = e2) _ e1) //=.
+ apply later_mono, forall_intro=>e'; apply forall_intro=>ef'.
+ apply impl_intro_l, const_elim_l=>-[-> ->] /=; done.
+Qed.
+
+End lifting.
+
diff --git a/program_logic/model.v b/program_logic/model.v
new file mode 100644
index 0000000000000000000000000000000000000000..40be67805f849501a21349ae326bdf2eb9a8286e
--- /dev/null
+++ b/program_logic/model.v
@@ -0,0 +1,46 @@
+Require Export logic.upred program_logic.resources.
+Require Import algebra.cofe_solver.
+
+Module iProp.
+Definition F (Λ : language) (Σ : iFunctor) (A B : cofeT) : cofeT :=
+ uPredC (resRA Λ Σ (laterC A)).
+Definition map {Λ : language} {Σ : iFunctor} {A1 A2 B1 B2 : cofeT}
+ (f : (A2 -n> A1) * (B1 -n> B2)) : F Λ Σ A1 B1 -n> F Λ Σ A2 B2 :=
+ uPredC_map (resRA_map (laterC_map (f.1))).
+Definition result Λ Σ : solution (F Λ Σ).
+Proof.
+ apply (solver.result _ (@map Λ Σ)).
+ * intros A B P. rewrite /map /= -{2}(uPred_map_id P). apply uPred_map_ext=> r.
+ rewrite /= -{2}(res_map_id r); apply res_map_ext=>{r} r /=.
+ by rewrite later_map_id.
+ * intros A1 A2 A3 B1 B2 B3 f g f' g' P. rewrite /map /=.
+ rewrite -uPred_map_compose. apply uPred_map_ext=>{P} r /=.
+ rewrite -res_map_compose. apply res_map_ext=>{r} r /=.
+ by rewrite -later_map_compose.
+ * intros A1 A2 B1 B2 n f f' [??] P.
+ by apply upredC_map_ne, resRA_map_ne, laterC_map_contractive.
+Qed.
+End iProp.
+
+(* Solution *)
+Definition iPreProp (Λ : language) (Σ : iFunctor) : cofeT := iProp.result Λ Σ.
+Notation iRes Λ Σ := (res Λ Σ (laterC (iPreProp Λ Σ))).
+Notation iResRA Λ Σ := (resRA Λ Σ (laterC (iPreProp Λ Σ))).
+Notation iWld Λ Σ := (mapRA positive (agreeRA (laterC (iPreProp Λ Σ)))).
+Notation iPst Λ := (exclRA (istateC Λ)).
+Notation iGst Λ Σ := (ifunctor_car Σ (laterC (iPreProp Λ Σ))).
+Definition iProp (Λ : language) (Σ : iFunctor) : cofeT := uPredC (iResRA Λ Σ).
+Definition iProp_unfold {Λ Σ} : iProp Λ Σ -n> iPreProp Λ Σ := solution_fold _.
+Definition iProp_fold {Λ Σ} : iPreProp Λ Σ -n> iProp Λ Σ := solution_unfold _.
+Lemma iProp_fold_unfold {Λ Σ} (P : iProp Λ Σ) : iProp_fold (iProp_unfold P) ≡ P.
+Proof. apply solution_unfold_fold. Qed.
+Lemma iProp_unfold_fold {Λ Σ} (P : iPreProp Λ Σ) :
+ iProp_unfold (iProp_fold P) ≡ P.
+Proof. apply solution_fold_unfold. Qed.
+Bind Scope uPred_scope with iProp.
+
+Instance iProp_fold_inj n Λ Σ : Injective (dist n) (dist n) (@iProp_fold Λ Σ).
+Proof. by intros X Y H; rewrite -(iProp_unfold_fold X) H iProp_unfold_fold. Qed.
+Instance iProp_unfold_inj n Λ Σ :
+ Injective (dist n) (dist n) (@iProp_unfold Λ Σ).
+Proof. by intros X Y H; rewrite -(iProp_fold_unfold X) H iProp_fold_unfold. Qed.
diff --git a/program_logic/namespace.v b/program_logic/namespace.v
new file mode 100644
index 0000000000000000000000000000000000000000..11c3a001c7dd849312843fc279801ce67ec3d142
--- /dev/null
+++ b/program_logic/namespace.v
@@ -0,0 +1,33 @@
+Require Export algebra.base prelude.countable prelude.co_pset.
+
+Definition namespace := list positive.
+Definition nnil : namespace := nil.
+Definition ndot `{Countable A} (I : namespace) (x : A) : namespace :=
+ encode x :: I.
+Definition nclose (I : namespace) : coPset := coPset_suffixes (encode I).
+
+Instance ndot_injective `{Countable A} : Injective2 (=) (=) (=) (@ndot A _ _).
+Proof. by intros I1 x1 I2 x2 ?; simplify_equality. Qed.
+Lemma nclose_nnil : nclose nnil = coPset_all.
+Proof. by apply (sig_eq_pi _). Qed.
+Lemma encode_nclose I : encode I ∈ nclose I.
+Proof. by apply elem_coPset_suffixes; exists xH; rewrite (left_id_L _ _). Qed.
+Lemma nclose_subseteq `{Countable A} I x : nclose (ndot I x) ⊆ nclose I.
+Proof.
+ intros p; rewrite /nclose !elem_coPset_suffixes; intros [q ->].
+ destruct (list_encode_suffix I (ndot I x)) as [q' ?]; [by exists [encode x]|].
+ by exists (q ++ q')%positive; rewrite <-(associative_L _); f_equal.
+Qed.
+Lemma ndot_nclose `{Countable A} I x : encode (ndot I x) ∈ nclose I.
+Proof. apply nclose_subseteq with x, encode_nclose. Qed.
+Lemma nclose_disjoint `{Countable A} I (x y : A) :
+ x ≠y → nclose (ndot I x) ∩ nclose (ndot I y) = ∅.
+Proof.
+ intros Hxy; apply elem_of_equiv_empty_L=> p; unfold nclose, ndot.
+ rewrite elem_of_intersection !elem_coPset_suffixes; intros [[q ->] [q' Hq]].
+ apply Hxy, (injective encode), (injective encode_nat); revert Hq.
+ rewrite !(list_encode_cons (encode _)).
+ rewrite !(associative_L _) (injective_iff (++ _)%positive) /=.
+ generalize (encode_nat (encode y)).
+ induction (encode_nat (encode x)); intros [|?] ?; f_equal'; naive_solver.
+Qed.
\ No newline at end of file
diff --git a/program_logic/ownership.v b/program_logic/ownership.v
new file mode 100644
index 0000000000000000000000000000000000000000..0fbbeb8ff18649f297af0fe645ac7e841ec4911d
--- /dev/null
+++ b/program_logic/ownership.v
@@ -0,0 +1,85 @@
+Require Export program_logic.model.
+
+Definition inv {Λ Σ} (i : positive) (P : iProp Λ Σ) : iProp Λ Σ :=
+ uPred_own (Res {[ i ↦ to_agree (Later (iProp_unfold P)) ]} ∅ ∅).
+Arguments inv {_ _} _ _%I.
+Definition ownP {Λ Σ} (σ: state Λ) : iProp Λ Σ := uPred_own (Res ∅ (Excl σ) ∅).
+Definition ownG {Λ Σ} (m : iGst Λ Σ) : iProp Λ Σ := uPred_own (Res ∅ ∅ m).
+Instance: Params (@inv) 3.
+Instance: Params (@ownP) 2.
+Instance: Params (@ownG) 2.
+
+Typeclasses Opaque inv ownG ownP.
+
+Section ownership.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types r : iRes Λ Σ.
+Implicit Types σ : state Λ.
+Implicit Types P : iProp Λ Σ.
+Implicit Types m : iGst Λ Σ.
+
+(* Invariants *)
+Global Instance inv_contractive i : Contractive (@inv Λ Σ i).
+Proof.
+ intros n P Q HPQ.
+ apply (_: Proper (_ ==> _) iProp_unfold), Later_contractive in HPQ.
+ by unfold inv; rewrite HPQ.
+Qed.
+Lemma always_inv i P : (□ inv i P)%I ≡ inv i P.
+Proof.
+ apply uPred.always_own.
+ by rewrite Res_unit !cmra_unit_empty map_unit_singleton.
+Qed.
+Global Instance inv_always_stable i P : AlwaysStable (inv i P).
+Proof. by rewrite /AlwaysStable always_inv. Qed.
+Lemma inv_sep_dup i P : inv i P ≡ (inv i P ★ inv i P)%I.
+Proof. apply (uPred.always_sep_dup' _). Qed.
+
+(* physical state *)
+Lemma ownP_twice σ1 σ2 : (ownP σ1 ★ ownP σ2 : iProp Λ Σ) ⊑ False.
+Proof.
+ rewrite /ownP -uPred.own_op Res_op.
+ by apply uPred.own_invalid; intros (_&?&_).
+Qed.
+Global Instance ownP_timeless σ : TimelessP (@ownP Λ Σ σ).
+Proof. rewrite /ownP; apply _. Qed.
+
+(* ghost state *)
+Global Instance ownG_ne n : Proper (dist n ==> dist n) (@ownG Λ Σ).
+Proof. by intros m m' Hm; unfold ownG; rewrite Hm. Qed.
+Global Instance ownG_proper : Proper ((≡) ==> (≡)) (@ownG Λ Σ) := ne_proper _.
+Lemma ownG_op m1 m2 : ownG (m1 ⋅ m2) ≡ (ownG m1 ★ ownG m2)%I.
+Proof. by rewrite /ownG -uPred.own_op Res_op !(left_id _ _). Qed.
+Lemma always_ownG_unit m : (□ ownG (unit m))%I ≡ ownG (unit m).
+Proof.
+ apply uPred.always_own.
+ by rewrite Res_unit !cmra_unit_empty cmra_unit_idempotent.
+Qed.
+Lemma ownG_valid m : (ownG m) ⊑ (✓ m).
+Proof. by rewrite /ownG uPred.own_valid; apply uPred.valid_mono=> n [? []]. Qed.
+Lemma ownG_valid_r m : (ownG m) ⊑ (ownG m ★ ✓ m).
+Proof. apply (uPred.always_entails_r' _ _), ownG_valid. Qed.
+Global Instance ownG_timeless m : Timeless m → TimelessP (ownG m).
+Proof. rewrite /ownG; apply _. Qed.
+
+(* inversion lemmas *)
+Lemma inv_spec r n i P :
+ ✓{n} r →
+ (inv i P) n r ↔ wld r !! i ={n}= Some (to_agree (Later (iProp_unfold P))).
+Proof.
+ intros [??]; rewrite /uPred_holds/=res_includedN/=singleton_includedN; split.
+ * intros [(P'&Hi&HP) _]; rewrite Hi.
+ by apply Some_dist, symmetry, agree_valid_includedN,
+ (cmra_included_includedN _ P'),HP; apply map_lookup_validN with (wld r) i.
+ * intros ?; split_ands; try apply cmra_empty_leastN; eauto.
+Qed.
+Lemma ownP_spec r n σ : ✓{n} r → (ownP σ) n r ↔ pst r ={n}= Excl σ.
+Proof.
+ intros (?&?&?); rewrite /uPred_holds /= res_includedN /= Excl_includedN //.
+ naive_solver (apply cmra_empty_leastN).
+Qed.
+Lemma ownG_spec r n m : (ownG m) n r ↔ m ≼{n} gst r.
+Proof.
+ rewrite /uPred_holds /= res_includedN; naive_solver (apply cmra_empty_leastN).
+Qed.
+End ownership.
diff --git a/program_logic/pviewshifts.v b/program_logic/pviewshifts.v
new file mode 100644
index 0000000000000000000000000000000000000000..1ce9fc629bae1c826717f0cd36d8846f838d73cd
--- /dev/null
+++ b/program_logic/pviewshifts.v
@@ -0,0 +1,144 @@
+Require Export program_logic.ownership prelude.co_pset.
+Require Import program_logic.wsat.
+Local Hint Extern 10 (_ ≤ _) => omega.
+Local Hint Extern 100 (@eq coPset _ _) => solve_elem_of.
+Local Hint Extern 100 (_ ∉ _) => solve_elem_of.
+Local Hint Extern 10 (✓{_} _) =>
+ repeat match goal with H : wsat _ _ _ _ |- _ => apply wsat_valid in H end;
+ solve_validN.
+
+Program Definition pvs {Λ Σ} (E1 E2 : coPset) (P : iProp Λ Σ) : iProp Λ Σ :=
+ {| uPred_holds n r1 := ∀ rf k Ef σ,
+ 1 < k ≤ n → (E1 ∪ E2) ∩ Ef = ∅ →
+ wsat k (E1 ∪ Ef) σ (r1 ⋅ rf) →
+ ∃ r2, P k r2 ∧ wsat k (E2 ∪ Ef) σ (r2 ⋅ rf) |}.
+Next Obligation.
+ intros Λ Σ E1 E2 P r1 r2 n HP Hr rf k Ef σ ?? Hwsat; simpl in *.
+ apply HP; auto. by rewrite (dist_le _ _ _ _ Hr); last lia.
+Qed.
+Next Obligation. intros Λ Σ E1 E2 P r rf k Ef σ; simpl in *; lia. Qed.
+Next Obligation.
+ intros Λ Σ E1 E2 P r1 r2 n1 n2 HP [r3 ?] Hn ? rf k Ef σ ?? Hws; setoid_subst.
+ destruct (HP (r3⋅rf) k Ef σ) as (r'&?&Hws'); rewrite ?(associative op); auto.
+ exists (r' â‹… r3); rewrite -(associative _); split; last done.
+ apply uPred_weaken with r' k; eauto using cmra_included_l.
+Qed.
+Arguments pvs {_ _} _ _ _%I : simpl never.
+Instance: Params (@pvs) 4.
+
+Section pvs.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types P Q : iProp Λ Σ.
+Implicit Types m : iGst Λ Σ.
+Transparent uPred_holds.
+
+Global Instance pvs_ne E1 E2 n : Proper (dist n ==> dist n) (@pvs Λ Σ E1 E2).
+Proof.
+ intros P Q HPQ r1 n' ??; simpl; split; intros HP rf k Ef σ ???;
+ destruct (HP rf k Ef σ) as (r2&?&?); auto;
+ exists r2; split_ands; auto; apply HPQ; eauto.
+Qed.
+Global Instance pvs_proper E1 E2 : Proper ((≡) ==> (≡)) (@pvs Λ Σ E1 E2).
+Proof. apply ne_proper, _. Qed.
+
+Lemma pvs_intro E P : P ⊑ pvs E E P.
+Proof.
+ intros r n ? HP rf k Ef σ ???; exists r; split; last done.
+ apply uPred_weaken with r n; eauto.
+Qed.
+Lemma pvs_mono E1 E2 P Q : P ⊑ Q → pvs E1 E2 P ⊑ pvs E1 E2 Q.
+Proof.
+ intros HPQ r n ? HP rf k Ef σ ???.
+ destruct (HP rf k Ef σ) as (r2&?&?); eauto; exists r2; eauto.
+Qed.
+Lemma pvs_timeless E P : TimelessP P → (▷ P) ⊑ pvs E E P.
+Proof.
+ rewrite uPred.timelessP_spec=> HP r [|n] ? HP' rf k Ef σ ???; first lia.
+ exists r; split; last done.
+ apply HP, uPred_weaken with r n; eauto using cmra_validN_le.
+Qed.
+Lemma pvs_trans E1 E2 E3 P :
+ E2 ⊆ E1 ∪ E3 → pvs E1 E2 (pvs E2 E3 P) ⊑ pvs E1 E3 P.
+Proof.
+ intros ? r1 n ? HP1 rf k Ef σ ???.
+ destruct (HP1 rf k Ef σ) as (r2&HP2&?); auto.
+Qed.
+Lemma pvs_mask_frame E1 E2 Ef P :
+ Ef ∩ (E1 ∪ E2) = ∅ → pvs E1 E2 P ⊑ pvs (E1 ∪ Ef) (E2 ∪ Ef) P.
+Proof.
+ intros ? r n ? HP rf k Ef' σ ???.
+ destruct (HP rf k (Ef∪Ef') σ) as (r'&?&?); rewrite ?(associative_L _); eauto.
+ by exists r'; rewrite -(associative_L _).
+Qed.
+Lemma pvs_frame_r E1 E2 P Q : (pvs E1 E2 P ★ Q) ⊑ pvs E1 E2 (P ★ Q).
+Proof.
+ intros r n ? (r1&r2&Hr&HP&?) rf k Ef σ ???.
+ destruct (HP (r2 ⋅ rf) k Ef σ) as (r'&?&?); eauto.
+ { by rewrite (associative _) -(dist_le _ _ _ _ Hr); last lia. }
+ exists (r' â‹… r2); split; last by rewrite -(associative _).
+ exists r', r2; split_ands; auto; apply uPred_weaken with r2 n; auto.
+Qed.
+Lemma pvs_open i P : inv i P ⊑ pvs {[ i ]} ∅ (▷ P).
+Proof.
+ intros r [|n] ? Hinv rf [|k] Ef σ ???; try lia.
+ apply inv_spec in Hinv; last auto.
+ destruct (wsat_open k Ef σ (r ⋅ rf) i P) as (rP&?&?); auto.
+ { rewrite lookup_wld_op_l ?Hinv; eauto; apply dist_le with (S n); eauto. }
+ exists (rP â‹… r); split; last by rewrite (left_id_L _ _) -(associative _).
+ eapply uPred_weaken with rP (S k); eauto using cmra_included_l.
+Qed.
+Lemma pvs_close i P : (inv i P ∧ ▷ P) ⊑ pvs ∅ {[ i ]} True.
+Proof.
+ intros r [|n] ? [? HP] rf [|k] Ef σ ? HE ?; try lia; exists ∅; split; [done|].
+ rewrite (left_id _ _); apply wsat_close with P r.
+ * apply inv_spec, uPred_weaken with r (S n); auto.
+ * solve_elem_of +HE.
+ * by rewrite -(left_id_L ∅ (∪) Ef).
+ * apply uPred_weaken with r n; auto.
+Qed.
+Lemma pvs_updateP E m (P : iGst Λ Σ → Prop) :
+ m ~~>: P → ownG m ⊑ pvs E E (∃ m', ■P m' ∧ ownG m').
+Proof.
+ intros Hup r [|n] ? Hinv%ownG_spec rf [|k] Ef σ ???; try lia.
+ destruct (wsat_update_gst k (E ∪ Ef) σ r rf m P)
+ as (m'&?&?); eauto using cmra_includedN_le.
+ by exists (update_gst m' r); split; [exists m'; split; [|apply ownG_spec]|].
+Qed.
+Lemma pvs_alloc E P : ¬set_finite E → ▷ P ⊑ pvs E E (∃ i, ■(i ∈ E) ∧ inv i P).
+Proof.
+ intros ? r [|n] ? HP rf [|k] Ef σ ???; try lia.
+ destruct (wsat_alloc k E Ef σ rf P r) as (i&?&?&?); auto.
+ { apply uPred_weaken with r n; eauto. }
+ exists (Res {[ i ↦ to_agree (Later (iProp_unfold P)) ]} ∅ ∅).
+ by split; [by exists i; split; rewrite /uPred_holds /=|].
+Qed.
+
+(* Derived rules *)
+Opaque uPred_holds.
+Import uPred.
+Global Instance pvs_mono' E1 E2 : Proper ((⊑) ==> (⊑)) (@pvs Λ Σ E1 E2).
+Proof. intros P Q; apply pvs_mono. Qed.
+Lemma pvs_trans' E P : pvs E E (pvs E E P) ⊑ pvs E E P.
+Proof. apply pvs_trans; solve_elem_of. Qed.
+Lemma pvs_frame_l E1 E2 P Q : (P ★ pvs E1 E2 Q) ⊑ pvs E1 E2 (P ★ Q).
+Proof. rewrite !(commutative _ P); apply pvs_frame_r. Qed.
+Lemma pvs_always_l E1 E2 P Q `{!AlwaysStable P} :
+ (P ∧ pvs E1 E2 Q) ⊑ pvs E1 E2 (P ∧ Q).
+Proof. by rewrite !always_and_sep_l' pvs_frame_l. Qed.
+Lemma pvs_always_r E1 E2 P Q `{!AlwaysStable Q} :
+ (pvs E1 E2 P ∧ Q) ⊑ pvs E1 E2 (P ∧ Q).
+Proof. by rewrite !always_and_sep_r' pvs_frame_r. Qed.
+Lemma pvs_impl_l E1 E2 P Q : (□ (P → Q) ∧ pvs E1 E2 P) ⊑ pvs E1 E2 Q.
+Proof. by rewrite pvs_always_l always_elim impl_elim_l. Qed.
+Lemma pvs_impl_r E1 E2 P Q : (pvs E1 E2 P ∧ □ (P → Q)) ⊑ pvs E1 E2 Q.
+Proof. by rewrite (commutative _) pvs_impl_l. Qed.
+Lemma pvs_mask_weaken E1 E2 P : E1 ⊆ E2 → pvs E1 E1 P ⊑ pvs E2 E2 P.
+Proof.
+ intros; rewrite (union_difference_L E1 E2) //; apply pvs_mask_frame; auto.
+Qed.
+Lemma pvs_update E m m' : m ~~> m' → ownG m ⊑ pvs E E (ownG m').
+Proof.
+ intros; rewrite ->(pvs_updateP E _ (m' =)); last by apply cmra_update_updateP.
+ by apply pvs_mono, uPred.exist_elim=> m''; apply uPred.const_elim_l=> ->.
+Qed.
+End pvs.
diff --git a/program_logic/resources.v b/program_logic/resources.v
new file mode 100644
index 0000000000000000000000000000000000000000..5692e645de60392349d6ce941908278035301622
--- /dev/null
+++ b/program_logic/resources.v
@@ -0,0 +1,215 @@
+Require Export algebra.fin_maps algebra.agree algebra.excl.
+Require Export program_logic.language program_logic.functor.
+
+Record res (Λ : language) (Σ : iFunctor) (A : cofeT) := Res {
+ wld : mapRA positive (agreeRA A);
+ pst : exclRA (istateC Λ);
+ gst : Σ A;
+}.
+Add Printing Constructor res.
+Arguments Res {_ _ _} _ _ _.
+Arguments wld {_ _ _} _.
+Arguments pst {_ _ _} _.
+Arguments gst {_ _ _} _.
+Instance: Params (@Res) 3.
+Instance: Params (@wld) 3.
+Instance: Params (@pst) 3.
+Instance: Params (@gst) 3.
+
+Section res.
+Context {Λ : language} {Σ : iFunctor} {A : cofeT}.
+Implicit Types r : res Λ Σ A.
+
+Inductive res_equiv' (r1 r2 : res Λ Σ A) := Res_equiv :
+ wld r1 ≡ wld r2 → pst r1 ≡ pst r2 → gst r1 ≡ gst r2 → res_equiv' r1 r2.
+Instance res_equiv : Equiv (res Λ Σ A) := res_equiv'.
+Inductive res_dist' (n : nat) (r1 r2 : res Λ Σ A) := Res_dist :
+ wld r1 ={n}= wld r2 → pst r1 ={n}= pst r2 → gst r1 ={n}= gst r2 →
+ res_dist' n r1 r2.
+Instance res_dist : Dist (res Λ Σ A) := res_dist'.
+Global Instance Res_ne n :
+ Proper (dist n ==> dist n ==> dist n ==> dist n) (@Res Λ Σ A).
+Proof. done. Qed.
+Global Instance Res_proper : Proper ((≡) ==> (≡) ==> (≡) ==> (≡)) (@Res Λ Σ A).
+Proof. done. Qed.
+Global Instance wld_ne n : Proper (dist n ==> dist n) (@wld Λ Σ A).
+Proof. by destruct 1. Qed.
+Global Instance wld_proper : Proper ((≡) ==> (≡)) (@wld Λ Σ A).
+Proof. by destruct 1. Qed.
+Global Instance pst_ne n : Proper (dist n ==> dist n) (@pst Λ Σ A).
+Proof. by destruct 1. Qed.
+Global Instance pst_ne' n : Proper (dist (S n) ==> (≡)) (@pst Λ Σ A).
+Proof.
+ intros σ σ' [???]; apply (timeless _), dist_le with (S n); auto with lia.
+Qed.
+Global Instance pst_proper : Proper ((≡) ==> (=)) (@pst Λ Σ A).
+Proof. by destruct 1; unfold_leibniz. Qed.
+Global Instance gst_ne n : Proper (dist n ==> dist n) (@gst Λ Σ A).
+Proof. by destruct 1. Qed.
+Global Instance gst_proper : Proper ((≡) ==> (≡)) (@gst Λ Σ A).
+Proof. by destruct 1. Qed.
+Instance res_compl : Compl (res Λ Σ A) := λ c,
+ Res (compl (chain_map wld c))
+ (compl (chain_map pst c)) (compl (chain_map gst c)).
+Definition res_cofe_mixin : CofeMixin (res Λ Σ A).
+Proof.
+ split.
+ * intros w1 w2; split.
+ + by destruct 1; constructor; apply equiv_dist.
+ + by intros Hw; constructor; apply equiv_dist=>n; destruct (Hw n).
+ * intros n; split.
+ + done.
+ + by destruct 1; constructor.
+ + do 2 destruct 1; constructor; etransitivity; eauto.
+ * by destruct 1; constructor; apply dist_S.
+ * done.
+ * intros c n; constructor.
+ + apply (conv_compl (chain_map wld c) n).
+ + apply (conv_compl (chain_map pst c) n).
+ + apply (conv_compl (chain_map gst c) n).
+Qed.
+Canonical Structure resC : cofeT := CofeT res_cofe_mixin.
+Global Instance res_timeless r :
+ Timeless (wld r) → Timeless (gst r) → Timeless r.
+Proof. by destruct 3; constructor; try apply (timeless _). Qed.
+
+Instance res_op : Op (res Λ Σ A) := λ r1 r2,
+ Res (wld r1 â‹… wld r2) (pst r1 â‹… pst r2) (gst r1 â‹… gst r2).
+Global Instance res_empty : Empty (res Λ Σ A) := Res ∅ ∅ ∅.
+Instance res_unit : Unit (res Λ Σ A) := λ r,
+ Res (unit (wld r)) (unit (pst r)) (unit (gst r)).
+Instance res_validN : ValidN (res Λ Σ A) := λ n r,
+ ✓{n} (wld r) ∧ ✓{n} (pst r) ∧ ✓{n} (gst r).
+Instance res_minus : Minus (res Λ Σ A) := λ r1 r2,
+ Res (wld r1 ⩪ wld r2) (pst r1 ⩪ pst r2) (gst r1 ⩪ gst r2).
+Lemma res_included (r1 r2 : res Λ Σ A) :
+ r1 ≼ r2 ↔ wld r1 ≼ wld r2 ∧ pst r1 ≼ pst r2 ∧ gst r1 ≼ gst r2.
+Proof.
+ split; [|by intros ([w ?]&[σ ?]&[m ?]); exists (Res w σ m)].
+ intros [r Hr]; split_ands;
+ [exists (wld r)|exists (pst r)|exists (gst r)]; apply Hr.
+Qed.
+Lemma res_includedN (r1 r2 : res Λ Σ A) n :
+ r1 ≼{n} r2 ↔ wld r1 ≼{n} wld r2 ∧ pst r1 ≼{n} pst r2 ∧ gst r1 ≼{n} gst r2.
+Proof.
+ split; [|by intros ([w ?]&[σ ?]&[m ?]); exists (Res w σ m)].
+ intros [r Hr]; split_ands;
+ [exists (wld r)|exists (pst r)|exists (gst r)]; apply Hr.
+Qed.
+Definition res_cmra_mixin : CMRAMixin (res Λ Σ A).
+Proof.
+ split.
+ * by intros n x [???] ? [???]; constructor; simpl in *; cofe_subst.
+ * by intros n [???] ? [???]; constructor; simpl in *; cofe_subst.
+ * by intros n [???] ? [???] (?&?&?); split_ands'; simpl in *; cofe_subst.
+ * by intros n [???] ? [???] [???] ? [???];
+ constructor; simpl in *; cofe_subst.
+ * done.
+ * by intros n ? (?&?&?); split_ands'; apply cmra_validN_S.
+ * intros ???; constructor; simpl; apply (associative _).
+ * intros ??; constructor; simpl; apply (commutative _).
+ * intros ?; constructor; simpl; apply cmra_unit_l.
+ * intros ?; constructor; simpl; apply cmra_unit_idempotent.
+ * intros n r1 r2; rewrite !res_includedN.
+ by intros (?&?&?); split_ands'; apply cmra_unit_preservingN.
+ * intros n r1 r2 (?&?&?);
+ split_ands'; simpl in *; eapply cmra_validN_op_l; eauto.
+ * intros n r1 r2; rewrite res_includedN; intros (?&?&?).
+ by constructor; apply cmra_op_minus.
+Qed.
+Definition res_cmra_extend_mixin : CMRAExtendMixin (res Λ Σ A).
+Proof.
+ intros n r r1 r2 (?&?&?) [???]; simpl in *.
+ destruct (cmra_extend_op n (wld r) (wld r1) (wld r2)) as ([w w']&?&?&?),
+ (cmra_extend_op n (pst r) (pst r1) (pst r2)) as ([σ σ']&?&?&?),
+ (cmra_extend_op n (gst r) (gst r1) (gst r2)) as ([m m']&?&?&?); auto.
+ by exists (Res w σ m, Res w' σ' m').
+Qed.
+Canonical Structure resRA : cmraT :=
+ CMRAT res_cofe_mixin res_cmra_mixin res_cmra_extend_mixin.
+Global Instance res_cmra_identity : CMRAIdentity resRA.
+Proof.
+ split.
+ * intros n; split_ands'; apply cmra_empty_valid.
+ * by split; rewrite /= (left_id _ _).
+ * apply _.
+Qed.
+
+Definition update_pst (σ : state Λ) (r : res Λ Σ A) : res Λ Σ A :=
+ Res (wld r) (Excl σ) (gst r).
+Definition update_gst (m : Σ A) (r : res Λ Σ A) : res Λ Σ A :=
+ Res (wld r) (pst r) m.
+
+Lemma wld_validN n r : ✓{n} r → ✓{n} (wld r).
+Proof. by intros (?&?&?). Qed.
+Lemma gst_validN n r : ✓{n} r → ✓{n} (gst r).
+Proof. by intros (?&?&?). Qed.
+Lemma Res_op w1 w2 σ1 σ2 m1 m2 :
+ Res w1 σ1 m1 ⋅ Res w2 σ2 m2 = Res (w1 ⋅ w2) (σ1 ⋅ σ2) (m1 ⋅ m2).
+Proof. done. Qed.
+Lemma Res_unit w σ m : unit (Res w σ m) = Res (unit w) (unit σ) (unit m).
+Proof. done. Qed.
+Lemma lookup_wld_op_l n r1 r2 i P :
+ ✓{n} (r1⋅r2) → wld r1 !! i ={n}= Some P → (wld r1 ⋅ wld r2) !! i ={n}= Some P.
+Proof.
+ move=>/wld_validN /(_ i) Hval Hi1P; move: Hi1P Hval; rewrite lookup_op.
+ destruct (wld r2 !! i) as [P'|] eqn:Hi; rewrite !Hi ?right_id // =>-> ?.
+ by constructor; rewrite (agree_op_inv P P') // agree_idempotent.
+Qed.
+Lemma lookup_wld_op_r n r1 r2 i P :
+ ✓{n} (r1⋅r2) → wld r2 !! i ={n}= Some P → (wld r1 ⋅ wld r2) !! i ={n}= Some P.
+Proof.
+ rewrite (commutative _ r1) (commutative _ (wld r1)); apply lookup_wld_op_l.
+Qed.
+Global Instance Res_timeless eσ m : Timeless m → Timeless (Res ∅ eσ m).
+Proof. by intros ? ? [???]; constructor; apply (timeless _). Qed.
+End res.
+Arguments resRA : clear implicits.
+
+Definition res_map {Λ Σ A B} (f : A -n> B) (r : res Λ Σ A) : res Λ Σ B :=
+ Res (agree_map f <$> (wld r))
+ (pst r)
+ (ifunctor_map Σ f (gst r)).
+Instance res_map_ne Λ Σ (A B : cofeT) (f : A -n> B) :
+ (∀ n, Proper (dist n ==> dist n) f) →
+ ∀ n, Proper (dist n ==> dist n) (@res_map Λ Σ _ _ f).
+Proof. by intros Hf n [] ? [???]; constructor; simpl in *; cofe_subst. Qed.
+Lemma res_map_id {Λ Σ A} (r : res Λ Σ A) : res_map cid r ≡ r.
+Proof.
+ constructor; simpl; [|done|].
+ * rewrite -{2}(map_fmap_id (wld r)); apply map_fmap_setoid_ext=> i y ? /=.
+ by rewrite -{2}(agree_map_id y); apply agree_map_ext=> y' /=.
+ * by rewrite -{2}(ifunctor_map_id Σ (gst r)); apply ifunctor_map_ext=> m /=.
+Qed.
+Lemma res_map_compose {Λ Σ A B C} (f : A -n> B) (g : B -n> C) (r : res Λ Σ A) :
+ res_map (g ◎ f) r ≡ res_map g (res_map f r).
+Proof.
+ constructor; simpl; [|done|].
+ * rewrite -map_fmap_compose; apply map_fmap_setoid_ext=> i y _ /=.
+ by rewrite -agree_map_compose; apply agree_map_ext=> y' /=.
+ * by rewrite -ifunctor_map_compose; apply ifunctor_map_ext=> m /=.
+Qed.
+Lemma res_map_ext {Λ Σ A B} (f g : A -n> B) (r : res Λ Σ A) :
+ (∀ x, f x ≡ g x) → res_map f r ≡ res_map g r.
+Proof.
+ intros Hfg; split; simpl; auto.
+ * by apply map_fmap_setoid_ext=>i x ?; apply agree_map_ext.
+ * by apply ifunctor_map_ext.
+Qed.
+Definition resRA_map {Λ Σ A B} (f : A -n> B) : resRA Λ Σ A -n> resRA Λ Σ B :=
+ CofeMor (res_map f : resRA Λ Σ A → resRA Λ Σ B).
+Instance res_map_cmra_monotone {Λ Σ} {A B : cofeT} (f : A -n> B) :
+ CMRAMonotone (@res_map Λ Σ _ _ f).
+Proof.
+ split.
+ * by intros n r1 r2; rewrite !res_includedN;
+ intros (?&?&?); split_ands'; simpl; try apply includedN_preserving.
+ * by intros n r (?&?&?); split_ands'; simpl; try apply validN_preserving.
+Qed.
+Instance resRA_map_ne {Λ Σ A B} n :
+ Proper (dist n ==> dist n) (@resRA_map Λ Σ A B).
+Proof.
+ intros f g Hfg r; split; simpl; auto.
+ * by apply (mapRA_map_ne _ (agreeRA_map f) (agreeRA_map g)), agreeRA_map_ne.
+ * by apply ifunctor_map_ne.
+Qed.
diff --git a/program_logic/tests.v b/program_logic/tests.v
new file mode 100644
index 0000000000000000000000000000000000000000..b499de9fab926a473890175117ac11f5c7ee42dc
--- /dev/null
+++ b/program_logic/tests.v
@@ -0,0 +1,7 @@
+(** This file tests a bunch of things. *)
+Require Import program_logic.model.
+
+Module ModelTest. (* Make sure we got the notations right. *)
+ Definition iResTest {Λ : language} {Σ : iFunctor}
+ (w : iWld Λ Σ) (p : iPst Λ) (g : iGst Λ Σ) : iRes Λ Σ := Res w p g.
+End ModelTest.
diff --git a/program_logic/viewshifts.v b/program_logic/viewshifts.v
new file mode 100644
index 0000000000000000000000000000000000000000..c44d8a4158df434357bbc75b85d8ff32c9d8db98
--- /dev/null
+++ b/program_logic/viewshifts.v
@@ -0,0 +1,96 @@
+Require Export program_logic.pviewshifts.
+
+Definition vs {Λ Σ} (E1 E2 : coPset) (P Q : iProp Λ Σ) : iProp Λ Σ :=
+ (□ (P → pvs E1 E2 Q))%I.
+Arguments vs {_ _} _ _ _%I _%I.
+Instance: Params (@vs) 4.
+Notation "P >{ E1 , E2 }> Q" := (vs E1 E2 P%I Q%I)
+ (at level 69, E1 at level 1, format "P >{ E1 , E2 }> Q") : uPred_scope.
+Notation "P >{ E1 , E2 }> Q" := (True ⊑ vs E1 E2 P%I Q%I)
+ (at level 69, E1 at level 1, format "P >{ E1 , E2 }> Q") : C_scope.
+Notation "P >{ E }> Q" := (vs E E P%I Q%I)
+ (at level 69, E at level 1, format "P >{ E }> Q") : uPred_scope.
+Notation "P >{ E }> Q" := (True ⊑ vs E E P%I Q%I)
+ (at level 69, E at level 1, format "P >{ E }> Q") : C_scope.
+
+Section vs.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types P Q : iProp Λ Σ.
+Implicit Types m : iGst Λ Σ.
+Import uPred.
+
+Lemma vs_alt E1 E2 P Q : (P ⊑ pvs E1 E2 Q) → P >{E1,E2}> Q.
+Proof.
+ intros; rewrite -{1}always_const; apply always_intro, impl_intro_l.
+ by rewrite always_const (right_id _ _).
+Qed.
+Global Instance vs_ne E1 E2 n :
+ Proper (dist n ==> dist n ==> dist n) (@vs Λ Σ E1 E2).
+Proof. by intros P P' HP Q Q' HQ; rewrite /vs HP HQ. Qed.
+Global Instance vs_proper E1 E2 : Proper ((≡) ==> (≡) ==> (≡)) (@vs Λ Σ E1 E2).
+Proof. apply ne_proper_2, _. Qed.
+Lemma vs_mono E1 E2 P P' Q Q' :
+ P ⊑ P' → Q' ⊑ Q → P' >{E1,E2}> Q' ⊑ P >{E1,E2}> Q.
+Proof. by intros HP HQ; rewrite /vs -HP HQ. Qed.
+Global Instance vs_mono' E1 E2 :
+ Proper (flip (⊑) ==> (⊑) ==> (⊑)) (@vs Λ Σ E1 E2).
+Proof. by intros until 2; apply vs_mono. Qed.
+
+Lemma vs_false_elim E1 E2 P : False >{E1,E2}> P.
+Proof. apply vs_alt, False_elim. Qed.
+Lemma vs_timeless E P : TimelessP P → ▷ P >{E}> P.
+Proof. by intros ?; apply vs_alt, pvs_timeless. Qed.
+Lemma vs_transitive E1 E2 E3 P Q R :
+ E2 ⊆ E1 ∪ E3 → (P >{E1,E2}> Q ∧ Q >{E2,E3}> R) ⊑ P >{E1,E3}> R.
+Proof.
+ intros; rewrite -always_and; apply always_intro, impl_intro_l.
+ rewrite always_and (associative _) (always_elim (P → _)) impl_elim_r.
+ by rewrite pvs_impl_r; apply pvs_trans.
+Qed.
+Lemma vs_transitive' E P Q R : (P >{E}> Q ∧ Q >{E}> R) ⊑ P >{E}> R.
+Proof. apply vs_transitive; solve_elem_of. Qed.
+Lemma vs_reflexive E P : P >{E}> P.
+Proof. apply vs_alt, pvs_intro. Qed.
+Lemma vs_impl E P Q : □ (P → Q) ⊑ P >{E}> Q.
+Proof.
+ apply always_intro, impl_intro_l.
+ by rewrite always_elim impl_elim_r -pvs_intro.
+Qed.
+Lemma vs_frame_l E1 E2 P Q R : P >{E1,E2}> Q ⊑ (R ★ P) >{E1,E2}> (R ★ Q).
+Proof.
+ apply always_intro, impl_intro_l.
+ rewrite -pvs_frame_l always_and_sep_r -always_wand_impl -(associative _).
+ by rewrite always_elim wand_elim_r.
+Qed.
+Lemma vs_frame_r E1 E2 P Q R : P >{E1,E2}> Q ⊑ (P ★ R) >{E1,E2}> (Q ★ R).
+Proof. rewrite !(commutative _ _ R); apply vs_frame_l. Qed.
+Lemma vs_mask_frame E1 E2 Ef P Q :
+ Ef ∩ (E1 ∪ E2) = ∅ → P >{E1,E2}> Q ⊑ P >{E1 ∪ Ef,E2 ∪ Ef}> Q.
+Proof.
+ intros ?; apply always_intro, impl_intro_l; rewrite (pvs_mask_frame _ _ Ef)//.
+ by rewrite always_elim impl_elim_r.
+Qed.
+Lemma vs_mask_frame' E Ef P Q : Ef ∩ E = ∅ → P >{E}> Q ⊑ P >{E ∪ Ef}> Q.
+Proof. intros; apply vs_mask_frame; solve_elem_of. Qed.
+Lemma vs_open i P : inv i P >{{[i]},∅}> ▷ P.
+Proof. intros; apply vs_alt, pvs_open. Qed.
+Lemma vs_open' E i P : i ∉ E → inv i P >{{[i]} ∪ E,E}> ▷ P.
+Proof.
+ intros; rewrite -{2}(left_id_L ∅ (∪) E) -vs_mask_frame; last solve_elem_of.
+ apply vs_open.
+Qed.
+Lemma vs_close i P : (inv i P ∧ ▷ P) >{∅,{[i]}}> True.
+Proof. intros; apply vs_alt, pvs_close. Qed.
+Lemma vs_close' E i P : i ∉ E → (inv i P ∧ ▷ P) >{E,{[i]} ∪ E}> True.
+Proof.
+ intros; rewrite -{1}(left_id_L ∅ (∪) E) -vs_mask_frame; last solve_elem_of.
+ apply vs_close.
+Qed.
+Lemma vs_updateP E m (P : iGst Λ Σ → Prop) :
+ m ~~>: P → ownG m >{E}> (∃ m', ■P m' ∧ ownG m').
+Proof. by intros; apply vs_alt, pvs_updateP. Qed.
+Lemma vs_update E m m' : m ~~> m' → ownG m >{E}> ownG m'.
+Proof. by intros; apply vs_alt, pvs_update. Qed.
+Lemma vs_alloc E P : ¬set_finite E → ▷ P >{E}> (∃ i, ■(i ∈ E) ∧ inv i P).
+Proof. by intros; apply vs_alt, pvs_alloc. Qed.
+End vs.
diff --git a/program_logic/weakestpre.v b/program_logic/weakestpre.v
new file mode 100644
index 0000000000000000000000000000000000000000..5d3a383f9874d0a1b5c923e96c17dde964e3c6a7
--- /dev/null
+++ b/program_logic/weakestpre.v
@@ -0,0 +1,208 @@
+Require Export program_logic.pviewshifts.
+Require Import program_logic.wsat.
+Local Hint Extern 10 (_ ≤ _) => omega.
+Local Hint Extern 100 (@eq coPset _ _) => eassumption || solve_elem_of.
+Local Hint Extern 100 (_ ∉ _) => solve_elem_of.
+Local Hint Extern 10 (✓{_} _) =>
+ repeat match goal with H : wsat _ _ _ _ |- _ => apply wsat_valid in H end;
+ solve_validN.
+
+Record wp_go {Λ Σ} (E : coPset) (Q Qfork : expr Λ → nat → iRes Λ Σ → Prop)
+ (k : nat) (rf : iRes Λ Σ) (e1 : expr Λ) (σ1 : state Λ) := {
+ wf_safe : reducible e1 σ1;
+ wp_step e2 σ2 ef :
+ prim_step e1 σ1 e2 σ2 ef →
+ ∃ r2 r2',
+ wsat k E σ2 (r2 ⋅ r2' ⋅ rf) ∧
+ Q e2 k r2 ∧
+ ∀ e', ef = Some e' → Qfork e' k r2'
+}.
+CoInductive wp_pre {Λ Σ} (E : coPset)
+ (Q : val Λ → iProp Λ Σ) : expr Λ → nat → iRes Λ Σ → Prop :=
+ | wp_pre_value n r v : Q v n r → wp_pre E Q (of_val v) n r
+ | wp_pre_step n r1 e1 :
+ to_val e1 = None →
+ (∀ rf k Ef σ1,
+ 1 < k < n → E ∩ Ef = ∅ →
+ wsat (S k) (E ∪ Ef) σ1 (r1 ⋅ rf) →
+ wp_go (E ∪ Ef) (wp_pre E Q)
+ (wp_pre coPset_all (λ _, True%I)) k rf e1 σ1) →
+ wp_pre E Q e1 n r1.
+Program Definition wp {Λ Σ} (E : coPset) (e : expr Λ)
+ (Q : val Λ → iProp Λ Σ) : iProp Λ Σ := {| uPred_holds := wp_pre E Q e |}.
+Next Obligation.
+ intros Λ Σ E e Q r1 r2 n Hwp Hr.
+ destruct Hwp as [|n r1 e2 ? Hgo]; constructor; rewrite -?Hr; auto.
+ intros rf k Ef σ1 ?; rewrite -(dist_le _ _ _ _ Hr); naive_solver.
+Qed.
+Next Obligation.
+ intros Λ Σ E e Q r; destruct (to_val e) as [v|] eqn:?.
+ * by rewrite -(of_to_val e v) //; constructor.
+ * constructor; auto with lia.
+Qed.
+Next Obligation.
+ intros Λ Σ E e Q r1 r2 n1; revert Q E e r1 r2.
+ induction n1 as [n1 IH] using lt_wf_ind; intros Q E e r1 r1' n2.
+ destruct 1 as [|n1 r1 e1 ? Hgo].
+ * constructor; eauto using uPred_weaken.
+ * intros [rf' Hr] ??; constructor; [done|intros rf k Ef σ1 ???].
+ destruct (Hgo (rf' ⋅ rf) k Ef σ1) as [Hsafe Hstep];
+ rewrite ?associative -?Hr; auto; constructor; [done|].
+ intros e2 σ2 ef ?; destruct (Hstep e2 σ2 ef) as (r2&r2'&?&?&?); auto.
+ exists r2, (r2' â‹… rf'); split_ands; eauto 10 using (IH k), cmra_included_l.
+ by rewrite -!associative (associative _ r2).
+Qed.
+Instance: Params (@wp) 4.
+
+Section wp.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types P : iProp Λ Σ.
+Implicit Types Q : val Λ → iProp Λ Σ.
+Implicit Types v : val Λ.
+Implicit Types e : expr Λ.
+Transparent uPred_holds.
+
+Lemma wp_weaken E1 E2 e Q1 Q2 r n n' :
+ E1 ⊆ E2 → (∀ v r n', n' ≤ n → ✓{n'} r → Q1 v n' r → Q2 v n' r) →
+ n' ≤ n → ✓{n'} r → wp E1 e Q1 n' r → wp E2 e Q2 n' r.
+Proof.
+ intros HE HQ; revert e r; induction n' as [n' IH] using lt_wf_ind; intros e r.
+ destruct 3 as [|n' r e1 ? Hgo]; constructor; eauto.
+ intros rf k Ef σ1 ???.
+ assert (E2 ∪ Ef = E1 ∪ (E2 ∖ E1 ∪ Ef)) as HE'.
+ { by rewrite associative_L -union_difference_L. }
+ destruct (Hgo rf k ((E2 ∖ E1) ∪ Ef) σ1) as [Hsafe Hstep]; rewrite -?HE'; auto.
+ split; [done|intros e2 σ2 ef ?].
+ destruct (Hstep e2 σ2 ef) as (r2&r2'&?&?&?); auto.
+ exists r2, r2'; split_ands; [rewrite HE'|eapply IH|]; eauto.
+Qed.
+Global Instance wp_ne E e n :
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@wp Λ Σ E e).
+Proof. by intros Q Q' HQ; split; apply wp_weaken with n; try apply HQ. Qed.
+Global Instance wp_proper E e :
+ Proper (pointwise_relation _ (≡) ==> (≡)) (@wp Λ Σ E e).
+Proof.
+ by intros Q Q' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist.
+Qed.
+
+Lemma wp_value_inv E Q v n r : wp E (of_val v) Q n r → Q v n r.
+Proof.
+ inversion 1 as [|??? He]; simplify_equality; auto.
+ by rewrite ?to_of_val in He.
+Qed.
+Lemma wp_step_inv E Ef Q e k n σ r rf :
+ to_val e = None → 1 < k < n → E ∩ Ef = ∅ →
+ wp E e Q n r → wsat (S k) (E ∪ Ef) σ (r ⋅ rf) →
+ wp_go (E ∪ Ef) (λ e, wp E e Q) (λ e, wp coPset_all e (λ _, True%I)) k rf e σ.
+Proof. intros He; destruct 3; [by rewrite ?to_of_val in He|eauto]. Qed.
+
+Lemma wp_value E Q v : Q v ⊑ wp E (of_val v) Q.
+Proof. by constructor. Qed.
+Lemma wp_mono E e Q1 Q2 : (∀ v, Q1 v ⊑ Q2 v) → wp E e Q1 ⊑ wp E e Q2.
+Proof. by intros HQ r n ?; apply wp_weaken with n; intros; try apply HQ. Qed.
+Lemma wp_pvs E e Q : pvs E E (wp E e Q) ⊑ wp E e (λ v, pvs E E (Q v)).
+Proof.
+ intros r [|n] ?; [done|]; intros Hvs.
+ destruct (to_val e) as [v|] eqn:He; [apply of_to_val in He; subst|].
+ { by constructor; eapply pvs_mono, Hvs; [intros ???; apply wp_value_inv|]. }
+ constructor; [done|intros rf k Ef σ1 ???].
+ destruct (Hvs rf (S k) Ef σ1) as (r'&Hwp&?); auto.
+ inversion Hwp as [|???? Hgo]; subst; [by rewrite to_of_val in He|].
+ destruct (Hgo rf k Ef σ1) as [Hsafe Hstep]; auto.
+ split; [done|intros e2 σ2 ef ?].
+ destruct (Hstep e2 σ2 ef) as (r2&r2'&?&Hwp'&?); auto.
+ exists r2, r2'; split_ands; auto.
+ eapply wp_mono, Hwp'; auto using pvs_intro.
+Qed.
+Lemma wp_atomic E1 E2 e Q :
+ E2 ⊆ E1 → atomic e → pvs E1 E2 (wp E2 e (λ v, pvs E2 E1 (Q v))) ⊑ wp E1 e Q.
+Proof.
+ intros ? He r n ? Hvs; constructor; eauto using atomic_not_val.
+ intros rf k Ef σ1 ???.
+ destruct (Hvs rf (S k) Ef σ1) as (r'&Hwp&?); auto.
+ inversion Hwp as [|???? Hgo]; subst; [by destruct (atomic_of_val v)|].
+ destruct (Hgo rf k Ef σ1) as [Hsafe Hstep]; clear Hgo; auto.
+ split; [done|intros e2 σ2 ef ?].
+ destruct (Hstep e2 σ2 ef) as (r2&r2'&?&Hwp'&?); clear Hsafe Hstep; auto.
+ destruct Hwp' as [k r2 v Hvs'|k r2 e2 Hgo];
+ [|destruct (atomic_step e σ1 e2 σ2 ef); naive_solver].
+ destruct (Hvs' (r2' ⋅ rf) k Ef σ2) as (r3&[]); rewrite ?(associative _); auto.
+ by exists r3, r2'; split_ands; [rewrite -(associative _)|constructor|].
+Qed.
+Lemma wp_mask_weaken E1 E2 e Q : E1 ⊆ E2 → wp E1 e Q ⊑ wp E2 e Q.
+Proof. by intros HE r n ?; apply wp_weaken with n. Qed.
+Lemma wp_frame_r E e Q R : (wp E e Q ★ R) ⊑ wp E e (λ v, Q v ★ R).
+Proof.
+ intros r' n Hvalid (r&rR&Hr&Hwp&?); revert Hvalid.
+ rewrite Hr; clear Hr; revert e r Hwp.
+ induction n as [n IH] using lt_wf_ind; intros e r1.
+ destruct 1 as [|n r e ? Hgo]; constructor; [exists r, rR; eauto|auto|].
+ intros rf k Ef σ1 ???; destruct (Hgo (rR⋅rf) k Ef σ1) as [Hsafe Hstep]; auto.
+ { by rewrite (associative _). }
+ split; [done|intros e2 σ2 ef ?].
+ destruct (Hstep e2 σ2 ef) as (r2&r2'&?&?&?); auto.
+ exists (r2 â‹… rR), r2'; split_ands; auto.
+ * by rewrite -(associative _ r2)
+ (commutative _ rR) !associative -(associative _ _ rR).
+ * apply IH; eauto using uPred_weaken.
+Qed.
+Lemma wp_frame_later_r E e Q R :
+ to_val e = None → (wp E e Q ★ ▷ R) ⊑ wp E e (λ v, Q v ★ R).
+Proof.
+ intros He r' n Hvalid (r&rR&Hr&Hwp&?); revert Hvalid; rewrite Hr; clear Hr.
+ destruct Hwp as [|[|n] r e ? Hgo]; [by rewrite to_of_val in He|done|].
+ constructor; [done|intros rf k Ef σ1 ???].
+ destruct (Hgo (rR⋅rf) k Ef σ1) as [Hsafe Hstep];rewrite ?(associative _);auto.
+ split; [done|intros e2 σ2 ef ?].
+ destruct (Hstep e2 σ2 ef) as (r2&r2'&?&?&?); auto.
+ exists (r2 â‹… rR), r2'; split_ands; auto.
+ * by rewrite -(associative _ r2)
+ (commutative _ rR) !associative -(associative _ _ rR).
+ * apply wp_frame_r; [auto|exists r2, rR; split_ands; auto].
+ eapply uPred_weaken with rR n; eauto.
+Qed.
+Lemma wp_bind `{LanguageCtx Λ K} E e Q :
+ wp E e (λ v, wp E (K (of_val v)) Q) ⊑ wp E (K e) Q.
+Proof.
+ intros r n; revert e r; induction n as [n IH] using lt_wf_ind; intros e r ?.
+ destruct 1 as [|n r e ? Hgo]; [|constructor]; auto using fill_not_val.
+ intros rf k Ef σ1 ???; destruct (Hgo rf k Ef σ1) as [Hsafe Hstep]; auto.
+ split.
+ { destruct Hsafe as (e2&σ2&ef&?).
+ by exists (K e2), σ2, ef; apply fill_step. }
+ intros e2 σ2 ef ?.
+ destruct (fill_step_inv e σ1 e2 σ2 ef) as (e2'&->&?); auto.
+ destruct (Hstep e2' σ2 ef) as (r2&r2'&?&?&?); auto.
+ exists r2, r2'; split_ands; try eapply IH; eauto.
+Qed.
+
+(* Derived rules *)
+Opaque uPred_holds.
+Import uPred.
+Global Instance wp_mono' E e :
+ Proper (pointwise_relation _ (⊑) ==> (⊑)) (@wp Λ Σ E e).
+Proof. by intros Q Q' ?; apply wp_mono. Qed.
+Lemma wp_value' E Q e v : to_val e = Some v → Q v ⊑ wp E e Q.
+Proof. intros; rewrite -(of_to_val e v) //; by apply wp_value. Qed.
+Lemma wp_frame_l E e Q R : (R ★ wp E e Q) ⊑ wp E e (λ v, R ★ Q v).
+Proof. setoid_rewrite (commutative _ R); apply wp_frame_r. Qed.
+Lemma wp_frame_later_l E e Q R :
+ to_val e = None → (▷ R ★ wp E e Q) ⊑ wp E e (λ v, R ★ Q v).
+Proof.
+ rewrite (commutative _ (â–· R)%I); setoid_rewrite (commutative _ R).
+ apply wp_frame_later_r.
+Qed.
+Lemma wp_always_l E e Q R `{!AlwaysStable R} :
+ (R ∧ wp E e Q) ⊑ wp E e (λ v, R ∧ Q v).
+Proof. by setoid_rewrite (always_and_sep_l' _ _); rewrite wp_frame_l. Qed.
+Lemma wp_always_r E e Q R `{!AlwaysStable R} :
+ (wp E e Q ∧ R) ⊑ wp E e (λ v, Q v ∧ R).
+Proof. by setoid_rewrite (always_and_sep_r' _ _); rewrite wp_frame_r. Qed.
+Lemma wp_impl_l E e Q1 Q2 : ((□ ∀ v, Q1 v → Q2 v) ∧ wp E e Q1) ⊑ wp E e Q2.
+Proof.
+ rewrite wp_always_l; apply wp_mono=> v.
+ by rewrite always_elim (forall_elim v) impl_elim_l.
+Qed.
+Lemma wp_impl_r E e Q1 Q2 : (wp E e Q1 ∧ □ ∀ v, Q1 v → Q2 v) ⊑ wp E e Q2.
+Proof. by rewrite commutative wp_impl_l. Qed.
+End wp.
diff --git a/program_logic/wsat.v b/program_logic/wsat.v
new file mode 100644
index 0000000000000000000000000000000000000000..6df7ef4be9423adf35becaf6cdd42fbf1a68539f
--- /dev/null
+++ b/program_logic/wsat.v
@@ -0,0 +1,175 @@
+Require Export program_logic.model prelude.co_pset.
+Require Export algebra.cmra_big_op algebra.cmra_tactics.
+Local Hint Extern 10 (_ ≤ _) => omega.
+Local Hint Extern 10 (✓{_} _) => solve_validN.
+Local Hint Extern 1 (✓{_} (gst _)) => apply gst_validN.
+Local Hint Extern 1 (✓{_} (wld _)) => apply wld_validN.
+
+Record wsat_pre {Λ Σ} (n : nat) (E : coPset)
+ (σ : state Λ) (rs : gmap positive (iRes Λ Σ)) (r : iRes Λ Σ) := {
+ wsat_pre_valid : ✓{S n} r;
+ wsat_pre_state : pst r ≡ Excl σ;
+ wsat_pre_dom i : is_Some (rs !! i) → i ∈ E ∧ is_Some (wld r !! i);
+ wsat_pre_wld i P :
+ i ∈ E →
+ wld r !! i ={S n}= Some (to_agree (Later (iProp_unfold P))) →
+ ∃ r', rs !! i = Some r' ∧ P n r'
+}.
+Arguments wsat_pre_valid {_ _ _ _ _ _ _} _.
+Arguments wsat_pre_state {_ _ _ _ _ _ _} _.
+Arguments wsat_pre_dom {_ _ _ _ _ _ _} _ _ _.
+Arguments wsat_pre_wld {_ _ _ _ _ _ _} _ _ _ _ _.
+
+Definition wsat {Λ Σ}
+ (n : nat) (E : coPset) (σ : state Λ) (r : iRes Λ Σ) : Prop :=
+ match n with 0 => True | S n => ∃ rs, wsat_pre n E σ rs (r ⋅ big_opM rs) end.
+Instance: Params (@wsat) 5.
+Arguments wsat : simpl never.
+
+Section wsat.
+Context {Λ : language} {Σ : iFunctor}.
+Implicit Types σ : state Λ.
+Implicit Types r : iRes Λ Σ.
+Implicit Types rs : gmap positive (iRes Λ Σ).
+Implicit Types P : iProp Λ Σ.
+Implicit Types m : iGst Λ Σ.
+
+Instance wsat_ne' : Proper (dist n ==> impl) (@wsat Λ Σ n E σ).
+Proof.
+ intros [|n] E σ r1 r2 Hr; first done; intros [rs [Hdom Hv Hs Hinv]].
+ exists rs; constructor; intros until 0; setoid_rewrite <-Hr; eauto.
+Qed.
+Global Instance wsat_ne n : Proper (dist n ==> iff) (@wsat Λ Σ n E σ) | 1.
+Proof. by intros E σ w1 w2 Hw; split; apply wsat_ne'. Qed.
+Global Instance wsat_proper n : Proper ((≡) ==> iff) (@wsat Λ Σ n E σ) | 1.
+Proof. by intros E σ w1 w2 Hw; apply wsat_ne, equiv_dist. Qed.
+Lemma wsat_le n n' E σ r : wsat n E σ r → n' ≤ n → wsat n' E σ r.
+Proof.
+ destruct n as [|n], n' as [|n']; simpl; try by (auto with lia).
+ intros [rs [Hval Hσ HE Hwld]] ?; exists rs; constructor; auto.
+ intros i P ? HiP; destruct (wld (r â‹… big_opM rs) !! i) as [P'|] eqn:HP';
+ [apply (injective Some) in HiP|inversion_clear HiP].
+ assert (P' ={S n}= to_agree $ Later $ iProp_unfold $
+ iProp_fold $ later_car $ P' (S n)) as HPiso.
+ { rewrite iProp_unfold_fold later_eta to_agree_car //.
+ apply (map_lookup_validN _ (wld (r â‹… big_opM rs)) i); rewrite ?HP'; auto. }
+ assert (P ={n'}= iProp_fold (later_car (P' (S n)))) as HPP'.
+ { apply (injective iProp_unfold), (injective Later), (injective to_agree).
+ by rewrite -HiP -(dist_le _ _ _ _ HPiso). }
+ destruct (Hwld i (iProp_fold (later_car (P' (S n))))) as (r'&?&?); auto.
+ { by rewrite HP' -HPiso. }
+ assert (✓{S n} r') by (apply (big_opM_lookup_valid _ rs i); auto).
+ exists r'; split; [done|apply HPP', uPred_weaken with r' n; auto].
+Qed.
+Lemma wsat_valid n E σ r : wsat n E σ r → ✓{n} r.
+Proof.
+ destruct n; [done|intros [rs ?]].
+ eapply cmra_validN_op_l, wsat_pre_valid; eauto.
+Qed.
+Lemma wsat_init k E σ m : ✓{S k} m → wsat (S k) E σ (Res ∅ (Excl σ) m).
+Proof.
+ intros Hv. exists ∅; constructor; auto.
+ * rewrite big_opM_empty right_id.
+ split_ands'; try (apply cmra_valid_validN, ra_empty_valid);
+ constructor || apply Hv.
+ * by intros i; rewrite lookup_empty=>-[??].
+ * intros i P ?; rewrite /= left_id lookup_empty; inversion_clear 1.
+Qed.
+Lemma wsat_open n E σ r i P :
+ wld r !! i ={S n}= Some (to_agree (Later (iProp_unfold P))) → i ∉ E →
+ wsat (S n) ({[i]} ∪ E) σ r → ∃ rP, wsat (S n) E σ (rP ⋅ r) ∧ P n rP.
+Proof.
+ intros HiP Hi [rs [Hval Hσ HE Hwld]].
+ destruct (Hwld i P) as (rP&?&?); [solve_elem_of +|by apply lookup_wld_op_l|].
+ assert (rP ⋅ r ⋅ big_opM (delete i rs) ≡ r ⋅ big_opM rs) as Hr.
+ { by rewrite (commutative _ rP) -associative big_opM_delete. }
+ exists rP; split; [exists (delete i rs); constructor; rewrite ?Hr|]; auto.
+ * intros j; rewrite lookup_delete_is_Some Hr.
+ generalize (HE j); solve_elem_of +Hi.
+ * intros j P'; rewrite Hr=> Hj ?.
+ setoid_rewrite lookup_delete_ne; last (solve_elem_of +Hi Hj).
+ apply Hwld; [solve_elem_of +Hj|done].
+Qed.
+Lemma wsat_close n E σ r i P rP :
+ wld rP !! i ={S n}= Some (to_agree (Later (iProp_unfold P))) → i ∉ E →
+ wsat (S n) E σ (rP ⋅ r) → P n rP → wsat (S n) ({[i]} ∪ E) σ r.
+Proof.
+ intros HiP HiE [rs [Hval Hσ HE Hwld]] ?.
+ assert (rs !! i = None) by (apply eq_None_not_Some; naive_solver).
+ assert (r ⋅ big_opM (<[i:=rP]> rs) ≡ rP ⋅ r ⋅ big_opM rs) as Hr.
+ { by rewrite (commutative _ rP) -associative big_opM_insert. }
+ exists (<[i:=rP]>rs); constructor; rewrite ?Hr; auto.
+ * intros j; rewrite Hr lookup_insert_is_Some=>-[?|[??]]; subst.
+ + rewrite !lookup_op HiP !op_is_Some; solve_elem_of -.
+ + destruct (HE j) as [Hj Hj']; auto; solve_elem_of +Hj Hj'.
+ * intros j P'; rewrite Hr elem_of_union elem_of_singleton=>-[?|?]; subst.
+ + rewrite !lookup_wld_op_l ?HiP; auto=> HP.
+ apply (injective Some), (injective to_agree),
+ (injective Later), (injective iProp_unfold) in HP.
+ exists rP; split; [rewrite lookup_insert|apply HP]; auto.
+ + intros. destruct (Hwld j P') as (r'&?&?); auto.
+ exists r'; rewrite lookup_insert_ne; naive_solver.
+Qed.
+Lemma wsat_update_pst n E σ1 σ1' r rf :
+ pst r ={S n}= Excl σ1 → wsat (S n) E σ1' (r ⋅ rf) →
+ σ1' = σ1 ∧ ∀ σ2, wsat (S n) E σ2 (update_pst σ2 r ⋅ rf).
+Proof.
+ intros Hpst_r [rs [(?&?&?) Hpst HE Hwld]]; simpl in *.
+ assert (pst rf ⋅ pst (big_opM rs) = ∅) as Hpst'.
+ { by apply: (excl_validN_inv_l n σ1); rewrite -Hpst_r associative. }
+ assert (σ1' = σ1) as ->.
+ { apply leibniz_equiv, (timeless _), dist_le with (S n); auto.
+ apply (injective Excl).
+ by rewrite -Hpst_r -Hpst -associative Hpst' (right_id _). }
+ split; [done|exists rs].
+ by constructor; split_ands'; try (rewrite /= -associative Hpst').
+Qed.
+Lemma wsat_update_gst n E σ r rf m1 (P : iGst Λ Σ → Prop) :
+ m1 ≼{S n} gst r → m1 ~~>: P →
+ wsat (S n) E σ (r ⋅ rf) → ∃ m2, wsat (S n) E σ (update_gst m2 r ⋅ rf) ∧ P m2.
+Proof.
+ intros [mf Hr] Hup [rs [(?&?&?) Hσ HE Hwld]].
+ destruct (Hup (mf â‹… gst (rf â‹… big_opM rs)) n) as (m2&?&Hval').
+ { by rewrite /= (associative _ m1) -Hr (associative _). }
+ exists m2; split; [exists rs; split; split_ands'; auto|done].
+Qed.
+Lemma wsat_alloc n E1 E2 σ r P rP :
+ ¬set_finite E1 → P n rP → wsat (S n) (E1 ∪ E2) σ (rP ⋅ r) →
+ ∃ i, wsat (S n) (E1 ∪ E2) σ
+ (Res {[i ↦ to_agree (Later (iProp_unfold P))]} ∅ ∅ ⋅ r) ∧
+ wld r !! i = None ∧ i ∈ E1.
+Proof.
+ intros HE1 ? [rs [Hval Hσ HE Hwld]].
+ assert (∃ i, i ∈ E1 ∧ wld r !! i = None ∧ wld rP !! i = None ∧
+ wld (big_opM rs) !! i = None) as (i&Hi&Hri&HrPi&Hrsi).
+ { exists (coPpick (E1 ∖
+ (dom _ (wld r) ∪ (dom _ (wld rP) ∪ dom _ (wld (big_opM rs)))))).
+ rewrite -!not_elem_of_dom -?not_elem_of_union -elem_of_difference.
+ apply coPpick_elem_of=>HE'; eapply HE1, (difference_finite_inv _ _), HE'.
+ by repeat apply union_finite; apply dom_finite. }
+ assert (rs !! i = None).
+ { apply eq_None_not_Some=>?; destruct (HE i) as [_ Hri']; auto; revert Hri'.
+ rewrite /= !lookup_op !op_is_Some -!not_eq_None_Some; tauto. }
+ assert (r ⋅ big_opM (<[i:=rP]> rs) ≡ rP ⋅ r ⋅ big_opM rs) as Hr.
+ { by rewrite (commutative _ rP) -associative big_opM_insert. }
+ exists i; split_ands; [exists (<[i:=rP]>rs); constructor| |]; auto.
+ * destruct Hval as (?&?&?); rewrite -associative Hr.
+ split_ands'; rewrite /= ?left_id; [|eauto|eauto].
+ intros j; destruct (decide (j = i)) as [->|].
+ + by rewrite !lookup_op Hri HrPi Hrsi !(right_id _ _) lookup_singleton.
+ + by rewrite lookup_op lookup_singleton_ne // (left_id _ _).
+ * by rewrite -associative Hr /= left_id.
+ * intros j; rewrite -associative Hr; destruct (decide (j = i)) as [->|].
+ + rewrite /= !lookup_op lookup_singleton !op_is_Some; solve_elem_of +Hi.
+ + rewrite lookup_insert_ne //.
+ rewrite lookup_op lookup_singleton_ne // left_id; eauto.
+ * intros j P'; rewrite -associative Hr; destruct (decide (j=i)) as [->|].
+ + rewrite /= !lookup_op Hri HrPi Hrsi right_id lookup_singleton=>? HP.
+ apply (injective Some), (injective to_agree),
+ (injective Later), (injective iProp_unfold) in HP.
+ exists rP; rewrite lookup_insert; split; [|apply HP]; auto.
+ + rewrite /= lookup_op lookup_singleton_ne // left_id=> ??.
+ destruct (Hwld j P') as [r' ?]; auto.
+ by exists r'; rewrite lookup_insert_ne.
+Qed.
+End wsat.
diff --git a/world_prop.v b/world_prop.v
deleted file mode 100644
index 709770cde02d4e38353527781324d48a4e821072..0000000000000000000000000000000000000000
--- a/world_prop.v
+++ /dev/null
@@ -1,44 +0,0 @@
-(** In this file, we we define what it means to be a solution of the recursive
- domain equations to build a higher-order separation logic *)
-Require Import ModuRes.PreoMet ModuRes.Finmap.
-Require Import ModuRes.RA ModuRes.CMRA ModuRes.Agreement ModuRes.SPred.
-
-Local Open Scope type.
-
-(* This interface keeps some of the details of the solution opaque *)
-Module Type WORLD_PROP (Res : CMRA_EXT_T).
- (* PreProp: The solution to the recursive equation. Equipped with a discrete order. *)
- Parameter PreProp : Type.
- Declare Instance PProp_t : Setoid PreProp.
- Declare Instance PProp_m : metric PreProp.
- Declare Instance PProp_cm : cmetric PreProp.
- Instance PProp_preo : preoType PreProp := disc_preo PreProp.
- Instance PProp_pcm : pcmType PreProp := disc_pcm PreProp.
-
- (* Defines Worlds, and make sure their order comes from the RA. *)
- Definition Wld := (nat -f> ra_agree PreProp) * Res.res.
- Instance Wld_ty : Setoid Wld := _.
- Instance Wld_m : metric Wld := _.
- Instance Wld_cm : cmetric Wld := _.
- Instance Wld_preo : preoType Wld := pord_ra. (* disambiguate the order *)
- Instance Wld_pcm : pcmType Wld := _.
- Instance Wld_unit : RA_unit Wld := _.
- Instance Wld_op : RA_op Wld := _.
- Instance Wld_valid : RA_valid Wld := _.
- Instance Wld_RA : RA Wld := _.
- Instance Wld_CMRAval:CMRA_valid Wld := _.
- Instance Wld_CMRA : CMRA Wld := _.
- Instance Wld_CMRAExt:CMRAExt Wld := _.
-
- (* Now we are ready to define Propositions. *)
- Definition Props := Wld -m> SPred.
- Instance Props_ty : Setoid Props := _.
- Instance Props_m : metric Props := _.
- Instance Props_cm : cmetric Props := _.
-
- (* Require recursion isomorphisms *)
- Parameter ı : PreProp -n> halve Props.
- Parameter ı' : halve Props -n> PreProp.
- Axiom iso : forall P, ı' (ı P) == P.
- Axiom isoR: forall T, ı (ı' T) == T.
-End WORLD_PROP.
diff --git a/world_prop_recdom.v b/world_prop_recdom.v
deleted file mode 100644
index 898fb825adbfd0ea478353b621930752ea53ba7b..0000000000000000000000000000000000000000
--- a/world_prop_recdom.v
+++ /dev/null
@@ -1,118 +0,0 @@
-(** In this file, we show how we can obtain a solution of the recursive
- domain equations to build a higher-order separation logic *)
-Require Import ModuRes.PreoMet ModuRes.Finmap ModuRes.RA ModuRes.CMRA ModuRes.Agreement ModuRes.SPred.
-Require Import ModuRes.CatBasics ModuRes.MetricRec ModuRes.CBUltInst.
-Require Import world_prop.
-
-(* Now we come to the actual implementation *)
-Module WorldProp (Res : CMRA_EXT_T) : WORLD_PROP Res.
- (** The construction is parametric in the monoid we choose *)
-
- (** We need to build a functor that would describe the following
- recursive domain equation:
- Prop ≃ (Loc -f> ra_agree Prop) * Res -m> SPred
- As usual, we split the negative and (not actually occurring)
- positive occurrences of Prop. *)
-
- Local Open Scope type.
-
- (** Finally, we need the right pcmType for the entire resource *)
- Definition FRes P `{metric P} := (nat -f> ra_agree P) * Res.res.
- Local Instance FResCMRA P `{cmetric P} : CMRA (FRes P) := _.
- Local Instance FResPO P `{cmetric P} : preoType (FRes P) := pord_ra. (* disambiguate the order *)
-
- Section Definitions.
- (** We'll be working with complete metric spaces, so whenever
- something needs an additional preorder, we'll just take a
- discrete one. *)
- Local Instance pt_disc P `{cmetric P} : preoType P | 2000 := disc_preo P.
- Local Instance pcm_disc P `{cmetric P} : pcmType P | 2000 := disc_pcm P.
-
- Section ObjectAction.
- Context (P: Type) `{cmP: cmetric P}.
-
- Definition FProp :=
- FRes P -m> SPred.
- End ObjectAction.
-
- Section ArrowAction.
- Context {U V} `{cmU : cmetric U} `{cmV : cmetric V}.
-
- Context (m: V -n> U).
- Let InvMap : FRes V -m> FRes U :=
- RAprod_map (fdRAMap (ra_agree_map m)) (pid _).
- Definition PropMorph : FProp U -n> FProp V :=
- InvMap â–¹. (* this "later" is post-composition *)
- End ArrowAction.
-
- End Definitions.
-
- Module F <: SimplInput (CBUlt).
- Import CBUlt.
- Open Scope cat_scope.
-
- Definition F (T1 T2 : cmtyp) := cmfromType (FProp T1).
- Program Instance FArr : BiFMap F :=
- fun P1 P2 P3 P4 => n[(PropMorph)] <M< Mfst.
- Next Obligation.
- intros m1 m2 Eqm; unfold PropMorph, equiv in *.
- rewrite Eqm; reflexivity.
- Qed.
-
- Instance FFun : BiFunctor F.
- Proof.
- split; intros; unfold fmorph; simpl morph; unfold PropMorph.
- - eapply precomp_by_comp. rewrite <-ra_agree_map_comp, <-fdRAMap_comp. eapply RAprod_map_comp_fst.
- - eapply precomp_by_id. unfold tid, MId. rewrite ra_agree_map_id, fdRAMap_id.
- eapply RAprod_map_id.
- Qed.
-
- Definition F_ne : 1 -t> F 1 1 :=
- umconst (pcmconst top_sp).
- End F.
-
- Module F_In := InputHalve(F).
- Module Import Fix := Solution(CBUlt)(F_In).
-
- (** Now we can name the two isomorphic spaces of propositions, and
- the space of worlds. We'll store the actual solutions in the
- worlds, and use the action of FProp on them as the space we
- normally work with. *)
- Definition PreProp : Type := DInfO.
- Instance PProp_t : Setoid PreProp := _.
- Instance PProp_m : metric PreProp := _.
- Instance PProp_cm : cmetric PreProp := _.
- Instance PProp_preo: preoType PreProp := disc_preo PreProp.
- Instance PProp_pcm : pcmType PreProp := disc_pcm PreProp.
-
- (* Define worlds *)
- Definition Wld := FRes PreProp.
- Instance Wld_ty : Setoid Wld := _.
- Instance Wld_m : metric Wld := _.
- Instance Wld_cm : cmetric Wld := _.
- Instance Wld_preo : preoType Wld := _.
- Instance Wld_pcm : pcmType Wld := _.
- Instance Wld_unit : RA_unit Wld := _.
- Instance Wld_op : RA_op Wld := _.
- Instance Wld_valid : RA_valid Wld := _.
- Instance Wld_RA : RA Wld := _.
- Instance Wld_CMRAval:CMRA_valid Wld := _.
- Instance Wld_CMRA : CMRA Wld := _.
- Instance Wld_CMRAExt:CMRAExt Wld := _.
-
- (* Define propositions *)
- Definition Props := FProp PreProp.
- Instance Props_ty : Setoid Props := _.
- Instance Props_m : metric Props := _.
- Instance Props_cm : cmetric Props := _.
-
- (* Establish the isomorphism *)
- Definition ı : DInfO -t> halveCM (cmfromType Props) := Unfold.
- Definition ı' : halveCM (cmfromType Props) -t> DInfO := Fold.
-
- Lemma iso P : ı' (ı P) == P.
- Proof. apply (FU_id P). Qed.
- Lemma isoR T : ı (ı' T) == T.
- Proof. apply (UF_id T). Qed.
-
-End WorldProp.