diff --git a/.gitignore b/.gitignore
index b6123404513f612b704a46a9f39f33819797f169..63df3a3d211bf1bef8a0e51888c368c73824efca 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,6 @@
*.vo
+*.vok
+*.vos
*.vio
*.v.d
.coqdeps.d
@@ -13,6 +15,16 @@
.coq-native/
build-dep/
Makefile.coq
+.Makefile.coq.d
Makefile.coq.conf
*.crashcoqide
.env
+_opam
+
+
+*.fdb_latexmk
+*.fls
+**/auto/*
+
+*.pygtex
+*.pygstyle
\ No newline at end of file
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
deleted file mode 100644
index 9c9ecb701a0cacd421969f950aea33019b48cd8d..0000000000000000000000000000000000000000
--- a/.gitlab-ci.yml
+++ /dev/null
@@ -1,67 +0,0 @@
-image: ralfjung/opam-ci:opam2
-
-stages:
- - build
-
-variables:
- CPU_CORES: "10"
-
-.template: &template
- stage: build
- tags:
- - fp
- script:
- - git clone https://gitlab.mpi-sws.org/iris/ci.git ci -b opam2
- - ci/buildjob
- cache:
- key: "$CI_JOB_NAME"
- paths:
- - opamroot/
- only:
- - master
- - /^ci/
- except:
- - triggers
- - schedules
- - api
-
-## Build jobs
-
-build-coq.dev:
- <<: *template
- variables:
- OCAML: "ocaml-base-compiler.4.07.0"
- OPAM_PINS: "coq version dev"
- CI_COQCHK: "1"
-
-build-coq.8.10.dev:
- <<: *template
- variables:
- OCAML: "ocaml-base-compiler.4.07.0"
- OPAM_PINS: "coq version 8.10.dev"
-
-build-coq.8.9.1:
- <<: *template
- variables:
- OPAM_PINS: "coq version 8.9.1"
-
-build-coq.8.9.0:
- <<: *template
- variables:
- OPAM_PINS: "coq version 8.9.0"
- OPAM_PKG: "coq-iris"
- DOC_DIR: "coqdoc@center.mpi-sws.org:iris"
- DOC_OPTS: "--external https://plv.mpi-sws.org/coqdoc/stdpp/ stdpp"
- TIMING_CONF: "coq-8.9.0"
- tags:
- - fp-timing
-
-build-coq.8.8.2:
- <<: *template
- variables:
- OPAM_PINS: "coq version 8.8.2"
-
-build-coq.8.7.2:
- <<: *template
- variables:
- OPAM_PINS: "coq version 8.7.2"
diff --git a/Makefile b/Makefile
index 8bf123000160fd65bcbd3455f67d536825f33081..8d615e4b2c9081e20b16fb3931cea5ef951c540c 100644
--- a/Makefile
+++ b/Makefile
@@ -9,7 +9,7 @@ all: Makefile.coq
clean: Makefile.coq
+@make -f Makefile.coq clean
find theories tests \( -name "*.d" -o -name "*.vo" -o -name "*.aux" -o -name "*.cache" -o -name "*.glob" -o -name "*.vio" \) -print -delete || true
- rm -f Makefile.coq
+ rm -f Makefile.coq .lia.cache
.PHONY: clean
# Create Coq Makefile.
@@ -29,14 +29,8 @@ build-dep: build-dep/opam phony
@# that are incompatible with our build requirements.
@# To achieve this, we create a fake opam package that has our build-dependencies as
@# dependencies, but does not actually install anything itself.
- @echo "# Pinning build-dep package." && \
- if opam --version | grep "^1\." -q; then \
- BUILD_DEP_PACKAGE="$$(egrep "^name:" build-dep/opam | sed 's/^name: *"\(.*\)" */\1/')" && \
- opam pin add -k path $(OPAMFLAGS) "$$BUILD_DEP_PACKAGE".dev build-dep && \
- opam reinstall $(OPAMFLAGS) "$$BUILD_DEP_PACKAGE"; \
- else \
- opam install $(OPAMFLAGS) build-dep/; \
- fi
+ @echo "# Installing build-dep package."
+ @opam install $(OPAMFLAGS) build-dep/
# Some files that do *not* need to be forwarded to Makefile.coq
Makefile: ;
diff --git a/Makefile.coq.local b/Makefile.coq.local
deleted file mode 100644
index 182c618ace21924f6e4215e7c4172409a91e8b4c..0000000000000000000000000000000000000000
--- a/Makefile.coq.local
+++ /dev/null
@@ -1,43 +0,0 @@
-# Run tests interleaved with main build. They have to be in the same target for this.
-real-all: $(if $(NO_TEST),,test)
-
-# the test suite
-TESTFILES=$(wildcard tests/*.v)
-NORMALIZER=test-normalizer.sed
-
-test: $(TESTFILES:.v=.vo)
-.PHONY: test
-
-COQ_TEST=$(COQTOP) $(COQDEBUG) -batch -test-mode
-COQ_OLD=$(shell echo "$(COQ_VERSION)" | egrep "^8\.7\b" -q && echo 1)
-COQ_MINOR_VERSION=$(shell echo "$(COQ_VERSION)" | egrep '^[0-9]+\.[0-9]+\b' -o)
-
-tests/.coqdeps.d: $(TESTFILES)
- $(SHOW)'COQDEP TESTFILES'
- $(HIDE)$(COQDEP) -dyndep var $(COQMF_COQLIBS_NOML) $^ $(redir_if_ok)
--include tests/.coqdeps.d
-
-# Main test script (comments out-of-line because macOS otherwise barfs?!?)
-# - Determine reference file (`REF`).
-# - Print user-visible status line.
-# - Dump Coq output into a temporary file.
-# - Run `sed -i` on that file in a way that works on macOS.
-# - Either compare the result with the reference file, or move it over the reference file.
-# - Cleanup, and mark as done for make.
-$(TESTFILES:.v=.vo): %.vo: %.v $(if $(MAKE_REF),,%.ref) $(NORMALIZER)
- $(HIDE)TEST="$$(basename -s .v $<)" && \
- if test -f "tests/$$TEST.$(COQ_MINOR_VERSION).ref"; then \
- REF="tests/$$TEST.$(COQ_MINOR_VERSION).ref"; \
- else \
- REF="tests/$$TEST.ref"; \
- fi && \
- echo "COQTEST$(if $(COQ_OLD), [no ref],$(if $(MAKE_REF), [make ref],)) $<$(if $(COQ_OLD),, (ref: $$REF))" && \
- TMPFILE="$$(mktemp)" && \
- $(TIMER) $(COQ_TEST) $(COQFLAGS) $(COQLIBS) -load-vernac-source $< > "$$TMPFILE" && \
- sed -f $(NORMALIZER) "$$TMPFILE" > "$$TMPFILE".new && \
- mv "$$TMPFILE".new "$$TMPFILE" && \
- $(if $(COQ_OLD),true, \
- $(if $(MAKE_REF),mv "$$TMPFILE" "$$REF",diff -u "$$REF" "$$TMPFILE") \
- ) && \
- rm -f "$$TMPFILE" && \
- touch $@
diff --git a/README.md b/README.md
index 234aae22fd2165da5ccbe6500ff1f051fd0d8075..0f54d89052e3635c0d1403f85a0bda54555a16da 100644
--- a/README.md
+++ b/README.md
@@ -1,71 +1,50 @@
-# IRIS COQ DEVELOPMENT [[coqdoc]](https://plv.mpi-sws.org/coqdoc/iris/)
+# TRANSFINITE IRIS COQ DEVELOPMENT
-This is the Coq development of the [Iris Project](http://iris-project.org),
+This is the Coq development of the Transfinite Iris project.
+It is based on the Coq development of the [Iris Project](http://iris-project.org),
which includes [MoSeL](http://iris-project.org/mosel/), a general proof mode
for carrying out separation logic proofs in Coq.
-For using the Coq library, check out the
-[API documentation](https://plv.mpi-sws.org/coqdoc/iris/).
+For understanding the theory of Transfinite Iris, a supplementary appendix PDF has been submitted alongside this artifact.
-For understanding the theory of Iris, a LaTeX version of the core logic
-definitions and some derived forms is available in
-[docs/iris.tex](docs/iris.tex). A compiled PDF version of this document is
-[available online](http://plv.mpi-sws.org/iris/appendix-3.1.pdf).
+For using Transfinite Iris and inspecting the development interactively, it needs to be compiled.
-## Building Iris
+## Building Transfinite Iris
### Prerequisites
This version is known to compile with:
- - Coq 8.7.2 / 8.8.2 / 8.9.0 / 8.9.1
- - A development version of [std++](https://gitlab.mpi-sws.org/iris/stdpp)
+ - Coq 8.10.2
+ - Iris-stdpp 1.3.0 ([std++](https://gitlab.mpi-sws.org/iris/stdpp))
-For a version compatible with Coq 8.6, have a look at the
-[iris-3.1 branch](https://gitlab.mpi-sws.org/iris/iris/tree/iris-3.1).
-If you need to work with Coq 8.5, please check out the
-[iris-3.0 branch](https://gitlab.mpi-sws.org/iris/iris/tree/iris-3.0).
+We assume that you have opam (2.0 or newer; tested with 2.0.7) available for the following instructions.
-### Working *with* Iris
+### Installation
-To use Iris in your own proofs, we recommend you install Iris via opam (1.2.2 or
-newer). To obtain the latest stable release, you have to add the Coq opam
-repository:
+1. Setup a new opam switch and switch to it:
+ ```
+ opam update
+ opam switch create iris-transfinite 4.07.1+flambda
+ eval $(opam env)
+ ```
- opam repo add coq-released https://coq.inria.fr/opam/released
+2. Add the Coq opam repository:
+```
+ opam repo add coq-released https://coq.inria.fr/opam/released
+```
+3. Run `make build-dep` to install the right versions of the dependencies,
+ in particular Coq 8.10.2 and coq-stdpp 1.3.0.
-To obtain a development version, also add the Iris opam repository:
-
- opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git
-
-Either way, you can now do `opam install coq-iris`. To fetch updates later, run
-`opam update && opam upgrade`. However, notice that we do not guarnatee
-backwards-compatibility, so upgrading Iris may break your Iris-using
-developments.
-
-### Working *on* Iris
-
-To work on Iris itself, you need to install its build-dependencies. Again we
-recommend you do that with opam (1.2.2 or newer). This requires the following
-two repositories:
-
- opam repo add coq-released https://coq.inria.fr/opam/released
- opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git
-
-Once you got opam set up, run `make build-dep` to install the right versions
-of the dependencies.
-
-Run `make -jN` to build the full development, where `N` is the number of your
-CPU cores.
-
-To update Iris, do `git pull`. After an update, the development may fail to
-compile because of outdated dependencies. To fix that, please run `opam update`
-followed by `make build-dep`.
+4. Run `make -jN` to build the full development, where `N` is the number of threads
+ to use for the build process.
## Directory Structure
-* The folder [algebra](theories/algebra) contains the COFE and CMRA
- constructions as well as the solver for recursive domain equations.
+* The folder [ordinals](theories/algebra/ordinals) contains a formalisation of
+ von Neumann ordinals and basic ordinal arithmetic.
+* The folder [algebra](theories/algebra) contains step-index types,
+ the COFE and CMRA constructions as well as the solver for recursive domain equations.
* The folder [base_logic](theories/base_logic) defines the Iris base logic and
the primitive connectives. It also contains derived constructions that are
entirely independent of the choice of resources.
@@ -74,9 +53,11 @@ followed by `make build-dep`.
dynamic resources and ownership of them; the other constructions depend
on this setup.
* The folder [program_logic](theories/program_logic) specializes the base logic
- to build Iris, the program logic. This includes weakest preconditions that
+ to build Iris, the program logic. This includes weakest preconditions that
are defined for any language satisfying some generic axioms, and some derived
constructions that work for any such language.
+* The folder [refinement](theories/program_logic/refinement) contains the definition
+ of a program logic for termination-preserving refinement and termination.
* The folder [bi](theories/bi) contains the BI++ laws, as well as derived
connectives, laws and constructions that are applicable for general BIS.
* The folder [proofmode](theories/proofmode) contains
@@ -85,59 +66,64 @@ followed by `make build-dep`.
interactive proofs. Documentation can be found in
[ProofMode.md](ProofMode.md).
* The folder [heap_lang](theories/heap_lang) defines the ML-like concurrent heap
- language
- * The subfolder [lib](theories/heap_lang/lib) contains a few derived
- constructions within this language, e.g., parallel composition.
- For more examples of using Iris and heap_lang, have a look at the
- [Iris Examples](https://gitlab.mpi-sws.org/iris/examples).
-* The folder [tests](theories/tests) contains modules we use to test our
- infrastructure. Users of the Iris Coq library should *not* depend on these
- modules; they may change or disappear without any notice.
-
-## Case Studies
-
-The following is a (probably incomplete) list of case studies that use Iris, and
-that should be compatible with this version:
-
-* [Iris Examples](https://gitlab.mpi-sws.org/iris/examples) is where we
- collect miscellaneous case studies that do not have their own repository.
-* [LambdaRust](https://gitlab.mpi-sws.org/iris/lambda-rust) is a Coq
- formalization of the core Rust type system.
-* [GPFSL](https://gitlab.mpi-sws.org/iris/gpfsl) is a logic for release-acquire
- and relaxed memory.
-* [Iron](https://gitlab.mpi-sws.org/iris/iron) is a linear separation logic
- built on top of Iris for precise reasoning about resources (such as making
- sure there are no memory leaks).
-
-## Further Resources
-
-Getting along with Iris in Coq:
-
-* Iris proof patterns are documented in the [proof guide](ProofGuide.md).
-* Syntactic conventions are described in the [style guide](StyleGuide.md).
-* The Iris tactics are described in the
- [the Iris Proof Mode (IPM) / MoSeL documentation](ProofMode.md) as well as the
- [HeapLang documentation](HeapLang.md).
-* The generated coqdoc is [available online](https://plv.mpi-sws.org/coqdoc/iris/).
-
-Contacting the developers:
-
-* Discussion about the Iris Coq development happens on the mailing list
- [iris-club@lists.mpi-sws.org](https://lists.mpi-sws.org/listinfo/iris-club)
- and in the [Iris Chat](https://mattermost.mpi-sws.org/iris). This is also the
- right place to ask questions. The chat requires an account at the
- [MPI-SWS GitLab](https://gitlab.mpi-sws.org/users/sign_in) (use the "Register"
- tab). If you have trouble joining the chat, please contact
- [Ralf](https://gitlab.mpi-sws.org/jung).
-* If you want to report a bug, please use the
- [issue tracker](https://gitlab.mpi-sws.org/iris/iris/issues), which also
- requires an MPI-SWS GitLab account.
-* To contribute to Iris itself, see the [contribution guide](CONTRIBUTING.md).
-
-Miscellaneous:
-
-* Information on how to set up your editor for unicode input and output is
- collected in [Editor.md](Editor.md).
-* If you are writing a paper that uses Iris in one way or another, you could use
- the [Iris LaTeX macros](docs/iris.sty) for typesetting the various Iris
- connectives.
+ language.
+* The folder [examples](theories/examples) contains examples executed in
+ Transfinite Iris. See below for a detailed summary.
+
+## Examples
+
+The following is a list of examples we have done in Transfinite Iris.
+* The key notions of simulations and generalized simulations used for the
+ key ideas section of the paper are formalized in [keyideas](theories/examples/keyideas).
+* Counterexamples for some negative statements in the paper are formalized in
+ [counterexamples.v](theories/examples/counterexamples.v)
+* [safety](theories/examples/safety) contains examples for safety reasoning taken
+ from existing work that we have ported to Transfinite Iris.
+* [termination](theories/examples/termination) contains proofs of termination:
+ * [eventloop](theories/examples/termination/eventloop.v) contains the verification
+ of the eventloop example from the paper.
+ * [thunk](theories/examples/termination/thunk.v) contains the verification of a thunk example.
+ * [logrel](theories/examples/termination/logrel.v) formalizes and extends the
+ logical relation for termination by Spies et al, "Transfinite Step-Indexing for Termination"
+* [refinements](theories/examples/refinements) contains the termination-preserving refinement
+ examples from the paper.
+ * [derived] (theories/examples/refinements/derived.v) contains the derived Hoare triples shown in the paper.
+ * [refinement](theories/examples/refinements/refinement.v) contains the HeapLang source language.
+ * [memoization](theories/examples/refinement/memoization.v) provides memoization functions and
+ the following examples:
+ * Fibonacci function
+ * Levenshtein distance
+
+
+## Theorems referenced in the paper
+
+We have fully mechanized the soundness of Iris and the examples in §3.4 and §4.2.
+The following table references the corresponding theorems as well as some additional mechanized lemmas.
+
+| Paper | Coq |
+| ------ | ------ |
+| Lemma 2.1 | [simulations/sim_is_rpr](theories/examples/keyideas/simulations.v) |
+| Lemma 2.2 | [simulations/sim_is_tpr](theories/examples/keyideas/simulations.v) |
+| Hoare Proof Rules of Figure 1 | [derived](theories/examples/refinements/derived.v) |
+| Theorem 3.3 (Refinement Adequacy) | [heap_lang_ref_adequacy](theories/examples/refinements/refinement.v) |
+| Definition of memo_rec | [mem_rec](theories/examples/refinements/memoization.v) |
+| PureMemoRec (simpl) | [natfun_mem_rec_spec](theories/examples/refinements/memoization.v) |
+| Levenshtein and Fibonacci | [memoization](theories/examples/refinements/memoization.v) |
+| Theorem 4.1 (Time Credits Adequacy) | [heap_lang_ref_adequacy](theories/examples/termination/adequacy.v) |
+| Reentrant Event Loop | [event_loop](theories/examples/termination/eventloop.v) |
+| Logical Relation for Termination | [logrel_adequacy](theories/examples/termination/logrel.v) |
+| Ordinals validate the existential property | [set_model_large_index](theories/algebra/ordinals/ord_stepindex.v) |
+| Theorem 5.3 | [fixpoint](theories/algebra/ofe.v) |
+| Model Construction (Theorem 5.4) | [iprop](theories/base_logic/lib/iprop.v) |
+| Theorem 5.5 | [no_later_existential_commuting](theories/examples/counterexamples.v) |
+
+## Acknowledgements
+
+The mechanization of set-theoretic ordinals and the underlying ZF model construction
+has been based on Coq code by Dominik Kirst and Gert Smolka, available at:
+
+* "Large Model Constructions for Second-Order ZF in Dependent Type Theory"
+ by Dominik Kirst and Gert Smolka, CPP 2018
+ See https://www.ps.uni-saarland.de/Publications/details/KirstSmolka:2017:Large-Model.html.
+* "Formalised Set Theory: Well-Orderings and the Axiom of Choice", Dominik Kirst.
+ See https://www.ps.uni-saarland.de/~kirst/bachelor.php
diff --git a/_CoqProject b/_CoqProject
index 071cd83b170d17968892d6a7426f60a2988f83df..08cde9de0dc6717e557e896ebb27af4e9a6c7f55 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -11,17 +11,34 @@
# We have ambiguous paths and so far it is not even clear what they are (https://gitlab.mpi-sws.org/iris/iris/issues/240).
-arg -w -arg -ambiguous-paths
+theories/algebra/ordinals/set_model.v
+theories/algebra/ordinals/set_sets.v
+theories/algebra/ordinals/set_functions.v
+theories/algebra/ordinals/set_ordinals.v
+theories/algebra/ordinals/ord_stepindex.v
+theories/algebra/ordinals/arithmetic.v
+
+theories/algebra/base.v
+theories/algebra/stepindex.v
theories/algebra/monoid.v
+theories/algebra/ofe.v
theories/algebra/cmra.v
+theories/algebra/updates.v
+theories/base_logic/base_logic.v
+theories/program_logic/language.v
+theories/bi/notation.v
+theories/bi/interface.v
+theories/bi/derived_connectives.v
+theories/bi/derived_laws_bi.v
+theories/bi/derived_laws_sbi.v
+theories/bi/satisfiable.v
+
+
theories/algebra/big_op.v
-theories/algebra/cmra_big_op.v
-theories/algebra/sts.v
theories/algebra/auth.v
theories/algebra/frac_auth.v
theories/algebra/gmap.v
-theories/algebra/ofe.v
-theories/algebra/base.v
-theories/algebra/dra.v
+theories/algebra/wf_IR.v
theories/algebra/cofe_solver.v
theories/algebra/agree.v
theories/algebra/excl.v
@@ -30,71 +47,59 @@ theories/algebra/frac.v
theories/algebra/csum.v
theories/algebra/list.v
theories/algebra/vector.v
-theories/algebra/updates.v
theories/algebra/local_updates.v
theories/algebra/gset.v
theories/algebra/gmultiset.v
theories/algebra/coPset.v
-theories/algebra/deprecated.v
theories/algebra/proofmode_classes.v
theories/algebra/ufrac.v
theories/algebra/namespace_map.v
theories/algebra/ufrac_auth.v
-theories/bi/notation.v
-theories/bi/interface.v
-theories/bi/derived_connectives.v
-theories/bi/derived_laws_bi.v
-theories/bi/derived_laws_sbi.v
+theories/algebra/dfrac.v
+theories/algebra/auth_map.v
+theories/algebra/auth_frac.v
+theories/algebra/mlist.v
theories/bi/plainly.v
theories/bi/big_op.v
theories/bi/updates.v
theories/bi/bi.v
theories/bi/tactics.v
-theories/bi/monpred.v
theories/bi/embedding.v
theories/bi/weakestpre.v
theories/bi/telescopes.v
-theories/bi/lib/counterexamples.v
theories/bi/lib/fixpoint.v
theories/bi/lib/fractional.v
-theories/bi/lib/laterable.v
-theories/bi/lib/atomic.v
-theories/bi/lib/core.v
theories/base_logic/upred.v
theories/base_logic/bi.v
theories/base_logic/derived.v
theories/base_logic/proofmode.v
-theories/base_logic/base_logic.v
-theories/base_logic/bupd_alt.v
+theories/base_logic/satisfiable.v
theories/base_logic/lib/iprop.v
theories/base_logic/lib/own.v
theories/base_logic/lib/saved_prop.v
theories/base_logic/lib/wsat.v
theories/base_logic/lib/invariants.v
theories/base_logic/lib/fancy_updates.v
+theories/base_logic/lib/logical_step.v
theories/base_logic/lib/viewshifts.v
-theories/base_logic/lib/auth.v
-theories/base_logic/lib/sts.v
-theories/base_logic/lib/boxes.v
theories/base_logic/lib/na_invariants.v
theories/base_logic/lib/cancelable_invariants.v
theories/base_logic/lib/gen_heap.v
-theories/base_logic/lib/fancy_updates_from_vs.v
theories/base_logic/lib/proph_map.v
-theories/program_logic/adequacy.v
-theories/program_logic/lifting.v
theories/program_logic/weakestpre.v
-theories/program_logic/total_weakestpre.v
-theories/program_logic/total_adequacy.v
+theories/program_logic/lifting.v
+theories/program_logic/adequacy.v
theories/program_logic/hoare.v
-theories/program_logic/language.v
theories/program_logic/ectx_language.v
theories/program_logic/ectxi_language.v
theories/program_logic/ectx_lifting.v
-theories/program_logic/ownp.v
-theories/program_logic/total_lifting.v
-theories/program_logic/total_ectx_lifting.v
-theories/program_logic/atomic.v
+theories/program_logic/refinement/ref_source.v
+theories/program_logic/refinement/ref_weakestpre.v
+theories/program_logic/refinement/ref_adequacy.v
+theories/program_logic/refinement/tc_weakestpre.v
+theories/program_logic/refinement/seq_weakestpre.v
+theories/program_logic/refinement/ref_lifting.v
+theories/program_logic/refinement/ref_ectx_lifting.v
theories/heap_lang/locations.v
theories/heap_lang/lang.v
theories/heap_lang/metatheory.v
@@ -103,19 +108,6 @@ theories/heap_lang/lifting.v
theories/heap_lang/notation.v
theories/heap_lang/proofmode.v
theories/heap_lang/adequacy.v
-theories/heap_lang/total_adequacy.v
-theories/heap_lang/lib/spawn.v
-theories/heap_lang/lib/par.v
-theories/heap_lang/lib/assert.v
-theories/heap_lang/lib/lock.v
-theories/heap_lang/lib/spin_lock.v
-theories/heap_lang/lib/ticket_lock.v
-theories/heap_lang/lib/nondet_bool.v
-theories/heap_lang/lib/lazy_coin.v
-theories/heap_lang/lib/clairvoyant_coin.v
-theories/heap_lang/lib/counter.v
-theories/heap_lang/lib/atomic_heap.v
-theories/heap_lang/lib/increment.v
theories/proofmode/base.v
theories/proofmode/tokens.v
theories/proofmode/coq_tactics.v
@@ -131,6 +123,49 @@ theories/proofmode/classes.v
theories/proofmode/class_instances_bi.v
theories/proofmode/class_instances_sbi.v
theories/proofmode/frame_instances.v
-theories/proofmode/monpred.v
theories/proofmode/modalities.v
theories/proofmode/modality_instances.v
+
+#################
+### Examples
+#################
+
+# General Transfinite Iris
+theories/examples/transfinite.v
+
+# derived Hoare triples
+theories/examples/refinements/derived.v
+
+# key ideas
+theories/examples/keyideas/simulations.v
+theories/examples/keyideas/generalized_simulations.v
+
+# Existing Safety Examples
+theories/examples/safety/spawn.v
+theories/examples/safety/par.v
+theories/examples/safety/assert.v
+theories/examples/safety/lock.v
+theories/examples/safety/spin_lock.v
+theories/examples/safety/ticket_lock.v
+theories/examples/safety/nondet_bool.v
+theories/examples/safety/counter.v
+theories/examples/safety/lazy_coin.v
+theories/examples/safety/clairvoyant_coin.v
+
+theories/examples/safety/barrier/barrier.v
+theories/examples/safety/barrier/proof.v
+theories/examples/safety/barrier/specification.v
+theories/examples/safety/barrier/example_client.v
+
+# Termination Proofs
+theories/examples/termination/adequacy.v
+theories/examples/termination/thunk.v
+theories/examples/termination/eventloop.v
+theories/examples/termination/logrel.v
+
+# Termination Preserving Refinement
+theories/examples/refinements/refinement.v
+theories/examples/refinements/memoization.v
+
+# Some formalised counterexamples
+theories/examples/counterexamples.v
diff --git a/opam b/opam
index 790563b1e03442add1370dd746edc460934dd127..8bcc12aef3948a24d81baf3be4eaf846b14d8bce 100644
--- a/opam
+++ b/opam
@@ -1,16 +1,18 @@
-opam-version: "1.2"
+opam-version: "2.0"
name: "coq-iris"
-synopsis: "This is the Coq development of the Iris Project"
maintainer: "Ralf Jung <jung@mpi-sws.org>"
authors: "The Iris Team"
-homepage: "http://iris-project.org/"
-bug-reports: "https://gitlab.mpi-sws.org/iris/iris/issues"
license: "BSD"
-dev-repo: "https://gitlab.mpi-sws.org/iris/iris.git"
-build: [make "-j%{jobs}%"]
-install: [make "install"]
-remove: ["rm" "-rf" "%{lib}%/coq/user-contrib/iris"]
+homepage: "https://iris-project.org/"
+bug-reports: "https://gitlab.mpi-sws.org/iris/iris/issues"
+dev-repo: "git+https://gitlab.mpi-sws.org/iris/iris.git"
+
+synopsis: "This is the Coq development of the Iris Project"
+
depends: [
- "coq" { (= "8.7.2") | (= "8.8.2") | (>= "8.9" & < "8.11~") | (= "dev") }
- "coq-stdpp" { (= "dev.2019-07-08.0.2e0bf441") | (= "dev") }
+ "coq" { (= "8.10.2") }
+ "coq-stdpp" { (= "1.3.0") }
]
+
+build: [make "-j%{jobs}%"]
+install: [make "install"]
diff --git a/theories/algebra/agree.v b/theories/algebra/agree.v
index 26a513024936fb1617226ccb622c57be43e663c3..a8edbefc64f08aa1d880c9f73c52f29d3c4b8bdd 100644
--- a/theories/algebra/agree.v
+++ b/theories/algebra/agree.v
@@ -51,17 +51,17 @@ Qed.
Section agree.
Local Set Default Proof Using "Type".
-Context {A : ofeT}.
+Context {SI} {A : ofeT SI}.
Implicit Types a b : A.
Implicit Types x y : agree A.
(* OFE *)
-Instance agree_dist : Dist (agree A) := λ n x y,
+Instance agree_dist : Dist SI (agree A) := λ n x y,
(∀ a, a ∈ agree_car x → ∃ b, b ∈ agree_car y ∧ a ≡{n}≡ b) ∧
(∀ b, b ∈ agree_car y → ∃ a, a ∈ agree_car x ∧ a ≡{n}≡ b).
Instance agree_equiv : Equiv (agree A) := λ x y, ∀ n, x ≡{n}≡ y.
-Definition agree_ofe_mixin : OfeMixin (agree A).
+Definition agree_ofe_mixin : OfeMixin SI (agree A).
Proof.
split.
- done.
@@ -73,14 +73,14 @@ Proof.
destruct (H2 b) as (c&?&?); eauto. by exists c; split; last etrans.
* intros a ?. destruct (H2' a) as (b&?&?); auto.
destruct (H1' b) as (c&?&?); eauto. by exists c; split; last etrans.
- - intros n x y [??]; split; naive_solver eauto using dist_S.
+ - intros α β x y [??]; split; naive_solver eauto using dist_le.
Qed.
Canonical Structure agreeO := OfeT (agree A) agree_ofe_mixin.
(* CMRA *)
(* agree_validN is carefully written such that, when applied to a singleton, it
is convertible to True. This makes working with agreement much more pleasant. *)
-Instance agree_validN : ValidN (agree A) := λ n x,
+Instance agree_validN : ValidN SI (agree A) := λ n x,
match agree_car x with
| [a] => True
| _ => ∀ a b, a ∈ agree_car x → b ∈ agree_car x → a ≡{n}≡ b
@@ -108,12 +108,12 @@ Qed.
Lemma agree_idemp (x : agree A) : x ⋅ x ≡ x.
Proof. intros n; split=> a /=; setoid_rewrite elem_of_app; naive_solver. Qed.
-Instance agree_validN_ne n : Proper (dist n ==> impl) (@validN (agree A) _ n).
+Instance agree_validN_ne n : Proper (dist n ==> impl) (@validN SI (agree A) _ n).
Proof.
intros x y [H H']; rewrite /impl !agree_validN_def; intros Hv a b Ha Hb.
destruct (H' a) as (a'&?&<-); auto. destruct (H' b) as (b'&?&<-); auto.
Qed.
-Instance agree_validN_proper n : Proper (equiv ==> iff) (@validN (agree A) _ n).
+Instance agree_validN_proper n : Proper (equiv ==> iff) (@validN SI (agree A) _ n).
Proof. move=> x y /equiv_dist H. by split; rewrite (H n). Qed.
Instance agree_op_ne' x : NonExpansive (op x).
@@ -137,10 +137,10 @@ Proof.
- destruct (elem_of_agree x1); naive_solver.
Qed.
-Definition agree_cmra_mixin : CmraMixin (agree A).
+Definition agree_cmra_mixin : CmraMixin SI (agree A).
Proof.
apply cmra_total_mixin; try apply _ || by eauto.
- - intros n x; rewrite !agree_validN_def; eauto using dist_S.
+ - intros α β x; rewrite !agree_validN_def; eauto using dist_le.
- intros x. apply agree_idemp.
- intros n x y; rewrite !agree_validN_def /=.
setoid_rewrite elem_of_app; naive_solver.
@@ -148,7 +148,7 @@ Proof.
+ by rewrite agree_idemp.
+ by move: Hval; rewrite Hx; move=> /agree_op_invN->; rewrite agree_idemp.
Qed.
-Canonical Structure agreeR : cmraT := CmraT (agree A) agree_cmra_mixin.
+Canonical Structure agreeR : cmraT SI := CmraT SI (agree A) agree_cmra_mixin.
Global Instance agree_cmra_total : CmraTotal agreeR.
Proof. rewrite /CmraTotal; eauto. Qed.
@@ -251,8 +251,8 @@ Proof. uPred.unseal. split=> n y _. exact: to_agree_uninjN. Qed.
End agree.
Instance: Params (@to_agree) 1 := {}.
-Arguments agreeO : clear implicits.
-Arguments agreeR : clear implicits.
+Arguments agreeO {_} _.
+Arguments agreeR {_} _.
Program Definition agree_map {A B} (f : A → B) (x : agree A) : agree B :=
{| agree_car := f <$> agree_car x |}.
@@ -267,7 +267,7 @@ Lemma agree_map_to_agree {A B} (f : A → B) (x : A) :
Proof. by apply agree_eq. Qed.
Section agree_map.
- Context {A B : ofeT} (f : A → B) {Hf: NonExpansive f}.
+ Context {SI} {A B : ofeT SI} (f : A → B) {Hf: NonExpansive f}.
Instance agree_map_ne : NonExpansive (agree_map f).
Proof.
@@ -297,33 +297,33 @@ Section agree_map.
Qed.
End agree_map.
-Definition agreeO_map {A B} (f : A -n> B) : agreeO A -n> agreeO B :=
+Definition agreeO_map {SI} {A B: ofeT SI} (f : A -n> B) : agreeO A -n> agreeO B :=
OfeMor (agree_map f : agreeO A → agreeO B).
-Instance agreeO_map_ne A B : NonExpansive (@agreeO_map A B).
+Instance agreeO_map_ne {SI} A B : NonExpansive (@agreeO_map SI A B).
Proof.
intros n f g Hfg x; split=> b /=;
setoid_rewrite elem_of_list_fmap; naive_solver.
Qed.
-Program Definition agreeRF (F : oFunctor) : rFunctor := {|
- rFunctor_car A _ B _ := agreeR (oFunctor_car F A B);
- rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := agreeO_map (oFunctor_map F fg)
+Program Definition agreeRF {SI} (F : oFunctor SI) : rFunctor SI := {|
+ rFunctor_car A B := agreeR (oFunctor_car F A B);
+ rFunctor_map A1 A2 B1 B2 fg := agreeO_map (oFunctor_map F fg)
|}.
Next Obligation.
- intros ? A1 ? A2 ? B1 ? B2 ? n ???; simpl. by apply agreeO_map_ne, oFunctor_ne.
+ intros ?? A1 A2 B1 B2 n ???; simpl. by apply agreeO_map_ne, oFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x; simpl. rewrite -{2}(agree_map_id x).
+ intros ? F A B x; simpl. rewrite -{2}(agree_map_id x).
apply (agree_map_ext _)=>y. by rewrite oFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl. rewrite -agree_map_compose.
+ intros ? F A1 A2 A3 B1 B2 B3 f g f' g' x; simpl. rewrite -agree_map_compose.
apply (agree_map_ext _)=>y; apply oFunctor_compose.
Qed.
-Instance agreeRF_contractive F :
+Instance agreeRF_contractive {SI} (F : oFunctor SI):
oFunctorContractive F → rFunctorContractive (agreeRF F).
Proof.
- intros ? A1 ? A2 ? B1 ? B2 ? n ???; simpl.
+ intros ? A1 A2 B1 B2 n ???; simpl.
by apply agreeO_map_ne, oFunctor_contractive.
Qed.
diff --git a/theories/algebra/auth.v b/theories/algebra/auth.v
index 6466762915684d38c6a625777abb32f528a1d4b6..64c5f64887bf16d82d0aba9236a73fe45a7a981c 100644
--- a/theories/algebra/auth.v
+++ b/theories/algebra/auth.v
@@ -21,14 +21,14 @@ Instance: Params (@Auth) 1 := {}.
Instance: Params (@auth_auth_proj) 1 := {}.
Instance: Params (@auth_frag_proj) 1 := {}.
-Definition auth_frag {A: ucmraT} (a: A) : auth A := Auth None a.
-Definition auth_auth {A: ucmraT} (q: Qp) (a: A) : auth A :=
+Definition auth_frag {SI} {A: ucmraT SI} (a: A) : auth A := Auth None a.
+Definition auth_auth {SI} {A: ucmraT SI} (q: Qp) (a: A) : auth A :=
Auth (Some (q, to_agree a)) ε.
Typeclasses Opaque auth_auth auth_frag.
-Instance: Params (@auth_frag) 1 := {}.
-Instance: Params (@auth_auth) 1 := {}.
+Instance: Params (@auth_frag) 2 := {}.
+Instance: Params (@auth_auth) 2 := {}.
Notation "â—¯ a" := (auth_frag a) (at level 20).
Notation "â—{ q } a" := (auth_auth q a) (at level 20, format "â—{ q } a").
@@ -36,14 +36,14 @@ Notation "â— a" := (auth_auth 1 a) (at level 20).
(* Ofe *)
Section ofe.
-Context {A : ofeT}.
+Context {SI} {A : ofeT SI}.
Implicit Types a : option (frac * agree A).
Implicit Types b : A.
Implicit Types x y : auth A.
Instance auth_equiv : Equiv (auth A) := λ x y,
auth_auth_proj x ≡ auth_auth_proj y ∧ auth_frag_proj x ≡ auth_frag_proj y.
-Instance auth_dist : Dist (auth A) := λ n x y,
+Instance auth_dist : Dist SI (auth A) := λ n x y,
auth_auth_proj x ≡{n}≡ auth_auth_proj y ∧
auth_frag_proj x ≡{n}≡ auth_frag_proj y.
@@ -60,8 +60,17 @@ Proof. by destruct 1. Qed.
Global Instance auth_frag_proj_proper : Proper ((≡) ==> (≡)) (@auth_frag_proj A).
Proof. by destruct 1. Qed.
-Definition auth_ofe_mixin : OfeMixin (auth A).
-Proof. by apply (iso_ofe_mixin (λ x, (auth_auth_proj x, auth_frag_proj x))). Qed.
+Definition auth_ofe_mixin : OfeMixin SI (auth A).
+Proof.
+ split.
+ - intros x y; split; [intros [] α; split|split]; try naive_solver.
+ all: apply equiv_dist; naive_solver.
+ - intros; split.
+ + split; reflexivity.
+ + intros x y []; split; naive_solver.
+ + intros x y z [] []; split; etransitivity; eauto.
+ - intros α β x y [] ?; split; eauto using dist_le.
+Qed.
Canonical Structure authO := OfeT (auth A) auth_ofe_mixin.
Global Instance Auth_discrete a b :
@@ -71,22 +80,23 @@ Global Instance auth_ofe_discrete : OfeDiscrete A → OfeDiscrete authO.
Proof. intros ? [??]; apply _. Qed.
End ofe.
-Arguments authO : clear implicits.
+Arguments authO {_} _.
(* Camera *)
Section cmra.
-Context {A : ucmraT}.
+Context {SI} {A : ucmraT SI}.
Implicit Types a b : A.
Implicit Types x y : auth A.
-Global Instance auth_frag_ne: NonExpansive (@auth_frag A).
+Global Instance auth_frag_ne: NonExpansive (@auth_frag SI A).
Proof. done. Qed.
-Global Instance auth_frag_proper : Proper ((≡) ==> (≡)) (@auth_frag A).
+Global Instance auth_frag_proper : Proper ((≡) ==> (≡)) (@auth_frag SI A).
Proof. done. Qed.
-Global Instance auth_auth_ne q : NonExpansive (@auth_auth A q).
-Proof. solve_proper. Qed.
-Global Instance auth_auth_proper : Proper ((≡) ==> (≡) ==> (≡)) (@auth_auth A).
+Global Instance auth_auth_ne q : NonExpansive (@auth_auth SI A q).
Proof. solve_proper. Qed.
+
+Global Instance auth_auth_proper : Proper ((ofe_equiv _ (fracO SI)) ==> (≡) ==> (≡)) (@auth_auth SI A).
+Proof. unshelve solve_proper. exact SI. Qed.
Global Instance auth_auth_discrete q a :
Discrete a → Discrete (ε : A) → Discrete (â—{q} a).
Proof. intros. apply Auth_discrete; apply _. Qed.
@@ -96,11 +106,11 @@ Proof. intros. apply Auth_discrete; apply _. Qed.
Instance auth_valid : Valid (auth A) := λ x,
match auth_auth_proj x with
| Some (q, ag) =>
- ✓ q ∧ (∀ n, ∃ a, ag ≡{n}≡ to_agree a ∧ auth_frag_proj x ≼{n} a ∧ ✓{n} a)
+ ✓ (q: fracR SI) ∧ (∀ n, ∃ a, ag ≡{n}≡ to_agree a ∧ auth_frag_proj x ≼{n} a ∧ ✓{n} a)
| None => ✓ auth_frag_proj x
end.
Global Arguments auth_valid !_ /.
-Instance auth_validN : ValidN (auth A) := λ n x,
+Instance auth_validN : ValidN SI (auth A) := λ n x,
match auth_auth_proj x with
| Some (q, ag) =>
✓{n} q ∧ ∃ a, ag ≡{n}≡ to_agree a ∧ auth_frag_proj x ≼{n} a ∧ ✓{n} a
@@ -178,7 +188,7 @@ Qed.
Lemma auth_frag_valid a : ✓ (◯ a) ↔ ✓ a.
Proof. done. Qed.
-Lemma auth_auth_frac_valid q a : ✓ (â—{q} a) ↔ ✓ q ∧ ✓ a.
+Lemma auth_auth_frac_valid (q: fracR SI) a : ✓ (â—{q} a) ↔ ✓ q ∧ ✓ a.
Proof.
rewrite auth_valid_eq /=. apply and_iff_compat_l. split.
- intros H'. apply cmra_valid_validN. intros n.
@@ -191,7 +201,7 @@ Proof. rewrite auth_auth_frac_valid frac_valid'. naive_solver. Qed.
(* The reverse direction of the two lemmas below only holds if the camera is
discrete. *)
-Lemma auth_both_frac_valid_2 q a b : ✓ q → ✓ a → b ≼ a → ✓ (â—{q} a â‹… â—¯ b).
+Lemma auth_both_frac_valid_2 (q: fracR SI) a b : ✓ q → ✓ a → b ≼ a → ✓ (â—{q} a â‹… â—¯ b).
Proof.
intros Val1 Val2 Incl. rewrite auth_valid_eq /=. split; [done|].
intros n. exists a. split; [done|]. rewrite left_id.
@@ -202,16 +212,16 @@ Proof. intros ??. by apply auth_both_frac_valid_2. Qed.
Lemma auth_valid_discrete `{!CmraDiscrete A} x :
✓ x ↔ match auth_auth_proj x with
- | Some (q, ag) => ✓ q ∧ ∃ a, ag ≡ to_agree a ∧ auth_frag_proj x ≼ a ∧ ✓ a
+ | Some (q, ag) => ✓ (q: fracR SI) ∧ ∃ a, ag ≡ to_agree a ∧ auth_frag_proj x ≼ a ∧ ✓ a
| None => ✓ auth_frag_proj x
end.
Proof.
rewrite auth_valid_eq. destruct x as [[[??]|] ?]; simpl; [|done].
setoid_rewrite <-cmra_discrete_included_iff.
setoid_rewrite <-(discrete_iff _ a).
- setoid_rewrite <-cmra_discrete_valid_iff. naive_solver eauto using O.
+ setoid_rewrite <-cmra_discrete_valid_iff. naive_solver eauto using zero.
Qed.
-Lemma auth_both_frac_valid `{!CmraDiscrete A} q a b :
+Lemma auth_both_frac_valid `{!CmraDiscrete A} (q: fracR SI) a b :
✓ (â—{q} a â‹… â—¯ b) ↔ ✓ q ∧ b ≼ a ∧ ✓ a.
Proof.
rewrite auth_valid_discrete /=. apply and_iff_compat_l.
@@ -222,7 +232,7 @@ Qed.
Lemma auth_both_valid `{!CmraDiscrete A} a b : ✓ (◠a ⋅ ◯ b) ↔ b ≼ a ∧ ✓ a.
Proof. rewrite auth_both_frac_valid frac_valid'. naive_solver. Qed.
-Lemma auth_cmra_mixin : CmraMixin (auth A).
+Lemma auth_cmra_mixin : CmraMixin SI (auth A).
Proof.
apply cmra_total_mixin.
- eauto.
@@ -233,8 +243,8 @@ Proof.
[destruct x,y|]; intros VI; ofe_subst; auto.
- intros [[[]|] ]; rewrite /= ?auth_valid_eq ?auth_validN_eq /=
?cmra_valid_validN; naive_solver.
- - intros n [[[]|] ]; rewrite !auth_validN_eq /=;
- naive_solver eauto using dist_S, cmra_includedN_S, cmra_validN_S.
+ - intros n m [[[]|] ]; rewrite !auth_validN_eq /=;
+ naive_solver eauto using dist_le, cmra_includedN_le, cmra_validN_le.
- by split; simpl; rewrite assoc.
- by split; simpl; rewrite comm.
- by split; simpl; rewrite ?cmra_core_l.
@@ -256,7 +266,7 @@ Proof.
as (b1&b2&?&?&?); auto using auth_frag_proj_validN.
by exists (Auth ea1 b1), (Auth ea2 b2).
Qed.
-Canonical Structure authR := CmraT (auth A) auth_cmra_mixin.
+Canonical Structure authR := CmraT SI (auth A) auth_cmra_mixin.
Global Instance auth_cmra_discrete : CmraDiscrete A → CmraDiscrete authR.
Proof.
@@ -270,14 +280,14 @@ Proof.
Qed.
Instance auth_empty : Unit (auth A) := Auth ε ε.
-Lemma auth_ucmra_mixin : UcmraMixin (auth A).
+Lemma auth_ucmra_mixin : UcmraMixin SI (auth A).
Proof.
split; simpl.
- rewrite auth_valid_eq /=. apply ucmra_unit_valid.
- by intros x; constructor; rewrite /= left_id.
- do 2 constructor; [done| apply (core_id_core _)].
Qed.
-Canonical Structure authUR := UcmraT (auth A) auth_ucmra_mixin.
+Canonical Structure authUR := UcmraT SI (auth A) auth_ucmra_mixin.
Global Instance auth_frag_core_id a : CoreId a → CoreId (◯ a).
Proof. do 2 constructor; simpl; auto. by apply core_id_core. Qed.
@@ -288,7 +298,7 @@ Lemma auth_frag_mono a b : a ≼ b → ◯ a ≼ ◯ b.
Proof. intros [c ->]. rewrite auth_frag_op. apply cmra_included_l. Qed.
Global Instance auth_frag_sep_homomorphism :
- MonoidHomomorphism op op (≡) (@auth_frag A).
+ MonoidHomomorphism op op (≡) (@auth_frag SI A).
Proof. by split; [split; try apply _|]. Qed.
Lemma auth_both_frac_op q a b : Auth (Some (q,to_agree a)) b ≡ â—{q} a â‹… â—¯ b.
@@ -339,6 +349,7 @@ Proof.
iRewrite -"Eq" in "H". iRewrite -"Eq" in "V". auto.
- iDestruct 1 as "[H V]". iExists a. auto.
Qed.
+
Lemma auth_auth_validI {M} q (a b: A) :
✓ (â—{q} a) ⊣⊢@{uPredI M} ✓ q ∧ ✓ a.
Proof.
@@ -389,7 +400,7 @@ Proof.
rewrite !local_update_unital=> Hup ? ? n /=.
move=> [[[qc ac]|] bc] /auth_both_validN [Le Val] [] /=.
- move => Ha. exfalso. move : Ha. rewrite right_id -Some_op pair_op.
- move => /Some_dist_inj [/=]. rewrite frac_op' => Eq _.
+ move => /dist_Some [/=]. rewrite frac_op' => Eq _.
apply (Qp_not_plus_q_ge_1 qc). by rewrite -Eq.
- move => _. rewrite !left_id=> ?.
destruct (Hup n bc) as [Hval' Heq]; eauto using cmra_validN_includedN.
@@ -399,14 +410,14 @@ Proof.
Qed.
End cmra.
-Arguments authR : clear implicits.
-Arguments authUR : clear implicits.
+Arguments authR {_} _.
+Arguments authUR {_} _.
(* Proof mode class instances *)
-Instance is_op_auth_frag {A : ucmraT} (a b1 b2 : A) :
+Instance is_op_auth_frag {SI} {A : ucmraT SI} (a b1 b2 : A) :
IsOp a b1 b2 → IsOp' (◯ a) (◯ b1) (◯ b2).
Proof. done. Qed.
-Instance is_op_auth_auth_frac {A : ucmraT} (q q1 q2 : frac) (a : A) :
+Instance is_op_auth_auth_frac {SI} {A : ucmraT SI} (q q1 q2 : fracR SI) (a : A) :
IsOp q q1 q2 → IsOp' (â—{q} a) (â—{q1} a) (â—{q2} a).
Proof. rewrite /IsOp' /IsOp => ->. by rewrite -auth_auth_frac_op. Qed.
@@ -418,20 +429,20 @@ Proof. destruct x as [[[]|] ]; by rewrite // /auth_map /= agree_map_id. Qed.
Lemma auth_map_compose {A B C} (f : A → B) (g : B → C) (x : auth A) :
auth_map (g ∘ f) x = auth_map g (auth_map f x).
Proof. destruct x as [[[]|] ]; by rewrite // /auth_map /= agree_map_compose. Qed.
-Lemma auth_map_ext {A B : ofeT} (f g : A → B) `{!NonExpansive f} x :
+Lemma auth_map_ext {SI} {A B : ofeT SI} (f g : A → B) `{!NonExpansive f} x :
(∀ x, f x ≡ g x) → auth_map f x ≡ auth_map g x.
Proof.
constructor; simpl; auto.
apply option_fmap_equiv_ext=> a; by rewrite /prod_map /= agree_map_ext.
Qed.
-Instance auth_map_ne {A B : ofeT} (f : A -> B) `{Hf : !NonExpansive f} :
+Instance auth_map_ne {SI} {A B : ofeT SI} (f : A -> B) `{Hf : !NonExpansive f} :
NonExpansive (auth_map f).
Proof.
intros n [??] [??] [??]; split; simpl in *; [|by apply Hf].
apply option_fmap_ne; [|done]=> x y ?. apply prod_map_ne; [done| |done].
by apply agree_map_ne.
Qed.
-Instance auth_map_cmra_morphism {A B : ucmraT} (f : A → B) :
+Instance auth_map_cmra_morphism {SI} {A B : ucmraT SI} (f : A → B) :
CmraMorphism f → CmraMorphism (auth_map f).
Proof.
split; try apply _.
@@ -445,52 +456,52 @@ Proof.
- intros [[[??]|]?] [[[??]|]?]; try apply Auth_proper=>//=; try by rewrite cmra_morphism_op.
by rewrite -Some_op pair_op cmra_morphism_op.
Qed.
-Definition authO_map {A B} (f : A -n> B) : authO A -n> authO B :=
+Definition authO_map {SI} {A B: ofeT SI} (f : A -n> B) : authO A -n> authO B :=
OfeMor (auth_map f).
-Lemma authO_map_ne A B : NonExpansive (@authO_map A B).
+Lemma authO_map_ne {SI} A B : NonExpansive (@authO_map SI A B).
Proof. intros n f f' Hf [[[]|] ]; repeat constructor; try naive_solver;
apply agreeO_map_ne; auto. Qed.
-Program Definition authRF (F : urFunctor) : rFunctor := {|
- rFunctor_car A _ B _ := authR (urFunctor_car F A B);
- rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := authO_map (urFunctor_map F fg)
+Program Definition authRF {SI} (F : urFunctor SI) : rFunctor SI := {|
+ rFunctor_car A B := authR (urFunctor_car F A B);
+ rFunctor_map A1 A2 B1 B2 fg := authO_map (urFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply authO_map_ne, urFunctor_ne.
+ by intros ? F A1 A2 B1 B2 n f g Hfg; apply authO_map_ne, urFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(auth_map_id x).
+ intros ? F A B x. rewrite /= -{2}(auth_map_id x).
apply (auth_map_ext _ _)=>y; apply urFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -auth_map_compose.
+ intros ? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
apply (auth_map_ext _ _)=>y; apply urFunctor_compose.
Qed.
-Instance authRF_contractive F :
+Instance authRF_contractive {SI} (F: urFunctor SI) :
urFunctorContractive F → rFunctorContractive (authRF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply authO_map_ne, urFunctor_contractive.
+ by intros ? A1 A2 B1 B2 n f g Hfg; apply authO_map_ne, urFunctor_contractive.
Qed.
-Program Definition authURF (F : urFunctor) : urFunctor := {|
- urFunctor_car A _ B _ := authUR (urFunctor_car F A B);
- urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := authO_map (urFunctor_map F fg)
+Program Definition authURF {SI} (F : urFunctor SI) : urFunctor SI := {|
+ urFunctor_car A B := authUR (urFunctor_car F A B);
+ urFunctor_map A1 A2 B1 B2 fg := authO_map (urFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply authO_map_ne, urFunctor_ne.
+ by intros ? F A1 A2 B1 B2 n f g Hfg; apply authO_map_ne, urFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(auth_map_id x).
+ intros ? F A B x. rewrite /= -{2}(auth_map_id x).
apply (auth_map_ext _ _)=>y; apply urFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -auth_map_compose.
+ intros ? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
apply (auth_map_ext _ _)=>y; apply urFunctor_compose.
Qed.
-Instance authURF_contractive F :
+Instance authURF_contractive {SI} (F : urFunctor SI):
urFunctorContractive F → urFunctorContractive (authURF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply authO_map_ne, urFunctor_contractive.
+ by intros ? A1 A2 B1 B2 n f g Hfg; apply authO_map_ne, urFunctor_contractive.
Qed.
diff --git a/theories/algebra/auth_frac.v b/theories/algebra/auth_frac.v
new file mode 100644
index 0000000000000000000000000000000000000000..72f971d12682053e288a38253a9471c208aa92c6
--- /dev/null
+++ b/theories/algebra/auth_frac.v
@@ -0,0 +1,63 @@
+From iris.algebra Require Import auth updates local_updates.
+From iris.proofmode Require Import tactics.
+From iris.bi.lib Require Import fractional.
+
+(* From perennial/iris-inv-hierarchy *)
+
+(** XXX: TODO, upsteam, although this proof is a mess *)
+Lemma auth_frac_update {SI} {A: ucmraT SI} q (a b b': A) :
+ (a,b) ~l~> (a,b') → â—{q} a â‹… â—¯ b ~~> â—{q} a â‹… â—¯ b'.
+Proof.
+ intros Hup; apply cmra_total_update.
+ move=> n [[[? b0]|] bf1] [/= VL [a0 [Eq [[bf2 Ha] VL2]]]]; do 2 red; simpl in *.
+ + split; auto.
+ assert (✓{n} to_agree a0).
+ { econstructor. }
+ assert (✓{n} b0) as Hb0val.
+ { eapply cmra_validN_includedN; last first.
+ { econstructor. rewrite comm. by symmetry. }
+ eauto. }
+ apply to_agree_uninjN in Hb0val as (a1&Heqa1).
+ assert (a ≡{n}≡ a0) as Heqa.
+ {
+ apply to_agree_injN. eapply agree_valid_includedN.
+ - econstructor.
+ - econstructor; by symmetry.
+ }
+ assert (a1 ≡{n}≡ a0) as Heqa1'.
+ {
+ apply to_agree_injN. eapply agree_valid_includedN.
+ - econstructor.
+ - econstructor. rewrite Heqa1 comm. by symmetry.
+ }
+ move: Ha; rewrite !left_id -assoc => Ha.
+ destruct (Hup n (Some (bf1 â‹… bf2))). simpl.
+ { by rewrite Heqa. }
+ { simpl. by rewrite Heqa. }
+ simpl in H1.
+ exists a0. rewrite -Heqa1 Heqa1'.
+ eexists; split_and!; eauto.
+ * intros ? Hin.
+ inversion Hin; subst; eexists; split_and!; first econstructor; eauto.
+ * intros ? Hin. inversion Hin; subst.
+ ** exists a0; split; auto. repeat econstructor.
+ ** inversion H4.
+ * rewrite -Heqa H1. simpl.
+ rewrite left_id assoc. econstructor; eauto.
+ + split; [done|]. apply to_agree_injN in Eq.
+ move: Ha; rewrite !left_id -assoc => Ha.
+ destruct (Hup n (Some (bf1 â‹… bf2))); [by rewrite Eq..|]. simpl in *.
+ exists a. split; [done|]. split; [|done]. exists bf2.
+ by rewrite left_id -assoc.
+Qed.
+
+Lemma auth_frac_update_alloc {SI} {A: ucmraT SI} (q: Qp) (a b': A):
+ (a, ε) ~l~> (a,b') → (â—{q} a ~~> â—{q} a â‹… â—¯ b').
+Proof. intros. rewrite -{1}(right_id _ _ (â—{q} a)). by eapply auth_frac_update in H. Qed.
+
+Lemma auth_frac_update_core_id {SI} {A: ucmraT SI} q (a b: A) `{!CoreId b} :
+ b ≼ a → â—{q} a ~~> â—{q} a â‹… â—¯ b.
+Proof.
+ intros Hincl. apply: auth_frac_update_alloc.
+ rewrite -(left_id ε _ b). apply: core_id_local_update. done.
+Qed.
diff --git a/theories/algebra/auth_map.v b/theories/algebra/auth_map.v
new file mode 100644
index 0000000000000000000000000000000000000000..432f60797c867b5733ea26fb54933bdb88f052fd
--- /dev/null
+++ b/theories/algebra/auth_map.v
@@ -0,0 +1,673 @@
+From iris.proofmode Require Import tactics.
+From iris.algebra Require Import excl agree auth gmap csum.
+From iris.bi.lib Require Import fractional.
+From iris.base_logic.lib Require Import own.
+
+(* This is a backport of auth_map.v by Tej Chajed from the Perennial project. *)
+
+Set Default Goal Selector "!".
+Set Default Proof Using "Type".
+
+Definition mapUR (SI: indexT) (K V: Type) `{Countable K}: ucmraT SI :=
+ gmapUR K (csumR SI (prodR (fracR SI) (agreeR (leibnizO SI V)))
+ (agreeR (leibnizO SI V))).
+
+Class mapG {SI} Σ K V `{Countable K} :=
+ { map_inG :> inG Σ (authUR (mapUR SI K V)); }.
+
+Definition mapΣ {SI} K V `{Countable K} :=
+ #[GFunctor (authR (mapUR SI K V))].
+
+Instance subG_mapG (SI : indexT) K V `{Countable K} :
+ subG (mapΣ (SI:=SI) K V) Σ → mapG (SI:=SI) Σ K V.
+Proof. solve_inG. Qed.
+
+Section auth_map.
+ Context {K V: Type} `{Countable0: Countable K}.
+ Implicit Types (γ:gname) (k:K) (q:Qp) (v:V) (m: gmap K V).
+ Context {SI} {Σ : gFunctors SI} `{!mapG Σ K V}.
+
+ Definition to_mapUR : gmap K (V*bool) → mapUR SI K V :=
+ fmap (λ '(v, ro), if (ro:bool) then Cinr (to_agree (v : leibnizO SI V))
+ else Cinl (1%Qp, to_agree (v : leibnizO SI V))).
+
+ Lemma to_mapUR_valid (m: gmap K (V*bool)) : ✓ to_mapUR m.
+ Proof.
+ intros k. rewrite lookup_fmap.
+ destruct (m !! k) as [mv|] eqn:Heq; rewrite Heq //=.
+ destruct mv as [v [|]]; rewrite //.
+ Qed.
+
+ Lemma lookup_to_mapUR_None (m: gmap K (V*bool)) k : m !! k = None → to_mapUR m !! k = None.
+ Proof. rewrite lookup_fmap => -> //. Qed.
+
+ Lemma to_mapUR_insert_inl k v (m: gmap K (V*bool)) :
+ to_mapUR (<[k:=(v,false)]> m) = <[k:=Cinl (1%Qp, to_agree (v:leibnizO SI V))]> (to_mapUR m).
+ Proof. rewrite /to_mapUR fmap_insert //. Qed.
+
+ Lemma to_mapUR_insert_inr k v (m: gmap K (V*bool)) :
+ to_mapUR (<[k:=(v,true)]> m) = <[k:=Cinr (to_agree (v:leibnizO SI V))]> (to_mapUR m).
+ Proof. rewrite /to_mapUR fmap_insert //. Qed.
+
+ Lemma to_mapUR_delete k (m: gmap K (V*bool)) :
+ to_mapUR (delete k m) = delete k (to_mapUR m).
+ Proof. rewrite /to_mapUR fmap_delete //. Qed.
+
+ Definition map_ctx γ q m : iProp Σ :=
+ (∃ ro_m,
+ ⌜m = fmap fst ro_m⌠∗
+ own γ (â—{q} to_mapUR ro_m))%I.
+
+ Global Instance map_ctx_fractional γ m : Fractional (λ q, map_ctx γ q m).
+ Proof.
+ iIntros (q1 q2).
+ rewrite /map_ctx.
+ setoid_rewrite auth_auth_frac_op.
+ setoid_rewrite own_op.
+ iSplit.
+ - iIntros "H".
+ iDestruct "H" as (ro_m) "[-> [H1 H2]]".
+ iSplitL "H1"; eauto.
+ - iIntros "[H1 H2]".
+ iDestruct "H1" as (ro_m1) "[-> H1]".
+ iDestruct "H2" as (ro_m2) "[-> H2]".
+ iDestruct (own_valid_2 with "H1 H2") as %Hvalid%auth_auth_frac_op_inv.
+ rewrite Hvalid.
+ iExists _; by iFrame.
+ Qed.
+
+ Global Instance map_ctx_AsFractional γ q m :
+ AsFractional (map_ctx γ q m) (λ q, map_ctx γ q m) q.
+ Proof.
+ split; (apply _ || auto).
+ Qed.
+
+ Theorem map_ctx_agree γ q1 q2 m1 m2 :
+ map_ctx γ q1 m1 -∗ map_ctx γ q2 m2 -∗ ⌜m1 = m2âŒ.
+ Proof.
+ iDestruct 1 as (ro_m1) "[-> H1]".
+ iDestruct 1 as (ro_m2) "[-> H2]".
+ iDestruct (own_valid_2 with "H1 H2") as %Hvalid%auth_auth_frac_op_inv.
+ iPureIntro.
+ apply map_eq => k.
+ rewrite !lookup_fmap.
+
+ assert (to_mapUR ro_m1 !! k ≡ to_mapUR ro_m2 !! k) as Hvalidk.
+ { apply Hvalid. }
+ rewrite /to_mapUR !lookup_fmap in Hvalidk.
+
+ destruct (ro_m1 !! k) eqn:He1; rewrite He1 /= in Hvalidk;
+ destruct (ro_m2 !! k) eqn:He2; rewrite He2 /= in Hvalidk;
+ inversion Hvalidk; clear Hvalidk; subst; eauto.
+ simpl; f_equal.
+ destruct p, p0, b, b0; simpl in *; inversion H1; clear H1; subst.
+ { apply to_agree_inj in H2. done. }
+ { inversion H2; clear H2; simpl in *; subst.
+ apply to_agree_inj in H0. done. }
+ Qed.
+
+ Definition ptsto_def γ k mq v :=
+ own γ (◯ {[ k := match mq with
+ | Some q => Cinl (q, to_agree (v : leibnizO SI V))
+ | None => Cinr (to_agree (v : leibnizO SI V))
+ end ]}).
+ Definition ptsto_aux : seal (@ptsto_def). Proof. by eexists. Qed.
+ Definition ptsto := ptsto_aux.(unseal).
+ Definition ptsto_eq : @ptsto = @ptsto_def := ptsto_aux.(seal_eq).
+
+ Definition ptsto_mut γ k q v := ptsto γ k (Some q) v.
+ Definition ptsto_ro γ k v := ptsto γ k None v.
+
+ Notation "k [[ γ ]]↦{ q } v" := (ptsto_mut γ k q%Qp v)
+ (at level 20, q at level 50, format "k [[ γ ]]↦{ q } v") : bi_scope.
+ Notation "k [[ γ ]]↦ v" := (k [[γ]]↦{1} v)%I
+ (at level 20, format "k [[ γ ]]↦ v") : bi_scope.
+ Notation "k [[ γ ]]↦ro v" := (ptsto_ro γ k v)
+ (at level 20, format "k [[ γ ]]↦ro v") : bi_scope.
+
+ Ltac unseal :=
+ rewrite /ptsto_mut /ptsto_ro ?ptsto_eq.
+
+ Global Instance ptsto_timeless : Timeless (ptsto γ k mq v).
+ Proof. unseal; apply _. Qed.
+
+ Global Instance ptsto_Fractional γ k v : Fractional (λ q, ptsto_mut γ k q v).
+ Proof.
+ unseal. intros p q. by rewrite -own_op -auth_frag_op
+ op_singleton Cinl_op pair_op agree_idemp.
+ Qed.
+ Global Instance ptsto_AsFractional γ k q v : AsFractional (ptsto_mut γ k q v) (λ q, ptsto_mut γ k q v) q.
+ Proof. split; auto; apply _. Qed.
+
+ Global Instance ptsto_ro_timeless : Timeless (ptsto_ro γ k v).
+ Proof. unseal; apply _. Qed.
+
+ Global Instance ptsto_ro_persistent : Persistent (ptsto_ro γ k v).
+ Proof. unseal; apply _. Qed.
+
+ Lemma Cinl_valid (A B:cmraT SI) (x:A) :
+ ✓ @Cinl A B x → ✓ x.
+ Proof. auto. Qed.
+
+ Lemma Cinr_valid (A B:cmraT SI) (x:B) :
+ ✓ @Cinr A B x → ✓ x.
+ Proof. auto. Qed.
+
+ Lemma Cinl_Cinr_op (A B:cmraT SI) x y :
+ @Cinl A B x â‹… @Cinr A B y = CsumBot.
+ Proof. reflexivity. Qed.
+
+ Lemma Cinr_Cinl_op (A B:cmraT SI) x y :
+ @Cinr A B y â‹… @Cinl A B x = CsumBot.
+ Proof. reflexivity. Qed.
+
+ Lemma ptsto_agree_frac_value γ k mq1 mq2 v1 v2 :
+ ptsto γ k mq1 v1 -∗ ptsto γ k mq2 v2 -∗
+ ⌜v1 = v2 ∧ match mq1, mq2 with
+ | Some q1, Some q2 => ✓(q1+q2 : fracR SI)%Qp
+ | None, None => True
+ | _, _ => False
+ endâŒ.
+ Proof.
+ unseal; rewrite /ptsto_def.
+ iIntros "H1 H2". iCombine "H1 H2" as "H".
+ destruct mq1, mq2.
+ - rewrite Cinl_op pair_op frac_op'.
+ iDestruct (own_valid with "H") as %Hvalid.
+ iPureIntro.
+ (* unification doesn't work with apply *)
+ apply auth_frag_valid in Hvalid as Hvalid%singleton_valid%Cinl_valid.
+ apply pair_valid in Hvalid as [? Hequiv%agree_op_invL'].
+ simpl in *.
+ auto.
+ - rewrite Cinl_Cinr_op.
+ iDestruct (own_valid with "H") as %Hvalid.
+ apply auth_frag_valid in Hvalid as []%singleton_valid.
+ - rewrite Cinr_Cinl_op.
+ iDestruct (own_valid with "H") as %Hvalid.
+ apply auth_frag_valid in Hvalid as []%singleton_valid.
+ - rewrite Cinr_op.
+ iDestruct (own_valid with "H") as %Hvalid.
+ iPureIntro.
+ (* unification doesn't work with apply *)
+ apply auth_frag_valid in Hvalid as Hvalid%singleton_valid%Cinr_valid.
+ apply agree_op_invL' in Hvalid. auto.
+ Qed.
+
+ Lemma ptsto_mut_agree_frac_value γ k q1 q2 v1 v2 :
+ ptsto_mut γ k q1 v1 -∗ ptsto_mut γ k q2 v2 -∗ ⌜v1 = v2 ∧ ✓(q1+q2 : fracR SI)%QpâŒ.
+ Proof.
+ iIntros "H1 H2".
+ iDestruct (ptsto_agree_frac_value with "H1 H2") as %?; auto.
+ Qed.
+
+ Theorem ptsto_agree γ k mq1 mq2 v1 v2 :
+ ptsto γ k mq1 v1 -∗ ptsto γ k mq2 v2 -∗ ⌜v1 = v2âŒ.
+ Proof.
+ iIntros "H1 H2".
+ iDestruct (ptsto_agree_frac_value with "H1 H2") as %[? ?].
+ auto.
+ Qed.
+
+ Theorem ptsto_mut_valid γ k q v :
+ ptsto_mut γ k q v -∗ ✓ q.
+ Proof.
+ unseal; rewrite /ptsto_def.
+ rewrite own_valid.
+ iIntros (Hvalid) "!%".
+ apply (iffLR (auth_frag_valid _)) in Hvalid as
+ Hvalid%singleton_valid%Cinl_valid.
+ apply (iffLR (pair_valid _ _)) in Hvalid; intuition.
+ Qed.
+ Theorem ptsto_valid_2 γ k q1 q2 v1 v2 :
+ ptsto_mut γ k q1 v1 -∗ ptsto_mut γ k q2 v2 -∗ ✓ (q1 + q2)%Qp.
+ Proof.
+ iIntros "H1 H2".
+ iDestruct (ptsto_mut_agree_frac_value with "H1 H2") as %[? ?].
+ auto.
+ Qed.
+
+ (* corollary of above lemmas for a useful special case *)
+ Theorem ptsto_conflict γ k v1 v2 :
+ ptsto_mut γ k 1 v1 -∗ ptsto_mut γ k 1 v2 -∗ False.
+ Proof.
+ iIntros "H1 H2".
+ iDestruct (ptsto_valid_2 with "H1 H2") as %?.
+ apply (iffLR (frac_valid' _)) in H.
+ contradiction H.
+ auto.
+ Qed.
+
+ Lemma ptsto_ro_agree γ k v1 v2 :
+ ptsto_ro γ k v1 -∗ ptsto_ro γ k v2 -∗ ⌜v1 = v2âŒ.
+ Proof.
+ iIntros "H1 H2".
+ iDestruct (ptsto_agree_frac_value with "H1 H2") as %[? ?]; auto.
+ Qed.
+
+ Theorem map_init m :
+ ⊢ |==> ∃ γ, map_ctx γ 1 m.
+ Proof.
+ iMod (own_alloc (◠to_mapUR ((., false) <$> m))) as (γ) "Hmap".
+ { rewrite auth_auth_valid.
+ apply to_mapUR_valid. }
+ iModIntro.
+ iExists γ, _; iFrame.
+ iPureIntro.
+ rewrite -map_fmap_compose map_fmap_id //.
+ Qed.
+
+ (* TODO: prove a map_strong_init lemma that allocates a map_ctx with all the
+ ptsto_mut fragments *)
+
+ Theorem map_alloc {γ m} k v :
+ m !! k = None →
+ map_ctx γ 1 m ==∗ map_ctx γ 1 (<[k:=v]> m) ∗ ptsto_mut γ k 1 v.
+ Proof.
+ unseal.
+ iIntros (Hlookup) "Hm".
+ iDestruct "Hm" as (m_ro ->) "Hm".
+ iMod (own_update with "Hm") as "[Hm Hk]".
+ { eapply auth_update_alloc,
+ (alloc_singleton_local_update _ _ (Cinl (1%Qp, to_agree (v:leibnizO SI V))))=> //.
+ apply lookup_to_mapUR_None.
+ rewrite lookup_fmap in Hlookup.
+ apply fmap_None in Hlookup; eauto. }
+ iModIntro.
+ iFrame "Hk".
+ rewrite -to_mapUR_insert_inl.
+ iExists _; iFrame.
+ iPureIntro.
+ rewrite fmap_insert //=.
+ Qed.
+
+ Theorem map_alloc_many {γ m} m0 :
+ ( ∀ k, is_Some (m0 !! k) -> m !! k = None ) ->
+ map_ctx γ 1 m ==∗ map_ctx γ 1 (m0 ∪ m) ∗ [∗ map] a↦v ∈ m0, ptsto_mut γ a 1 v.
+ Proof.
+ iIntros (Hnone) "Hm".
+ iInduction m0 as [|l v m0'] "IH" using map_ind forall (m Hnone).
+ { rewrite left_id. iFrame. iModIntro. iApply big_sepM_empty. done. }
+ iMod ("IH" with "[] Hm") as "[Hm Hmany]".
+ { iPureIntro. intros k Hk. eapply Hnone.
+ destruct (decide (l = k)); subst.
+ { rewrite lookup_insert. eauto. }
+ rewrite lookup_insert_ne; eauto.
+ }
+ iMod (map_alloc l v with "Hm") as "[Hm Hl]".
+ { rewrite lookup_union_None; intuition.
+ eapply Hnone. rewrite lookup_insert. eauto. }
+ iModIntro.
+ rewrite insert_union_l; iFrame "Hm".
+ iApply big_sepM_insert; eauto. iFrame.
+ Qed.
+
+ Theorem map_delete {γ m} k v :
+ ptsto_mut γ k 1 v -∗ map_ctx γ 1 m ==∗ map_ctx γ 1 (delete k m).
+ Proof.
+ unseal. rewrite /ptsto_def /map_ctx.
+ iIntros "Hk Hm".
+ iDestruct "Hm" as (m_ro ->) "Hm".
+ iExists (delete k m_ro).
+ iSplitR.
+ 2: {
+ iMod (own_update with "[Hk Hm]") as "Hm".
+ 2: iApply own_op; iFrame.
+ { eapply auth_update_dealloc.
+ eapply delete_singleton_local_update.
+ apply Cinl_exclusive.
+ apply pair_exclusive_l.
+ apply frac_full_exclusive. }
+ rewrite to_mapUR_delete. done.
+ }
+ rewrite fmap_delete; done.
+ Qed.
+
+ Lemma Cinl_included_inv (A B: cmraT SI) (x:A) (y:csumR SI A B) :
+ Cinl x ≼ y →
+ y = CsumBot ∨ ∃ x', y = Cinl x' ∧ x ≼ x'.
+ Proof.
+ rewrite csum_included; intros [|[|]]; eauto; right.
+ - destruct H as [x' [x'' ?]]; intuition subst.
+ inversion H0; subst; clear H0.
+ eauto.
+ - destruct H as [x' [x'' ?]]; intuition subst.
+ inversion H0.
+ Qed.
+
+ Lemma Cinr_included_inv (A B: cmraT SI) (x:B) (y:csumR SI A B) :
+ Cinr x ≼ y →
+ y = CsumBot ∨ ∃ x', y = Cinr x' ∧ x ≼ x'.
+ Proof.
+ rewrite csum_included; intros [|[|]]; eauto; right.
+ - destruct H as [x' [x'' ?]]; intuition subst.
+ inversion H0.
+ - destruct H as [x' [x'' ?]]; intuition subst.
+ inversion H0; subst; clear H0.
+ eauto.
+ Qed.
+
+ Lemma Some_included_inv (A: cmraT SI) (x y:A) :
+ Some x ≼ Some y → x ≡ y ∨ x ≼ y.
+ Proof.
+ rewrite option_included.
+ intros [|]; [ congruence | ].
+ destruct H as [x' [y' ?]]; intuition idtac.
+ - inversion H0; inversion H; subst.
+ eauto.
+ - inversion H0; inversion H; subst.
+ eauto.
+ Qed.
+
+ Lemma Some_Cinl_included (A B: cmraT SI) (x:A) (y: csumR SI A B) :
+ Some (Cinl x) ≼ Some y → y = CsumBot ∨ (∃ x', y = Cinl x' ∧ (x ≡ x' ∨ x ≼ x')).
+ Proof.
+ intros H%Some_included_inv.
+ intuition idtac.
+ - inversion H0; subst; eauto.
+ - apply Cinl_included_inv in H0.
+ intuition eauto.
+ right.
+ destruct H as [? (?&?)]; eauto.
+ Qed.
+
+ Lemma Some_Cinr_included (A B: cmraT SI) (x:B) (y: csumR SI A B) :
+ Some (Cinr x) ≼ Some y → y = CsumBot ∨ (∃ x', y = Cinr x' ∧ (x ≡ x' ∨ x ≼ x')).
+ Proof.
+ intros H%Some_included_inv.
+ intuition idtac.
+ - inversion H0; subst; eauto.
+ - apply Cinr_included_inv in H0.
+ intuition eauto.
+ right.
+ destruct H as [? (?&?)]; eauto.
+ Qed.
+
+ Lemma map_ptsto_included k q v (m: gmap K (V*bool)) :
+ {[k := Cinl (q, to_agree v)]} ≼ to_mapUR m → m !! k = Some (v, false).
+ Proof.
+ (* this proof is just a mess, it seems none of the lemmas needed are
+ there *)
+ rewrite singleton_included lookup_fmap.
+ intros [y [Hequiv Hincl]].
+ apply fmap_Some_equiv in Hequiv as [ [v' ro] [Hlookup Hy_equiv] ].
+ rewrite Hlookup.
+ f_equiv.
+ apply Some_Cinl_included in Hincl as [-> | Hincl].
+ { destruct ro; inversion Hy_equiv. }
+ destruct Hincl as [ [q' v''] [-> Hequiv_incl ]].
+ destruct ro; [ inversion Hy_equiv | ].
+ f_equiv.
+ inversion Hy_equiv; subst; clear Hy_equiv.
+ rewrite -> H1 in Hequiv_incl.
+ destruct Hequiv_incl as [Hequiv|Hincl].
+ - inversion Hequiv; subst; simpl in *.
+ apply (inj to_agree), leibniz_equiv_iff in H0; auto.
+ - apply prod_included in Hincl as [_ Hincl]; simpl in Hincl.
+ apply to_agree_included, leibniz_equiv in Hincl; auto.
+ Qed.
+
+ Lemma map_ptsto_ro_included k v (m: gmap K (V*bool)) :
+ {[k := Cinr (to_agree v)]} ≼ to_mapUR m → m !! k = Some (v, true).
+ Proof.
+ (* this proof is also a mess *)
+ rewrite singleton_included lookup_fmap.
+ intros [y [Hequiv Hincl]].
+ apply fmap_Some_equiv in Hequiv as [ [v' ro] [Hlookup Hy_equiv] ].
+ rewrite Hlookup.
+ f_equiv.
+ apply Some_Cinr_included in Hincl as [-> | Hincl].
+ { destruct ro; inversion Hy_equiv. }
+ destruct Hincl as [ [q' v''] [-> Hequiv_incl ]].
+ destruct ro; [ | by inversion Hy_equiv ].
+ f_equiv.
+ inversion Hy_equiv; subst; clear Hy_equiv.
+ rewrite -> H1 in Hequiv_incl.
+ destruct Hequiv_incl as [Hequiv|Hincl].
+ - apply (inj to_agree), leibniz_equiv_iff in Hequiv; auto.
+ - apply to_agree_included, leibniz_equiv in Hincl; auto.
+ Qed.
+
+ Theorem map_valid {γ m} k q mq v :
+ map_ctx γ q m -∗ ptsto γ k mq v -∗ ⌜m !! k = Some vâŒ.
+ Proof.
+ unseal; rewrite /ptsto_def.
+ iDestruct 1 as (m_ro ->) "Hm".
+ iIntros "Hk".
+ rewrite lookup_fmap.
+ destruct mq.
+ - iDestruct (own_valid_2 with "Hm Hk") as
+ %(_ & Hlookup%map_ptsto_included & _)%auth_both_frac_valid.
+ iPureIntro.
+ rewrite Hlookup //.
+ - iDestruct (own_valid_2 with "Hm Hk") as
+ %(_ & Hlookup%map_ptsto_ro_included & _)%auth_both_frac_valid.
+ iPureIntro.
+ rewrite Hlookup //.
+ Qed.
+
+ Theorem map_ro_valid {γ m} k q v :
+ map_ctx γ q m -∗ ptsto_ro γ k v -∗ ⌜m !! k = Some vâŒ.
+ Proof. apply map_valid. Qed.
+
+ Theorem map_valid_subset γ q (m0 m: gmap K V) mq :
+ map_ctx γ q m -∗
+ ([∗ map] a↦v ∈ m0, ptsto γ a mq v) -∗
+ ⌜m0 ⊆ mâŒ.
+ Proof.
+ iIntros "Hctx Hm0".
+ iInduction m0 as [|l v m0] "IH" using map_ind.
+ - iPureIntro. apply map_subseteq_spec. intros ?? Hin.
+ rewrite lookup_empty in Hin. congruence.
+ - rewrite big_sepM_insert //.
+ iDestruct "Hm0" as "[Hl Hm0]".
+ iDestruct ("IH" with "Hctx Hm0") as %Hsubseteq.
+ iDestruct (map_valid with "Hctx Hl") as %Hlookup.
+ iPureIntro.
+ apply map_subseteq_spec => l' v'.
+ intros [(-> & ->) | (? & ?)]%lookup_insert_Some; auto.
+ eapply map_subseteq_spec; eauto.
+ Qed.
+
+ Lemma map_update {γ m} k v1 v2 :
+ map_ctx γ 1 m -∗ ptsto_mut γ k 1 v1 ==∗ map_ctx γ 1 (<[k:=v2]>m) ∗ ptsto_mut γ k 1 v2.
+ Proof.
+ unseal.
+ iDestruct 1 as (m_ro ->) "Hm".
+ iIntros "Hk".
+ iDestruct (own_valid_2 with "Hm Hk") as
+ %[Hlookup%map_ptsto_included _]%auth_both_valid.
+ iMod (own_update_2 with "Hm Hk") as "[Hm $]".
+ { eapply auth_update, singleton_local_update,
+ (exclusive_local_update _ (Cinl (1%Qp, to_agree (v2: leibnizO SI V))))=> //.
+ rewrite lookup_fmap Hlookup //=. }
+ iModIntro.
+ rewrite -to_mapUR_insert_inl.
+ iExists _; iFrame.
+ iPureIntro.
+ rewrite fmap_insert //.
+ Qed.
+
+ Lemma gset_eq `{Countable A} (c1 c2: gset A) :
+ (forall (x:A), x ∈ c1 ↔ x ∈ c2) → c1 = c2.
+ Proof.
+ intros Hexteq.
+ destruct c1 as [c1], c2 as [c2].
+ f_equal.
+ apply map_eq.
+ unfold elem_of, gset_elem_of, mapset.mapset_elem_of in Hexteq.
+ simpl in Hexteq.
+ intros.
+ destruct (c1 !! i) eqn:Hc1;
+ destruct (c2 !! i) eqn:Hc2;
+ repeat match goal with u: unit |- _ => destruct u end; auto.
+ - apply Hexteq in Hc1; congruence.
+ - apply Hexteq in Hc2; congruence.
+ Qed.
+
+ Lemma set_split_element `{!EqDecision L, !Countable L} (d: gset L) a :
+ a ∈ d →
+ d = {[a]} ∪ (d ∖ {[a]}).
+ Proof.
+ intros.
+ apply gset_eq; intros a'.
+ destruct (decide (a = a')); set_solver.
+ Qed.
+
+ Lemma dom_union_inv m (d1 d2: gset K) :
+ d1 ## d2 →
+ dom (gset K) m = d1 ∪ d2 →
+ ∃ m1 m2, m1 ##ₘ m2 ∧ m = m1 ∪ m2 ∧ dom _ m1 = d1 ∧ dom _ m2 = d2.
+ Proof.
+ revert d1 d2.
+ induction m as [|a v m] using map_ind; intros.
+ - eexists ∅, ∅.
+ rewrite left_id_L.
+ split_and!; [ apply map_disjoint_empty_l | set_solver .. ].
+ - rewrite dom_insert_L in H1.
+ wlog: d1 d2 H0 H1 / (gset_elem_of a d1).
+ { intros.
+ assert (a ∈ d1 ∨ a ∈ d2) by set_solver.
+ intuition eauto.
+ destruct (x d2 d1) as (m1&m2&?); auto.
+ - rewrite (comm_L _ d2 d1) //.
+ - exists m2, m1.
+ intuition auto.
+ rewrite map_union_comm //. }
+ intros.
+ assert (d1 = {[a]} ∪ (d1 ∖ {[a]})) as Hsplit.
+ { apply set_split_element. set_solver. }
+ rewrite Hsplit in H1.
+ rewrite -assoc_L in H1.
+ apply (not_elem_of_dom (D := gset K)) in H.
+ apply union_cancel_l_L in H1; [ | set_solver..].
+ apply IHm in H1 as (m1&m2&?); [ | set_solver ]; intuition idtac.
+ exists (<[a:=v]> m1), m2.
+ split_and!; auto.
+ + apply (map_disjoint_dom (D := gset K)).
+ set_solver.
+ + rewrite -insert_union_l.
+ congruence.
+ + set_solver.
+ Qed.
+
+ Lemma dom_singleton_inv (m: gmap K V) (a : K) :
+ dom (gset K) m = {[a]} →
+ ∃ (v : V), m = {[a := v]}.
+ Proof.
+ intros.
+ destruct (m !! a) eqn:He.
+ 2: {
+ cut (a ∈ dom (gset _) m); [|set_solver].
+ rewrite elem_of_dom He.
+ intros [x ?]; congruence.
+ }
+ exists v. rewrite -insert_empty.
+ apply map_eq; intros.
+ destruct (decide (i = a)); subst.
+ - rewrite lookup_insert; eauto.
+ - rewrite lookup_insert_ne; eauto.
+ rewrite lookup_empty.
+ apply (not_elem_of_dom (D := gset K)). set_solver.
+ Qed.
+
+ Lemma union_singleton_l_insert k v m :
+ {[k := v]} ∪ m = <[k := v]> m.
+ Proof.
+ apply map_eq => k'.
+ apply option_eq => v'.
+ destruct (decide (k = k')); subst.
+ - rewrite lookup_insert.
+ erewrite lookup_union_Some_l; eauto.
+ rewrite lookup_singleton_Some //.
+ - rewrite lookup_insert_ne //.
+ erewrite lookup_union_r; eauto.
+ rewrite lookup_singleton_None //.
+ Qed.
+
+ (* like an update from l↦v0 to l↦v, except that we update an entire subset m0 ⊆
+ m to m' *)
+ Theorem map_update_map {γ} m' m0 m :
+ dom (gset K) m' = dom _ m0 →
+ map_ctx γ 1 m -∗
+ ([∗ map] a↦v ∈ m0, ptsto_mut γ a 1 v) -∗
+ |==> map_ctx γ 1 (m' ∪ m) ∗
+ [∗ map] a↦v ∈ m', ptsto_mut γ a 1 v.
+ Proof.
+ iIntros (Hdom) "Hctx Hm0".
+ iInduction m0 as [|l v m0] "IH" using map_ind forall (m m' Hdom).
+ - rewrite dom_empty_L in Hdom; apply dom_empty_inv_L in Hdom as ->.
+ rewrite left_id_L big_sepM_empty.
+ by iFrame.
+ - rewrite big_sepM_insert //.
+ iDestruct "Hm0" as "[Hl Hm0]".
+ rewrite dom_insert_L in Hdom.
+ assert (l ∈ dom (gset K) m') by set_solver.
+ apply elem_of_dom in H0 as [v' Hlookup].
+ iMod (map_update _ _ v' with "Hctx Hl") as "[Hctx Hl]".
+ iSpecialize ("IH" $! (<[l:=v']> m)).
+ apply dom_union_inv in Hdom as (m1&m2 & ? & -> & ? & ?); last first.
+ { apply disjoint_singleton_l, not_elem_of_dom; auto. }
+ iMod ("IH" $! m2 with "[%] Hctx Hm0") as "[Hctx Hm0]"; auto.
+ iModIntro.
+ assert (m1 = {[l := v']}).
+ { apply dom_singleton_inv in H1 as [v'' ->].
+ f_equal.
+ erewrite lookup_union_Some_l in Hlookup; last first.
+ { rewrite lookup_singleton_Some //. }
+ congruence. }
+ subst.
+ rewrite big_sepM_union // big_sepM_singleton.
+ iFrame.
+ assert (m2 ∪ <[l := v']> m =({[l := v']} ∪ m2 ∪ m)) as ->; eauto.
+ rewrite -union_singleton_l_insert.
+ rewrite assoc.
+ f_equal.
+ rewrite map_union_comm //.
+ Qed.
+
+ Theorem map_freeze γ m k v :
+ map_ctx γ 1 m -∗
+ ptsto_mut γ k 1 v ==∗ map_ctx γ 1 m ∗ ptsto_ro γ k v.
+ Proof.
+ unseal.
+ iDestruct 1 as (m_ro ->) "Hm".
+ iIntros "Hk".
+ iDestruct (own_valid_2 with "Hm Hk") as
+ %[Hlookup%map_ptsto_included _]%auth_both_valid.
+ iMod (own_update_2 with "Hm Hk") as "[Hm $]".
+ { eapply auth_update, singleton_local_update,
+ (exclusive_local_update _ (Cinr (to_agree (v: leibnizO SI V))))=> //.
+ rewrite lookup_fmap Hlookup //=. }
+ iModIntro.
+ rewrite -to_mapUR_insert_inr.
+ iExists _; iFrame.
+ iPureIntro.
+ apply map_eq; intros k'; rewrite !lookup_fmap.
+ destruct (decide (k = k')); subst.
+ - rewrite lookup_insert Hlookup //.
+ - rewrite lookup_insert_ne //.
+ Qed.
+
+ Theorem map_alloc_ro {γ m} k v :
+ m !! k = None →
+ map_ctx γ 1 m ==∗ map_ctx γ 1 (<[k:=v]> m) ∗ ptsto_ro γ k v.
+ Proof.
+ iIntros (?) "Hm".
+ iMod (map_alloc k v with "Hm") as "[Hm Hk]"; auto.
+ iMod (map_freeze with "Hm Hk") as "[$ $]".
+ auto.
+ Qed.
+
+End auth_map.
+
+(* TODO: this notation is cumbersome and also breaks [[ in Ltac, but that first
+token needs to disambiguate the notation which makes it hard to use something
+simple. *)
+
+Notation "k [[ γ ]]↦{ q } v" := (ptsto_mut γ k q%Qp v)
+ (at level 20, q at level 50, format "k [[ γ ]]↦{ q } v") : bi_scope.
+Notation "k [[ γ ]]↦ v" := (k [[γ]]↦{1} v)%I
+ (at level 20, format "k [[ γ ]]↦ v") : bi_scope.
+Notation "k [[ γ ]]↦ro v" := (ptsto_ro γ k v)
+ (at level 20, format "k [[ γ ]]↦ro v") : bi_scope.
diff --git a/theories/algebra/big_op.v b/theories/algebra/big_op.v
index ee57b0dfac3441aae18ca0f83f5e3f56c46824ce..875e58244fa1ab8b2f3d01bb0e10ccf1fe5e8a88 100644
--- a/theories/algebra/big_op.v
+++ b/theories/algebra/big_op.v
@@ -20,13 +20,13 @@ Since these big operators are like quantifiers, they have the same precedence as
[∀] and [∃]. *)
(** * Big ops over lists *)
-Fixpoint big_opL `{Monoid M o} {A} (f : nat → A → M) (xs : list A) : M :=
+Fixpoint big_opL `{Monoid SI M o} {A} (f : nat → A → M) (xs : list A) : M :=
match xs with
| [] => monoid_unit
| x :: xs => o (f 0 x) (big_opL (λ n, f (S n)) xs)
end.
-Instance: Params (@big_opL) 4 := {}.
-Arguments big_opL {M} o {_ A} _ !_ /.
+Instance: Params (@big_opL) 5 := {}.
+Arguments big_opL {_ M} o {_ A} _ !_ /.
Typeclasses Opaque big_opL.
Notation "'[^' o 'list]' k ↦ x ∈ l , P" := (big_opL o (λ k x, P) l)
(at level 200, o at level 1, l at level 10, k, x at level 1, right associativity,
@@ -35,10 +35,10 @@ Notation "'[^' o 'list]' x ∈ l , P" := (big_opL o (λ _ x, P) l)
(at level 200, o at level 1, l at level 10, x at level 1, right associativity,
format "[^ o list] x ∈ l , P") : stdpp_scope.
-Definition big_opM `{Monoid M o} `{Countable K} {A} (f : K → A → M)
+Definition big_opM `{Monoid SI M o} `{Countable K} {A} (f : K → A → M)
(m : gmap K A) : M := big_opL o (λ _, curry f) (map_to_list m).
-Instance: Params (@big_opM) 7 := {}.
-Arguments big_opM {M} o {_ K _ _ A} _ _ : simpl never.
+Instance: Params (@big_opM) 8 := {}.
+Arguments big_opM {_ M} o {_ K _ _ A} _ _ : simpl never.
Typeclasses Opaque big_opM.
Notation "'[^' o 'map]' k ↦ x ∈ m , P" := (big_opM o (λ k x, P) m)
(at level 200, o at level 1, m at level 10, k, x at level 1, right associativity,
@@ -47,19 +47,19 @@ Notation "'[^' o 'map]' x ∈ m , P" := (big_opM o (λ _ x, P) m)
(at level 200, o at level 1, m at level 10, x at level 1, right associativity,
format "[^ o map] x ∈ m , P") : stdpp_scope.
-Definition big_opS `{Monoid M o} `{Countable A} (f : A → M)
+Definition big_opS `{Monoid SI M o} `{Countable A} (f : A → M)
(X : gset A) : M := big_opL o (λ _, f) (elements X).
-Instance: Params (@big_opS) 6 := {}.
-Arguments big_opS {M} o {_ A _ _} _ _ : simpl never.
+Instance: Params (@big_opS) 7 := {}.
+Arguments big_opS {_ M} o {_ A _ _} _ _ : simpl never.
Typeclasses Opaque big_opS.
Notation "'[^' o 'set]' x ∈ X , P" := (big_opS o (λ x, P) X)
(at level 200, o at level 1, X at level 10, x at level 1, right associativity,
format "[^ o set] x ∈ X , P") : stdpp_scope.
-Definition big_opMS `{Monoid M o} `{Countable A} (f : A → M)
+Definition big_opMS `{Monoid SI M o} `{Countable A} (f : A → M)
(X : gmultiset A) : M := big_opL o (λ _, f) (elements X).
Instance: Params (@big_opMS) 7 := {}.
-Arguments big_opMS {M} o {_ A _ _} _ _ : simpl never.
+Arguments big_opMS {_ M} o {_ A _ _} _ _ : simpl never.
Typeclasses Opaque big_opMS.
Notation "'[^' o 'mset]' x ∈ X , P" := (big_opMS o (λ x, P) X)
(at level 200, o at level 1, X at level 10, x at level 1, right associativity,
@@ -67,7 +67,7 @@ Notation "'[^' o 'mset]' x ∈ X , P" := (big_opMS o (λ x, P) X)
(** * Properties about big ops *)
Section big_op.
-Context `{Monoid M o}.
+Context `{Monoid SI M o}.
Implicit Types xs : list M.
Infix "`o`" := o (at level 50, left associativity).
@@ -416,7 +416,7 @@ End gmultiset.
End big_op.
Section homomorphisms.
- Context `{Monoid M1 o1, Monoid M2 o2}.
+ Context `{Monoid SI M1 o1, Monoid SI M2 o2}.
Infix "`o1`" := o1 (at level 50, left associativity).
Infix "`o2`" := o2 (at level 50, left associativity).
(** The ssreflect rewrite tactic only works for relations that have a
diff --git a/theories/algebra/cmra.v b/theories/algebra/cmra.v
index 9858c033cfe68790af779907db849130f86e06ae..b1ecba9643db76c754fb7e75479978467dfb205e 100644
--- a/theories/algebra/cmra.v
+++ b/theories/algebra/cmra.v
@@ -1,5 +1,6 @@
From iris.algebra Require Export ofe monoid.
From stdpp Require Import finite.
+From iris.algebra Require ord_stepindex arithmetic.
Set Default Proof Using "Type".
Class PCore (A : Type) := pcore : A → option A.
@@ -23,34 +24,34 @@ Notation "(≼)" := included (only parsing) : stdpp_scope.
Hint Extern 0 (_ ≼ _) => reflexivity : core.
Instance: Params (@included) 3 := {}.
-Class ValidN (A : Type) := validN : nat → A → Prop.
-Hint Mode ValidN ! : typeclass_instances.
-Instance: Params (@validN) 3 := {}.
-Notation "✓{ n } x" := (validN n x)
- (at level 20, n at next level, format "✓{ n } x").
+Class ValidN (I: indexT) (A : Type) := validN : I → A → Prop.
+Hint Mode ValidN - ! : typeclass_instances.
+Instance: Params (@validN) 4 := {}.
+Notation "✓{ α } x" := (validN α x)
+ (at level 20, α at next level, format "✓{ α } x").
Class Valid (A : Type) := valid : A → Prop.
Hint Mode Valid ! : typeclass_instances.
Instance: Params (@valid) 2 := {}.
Notation "✓ x" := (valid x) (at level 20) : stdpp_scope.
-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, n at next level, format "x ≼{ n } y") : stdpp_scope.
-Instance: Params (@includedN) 4 := {}.
+Definition includedN {I: indexT} `{Dist I A, Op A} (α : I) (x y : A) := ∃ z, y ≡{α}≡ x ⋅ z.
+Notation "x ≼{ α } y" := (includedN α x y)
+ (at level 70, α at next level, format "x ≼{ α } y") : stdpp_scope.
+Instance: Params (@includedN) 5 := {}.
Hint Extern 0 (_ ≼{_} _) => reflexivity : core.
Section mixin.
Local Set Primitive Projections.
- Record CmraMixin A `{Dist A, Equiv A, PCore A, Op A, Valid A, ValidN A} := {
+ Record CmraMixin {I: indexT} A `{Dist I A, Equiv A, PCore A, Op A, Valid A, ValidN I A} := {
(* setoids *)
mixin_cmra_op_ne (x : A) : NonExpansive (op x);
- mixin_cmra_pcore_ne n (x y : A) cx :
- x ≡{n}≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡{n}≡ cy;
- mixin_cmra_validN_ne n : Proper (dist n ==> impl) (validN n);
+ mixin_cmra_pcore_ne α (x y : A) cx :
+ x ≡{α}≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡{α}≡ cy;
+ mixin_cmra_validN_ne α : Proper (dist α ==> impl) (validN α);
(* valid *)
- mixin_cmra_valid_validN (x : A) : ✓ x ↔ ∀ n, ✓{n} x;
- mixin_cmra_validN_S n (x : A) : ✓{S n} x → ✓{n} x;
+ mixin_cmra_valid_validN (x : A) : ✓ x ↔ ∀ α, ✓{α} x;
+ mixin_cmra_validN_downward α β (x : A) : ✓{α} x → β ⪯ α → ✓{β} x;
(* monoid *)
mixin_cmra_assoc : Assoc (≡@{A}) (⋅);
mixin_cmra_comm : Comm (≡@{A}) (⋅);
@@ -58,68 +59,71 @@ Section mixin.
mixin_cmra_pcore_idemp (x : A) cx : pcore x = Some cx → pcore cx ≡ Some cx;
mixin_cmra_pcore_mono (x y : A) cx :
x ≼ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼ cy;
- mixin_cmra_validN_op_l n (x y : A) : ✓{n} (x ⋅ y) → ✓{n} x;
- mixin_cmra_extend n (x y1 y2 : A) :
- ✓{n} x → x ≡{n}≡ y1 ⋅ y2 →
- { z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{n}≡ y1 ∧ z2 ≡{n}≡ y2 } }
+ mixin_cmra_validN_op_l α (x y : A) : ✓{α} (x ⋅ y) → ✓{α} x;
+ mixin_cmra_extend α (x y1 y2 : A) :
+ ✓{α} x → x ≡{α}≡ y1 ⋅ y2 →
+ { z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{α}≡ y1 ∧ z2 ≡{α}≡ y2 } }
}.
End mixin.
+Arguments CmraMixin _ _ {_ _ _ _ _ _}.
(** Bundled version *)
-Structure cmraT := CmraT' {
+Structure cmraT (I: indexT) := CmraT' {
cmra_car :> Type;
cmra_equiv : Equiv cmra_car;
- cmra_dist : Dist cmra_car;
+ cmra_dist : Dist I cmra_car;
cmra_pcore : PCore cmra_car;
cmra_op : Op cmra_car;
cmra_valid : Valid cmra_car;
- cmra_validN : ValidN cmra_car;
- cmra_ofe_mixin : OfeMixin cmra_car;
- cmra_mixin : CmraMixin cmra_car;
+ cmra_validN : ValidN I cmra_car;
+ cmra_ofe_mixin : OfeMixin I cmra_car;
+ cmra_mixin : CmraMixin I cmra_car;
_ : Type
}.
-Arguments CmraT' _ {_ _ _ _ _ _} _ _ _.
+Arguments CmraT' {_} _ {_ _ _ _ _ _} _ _ _.
(* Given [m : CmraMixin A], the notation [CmraT A m] provides a smart
constructor, which uses [ofe_mixin_of A] to infer the canonical OFE mixin of
the type [A], so that it does not have to be given manually. *)
-Notation CmraT A m := (CmraT' A (ofe_mixin_of A%type) m A) (only parsing).
-
-Arguments cmra_car : simpl never.
-Arguments cmra_equiv : simpl never.
-Arguments cmra_dist : simpl never.
-Arguments cmra_pcore : simpl never.
-Arguments cmra_op : simpl never.
-Arguments cmra_valid : simpl never.
-Arguments cmra_validN : simpl never.
-Arguments cmra_ofe_mixin : simpl never.
-Arguments cmra_mixin : simpl never.
+Notation CmraT I A m :=
+ (CmraT' A (ofe_mixin_of I A%type) m A) (only parsing).
+
+
+Arguments cmra_car {_} : simpl never.
+Arguments cmra_equiv {_} : simpl never.
+Arguments cmra_dist {_} : simpl never.
+Arguments cmra_pcore {_} : simpl never.
+Arguments cmra_op {_} : simpl never.
+Arguments cmra_valid {_} : simpl never.
+Arguments cmra_validN {_} : simpl never.
+Arguments cmra_ofe_mixin {_} : simpl never.
+Arguments cmra_mixin {_} : simpl never.
Add Printing Constructor cmraT.
-Hint Extern 0 (PCore _) => eapply (@cmra_pcore _) : typeclass_instances.
-Hint Extern 0 (Op _) => eapply (@cmra_op _) : typeclass_instances.
-Hint Extern 0 (Valid _) => eapply (@cmra_valid _) : typeclass_instances.
-Hint Extern 0 (ValidN _) => eapply (@cmra_validN _) : typeclass_instances.
-Coercion cmra_ofeO (A : cmraT) : ofeT := OfeT A (cmra_ofe_mixin A).
+Hint Extern 0 (PCore _) => eapply (@cmra_pcore _ _) : typeclass_instances.
+Hint Extern 0 (Op _) => eapply (@cmra_op _ _) : typeclass_instances.
+Hint Extern 0 (Valid _) => eapply (@cmra_valid _ _) : typeclass_instances.
+Hint Extern 0 (ValidN _ _) => eapply (@cmra_validN _ _) : typeclass_instances.
+Coercion cmra_ofeO {I: indexT} (A : cmraT I) : ofeT I := OfeT A (cmra_ofe_mixin A).
Canonical Structure cmra_ofeO.
-Definition cmra_mixin_of' A {Ac : cmraT} (f : Ac → A) : CmraMixin Ac := cmra_mixin Ac.
+Definition cmra_mixin_of' {I: indexT} A {Ac : cmraT I} (f : Ac → A) : CmraMixin I Ac := cmra_mixin Ac.
Notation cmra_mixin_of A :=
ltac:(let H := eval hnf in (cmra_mixin_of' A id) in exact H) (only parsing).
(** Lifting properties from the mixin *)
Section cmra_mixin.
- Context {A : cmraT}.
+ Context {I: indexT} {A : cmraT I}.
Implicit Types x y : A.
Global Instance cmra_op_ne (x : A) : NonExpansive (op x).
Proof. apply (mixin_cmra_op_ne _ (cmra_mixin A)). Qed.
- Lemma cmra_pcore_ne n x y cx :
- x ≡{n}≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡{n}≡ cy.
+ Lemma cmra_pcore_ne α x y cx :
+ x ≡{α}≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡{α}≡ cy.
Proof. apply (mixin_cmra_pcore_ne _ (cmra_mixin A)). Qed.
- Global Instance cmra_validN_ne n : Proper (dist n ==> impl) (@validN A _ n).
+ Global Instance cmra_validN_ne α : Proper (dist α ==> impl) (@validN _ A _ α).
Proof. apply (mixin_cmra_validN_ne _ (cmra_mixin A)). Qed.
- Lemma cmra_valid_validN x : ✓ x ↔ ∀ n, ✓{n} x.
+ Lemma cmra_valid_validN x : ✓ x ↔ ∀ α, ✓{α} x.
Proof. apply (mixin_cmra_valid_validN _ (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.
+ Lemma cmra_validN_downward α β x : ✓{α} x → β ⪯ α → ✓{β} x.
+ Proof. apply (mixin_cmra_validN_downward _ (cmra_mixin A)). Qed.
Global Instance cmra_assoc : Assoc (≡) (@op A _).
Proof. apply (mixin_cmra_assoc _ (cmra_mixin A)). Qed.
Global Instance cmra_comm : Comm (≡) (@op A _).
@@ -131,47 +135,47 @@ Section cmra_mixin.
Lemma cmra_pcore_mono x y cx :
x ≼ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼ cy.
Proof. apply (mixin_cmra_pcore_mono _ (cmra_mixin A)). Qed.
- Lemma cmra_validN_op_l n x y : ✓{n} (x ⋅ y) → ✓{n} x.
+ Lemma cmra_validN_op_l α x y : ✓{α} (x ⋅ y) → ✓{α} x.
Proof. apply (mixin_cmra_validN_op_l _ (cmra_mixin A)). Qed.
- Lemma cmra_extend n x y1 y2 :
- ✓{n} x → x ≡{n}≡ y1 ⋅ y2 →
- { z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{n}≡ y1 ∧ z2 ≡{n}≡ y2 } }.
+ Lemma cmra_extend α x y1 y2 :
+ ✓{α} x → x ≡{α}≡ y1 ⋅ y2 →
+ { z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{α}≡ y1 ∧ z2 ≡{α}≡ y2 } }.
Proof. apply (mixin_cmra_extend _ (cmra_mixin A)). Qed.
End cmra_mixin.
-Definition opM {A : cmraT} (x : A) (my : option A) :=
+Definition opM {I: indexT} {A : cmraT I} (x : A) (my : option A) :=
match my with Some y => x â‹… y | None => x end.
Infix "â‹…?" := opM (at level 50, left associativity) : stdpp_scope.
(** * CoreId elements *)
-Class CoreId {A : cmraT} (x : A) := core_id : pcore x ≡ Some x.
-Arguments core_id {_} _ {_}.
-Hint Mode CoreId + ! : typeclass_instances.
-Instance: Params (@CoreId) 1 := {}.
+Class CoreId {I: indexT} {A : cmraT I} (x : A) := core_id : pcore x ≡ Some x.
+Arguments core_id {_ _} _ {_}.
+Hint Mode CoreId - + ! : typeclass_instances.
+Instance: Params (@CoreId) 2 := {}.
(** * Exclusive elements (i.e., elements that cannot have a frame). *)
-Class Exclusive {A : cmraT} (x : A) := exclusive0_l y : ✓{0} (x ⋅ y) → False.
-Arguments exclusive0_l {_} _ {_} _ _.
-Hint Mode Exclusive + ! : typeclass_instances.
-Instance: Params (@Exclusive) 1 := {}.
+Class Exclusive {I: indexT} {A : cmraT I} (x : A) := exclusive0_l y : ✓{zero} (x ⋅ y) → False.
+Arguments exclusive0_l {_ _} _ {_} _ _.
+Hint Mode Exclusive - + ! : typeclass_instances.
+Instance: Params (@Exclusive) 2 := {}.
(** * Cancelable elements. *)
-Class Cancelable {A : cmraT} (x : A) :=
- cancelableN n y z : ✓{n}(x ⋅ y) → x ⋅ y ≡{n}≡ x ⋅ z → y ≡{n}≡ z.
-Arguments cancelableN {_} _ {_} _ _ _ _.
-Hint Mode Cancelable + ! : typeclass_instances.
-Instance: Params (@Cancelable) 1 := {}.
+Class Cancelable {I: indexT} {A : cmraT I} (x : A) :=
+ cancelableN α y z : ✓{α}(x ⋅ y) → x ⋅ y ≡{α}≡ x ⋅ z → y ≡{α}≡ z.
+Arguments cancelableN {_ _} _ {_} _ _ _ _.
+Hint Mode Cancelable - + ! : typeclass_instances.
+Instance: Params (@Cancelable) 2 := {}.
(** * Identity-free elements. *)
-Class IdFree {A : cmraT} (x : A) :=
- id_free0_r y : ✓{0}x → x ⋅ y ≡{0}≡ x → False.
-Arguments id_free0_r {_} _ {_} _ _.
-Hint Mode IdFree + ! : typeclass_instances.
-Instance: Params (@IdFree) 1 := {}.
+Class IdFree {I: indexT} {A : cmraT I} (x : A) :=
+ id_free0_r y : ✓{zero}x → x ⋅ y ≡{zero}≡ x → False.
+Arguments id_free0_r {_ _} {_} _ {_} _ _.
+Hint Mode IdFree - + ! : typeclass_instances.
+Instance: Params (@IdFree) 2 := {}.
(** * CMRAs whose core is total *)
-Class CmraTotal (A : cmraT) := cmra_total (x : A) : is_Some (pcore x).
-Hint Mode CmraTotal ! : typeclass_instances.
+Class CmraTotal {I: indexT} (A : cmraT I) := cmra_total (x : A) : is_Some (pcore x).
+Hint Mode CmraTotal - ! : typeclass_instances.
(** The function [core] returns a dummy when used on CMRAs without total
core. *)
@@ -186,50 +190,52 @@ Arguments core' _ _ _ /.
Class Unit (A : Type) := ε : A.
Arguments ε {_ _}.
-Record UcmraMixin A `{Dist A, Equiv A, PCore A, Op A, Valid A, Unit A} := {
+Record UcmraMixin {I: indexT} A `{Dist I A, Equiv A, PCore A, Op A, Valid A, Unit A} := {
mixin_ucmra_unit_valid : ✓ (ε : A);
mixin_ucmra_unit_left_id : LeftId (≡) ε (⋅);
mixin_ucmra_pcore_unit : pcore ε ≡ Some ε
}.
+Arguments UcmraMixin _ _ {_ _ _ _ _ _}.
-Structure ucmraT := UcmraT' {
+Structure ucmraT (I: indexT) := UcmraT' {
ucmra_car :> Type;
ucmra_equiv : Equiv ucmra_car;
- ucmra_dist : Dist ucmra_car;
+ ucmra_dist : Dist I ucmra_car;
ucmra_pcore : PCore ucmra_car;
ucmra_op : Op ucmra_car;
ucmra_valid : Valid ucmra_car;
- ucmra_validN : ValidN ucmra_car;
+ ucmra_validN : ValidN I ucmra_car;
ucmra_unit : Unit ucmra_car;
- ucmra_ofe_mixin : OfeMixin ucmra_car;
- ucmra_cmra_mixin : CmraMixin ucmra_car;
- ucmra_mixin : UcmraMixin ucmra_car;
+ ucmra_ofe_mixin : OfeMixin I ucmra_car;
+ ucmra_cmra_mixin : CmraMixin I ucmra_car;
+ ucmra_mixin : UcmraMixin I ucmra_car;
_ : Type;
}.
-Arguments UcmraT' _ {_ _ _ _ _ _ _} _ _ _ _.
-Notation UcmraT A m :=
- (UcmraT' A (ofe_mixin_of A%type) (cmra_mixin_of A%type) m A) (only parsing).
-Arguments ucmra_car : simpl never.
-Arguments ucmra_equiv : simpl never.
-Arguments ucmra_dist : simpl never.
-Arguments ucmra_pcore : simpl never.
-Arguments ucmra_op : simpl never.
-Arguments ucmra_valid : simpl never.
-Arguments ucmra_validN : simpl never.
-Arguments ucmra_ofe_mixin : simpl never.
-Arguments ucmra_cmra_mixin : simpl never.
-Arguments ucmra_mixin : simpl never.
+Arguments UcmraT' {_} _ {_ _ _ _ _ _ _} _ _ _ _.
+Notation UcmraT I A m :=
+ (UcmraT' A (ofe_mixin_of I A%type) (cmra_mixin_of A%type) m A) (only parsing).
+
+Arguments ucmra_car {_} : simpl never.
+Arguments ucmra_equiv {_} : simpl never.
+Arguments ucmra_dist {_} : simpl never.
+Arguments ucmra_pcore {_} : simpl never.
+Arguments ucmra_op {_} : simpl never.
+Arguments ucmra_valid {_} : simpl never.
+Arguments ucmra_validN {_} : simpl never.
+Arguments ucmra_ofe_mixin {_} : simpl never.
+Arguments ucmra_cmra_mixin {_} : simpl never.
+Arguments ucmra_mixin {_} : simpl never.
Add Printing Constructor ucmraT.
Hint Extern 0 (Unit _) => eapply (@ucmra_unit _) : typeclass_instances.
-Coercion ucmra_ofeO (A : ucmraT) : ofeT := OfeT A (ucmra_ofe_mixin A).
+Coercion ucmra_ofeO {I: indexT} (A : ucmraT I) : ofeT I := OfeT A (ucmra_ofe_mixin A).
Canonical Structure ucmra_ofeO.
-Coercion ucmra_cmraR (A : ucmraT) : cmraT :=
+Coercion ucmra_cmraR {I: indexT} (A : ucmraT I) : cmraT I :=
CmraT' A (ucmra_ofe_mixin A) (ucmra_cmra_mixin A) A.
Canonical Structure ucmra_cmraR.
(** Lifting properties from the mixin *)
Section ucmra_mixin.
- Context {A : ucmraT}.
+ Context {I: indexT} {A : ucmraT I}.
Implicit Types x y : A.
Lemma ucmra_unit_valid : ✓ (ε : A).
Proof. apply (mixin_ucmra_unit_valid _ (ucmra_mixin A)). Qed.
@@ -240,71 +246,71 @@ Section ucmra_mixin.
End ucmra_mixin.
(** * Discrete CMRAs *)
-Class CmraDiscrete (A : cmraT) := {
+Class CmraDiscrete {I: indexT} (A : cmraT I) := {
cmra_discrete_ofe_discrete :> OfeDiscrete A;
- cmra_discrete_valid (x : A) : ✓{0} x → ✓ x
+ cmra_discrete_valid (x : A) : ✓{zero} x → ✓ x
}.
-Hint Mode CmraDiscrete ! : typeclass_instances.
+Hint Mode CmraDiscrete - ! : typeclass_instances.
(** * Morphisms *)
-Class CmraMorphism {A B : cmraT} (f : A → B) := {
+Class CmraMorphism {I: indexT} {A B : cmraT I} (f : A → B) := {
cmra_morphism_ne :> NonExpansive f;
- cmra_morphism_validN n x : ✓{n} x → ✓{n} f x;
+ cmra_morphism_validN α x : ✓{α} x → ✓{α} f x;
cmra_morphism_pcore x : pcore (f x) ≡ f <$> pcore x;
cmra_morphism_op x y : f x ⋅ f y ≡ f (x ⋅ y)
}.
-Arguments cmra_morphism_validN {_ _} _ {_} _ _ _.
-Arguments cmra_morphism_pcore {_ _} _ {_} _.
-Arguments cmra_morphism_op {_ _} _ {_} _ _.
+Arguments cmra_morphism_validN {_ _ _} _ {_} _ _ _.
+Arguments cmra_morphism_pcore {_ _ _} _ {_} _.
+Arguments cmra_morphism_op {_ _ _} _ {_} _ _.
(** * Properties **)
Section cmra.
-Context {A : cmraT}.
+Context {I: indexT} {A : cmraT I}.
Implicit Types x y z : A.
Implicit Types xs ys zs : list A.
(** ** Setoids *)
Global Instance cmra_pcore_ne' : NonExpansive (@pcore A _).
Proof.
- intros n x y Hxy. destruct (pcore x) as [cx|] eqn:?.
- { destruct (cmra_pcore_ne n x y cx) as (cy&->&->); auto. }
+ intros α x y Hxy. destruct (pcore x) as [cx|] eqn:?.
+ { destruct (cmra_pcore_ne α x y cx) as (cy&->&->); auto. }
destruct (pcore y) as [cy|] eqn:?; auto.
- destruct (cmra_pcore_ne n y x cy) as (cx&?&->); simplify_eq/=; auto.
+ destruct (cmra_pcore_ne α y x cy) as (cx&?&->); simplify_eq/=; auto.
Qed.
Lemma cmra_pcore_proper x y cx :
x ≡ y → pcore x = Some cx → ∃ cy, pcore y = Some cy ∧ cx ≡ cy.
Proof.
- intros. destruct (cmra_pcore_ne 0 x y cx) as (cy&?&?); auto.
- exists cy; split; [done|apply equiv_dist=> n].
- destruct (cmra_pcore_ne n x y cx) as (cy'&?&?); naive_solver.
+ intros. destruct (cmra_pcore_ne zero x y cx) as (cy&?&?); auto.
+ exists cy; split; [done|apply equiv_dist=> α].
+ destruct (cmra_pcore_ne α x y cx) as (cy'&?&?); naive_solver.
Qed.
Global Instance cmra_pcore_proper' : Proper ((≡) ==> (≡)) (@pcore A _).
Proof. apply (ne_proper _). Qed.
Global Instance cmra_op_ne' : NonExpansive2 (@op A _).
-Proof. intros n x1 x2 Hx y1 y2 Hy. by rewrite Hy (comm _ x1) Hx (comm _ y2). Qed.
+Proof. intros α x1 x2 Hx y1 y2 Hy. by rewrite Hy (comm _ x1) Hx (comm _ y2). Qed.
Global Instance cmra_op_proper' : Proper ((≡) ==> (≡) ==> (≡)) (@op A _).
Proof. apply (ne_proper_2 _). Qed.
-Global Instance cmra_validN_ne' : Proper (dist n ==> iff) (@validN A _ n) | 1.
+Global Instance cmra_validN_ne' : Proper (dist α ==> iff) (@validN I A _ α) | 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_validN_proper : Proper ((≡) ==> iff) (@validN I A _ α) | 1.
+Proof. by intros α x1 x2 Hx; apply cmra_validN_ne', equiv_dist. Qed.
Global Instance cmra_valid_proper : Proper ((≡) ==> iff) (@valid A _).
Proof.
intros x y Hxy; rewrite !cmra_valid_validN.
by split=> ? n; [rewrite -Hxy|rewrite Hxy].
Qed.
-Global Instance cmra_includedN_ne n :
- Proper (dist n ==> dist n ==> iff) (@includedN A _ _ n) | 1.
+Global Instance cmra_includedN_ne α :
+ Proper (dist α ==> dist α ==> iff) (@includedN I 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_includedN_proper n :
- Proper ((≡) ==> (≡) ==> iff) (@includedN A _ _ n) | 1.
+Global Instance cmra_includedN_proper α :
+ Proper ((≡) ==> (≡) ==> iff) (@includedN I A _ _ α) | 1.
Proof.
intros x x' Hx y y' Hy; revert Hx Hy; rewrite !equiv_dist=> Hx Hy.
- by rewrite (Hx n) (Hy n).
+ by rewrite (Hx α) (Hy α).
Qed.
Global Instance cmra_included_proper :
Proper ((≡) ==> (≡) ==> iff) (@included A _ _) | 1.
@@ -312,18 +318,18 @@ Proof.
intros x x' Hx y y' Hy.
by split; intros [z ?]; exists z; [rewrite -Hx -Hy|rewrite Hx Hy].
Qed.
-Global Instance cmra_opM_ne : NonExpansive2 (@opM A).
+Global Instance cmra_opM_ne : NonExpansive2 (@opM _ A).
Proof. destruct 2; by ofe_subst. Qed.
-Global Instance cmra_opM_proper : Proper ((≡) ==> (≡) ==> (≡)) (@opM A).
+Global Instance cmra_opM_proper : Proper ((≡) ==> (≡) ==> (≡)) (@opM _ A).
Proof. destruct 2; by setoid_subst. Qed.
-Global Instance CoreId_proper : Proper ((≡) ==> iff) (@CoreId A).
-Proof. solve_proper. Qed.
-Global Instance Exclusive_proper : Proper ((≡) ==> iff) (@Exclusive A).
+Global Instance CoreId_proper : Proper ((≡) ==> iff) (@CoreId _ A).
+Proof. intros x y Hxy. rewrite /CoreId. by setoid_rewrite Hxy. Qed.
+Global Instance Exclusive_proper : Proper ((≡) ==> iff) (@Exclusive _ A).
Proof. intros x y Hxy. rewrite /Exclusive. by setoid_rewrite Hxy. Qed.
-Global Instance Cancelable_proper : Proper ((≡) ==> iff) (@Cancelable A).
+Global Instance Cancelable_proper : Proper ((≡) ==> iff) (@Cancelable _ A).
Proof. intros x y Hxy. rewrite /Cancelable. by setoid_rewrite Hxy. Qed.
-Global Instance IdFree_proper : Proper ((≡) ==> iff) (@IdFree A).
+Global Instance IdFree_proper : Proper ((≡) ==> iff) (@IdFree _ A).
Proof. intros x y Hxy. rewrite /IdFree. by setoid_rewrite Hxy. Qed.
(** ** Op *)
@@ -331,11 +337,11 @@ Lemma cmra_op_opM_assoc x y mz : (x ⋅ y) ⋅? mz ≡ x ⋅ (y ⋅? mz).
Proof. destruct mz; by rewrite /= -?assoc. Qed.
(** ** Validity *)
-Lemma cmra_validN_le n n' x : ✓{n} x → n' ≤ n → ✓{n'} x.
-Proof. induction 2; eauto using cmra_validN_S. Qed.
+Lemma cmra_validN_le α α' x : ✓{α} x → α' ⪯ α → ✓{α'} x.
+Proof. eapply cmra_validN_downward. Qed.
Lemma cmra_valid_op_l x y : ✓ (x ⋅ y) → ✓ x.
Proof. rewrite !cmra_valid_validN; eauto using cmra_validN_op_l. Qed.
-Lemma cmra_validN_op_r n x y : ✓{n} (x ⋅ y) → ✓{n} y.
+Lemma cmra_validN_op_r α x y : ✓{α} (x ⋅ y) → ✓{α} y.
Proof. rewrite (comm _ x); apply cmra_validN_op_l. Qed.
Lemma cmra_valid_op_r x y : ✓ (x ⋅ y) → ✓ y.
Proof. rewrite !cmra_valid_validN; eauto using cmra_validN_op_r. Qed.
@@ -353,7 +359,7 @@ Lemma cmra_pcore_dup x cx : pcore x = Some cx → cx ≡ cx ⋅ cx.
Proof. intros; symmetry; eauto using cmra_pcore_r', cmra_pcore_idemp. Qed.
Lemma cmra_pcore_dup' x cx : pcore x ≡ Some cx → cx ≡ cx ⋅ cx.
Proof. intros; symmetry; eauto using cmra_pcore_r', cmra_pcore_idemp'. Qed.
-Lemma cmra_pcore_validN n x cx : ✓{n} x → pcore x = Some cx → ✓{n} cx.
+Lemma cmra_pcore_validN α x cx : ✓{α} x → pcore x = Some cx → ✓{α} cx.
Proof.
intros Hvx Hx%cmra_pcore_l. move: Hvx; rewrite -Hx. apply cmra_validN_op_l.
Qed.
@@ -363,25 +369,25 @@ Proof.
Qed.
(** ** Exclusive elements *)
-Lemma exclusiveN_l n x `{!Exclusive x} y : ✓{n} (x ⋅ y) → False.
-Proof. intros. eapply (exclusive0_l x y), cmra_validN_le; eauto with lia. Qed.
-Lemma exclusiveN_r n x `{!Exclusive x} y : ✓{n} (y ⋅ x) → False.
+Lemma exclusiveN_l α x `{!Exclusive x} y : ✓{α} (x ⋅ y) → False.
+Proof. intros. eapply (exclusive0_l x y), cmra_validN_le; eauto using index_zero_minimum. Qed.
+Lemma exclusiveN_r α x `{!Exclusive x} y : ✓{α} (y ⋅ x) → False.
Proof. rewrite comm. by apply exclusiveN_l. Qed.
Lemma exclusive_l x `{!Exclusive x} y : ✓ (x ⋅ y) → False.
-Proof. by move /cmra_valid_validN /(_ 0) /exclusive0_l. Qed.
+Proof. by move /cmra_valid_validN /(_ zero) /exclusive0_l. Qed.
Lemma exclusive_r x `{!Exclusive x} y : ✓ (y ⋅ x) → False.
Proof. rewrite comm. by apply exclusive_l. Qed.
-Lemma exclusiveN_opM n x `{!Exclusive x} my : ✓{n} (x ⋅? my) → my = None.
+Lemma exclusiveN_opM α x `{!Exclusive x} my : ✓{α} (x ⋅? my) → my = None.
Proof. destruct my as [y|]. move=> /(exclusiveN_l _ x) []. done. Qed.
-Lemma exclusive_includedN n x `{!Exclusive x} y : x ≼{n} y → ✓{n} y → False.
+Lemma exclusive_includedN α x `{!Exclusive x} y : x ≼{α} y → ✓{α} y → False.
Proof. intros [? ->]. by apply exclusiveN_l. Qed.
Lemma exclusive_included x `{!Exclusive x} y : x ≼ y → ✓ y → False.
Proof. intros [? ->]. by apply exclusive_l. Qed.
(** ** Order *)
-Lemma cmra_included_includedN n x y : x ≼ y → x ≼{n} y.
+Lemma cmra_included_includedN α x y : x ≼ y → x ≼{α} y.
Proof. intros [z ->]. by exists z. Qed.
-Global Instance cmra_includedN_trans n : Transitive (@includedN A _ _ n).
+Global Instance cmra_includedN_trans α : Transitive (@includedN _ A _ _ α).
Proof.
intros x y z [z1 Hy] [z2 Hz]; exists (z1 â‹… z2). by rewrite assoc -Hy -Hz.
Qed.
@@ -391,21 +397,21 @@ Proof.
Qed.
Lemma cmra_valid_included x y : ✓ y → x ≼ y → ✓ x.
Proof. intros Hyv [z ?]; setoid_subst; eauto using cmra_valid_op_l. Qed.
-Lemma cmra_validN_includedN n x y : ✓{n} y → x ≼{n} y → ✓{n} x.
+Lemma cmra_validN_includedN α x y : ✓{α} y → x ≼{α} y → ✓{α} x.
Proof. intros Hyv [z ?]; ofe_subst y; eauto using cmra_validN_op_l. Qed.
-Lemma cmra_validN_included n x y : ✓{n} y → x ≼ y → ✓{n} x.
+Lemma cmra_validN_included α x y : ✓{α} y → x ≼ y → ✓{α} x.
Proof. intros Hyv [z ?]; setoid_subst; eauto using cmra_validN_op_l. Qed.
-Lemma cmra_includedN_S n x y : x ≼{S n} y → x ≼{n} y.
-Proof. by intros [z Hz]; exists z; apply dist_S. Qed.
-Lemma cmra_includedN_le n n' x y : x ≼{n} y → n' ≤ n → x ≼{n'} y.
-Proof. induction 2; auto using cmra_includedN_S. Qed.
+Lemma cmra_includedN_le α α' x y : x ≼{α} y → α' ⪯ α → x ≼{α'} y.
+Proof. by intros [z Hz] H; exists z; eapply dist_le. Qed.
+Lemma cmra_includedN_succ α x y : x ≼{succ α} y → x ≼{α} y.
+Proof. intros; eapply cmra_includedN_le; eauto with index. Qed.
-Lemma cmra_includedN_l n x y : x ≼{n} x ⋅ y.
+Lemma cmra_includedN_l α x y : x ≼{α} 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.
+Lemma cmra_includedN_r α x y : y ≼{α} x ⋅ y.
Proof. rewrite (comm op); apply cmra_includedN_l. Qed.
Lemma cmra_included_r x y : y ≼ x ⋅ y.
Proof. rewrite (comm op); apply cmra_included_l. Qed.
@@ -417,13 +423,13 @@ Proof.
destruct (cmra_pcore_mono x y cx') as (cy&->&?); auto.
exists cy; by rewrite Hcx.
Qed.
-Lemma cmra_pcore_monoN' n x y cx :
- x ≼{n} y → pcore x ≡{n}≡ Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼{n} cy.
+Lemma cmra_pcore_monoN' α x y cx :
+ x ≼{α} y → pcore x ≡{α}≡ Some cx → ∃ cy, pcore y = Some cy ∧ cx ≼{α} cy.
Proof.
intros [z Hy] (cx'&?&Hcx)%dist_Some_inv_r'.
destruct (cmra_pcore_mono x (x â‹… z) cx')
as (cy&Hxy&?); auto using cmra_included_l.
- assert (pcore y ≡{n}≡ Some cy) as (cy'&?&Hcy')%dist_Some_inv_r'.
+ assert (pcore y ≡{α}≡ Some cy) as (cy'&?&Hcy')%dist_Some_inv_r'.
{ by rewrite Hy Hxy. }
exists cy'; split; first done.
rewrite Hcx -Hcy'; auto using cmra_included_includedN.
@@ -431,28 +437,28 @@ Qed.
Lemma cmra_included_pcore x cx : pcore x = Some cx → cx ≼ x.
Proof. exists x. by rewrite cmra_pcore_l. Qed.
-Lemma cmra_monoN_l n x y z : x ≼{n} y → z ⋅ x ≼{n} z ⋅ y.
+Lemma cmra_monoN_l α x y z : x ≼{α} y → z ⋅ x ≼{α} z ⋅ y.
Proof. by intros [z1 Hz1]; exists z1; rewrite Hz1 (assoc op). Qed.
Lemma cmra_mono_l x y z : x ≼ y → z ⋅ x ≼ z ⋅ y.
Proof. by intros [z1 Hz1]; exists z1; rewrite Hz1 (assoc op). Qed.
-Lemma cmra_monoN_r n x y z : x ≼{n} y → x ⋅ z ≼{n} y ⋅ z.
+Lemma cmra_monoN_r α x y z : x ≼{α} y → x ⋅ z ≼{α} y ⋅ z.
Proof. by intros; rewrite -!(comm _ z); apply cmra_monoN_l. Qed.
Lemma cmra_mono_r x y z : x ≼ y → x ⋅ z ≼ y ⋅ z.
Proof. by intros; rewrite -!(comm _ z); apply cmra_mono_l. Qed.
-Lemma cmra_monoN n x1 x2 y1 y2 : x1 ≼{n} y1 → x2 ≼{n} y2 → x1 ⋅ x2 ≼{n} y1 ⋅ y2.
+Lemma cmra_monoN α x1 x2 y1 y2 : x1 ≼{α} y1 → x2 ≼{α} y2 → x1 ⋅ x2 ≼{α} y1 ⋅ y2.
Proof. intros; etrans; eauto using cmra_monoN_l, cmra_monoN_r. Qed.
Lemma cmra_mono x1 x2 y1 y2 : x1 ≼ y1 → x2 ≼ y2 → x1 ⋅ x2 ≼ y1 ⋅ y2.
Proof. intros; etrans; eauto using cmra_mono_l, cmra_mono_r. Qed.
-Global Instance cmra_monoN' n :
- Proper (includedN n ==> includedN n ==> includedN n) (@op A _).
+Global Instance cmra_monoN' α :
+ Proper (includedN α ==> includedN α ==> includedN α) (@op A _).
Proof. intros x1 x2 Hx y1 y2 Hy. by apply cmra_monoN. Qed.
Global Instance cmra_mono' :
Proper (included ==> included ==> included) (@op A _).
Proof. intros x1 x2 Hx y1 y2 Hy. by apply cmra_mono. Qed.
-Lemma cmra_included_dist_l n x1 x2 x1' :
- x1 ≼ x2 → x1' ≡{n}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{n}≡ x2.
+Lemma cmra_included_dist_l α x1 x2 x1' :
+ x1 ≼ x2 → x1' ≡{α}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{α}≡ x2.
Proof.
intros [z Hx2] Hx1; exists (x1' â‹… z); split; auto using cmra_included_l.
by rewrite Hx1 Hx2.
@@ -474,7 +480,7 @@ Qed.
(** ** Total core *)
Section total_core.
Local Set Default Proof Using "Type*".
- Context `{CmraTotal A}.
+ Context `{CmraTotal I A}.
Lemma cmra_pcore_core x : pcore x = Some (core x).
Proof.
@@ -497,7 +503,7 @@ Section total_core.
Global Instance cmra_core_ne : NonExpansive (@core A _).
Proof.
- intros n x y Hxy. destruct (cmra_total x) as [cx Hcx].
+ intros α x y Hxy. destruct (cmra_total x) as [cx Hcx].
by rewrite /core /= -Hxy Hcx.
Qed.
Global Instance cmra_core_proper : Proper ((≡) ==> (≡)) (@core A _).
@@ -507,7 +513,7 @@ Section total_core.
Proof. by rewrite (comm _ x) cmra_core_l. Qed.
Lemma cmra_core_dup x : core x ≡ core x ⋅ core x.
Proof. by rewrite -{3}(cmra_core_idemp x) cmra_core_r. Qed.
- Lemma cmra_core_validN n x : ✓{n} x → ✓{n} core x.
+ Lemma cmra_core_validN α x : ✓{α} x → ✓{α} core x.
Proof. rewrite -{1}(cmra_core_l x); apply cmra_validN_op_l. Qed.
Lemma cmra_core_valid x : ✓ x → ✓ core x.
Proof. rewrite -{1}(cmra_core_l x); apply cmra_valid_op_l. Qed.
@@ -529,7 +535,7 @@ Section total_core.
Lemma cmra_included_core x : core x ≼ x.
Proof. by exists x; rewrite cmra_core_l. Qed.
- Global Instance cmra_includedN_preorder n : PreOrder (@includedN A _ _ n).
+ Global Instance cmra_includedN_preorder α : PreOrder (@includedN I A _ _ α).
Proof.
split; [|apply _]. by intros x; exists (core x); rewrite cmra_core_r.
Qed.
@@ -537,7 +543,7 @@ Section total_core.
Proof.
split; [|apply _]. by intros x; exists (core x); rewrite cmra_core_r.
Qed.
- Lemma cmra_core_monoN n x y : x ≼{n} y → core x ≼{n} core y.
+ Lemma cmra_core_monoN α x y : x ≼{α} y → core x ≼{α} core y.
Proof.
intros [z ->].
apply cmra_included_includedN, cmra_core_mono, cmra_included_l.
@@ -545,75 +551,75 @@ Section total_core.
End total_core.
(** ** Discrete *)
-Lemma cmra_discrete_included_l x y : Discrete x → ✓{0} y → x ≼{0} y → x ≼ y.
+Lemma cmra_discrete_included_l x y : Discrete x → ✓{zero} y → x ≼{zero} y → x ≼ y.
Proof.
intros ?? [x' ?].
- destruct (cmra_extend 0 y x x') as (z&z'&Hy&Hz&Hz'); auto; simpl in *.
+ destruct (cmra_extend zero y x x') as (z&z'&Hy&Hz&Hz'); auto; simpl in *.
by exists z'; rewrite Hy (discrete x z).
Qed.
-Lemma cmra_discrete_included_r x y : Discrete y → x ≼{0} y → x ≼ y.
+Lemma cmra_discrete_included_r x y : Discrete y → x ≼{zero} y → x ≼ y.
Proof. intros ? [x' ?]. exists x'. by apply (discrete y). Qed.
Lemma cmra_op_discrete x1 x2 :
✓ (x1 ⋅ x2) → Discrete x1 → Discrete x2 → Discrete (x1 ⋅ x2).
Proof.
intros ??? z Hz.
- destruct (cmra_extend 0 z x1 x2) as (y1&y2&Hz'&?&?); auto; simpl in *.
+ destruct (cmra_extend zero z x1 x2) as (y1&y2&Hz'&?&?); auto; simpl in *.
{ rewrite -?Hz. by apply cmra_valid_validN. }
by rewrite Hz' (discrete x1 y1) // (discrete x2 y2).
Qed.
(** ** Discrete *)
-Lemma cmra_discrete_valid_iff `{CmraDiscrete A} n x : ✓ x ↔ ✓{n} x.
+Lemma cmra_discrete_valid_iff `{CmraDiscrete I A} α x : ✓ x ↔ ✓{α} x.
Proof.
split; first by rewrite cmra_valid_validN.
- eauto using cmra_discrete_valid, cmra_validN_le with lia.
+ eauto using cmra_discrete_valid, cmra_validN_le, index_zero_minimum.
Qed.
-Lemma cmra_discrete_valid_iff_0 `{CmraDiscrete A} n x : ✓{0} x ↔ ✓{n} x.
+Lemma cmra_discrete_valid_iff_0 `{CmraDiscrete I A} α x : ✓{zero} x ↔ ✓{α} x.
Proof. by rewrite -!cmra_discrete_valid_iff. Qed.
-Lemma cmra_discrete_included_iff `{OfeDiscrete A} n x y : x ≼ y ↔ x ≼{n} y.
+Lemma cmra_discrete_included_iff `{OfeDiscrete I A} α x y : x ≼ y ↔ x ≼{α} y.
Proof.
split; first by apply cmra_included_includedN.
intros [z ->%(discrete_iff _ _)]; eauto using cmra_included_l.
Qed.
-Lemma cmra_discrete_included_iff_0 `{OfeDiscrete A} n x y : x ≼{0} y ↔ x ≼{n} y.
+Lemma cmra_discrete_included_iff_0 `{OfeDiscrete I A} α x y : x ≼{zero} y ↔ x ≼{α} y.
Proof. by rewrite -!cmra_discrete_included_iff. Qed.
(** Cancelable elements *)
-Global Instance cancelable_proper : Proper (equiv ==> iff) (@Cancelable A).
+Global Instance cancelable_proper : Proper (equiv ==> iff) (@Cancelable I A).
Proof. unfold Cancelable. intros x x' EQ. by setoid_rewrite EQ. Qed.
Lemma cancelable x `{!Cancelable x} y z : ✓(x ⋅ y) → x ⋅ y ≡ x ⋅ z → y ≡ z.
Proof. rewrite !equiv_dist cmra_valid_validN. intros. by apply (cancelableN x). Qed.
-Lemma discrete_cancelable x `{CmraDiscrete A}:
+Lemma discrete_cancelable x `{CmraDiscrete I A}:
(∀ y z, ✓(x ⋅ y) → x ⋅ y ≡ x ⋅ z → y ≡ z) → Cancelable x.
Proof. intros ????. rewrite -!discrete_iff -cmra_discrete_valid_iff. auto. Qed.
Global Instance cancelable_op x y :
Cancelable x → Cancelable y → Cancelable (x ⋅ y).
Proof.
- intros ?? n z z' ??. apply (cancelableN y), (cancelableN x).
+ intros ?? α z z' ??. apply (cancelableN y), (cancelableN x).
- eapply cmra_validN_op_r. by rewrite assoc.
- by rewrite assoc.
- by rewrite !assoc.
Qed.
Global Instance exclusive_cancelable (x : A) : Exclusive x → Cancelable x.
-Proof. intros ? n z z' []%(exclusiveN_l _ x). Qed.
+Proof. intros ? α z z' []%(exclusiveN_l _ x). Qed.
(** Id-free elements *)
-Global Instance id_free_ne n : Proper (dist n ==> iff) (@IdFree A).
+Global Instance id_free_ne α : Proper (dist α ==> iff) (@IdFree I A).
Proof.
- intros x x' EQ%(dist_le _ 0); last lia. rewrite /IdFree.
+ intros x x' EQ%(dist_le _ zero); eauto using index_zero_minimum. rewrite /IdFree.
split=> y ?; (rewrite -EQ || rewrite EQ); eauto.
Qed.
-Global Instance id_free_proper : Proper (equiv ==> iff) (@IdFree A).
-Proof. by move=> P Q /equiv_dist /(_ 0)=> ->. Qed.
-Lemma id_freeN_r n n' x `{!IdFree x} y : ✓{n}x → x ⋅ y ≡{n'}≡ x → False.
-Proof. eauto using cmra_validN_le, dist_le with lia. Qed.
-Lemma id_freeN_l n n' x `{!IdFree x} y : ✓{n}x → y ⋅ x ≡{n'}≡ x → False.
+Global Instance id_free_proper : Proper (equiv ==> iff) (@IdFree I A).
+Proof. by move=> P Q /equiv_dist /(_ zero)=> ->. Qed.
+Lemma id_freeN_r α n' x `{!IdFree x} y : ✓{α}x → x ⋅ y ≡{n'}≡ x → False.
+Proof. eauto using cmra_validN_le, dist_le, index_zero_minimum. Qed.
+Lemma id_freeN_l α n' x `{!IdFree x} y : ✓{α}x → y ⋅ x ≡{n'}≡ x → False.
Proof. rewrite comm. eauto using id_freeN_r. Qed.
Lemma id_free_r x `{!IdFree x} y : ✓x → x ⋅ y ≡ x → False.
Proof. move=> /cmra_valid_validN ? /equiv_dist. eauto. Qed.
Lemma id_free_l x `{!IdFree x} y : ✓x → y ⋅ x ≡ x → False.
Proof. rewrite comm. eauto using id_free_r. Qed.
-Lemma discrete_id_free x `{CmraDiscrete A}:
+Lemma discrete_id_free x `{CmraDiscrete I A}:
(∀ y, ✓ x → x ⋅ y ≡ x → False) → IdFree x.
Proof.
intros Hx y ??. apply (Hx y), (discrete _); eauto using cmra_discrete_valid.
@@ -626,17 +632,17 @@ Qed.
Global Instance id_free_op_l x y : IdFree x → Cancelable y → IdFree (x ⋅ y).
Proof. intros. rewrite comm. apply _. Qed.
Global Instance exclusive_id_free x : Exclusive x → IdFree x.
-Proof. intros ? z ? Hid. apply (exclusiveN_l 0 x z). by rewrite Hid. Qed.
+Proof. intros ? z ? Hid. apply (exclusiveN_l zero x z). by rewrite Hid. Qed.
End cmra.
(** * Properties about CMRAs with a unit element **)
Section ucmra.
- Context {A : ucmraT}.
+ Context {I: indexT} {A : ucmraT I}.
Implicit Types x y z : A.
- Lemma ucmra_unit_validN n : ✓{n} (ε:A).
+ Lemma ucmra_unit_validN α : ✓{α} (ε:A).
Proof. apply cmra_valid_validN, ucmra_unit_valid. Qed.
- Lemma ucmra_unit_leastN n x : ε ≼{n} x.
+ Lemma ucmra_unit_leastN α x : ε ≼{α} x.
Proof. by exists x; rewrite left_id. Qed.
Lemma ucmra_unit_least x : ε ≼ x.
Proof. by exists x; rewrite left_id. Qed.
@@ -662,7 +668,7 @@ Hint Immediate cmra_unit_cmra_total : core.
(** * Properties about CMRAs with Leibniz equality *)
Section cmra_leibniz.
Local Set Default Proof Using "Type*".
- Context {A : cmraT} `{!LeibnizEquiv A}.
+ Context {I: indexT} {A : cmraT I} `{!LeibnizEquiv A}.
Implicit Types x y : A.
Global Instance cmra_assoc_L : Assoc (=) (@op A _).
@@ -690,7 +696,7 @@ Section cmra_leibniz.
(** ** Total core *)
Section total_core.
- Context `{CmraTotal A}.
+ Context `{CmraTotal I A}.
Lemma cmra_core_r_L x : x â‹… core x = x.
Proof. unfold_leibniz. apply cmra_core_r. Qed.
@@ -709,7 +715,7 @@ End cmra_leibniz.
Section ucmra_leibniz.
Local Set Default Proof Using "Type*".
- Context {A : ucmraT} `{!LeibnizEquiv A}.
+ Context {I: indexT} {A : ucmraT I} `{!LeibnizEquiv A}.
Implicit Types x y z : A.
Global Instance ucmra_unit_left_id_L : LeftId (=) ε (@op A _).
@@ -720,26 +726,26 @@ End ucmra_leibniz.
(** * Constructing a CMRA with total core *)
Section cmra_total.
- Context A `{Dist A, Equiv A, PCore A, Op A, Valid A, ValidN A}.
+ Context A {I: indexT} `{Dist I A, Equiv A, PCore A, Op A, Valid A, ValidN I A}.
Context (total : ∀ x : A, is_Some (pcore x)).
Context (op_ne : ∀ x : A, NonExpansive (op x)).
Context (core_ne : NonExpansive (@core A _)).
- Context (validN_ne : ∀ n, Proper (dist n ==> impl) (@validN A _ n)).
- Context (valid_validN : ∀ (x : A), ✓ x ↔ ∀ n, ✓{n} x).
- Context (validN_S : ∀ n (x : A), ✓{S n} x → ✓{n} x).
+ Context (validN_ne : ∀ α, Proper (dist α ==> impl) (@validN I A _ α)).
+ Context (valid_validN : ∀ (x : A), ✓ x ↔ ∀ α, ✓{α} x).
+ Context (validN_downward : ∀ α β (x : A), ✓{α} x → β ⪯ α → ✓{β} x).
Context (op_assoc : Assoc (≡) (@op A _)).
Context (op_comm : Comm (≡) (@op A _)).
Context (core_l : ∀ x : A, core x ⋅ x ≡ x).
Context (core_idemp : ∀ x : A, core (core x) ≡ core x).
Context (core_mono : ∀ x y : A, x ≼ y → core x ≼ core y).
- Context (validN_op_l : ∀ n (x y : A), ✓{n} (x ⋅ y) → ✓{n} x).
- Context (extend : ∀ n (x y1 y2 : A),
- ✓{n} x → x ≡{n}≡ y1 ⋅ y2 →
- { z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{n}≡ y1 ∧ z2 ≡{n}≡ y2 } }).
- Lemma cmra_total_mixin : CmraMixin A.
+ Context (validN_op_l : ∀ α (x y : A), ✓{α} (x ⋅ y) → ✓{α} x).
+ Context (extend : ∀ α (x y1 y2 : A),
+ ✓{α} x → x ≡{α}≡ y1 ⋅ y2 →
+ { z1 : A & { z2 | x ≡ z1 ⋅ z2 ∧ z1 ≡{α}≡ y1 ∧ z2 ≡{α}≡ y2 } }).
+ Lemma cmra_total_mixin : CmraMixin I A.
Proof using Type*.
split; auto.
- - intros n x y ? Hcx%core_ne Hx; move: Hcx. rewrite /core /= Hx /=.
+ - intros α x y ? Hcx%core_ne Hx; move: Hcx. rewrite /core /= Hx /=.
case (total y)=> [cy ->]; eauto.
- intros x cx Hcx. move: (core_l x). by rewrite /core /= Hcx.
- intros x cx Hcx. move: (core_idemp x). rewrite /core /= Hcx /=.
@@ -750,114 +756,116 @@ Section cmra_total.
End cmra_total.
(** * Properties about morphisms *)
-Instance cmra_morphism_id {A : cmraT} : CmraMorphism (@id A).
+Instance cmra_morphism_id {I: indexT} {A : cmraT I} : CmraMorphism (@id A).
Proof. split=>//=. apply _. intros. by rewrite option_fmap_id. Qed.
-Instance cmra_morphism_proper {A B : cmraT} (f : A → B) `{!CmraMorphism f} :
+Instance cmra_morphism_proper {I: indexT} {A B : cmraT I} (f : A → B) `{!CmraMorphism f} :
Proper ((≡) ==> (≡)) f := ne_proper _.
-Instance cmra_morphism_compose {A B C : cmraT} (f : A → B) (g : B → C) :
+Instance cmra_morphism_compose {I: indexT} {A B C : cmraT I} (f : A → B) (g : B → C) :
CmraMorphism f → CmraMorphism g → CmraMorphism (g ∘ f).
Proof.
split.
- apply _.
- - move=> n x Hx /=. by apply cmra_morphism_validN, cmra_morphism_validN.
+ - move=> α x Hx /=. by apply cmra_morphism_validN, cmra_morphism_validN.
- move=> x /=. by rewrite 2!cmra_morphism_pcore option_fmap_compose.
- move=> x y /=. by rewrite !cmra_morphism_op.
Qed.
Section cmra_morphism.
Local Set Default Proof Using "Type*".
- Context {A B : cmraT} (f : A → B) `{!CmraMorphism f}.
+ Context {I: indexT} {A B : cmraT I} (f : A → B) `{!CmraMorphism f}.
Lemma cmra_morphism_core x : core (f x) ≡ f (core x).
Proof. unfold core, core'. rewrite cmra_morphism_pcore. by destruct (pcore x). Qed.
Lemma cmra_morphism_monotone x y : x ≼ y → f x ≼ f y.
Proof. intros [z ->]. exists (f z). by rewrite cmra_morphism_op. Qed.
- Lemma cmra_morphism_monotoneN n x y : x ≼{n} y → f x ≼{n} f y.
+ Lemma cmra_morphism_monotoneN α x y : x ≼{α} y → f x ≼{α} f y.
Proof. intros [z ->]. exists (f z). by rewrite cmra_morphism_op. Qed.
Lemma cmra_monotone_valid x : ✓ x → ✓ f x.
Proof. rewrite !cmra_valid_validN; eauto using cmra_morphism_validN. Qed.
End cmra_morphism.
(** Functors *)
-Record rFunctor := RFunctor {
- rFunctor_car : ∀ A `{!Cofe A} B `{!Cofe B}, cmraT;
- rFunctor_map `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
+Record rFunctor {I: indexT} := RFunctor {
+ rFunctor_car : ∀ (A: ofeT I) (B: ofeT I), cmraT I;
+ rFunctor_map {A1 A2 B1 B2} :
((A2 -n> A1) * (B1 -n> B2)) → rFunctor_car A1 B1 -n> rFunctor_car A2 B2;
- rFunctor_ne `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
- NonExpansive (@rFunctor_map A1 _ A2 _ B1 _ B2 _);
- rFunctor_id `{!Cofe A, !Cofe B} (x : rFunctor_car A B) :
+ rFunctor_ne A1 A2 B1 B2:
+ NonExpansive (@rFunctor_map A1 A2 B1 B2);
+ rFunctor_id {A B} (x : rFunctor_car A B) :
rFunctor_map (cid,cid) x ≡ x;
- rFunctor_compose `{!Cofe A1, !Cofe A2, !Cofe A3, !Cofe B1, !Cofe B2, !Cofe B3}
+ rFunctor_compose {A1 A2 A3 B1 B2 B3}
(f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x :
rFunctor_map (f◎g, g'◎f') x ≡ rFunctor_map (g,g') (rFunctor_map (f,f') x);
- rFunctor_mor `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2}
+ rFunctor_mor {A1 A2 B1 B2}
(fg : (A2 -n> A1) * (B1 -n> B2)) :
CmraMorphism (rFunctor_map fg)
}.
+Arguments rFunctor : clear implicits.
Existing Instances rFunctor_ne rFunctor_mor.
-Instance: Params (@rFunctor_map) 9 := {}.
+Instance: Params (@rFunctor_map) 6 := {}.
Delimit Scope rFunctor_scope with RF.
Bind Scope rFunctor_scope with rFunctor.
-Class rFunctorContractive (F : rFunctor) :=
- rFunctor_contractive `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :>
- Contractive (@rFunctor_map F A1 _ A2 _ B1 _ B2 _).
+Class rFunctorContractive {I: indexT} (F : rFunctor I) :=
+ rFunctor_contractive A1 A2 B1 B2 :>
+ Contractive (@rFunctor_map I F A1 A2 B1 B2).
-Definition rFunctor_diag (F: rFunctor) (A: ofeT) `{!Cofe A} : cmraT :=
+Definition rFunctor_diag {I: indexT} (F: rFunctor I) (A: ofeT I) `{!Cofe A} : cmraT I :=
rFunctor_car F A A.
Coercion rFunctor_diag : rFunctor >-> Funclass.
-Program Definition constRF (B : cmraT) : rFunctor :=
- {| rFunctor_car A1 _ A2 _ := B; rFunctor_map A1 _ A2 _ B1 _ B2 _ f := cid |}.
+Program Definition constRF {I: indexT} (B : cmraT I) : rFunctor I :=
+ {| rFunctor_car A1 A2 := B; rFunctor_map A1 A2 B1 B2 f := cid |}.
Solve Obligations with done.
Coercion constRF : cmraT >-> rFunctor.
-Instance constRF_contractive B : rFunctorContractive (constRF B).
+Instance constRF_contractive {I: indexT} (B : cmraT I): rFunctorContractive (constRF B).
Proof. rewrite /rFunctorContractive; apply _. Qed.
-Record urFunctor := URFunctor {
- urFunctor_car : ∀ A `{!Cofe A} B `{!Cofe B}, ucmraT;
- urFunctor_map `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
+Record urFunctor {I: indexT} := URFunctor {
+ urFunctor_car : ∀ A B, ucmraT I;
+ urFunctor_map {A1 A2 B1 B2}:
((A2 -n> A1) * (B1 -n> B2)) → urFunctor_car A1 B1 -n> urFunctor_car A2 B2;
- urFunctor_ne `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
- NonExpansive (@urFunctor_map A1 _ A2 _ B1 _ B2 _);
- urFunctor_id `{!Cofe A, !Cofe B} (x : urFunctor_car A B) :
+ urFunctor_ne {A1 A2 B1 B2 : ofeT I}:
+ NonExpansive (@urFunctor_map A1 A2 B1 B2);
+ urFunctor_id {A B : ofeT I} (x : urFunctor_car A B) :
urFunctor_map (cid,cid) x ≡ x;
- urFunctor_compose `{!Cofe A1, !Cofe A2, !Cofe A3, !Cofe B1, !Cofe B2, !Cofe B3}
+ urFunctor_compose {A1 A2 A3 B1 B2 B3 : ofeT I}
(f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x :
urFunctor_map (f◎g, g'◎f') x ≡ urFunctor_map (g,g') (urFunctor_map (f,f') x);
- urFunctor_mor `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2}
+ urFunctor_mor {A1 A2 B1 B2 : ofeT I}
(fg : (A2 -n> A1) * (B1 -n> B2)) :
CmraMorphism (urFunctor_map fg)
}.
+Arguments urFunctor : clear implicits.
Existing Instances urFunctor_ne urFunctor_mor.
-Instance: Params (@urFunctor_map) 9 := {}.
+Instance: Params (@urFunctor_map) 6 := {}.
Delimit Scope urFunctor_scope with URF.
Bind Scope urFunctor_scope with urFunctor.
-Class urFunctorContractive (F : urFunctor) :=
- urFunctor_contractive `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :>
- Contractive (@urFunctor_map F A1 _ A2 _ B1 _ B2 _).
+Class urFunctorContractive {I: indexT} (F : urFunctor I) :=
+ urFunctor_contractive A1 A2 B1 B2 :>
+ Contractive (@urFunctor_map I F A1 A2 B1 B2).
-Definition urFunctor_diag (F: urFunctor) (A: ofeT) `{!Cofe A} : ucmraT :=
+Definition urFunctor_diag {I: indexT} (F: urFunctor I) (A: ofeT I) `{!Cofe A} : ucmraT I :=
urFunctor_car F A A.
Coercion urFunctor_diag : urFunctor >-> Funclass.
-Program Definition constURF (B : ucmraT) : urFunctor :=
- {| urFunctor_car A1 _ A2 _ := B; urFunctor_map A1 _ A2 _ B1 _ B2 _ f := cid |}.
+Program Definition constURF {I: indexT} (B : ucmraT I) : urFunctor I :=
+ {| urFunctor_car A1 A2 := B; urFunctor_map A1 A2 B1 B2 f := cid |}.
Solve Obligations with done.
Coercion constURF : ucmraT >-> urFunctor.
-Instance constURF_contractive B : urFunctorContractive (constURF B).
+Instance constURF_contractive {I: indexT} (B: ucmraT I) : urFunctorContractive (constURF B).
Proof. rewrite /urFunctorContractive; apply _. Qed.
(** * Transporting a CMRA equality *)
-Definition cmra_transport {A B : cmraT} (H : A = B) (x : A) : B :=
+Definition cmra_transport {I: indexT} {A B : cmraT I} (H : A = B) (x : A) : B :=
eq_rect A id x _ H.
Section cmra_transport.
- Context {A B : cmraT} (H : A = B).
+ Context {I: indexT} {A B : cmraT I} (H : A = B).
Notation T := (cmra_transport H).
Global Instance cmra_transport_ne : NonExpansive T.
Proof. by intros ???; destruct H. Qed.
@@ -867,7 +875,7 @@ Section cmra_transport.
Proof. by destruct H. Qed.
Lemma cmra_transport_core x : T (core x) = core (T x).
Proof. by destruct H. Qed.
- Lemma cmra_transport_validN n x : ✓{n} T x ↔ ✓{n} x.
+ Lemma cmra_transport_validN α x : ✓{α} T x ↔ ✓{α} x.
Proof. by destruct H. Qed.
Lemma cmra_transport_valid x : ✓ T x ↔ ✓ x.
Proof. by destruct H. Qed.
@@ -897,16 +905,16 @@ Record RAMixin A `{Equiv A, PCore A, Op A, Valid A} := {
Section discrete.
Local Set Default Proof Using "Type*".
- Context `{Equiv A, PCore A, Op A, Valid A} (Heq : @Equivalence A (≡)).
+ Context {I: indexT} `{Equiv A, PCore A, Op A, Valid A} (Heq : @Equivalence A (≡)).
Context (ra_mix : RAMixin A).
Existing Instances discrete_dist.
- Instance discrete_validN : ValidN A := λ n x, ✓ x.
- Definition discrete_cmra_mixin : CmraMixin A.
+ Instance discrete_validN : ValidN I A := λ α x, ✓ x.
+ Definition discrete_cmra_mixin : CmraMixin I A.
Proof.
destruct ra_mix; split; try done.
- - intros x; split; first done. by move=> /(_ 0).
- - intros n x y1 y2 ??; by exists y1, y2.
+ - intros x; split; first done. by move=> /(_ zero).
+ - intros α x y1 y2 ??; by exists y1, y2.
Qed.
Instance discrete_cmra_discrete :
@@ -917,8 +925,8 @@ End discrete.
(** A smart constructor for the discrete RA over a carrier [A]. It uses
[ofe_discrete_equivalence_of A] to make sure the same [Equivalence] proof is
used as when constructing the OFE. *)
-Notation discreteR A ra_mix :=
- (CmraT A (discrete_cmra_mixin (discrete_ofe_equivalence_of A%type) ra_mix))
+Notation discreteR I A ra_mix :=
+ (CmraT I A (@discrete_cmra_mixin I A _ _ _ _ (discrete_ofe_equivalence_of I A%type) ra_mix))
(only parsing).
Section ra_total.
@@ -949,18 +957,19 @@ End ra_total.
(** ** CMRA for the unit type *)
Section unit.
+ Variable (I: indexT).
Instance unit_valid : Valid () := λ x, True.
- Instance unit_validN : ValidN () := λ n x, True.
+ Instance unit_validN : ValidN I () := λ α x, True.
Instance unit_pcore : PCore () := λ x, Some x.
Instance unit_op : Op () := λ x y, ().
- Lemma unit_cmra_mixin : CmraMixin ().
+ Lemma unit_cmra_mixin : @CmraMixin I () (unit_dist I) unit_equiv _ _ _ _.
Proof. apply discrete_cmra_mixin, ra_total_mixin; by eauto. Qed.
- Canonical Structure unitR : cmraT := CmraT unit unit_cmra_mixin.
+ Canonical Structure unitR : cmraT I := CmraT I unit unit_cmra_mixin.
Instance unit_unit : Unit () := ().
- Lemma unit_ucmra_mixin : UcmraMixin ().
+ Lemma unit_ucmra_mixin : @UcmraMixin I () (unit_dist I) unit_equiv _ _ _ _.
Proof. done. Qed.
- Canonical Structure unitUR : ucmraT := UcmraT unit unit_ucmra_mixin.
+ Canonical Structure unitUR : ucmraT I := UcmraT I unit unit_ucmra_mixin.
Global Instance unit_cmra_discrete : CmraDiscrete unitR.
Proof. done. Qed.
@@ -972,14 +981,15 @@ End unit.
(** ** Natural numbers *)
Section nat.
+ Variable (I: indexT).
Instance nat_valid : Valid nat := λ x, True.
- Instance nat_validN : ValidN nat := λ n x, True.
+ Instance nat_validN : ValidN I nat := λ α x, True.
Instance nat_pcore : PCore nat := λ x, Some 0.
Instance nat_op : Op nat := plus.
Definition nat_op_plus x y : x â‹… y = x + y := eq_refl.
- Lemma nat_included (x y : nat) : x ≼ y ↔ x ≤ y.
+ Lemma nat_included (x y : nat) : (x: natO I) ≼ y ↔ x ≤ y.
Proof. by rewrite nat_le_sum. Qed.
- Lemma nat_ra_mixin : RAMixin nat.
+ Lemma nat_ra_mixin : RAMixin (natO I).
Proof.
apply ra_total_mixin; try by eauto.
- solve_proper.
@@ -987,15 +997,17 @@ Section nat.
- intros x y. apply Nat.add_comm.
- by exists 0.
Qed.
- Canonical Structure natR : cmraT := discreteR nat nat_ra_mixin.
+
+ Canonical Structure natR : cmraT I := discreteR I nat nat_ra_mixin.
Global Instance nat_cmra_discrete : CmraDiscrete natR.
Proof. apply discrete_cmra_discrete. Qed.
Instance nat_unit : Unit nat := 0.
- Lemma nat_ucmra_mixin : UcmraMixin nat.
+ Lemma nat_ucmra_mixin : UcmraMixin I (natO I).
Proof. split; apply _ || done. Qed.
- Canonical Structure natUR : ucmraT := UcmraT nat nat_ucmra_mixin.
+
+ Canonical Structure natUR : ucmraT I := UcmraT I nat nat_ucmra_mixin.
Global Instance nat_cancelable (x : nat) : Cancelable x.
Proof. by intros ???? ?%Nat.add_cancel_l. Qed.
@@ -1004,19 +1016,20 @@ End nat.
Definition mnat := nat.
Section mnat.
+ Variable (I: indexT).
Instance mnat_unit : Unit mnat := 0.
Instance mnat_valid : Valid mnat := λ x, True.
- Instance mnat_validN : ValidN mnat := λ n x, True.
+ Instance mnat_validN : ValidN I mnat := λ α x, True.
Instance mnat_pcore : PCore mnat := Some.
Instance mnat_op : Op mnat := Nat.max.
Definition mnat_op_max x y : x â‹… y = x `max` y := eq_refl.
- Lemma mnat_included (x y : mnat) : x ≼ y ↔ x ≤ y.
+ Lemma mnat_included (x y : mnat) : (x: natO I) ≼ y ↔ x ≤ y.
Proof.
split.
- intros [z ->]; unfold op, mnat_op; lia.
- exists y. by symmetry; apply Nat.max_r.
Qed.
- Lemma mnat_ra_mixin : RAMixin mnat.
+ Lemma mnat_ra_mixin : RAMixin (natO I).
Proof.
apply ra_total_mixin; try by eauto.
- solve_proper.
@@ -1025,14 +1038,14 @@ Section mnat.
- intros x y. apply Nat.max_comm.
- intros x. apply Max.max_idempotent.
Qed.
- Canonical Structure mnatR : cmraT := discreteR mnat mnat_ra_mixin.
+ Canonical Structure mnatR : cmraT I := discreteR I mnat mnat_ra_mixin.
Global Instance mnat_cmra_discrete : CmraDiscrete mnatR.
Proof. apply discrete_cmra_discrete. Qed.
- Lemma mnat_ucmra_mixin : UcmraMixin mnat.
+ Lemma mnat_ucmra_mixin : UcmraMixin I (natO I).
Proof. split; apply _ || done. Qed.
- Canonical Structure mnatUR : ucmraT := UcmraT mnat mnat_ucmra_mixin.
+ Canonical Structure mnatUR : ucmraT I := UcmraT I mnat mnat_ucmra_mixin.
Global Instance mnat_core_id (x : mnat) : CoreId x.
Proof. by constructor. Qed.
@@ -1040,37 +1053,95 @@ End mnat.
(** ** Positive integers. *)
Section positive.
+ Variable (I: indexT).
Instance pos_valid : Valid positive := λ x, True.
- Instance pos_validN : ValidN positive := λ n x, True.
+ Instance pos_validN : ValidN I positive := λ α x, True.
Instance pos_pcore : PCore positive := λ x, None.
Instance pos_op : Op positive := Pos.add.
Definition pos_op_plus x y : x â‹… y = (x + y)%positive := eq_refl.
- Lemma pos_included (x y : positive) : x ≼ y ↔ (x < y)%positive.
+ Lemma pos_included (x y : positive) : (x: positiveO I) ≼ y ↔ (x < y)%positive.
Proof. by rewrite Plt_sum. Qed.
- Lemma pos_ra_mixin : RAMixin positive.
+ Lemma pos_ra_mixin : RAMixin (positiveO I).
Proof.
split; try by eauto.
- by intros ??? ->.
- intros ???. apply Pos.add_assoc.
- intros ??. apply Pos.add_comm.
Qed.
- Canonical Structure positiveR : cmraT := discreteR positive pos_ra_mixin.
+ Canonical Structure positiveR : cmraT I := discreteR I positive pos_ra_mixin.
Global Instance pos_cmra_discrete : CmraDiscrete positiveR.
Proof. apply discrete_cmra_discrete. Qed.
- Global Instance pos_cancelable (x : positive) : Cancelable x.
- Proof. intros n y z ??. by eapply Pos.add_reg_l, leibniz_equiv. Qed.
+ Global Instance pos_cancelable (x : positiveO I) : Cancelable (x: positiveO I).
+ Proof.
+ intros α y z Hv H.
+ eapply Pos.add_reg_l, (@leibniz_equiv (positiveO I)), H.
+ eapply (@leibnizO_leibniz _ I).
+ Qed.
Global Instance pos_id_free (x : positive) : IdFree x.
Proof.
intros y ??. apply (Pos.add_no_neutral x y). rewrite Pos.add_comm.
- by apply leibniz_equiv.
+ by eapply (@leibniz_equiv (positiveO I) (ofe_equiv _ (positiveO I)) _).
Qed.
End positive.
+(** Ordinals *)
+Section ordinals.
+ Context (SI : indexT).
+ Import ord_stepindex arithmetic.
+ Canonical Structure OrdO SI := leibnizO SI Ord.
+ Instance ord_valid : Valid Ord := λ x, True.
+ Instance ord_validI : ValidN SI Ord := λ α x, True.
+ Instance ord_pcore : PCore Ord := λ x, Some zero.
+ Instance ord_op : Op Ord := nadd.
+ Instance ord_inhabited : Inhabited Ord := populate zero.
+ Definition ord_op_plus (x y: Ord) : x ⋅ y = (x ⊕ y) := eq_refl.
+ Definition ord_equiv_eq (x y: Ord) : ((x: OrdO SI) ≡ y) = (x = y) := eq_refl.
+
+ Lemma ord_ra_mixin : RAMixin (OrdO SI).
+ Proof.
+ split; try by eauto.
+ - by intros ??? ->.
+ - intros ???. rewrite !ord_op_plus ord_equiv_eq; simpl.
+ by rewrite -(natural_addition_assoc).
+ - intros ??. by rewrite !ord_op_plus -natural_addition_comm.
+ - intros x cx; injection 1 as <-. by rewrite ord_op_plus natural_addition_zero_left_id.
+ - intros x cx; by injection 1 as <-.
+ - intros x y cx Hleq; injection 1 as <-.
+ exists zero; split; eauto.
+ exists zero. by rewrite !ord_op_plus natural_addition_zero_left_id.
+ Qed.
+
+ Canonical Structure OrdR : cmraT SI := discreteR SI Ord ord_ra_mixin.
+
+ Global Instance ord_cmra_discrete : CmraDiscrete OrdR.
+ Proof. apply discrete_cmra_discrete. Qed.
+
+ Global Instance ord_cancelable (x : OrdO SI) : Cancelable (x: OrdO SI).
+ Proof.
+ intros α y z Hv H. eapply natural_addition_cancel.
+ rewrite natural_addition_comm [z ⊕ _]natural_addition_comm.
+ by apply H.
+ Qed.
+
+ Instance ord_zero_left_id: LeftId eq zero nadd.
+ Proof.
+ intros ?. by rewrite natural_addition_zero_left_id.
+ Qed.
+
+ Instance ord_unit : Unit Ord := zero.
+ Lemma ord_ucmra_mixin : UcmraMixin SI (OrdO SI).
+ Proof.
+ split; apply _ || done.
+ Qed.
+
+ Canonical Structure OrdUR : ucmraT SI := UcmraT SI Ord ord_ucmra_mixin.
+End ordinals.
+
(** ** Product *)
Section prod.
- Context {A B : cmraT}.
+ Context {I: indexT} {A B : cmraT I}.
Local Arguments pcore _ _ !_ /.
Local Arguments cmra_pcore _ !_/.
@@ -1079,7 +1150,7 @@ Section prod.
c1 ↠pcore (x.1); c2 ↠pcore (x.2); Some (c1, c2).
Arguments prod_pcore !_ /.
Instance prod_valid : Valid (A * B) := λ x, ✓ x.1 ∧ ✓ x.2.
- Instance prod_validN : ValidN (A * B) := λ n x, ✓{n} x.1 ∧ ✓{n} x.2.
+ Instance prod_validN : ValidN I (A * B) := λ α x, ✓{α} x.1 ∧ ✓{α} x.2.
Lemma prod_pcore_Some (x cx : A * B) :
pcore x = Some cx ↔ pcore (x.1) = Some (cx.1) ∧ pcore (x.2) = Some (cx.2).
@@ -1098,25 +1169,25 @@ Section prod.
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.
+ Lemma prod_includedN (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.
- Definition prod_cmra_mixin : CmraMixin (A * B).
+ Definition prod_cmra_mixin : CmraMixin I (A * B).
Proof.
split; try apply _.
- - by intros n x y1 y2 [Hy1 Hy2]; split; rewrite /= ?Hy1 ?Hy2.
- - intros n x y cx; setoid_rewrite prod_pcore_Some=> -[??] [??].
- destruct (cmra_pcore_ne n (x.1) (y.1) (cx.1)) as (z1&->&?); auto.
- destruct (cmra_pcore_ne n (x.2) (y.2) (cx.2)) as (z2&->&?); auto.
+ - by intros α x y1 y2 [Hy1 Hy2]; split; rewrite /= ?Hy1 ?Hy2.
+ - intros α x y cx; setoid_rewrite prod_pcore_Some=> -[??] [??].
+ destruct (cmra_pcore_ne α (x.1) (y.1) (cx.1)) as (z1&->&?); auto.
+ destruct (cmra_pcore_ne α (x.2) (y.2) (cx.2)) as (z2&->&?); auto.
exists (z1,z2); repeat constructor; auto.
- - by intros n y1 y2 [Hy1 Hy2] [??]; split; rewrite /= -?Hy1 -?Hy2.
+ - by intros α y1 y2 [Hy1 Hy2] [??]; split; rewrite /= -?Hy1 -?Hy2.
- intros x; split.
+ intros [??] n; split; by apply cmra_valid_validN.
+ intros Hxy; split; apply cmra_valid_validN=> n; apply Hxy.
- - by intros n x [??]; split; apply cmra_validN_S.
+ - intros α β x [??]; split; eapply cmra_validN_downward; eauto.
- by split; rewrite /= assoc.
- by split; rewrite /= comm.
- intros x y [??]%prod_pcore_Some;
@@ -1127,13 +1198,13 @@ Section prod.
destruct (cmra_pcore_mono (x.1) (y.1) (cx.1)) as (z1&?&?); auto.
destruct (cmra_pcore_mono (x.2) (y.2) (cx.2)) as (z2&?&?); auto.
exists (z1,z2). by rewrite prod_included prod_pcore_Some.
- - intros n x y [??]; split; simpl in *; eauto using cmra_validN_op_l.
- - intros n x y1 y2 [??] [??]; simpl in *.
- destruct (cmra_extend n (x.1) (y1.1) (y2.1)) as (z11&z12&?&?&?); auto.
- destruct (cmra_extend n (x.2) (y1.2) (y2.2)) as (z21&z22&?&?&?); auto.
+ - intros α x y [??]; split; simpl in *; eauto using cmra_validN_op_l.
+ - intros α x y1 y2 [??] [??]; simpl in *.
+ destruct (cmra_extend α (x.1) (y1.1) (y2.1)) as (z11&z12&?&?&?); auto.
+ destruct (cmra_extend α (x.2) (y1.2) (y2.2)) as (z21&z22&?&?&?); auto.
by exists (z11,z21), (z12,z22).
Qed.
- Canonical Structure prodR := CmraT (prod A B) prod_cmra_mixin.
+ Canonical Structure prodR := CmraT I (prod A B) prod_cmra_mixin.
Lemma pair_op (a a' : A) (b b' : B) : (a, b) â‹… (a', b') = (a â‹… a', b â‹… b').
Proof. done. Qed.
@@ -1176,20 +1247,20 @@ Section prod.
Proof. move=>? [??] [_ ?] [_ /=?]. eauto. Qed.
End prod.
-Arguments prodR : clear implicits.
+Arguments prodR {_} _ _.
Section prod_unit.
- Context {A B : ucmraT}.
+ Context {I: indexT} {A B : ucmraT I}.
Instance prod_unit `{Unit A, Unit B} : Unit (A * B) := (ε, ε).
- Lemma prod_ucmra_mixin : UcmraMixin (A * B).
+ Lemma prod_ucmra_mixin : UcmraMixin I (A * B).
Proof.
split.
- split; apply ucmra_unit_valid.
- by split; rewrite /=left_id.
- rewrite prod_pcore_Some'; split; apply (core_id _).
Qed.
- Canonical Structure prodUR := UcmraT (prod A B) prod_ucmra_mixin.
+ Canonical Structure prodUR := UcmraT I (prod A B) prod_ucmra_mixin.
Lemma pair_split (x : A) (y : B) : (x, y) ≡ (x, ε) ⋅ (ε, y).
Proof. by rewrite pair_op left_id right_id. Qed.
@@ -1199,72 +1270,72 @@ Section prod_unit.
Proof. unfold_leibniz. apply pair_split. Qed.
End prod_unit.
-Arguments prodUR : clear implicits.
+Arguments prodUR {_} _ _.
-Instance prod_map_cmra_morphism {A A' B B' : cmraT} (f : A → A') (g : B → B') :
+Instance prod_map_cmra_morphism {I: indexT} {A A' B B' : cmraT I} (f : A → A') (g : B → B') :
CmraMorphism f → CmraMorphism g → CmraMorphism (prod_map f g).
Proof.
split; first apply _.
- - by intros n x [??]; split; simpl; apply cmra_morphism_validN.
- - intros x. etrans. apply (reflexivity (mbind _ _)).
- etrans; last apply (reflexivity (_ <$> mbind _ _)). simpl.
+ - by intros α x [??]; split; simpl; apply cmra_morphism_validN.
+ - intros x. transitivity (c1 ↠pcore (f x.1); c2 ↠pcore (g x.2); Some (c1, c2)); [reflexivity|].
+ transitivity (prod_map f g <$> (c1 ↠pcore (x.1); c2 ↠pcore (x.2); Some (c1, c2))); [|reflexivity].
assert (Hf := cmra_morphism_pcore f (x.1)).
- destruct (pcore (f (x.1))), (pcore (x.1)); inversion_clear Hf=>//=.
assert (Hg := cmra_morphism_pcore g (x.2)).
+ destruct (pcore (f (x.1))), (pcore (x.1)); inversion_clear Hf=>//=.
destruct (pcore (g (x.2))), (pcore (x.2)); inversion_clear Hg=>//=.
by setoid_subst.
- intros. by rewrite /prod_map /= -!cmra_morphism_op.
Qed.
-Program Definition prodRF (F1 F2 : rFunctor) : rFunctor := {|
- rFunctor_car A _ B _ := prodR (rFunctor_car F1 A B) (rFunctor_car F2 A B);
- rFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
+Program Definition prodRF {I: indexT} (F1 F2 : rFunctor I) : rFunctor I := {|
+ rFunctor_car A B := prodR (rFunctor_car F1 A B) (rFunctor_car F2 A B);
+ rFunctor_map A1 A2 B1 B2 fg :=
prodO_map (rFunctor_map F1 fg) (rFunctor_map F2 fg)
|}.
Next Obligation.
- intros F1 F2 A1 ? A2 ? B1 ? B2 ? n ???. by apply prodO_map_ne; apply rFunctor_ne.
+ intros I F1 F2 A1 A2 B1 B2 α ???. by apply prodO_map_ne; apply rFunctor_ne.
Qed.
-Next Obligation. by intros F1 F2 A ? B ? [??]; rewrite /= !rFunctor_id. Qed.
+Next Obligation. by intros I F1 F2 A B [??]; rewrite /= !rFunctor_id. Qed.
Next Obligation.
- intros F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [??]; simpl.
+ intros I F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [??]; simpl.
by rewrite !rFunctor_compose.
Qed.
Notation "F1 * F2" := (prodRF F1%RF F2%RF) : rFunctor_scope.
-Instance prodRF_contractive F1 F2 :
+Instance prodRF_contractive {I: indexT} (F1 F2 : rFunctor I):
rFunctorContractive F1 → rFunctorContractive F2 →
rFunctorContractive (prodRF F1 F2).
Proof.
- intros ?? A1 ? A2 ? B1 ? B2 ? n ???;
+ intros ?? A1 A2 B1 B2 α ???;
by apply prodO_map_ne; apply rFunctor_contractive.
Qed.
-Program Definition prodURF (F1 F2 : urFunctor) : urFunctor := {|
- urFunctor_car A _ B _ := prodUR (urFunctor_car F1 A B) (urFunctor_car F2 A B);
- urFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
+Program Definition prodURF {I} (F1 F2 : urFunctor I) : urFunctor I := {|
+ urFunctor_car A B := prodUR (urFunctor_car F1 A B) (urFunctor_car F2 A B);
+ urFunctor_map A1 A2 B1 B2 fg :=
prodO_map (urFunctor_map F1 fg) (urFunctor_map F2 fg)
|}.
Next Obligation.
- intros F1 F2 A1 ? A2 ? B1 ? B2 ? n ???. by apply prodO_map_ne; apply urFunctor_ne.
+ intros I F1 F2 A1 A2 B1 B2 α ???. by apply prodO_map_ne; apply urFunctor_ne.
Qed.
-Next Obligation. by intros F1 F2 A ? B ? [??]; rewrite /= !urFunctor_id. Qed.
+Next Obligation. by intros I F1 F2 A B [??]; rewrite /= !urFunctor_id. Qed.
Next Obligation.
- intros F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [??]; simpl.
+ intros I F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [??]; simpl.
by rewrite !urFunctor_compose.
Qed.
Notation "F1 * F2" := (prodURF F1%URF F2%URF) : urFunctor_scope.
-Instance prodURF_contractive F1 F2 :
+Instance prodURF_contractive {I} (F1 F2 : urFunctor I):
urFunctorContractive F1 → urFunctorContractive F2 →
urFunctorContractive (prodURF F1 F2).
Proof.
- intros ?? A1 ? A2 ? B1 ? B2 ? n ???;
+ intros ?? A1 A2 B1 B2 α ???;
by apply prodO_map_ne; apply urFunctor_contractive.
Qed.
(** ** CMRA for the option type *)
Section option.
- Context {A : cmraT}.
+ Context {I: indexT} {A : cmraT I}.
Implicit Types a b : A.
Implicit Types ma mb : option A.
Local Arguments core _ _ !_ /.
@@ -1272,16 +1343,16 @@ Section option.
Instance option_valid : Valid (option A) := λ ma,
match ma with Some a => ✓ a | None => True end.
- Instance option_validN : ValidN (option A) := λ n ma,
- match ma with Some a => ✓{n} a | None => True end.
+ Instance option_validN : ValidN I (option A) := λ α ma,
+ match ma with Some a => ✓{α} a | None => True end.
Instance option_pcore : PCore (option A) := λ ma, Some (ma ≫= pcore).
Arguments option_pcore !_ /.
Instance option_op : Op (option A) := union_with (λ a b, Some (a ⋅ b)).
Definition Some_valid a : ✓ Some a ↔ ✓ a := reflexivity _.
- Definition Some_validN a n : ✓{n} Some a ↔ ✓{n} a := reflexivity _.
+ Definition Some_validN a α : ✓{α} Some a ↔ ✓{α} a := reflexivity _.
Definition Some_op a b : Some (a â‹… b) = Some a â‹… Some b := eq_refl.
- Lemma Some_core `{CmraTotal A} a : Some (core a) = core (Some a).
+ Lemma Some_core `{CmraTotal I A} a : Some (core a) = core (Some a).
Proof. rewrite /core /=. by destruct (cmra_total a) as [? ->]. Qed.
Lemma Some_op_opM a ma : Some a â‹… ma = Some (a â‹…? ma).
Proof. by destruct ma. Qed.
@@ -1301,8 +1372,8 @@ Section option.
+ exists (Some c); by constructor.
Qed.
- Lemma option_includedN n ma mb :
- ma ≼{n} mb ↔ ma = None ∨ ∃ x y, ma = Some x ∧ mb = Some y ∧ (x ≡{n}≡ y ∨ x ≼{n} y).
+ Lemma option_includedN α ma mb :
+ ma ≼{α} mb ↔ ma = None ∨ ∃ x y, ma = Some x ∧ mb = Some y ∧ (x ≡{α}≡ y ∨ x ≼{α} y).
Proof.
split.
- intros [mc Hmc].
@@ -1316,7 +1387,7 @@ Section option.
+ exists (Some c); by constructor.
Qed.
- Lemma option_cmra_mixin : CmraMixin (option A).
+ Lemma option_cmra_mixin : CmraMixin I (option A).
Proof.
apply cmra_total_mixin.
- eauto.
@@ -1324,7 +1395,7 @@ Section option.
- destruct 1; by ofe_subst.
- by destruct 1; rewrite /validN /option_validN //=; ofe_subst.
- intros [a|]; [apply cmra_valid_validN|done].
- - intros n [a|]; unfold validN, option_validN; eauto using cmra_validN_S.
+ - intros α β [a|]; unfold validN, option_validN; eauto using cmra_validN_downward.
- intros [a|] [b|] [c|]; constructor; rewrite ?assoc; auto.
- intros [a|] [b|]; constructor; rewrite 1?comm; auto.
- intros [a|]; simpl; auto.
@@ -1337,26 +1408,26 @@ Section option.
destruct (cmra_pcore_proper a b ca) as (?&?&?); eauto 10.
+ destruct (pcore a) as [ca|] eqn:?; eauto.
destruct (cmra_pcore_mono a b ca) as (?&?&?); eauto 10.
- - intros n [a|] [b|]; rewrite /validN /option_validN /=;
+ - intros α [a|] [b|]; rewrite /validN /option_validN /=;
eauto using cmra_validN_op_l.
- - intros n ma mb1 mb2.
+ - intros α ma mb1 mb2.
destruct ma as [a|], mb1 as [b1|], mb2 as [b2|]; intros Hx Hx';
(try by exfalso; inversion Hx'); (try (apply (inj Some) in Hx')).
- + destruct (cmra_extend n a b1 b2) as (c1&c2&?&?&?); auto.
+ + destruct (cmra_extend α a b1 b2) as (c1&c2&?&?&?); auto.
by exists (Some c1), (Some c2); repeat constructor.
+ by exists (Some a), None; repeat constructor.
+ by exists None, (Some a); repeat constructor.
+ exists None, None; repeat constructor.
Qed.
- Canonical Structure optionR := CmraT (option A) option_cmra_mixin.
+ Canonical Structure optionR := CmraT I (option A) option_cmra_mixin.
Global Instance option_cmra_discrete : CmraDiscrete A → CmraDiscrete optionR.
Proof. split; [apply _|]. by intros [a|]; [apply (cmra_discrete_valid a)|]. Qed.
Instance option_unit : Unit (option A) := None.
- Lemma option_ucmra_mixin : UcmraMixin optionR.
+ Lemma option_ucmra_mixin : UcmraMixin I optionR.
Proof. split. done. by intros []. done. Qed.
- Canonical Structure optionUR := UcmraT (option A) option_ucmra_mixin.
+ Canonical Structure optionUR := UcmraT I (option A) option_ucmra_mixin.
(** Misc *)
Lemma op_None ma mb : ma ⋅ mb = None ↔ ma = None ∧ mb = None.
@@ -1378,11 +1449,11 @@ Section option.
Global Instance option_core_id ma : (∀ x : A, CoreId x) → CoreId ma.
Proof. intros. destruct ma; apply _. Qed.
- Lemma exclusiveN_Some_l n a `{!Exclusive a} mb :
- ✓{n} (Some a ⋅ mb) → mb = None.
+ Lemma exclusiveN_Some_l α a `{!Exclusive a} mb :
+ ✓{α} (Some a ⋅ mb) → mb = None.
Proof. destruct mb. move=> /(exclusiveN_l _ a) []. done. Qed.
- Lemma exclusiveN_Some_r n a `{!Exclusive a} mb :
- ✓{n} (mb ⋅ Some a) → mb = None.
+ Lemma exclusiveN_Some_r α a `{!Exclusive a} mb :
+ ✓{α} (mb ⋅ Some a) → mb = None.
Proof. rewrite comm. by apply exclusiveN_Some_l. Qed.
Lemma exclusive_Some_l a `{!Exclusive a} mb : ✓ (Some a ⋅ mb) → mb = None.
@@ -1390,26 +1461,26 @@ Section option.
Lemma exclusive_Some_r a `{!Exclusive a} mb : ✓ (mb ⋅ Some a) → mb = None.
Proof. rewrite comm. by apply exclusive_Some_l. Qed.
- Lemma Some_includedN n a b : Some a ≼{n} Some b ↔ a ≡{n}≡ b ∨ a ≼{n} b.
+ Lemma Some_includedN α a b : Some a ≼{α} Some b ↔ a ≡{α}≡ b ∨ a ≼{α} b.
Proof. rewrite option_includedN; naive_solver. Qed.
Lemma Some_included a b : Some a ≼ Some b ↔ a ≡ b ∨ a ≼ b.
Proof. rewrite option_included; naive_solver. Qed.
Lemma Some_included_2 a b : a ≼ b → Some a ≼ Some b.
Proof. rewrite Some_included; eauto. Qed.
- Lemma Some_includedN_total `{CmraTotal A} n a b : Some a ≼{n} Some b ↔ a ≼{n} b.
+ Lemma Some_includedN_total `{CmraTotal I A} α a b : Some a ≼{α} Some b ↔ a ≼{α} b.
Proof. rewrite Some_includedN. split. by intros [->|?]. eauto. Qed.
- Lemma Some_included_total `{CmraTotal A} a b : Some a ≼ Some b ↔ a ≼ b.
+ Lemma Some_included_total `{CmraTotal I A} a b : Some a ≼ Some b ↔ a ≼ b.
Proof. rewrite Some_included. split. by intros [->|?]. eauto. Qed.
- Lemma Some_includedN_exclusive n a `{!Exclusive a} b :
- Some a ≼{n} Some b → ✓{n} b → a ≡{n}≡ b.
+ Lemma Some_includedN_exclusive α a `{!Exclusive a} b :
+ Some a ≼{α} Some b → ✓{α} b → a ≡{α}≡ b.
Proof. move=> /Some_includedN [//|/exclusive_includedN]; tauto. Qed.
Lemma Some_included_exclusive a `{!Exclusive a} b :
Some a ≼ Some b → ✓ b → a ≡ b.
Proof. move=> /Some_included [//|/exclusive_included]; tauto. Qed.
- Lemma is_Some_includedN n ma mb : ma ≼{n} mb → is_Some ma → is_Some mb.
+ Lemma is_Some_includedN α ma mb : ma ≼{α} mb → is_Some ma → is_Some mb.
Proof. rewrite -!not_eq_None_Some option_includedN. naive_solver. Qed.
Lemma is_Some_included ma mb : ma ≼ mb → is_Some ma → is_Some mb.
Proof. rewrite -!not_eq_None_Some option_included. naive_solver. Qed.
@@ -1419,10 +1490,10 @@ Section option.
Proof.
intros Hirr ?? [b|] [c|] ? EQ; inversion_clear EQ.
- constructor. by apply (cancelableN a).
- - destruct (Hirr b); [|eauto using dist_le with lia].
- by eapply (cmra_validN_op_l 0 a b), (cmra_validN_le n); last lia.
- - destruct (Hirr c); [|symmetry; eauto using dist_le with lia].
- by eapply (cmra_validN_le n); last lia.
+ - destruct (Hirr b); [|eauto using dist_le, index_zero_minimum].
+ eapply (cmra_validN_op_l zero a b), (cmra_validN_le α); eauto using index_zero_minimum.
+ - destruct (Hirr c); [|symmetry; eauto using dist_le, index_zero_minimum].
+ by eapply (cmra_validN_le α); eauto using index_zero_minimum.
- done.
Qed.
@@ -1431,36 +1502,36 @@ Section option.
Proof. destruct ma; apply _. Qed.
End option.
-Arguments optionR : clear implicits.
-Arguments optionUR : clear implicits.
+Arguments optionR {_} _.
+Arguments optionUR {_} _.
Section option_prod.
- Context {A B : cmraT}.
+ Context {I: indexT} {A B : cmraT I}.
Implicit Types a : A.
Implicit Types b : B.
- Lemma Some_pair_includedN n a1 a2 b1 b2 :
- Some (a1,b1) ≼{n} Some (a2,b2) → Some a1 ≼{n} Some a2 ∧ Some b1 ≼{n} Some b2.
+ Lemma Some_pair_includedN α a1 a2 b1 b2 :
+ Some (a1,b1) ≼{α} Some (a2,b2) → Some a1 ≼{α} Some a2 ∧ Some b1 ≼{α} Some b2.
Proof. rewrite !Some_includedN. intros [[??]|[??]%prod_includedN]; eauto. Qed.
- Lemma Some_pair_includedN_total_1 `{CmraTotal A} n a1 a2 b1 b2 :
- Some (a1,b1) ≼{n} Some (a2,b2) → a1 ≼{n} a2 ∧ Some b1 ≼{n} Some b2.
+ Lemma Some_pair_includedN_total_1 `{CmraTotal I A} α a1 a2 b1 b2 :
+ Some (a1,b1) ≼{α} Some (a2,b2) → a1 ≼{α} a2 ∧ Some b1 ≼{α} Some b2.
Proof. intros ?%Some_pair_includedN. by rewrite -(Some_includedN_total _ a1). Qed.
- Lemma Some_pair_includedN_total_2 `{CmraTotal B} n a1 a2 b1 b2 :
- Some (a1,b1) ≼{n} Some (a2,b2) → Some a1 ≼{n} Some a2 ∧ b1 ≼{n} b2.
+ Lemma Some_pair_includedN_total_2 `{CmraTotal I B} α a1 a2 b1 b2 :
+ Some (a1,b1) ≼{α} Some (a2,b2) → Some a1 ≼{α} Some a2 ∧ b1 ≼{α} b2.
Proof. intros ?%Some_pair_includedN. by rewrite -(Some_includedN_total _ b1). Qed.
Lemma Some_pair_included a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → Some a1 ≼ Some a2 ∧ Some b1 ≼ Some b2.
Proof. rewrite !Some_included. intros [[??]|[??]%prod_included]; eauto. Qed.
- Lemma Some_pair_included_total_1 `{CmraTotal A} a1 a2 b1 b2 :
+ Lemma Some_pair_included_total_1 `{CmraTotal I A} a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → a1 ≼ a2 ∧ Some b1 ≼ Some b2.
Proof. intros ?%Some_pair_included. by rewrite -(Some_included_total a1). Qed.
- Lemma Some_pair_included_total_2 `{CmraTotal B} a1 a2 b1 b2 :
+ Lemma Some_pair_included_total_2 `{CmraTotal I B} a1 a2 b1 b2 :
Some (a1,b1) ≼ Some (a2,b2) → Some a1 ≼ Some a2 ∧ b1 ≼ b2.
Proof. intros ?%Some_pair_included. by rewrite -(Some_included_total b1). Qed.
End option_prod.
-Lemma option_fmap_mono {A B : cmraT} (f : A → B) ma mb :
+Lemma option_fmap_mono {I} {A B : cmraT I} (f : A → B) ma mb :
Proper ((≡) ==> (≡)) f →
(∀ a b, a ≼ b → f a ≼ f b) →
ma ≼ mb → f <$> ma ≼ f <$> mb.
@@ -1468,68 +1539,69 @@ Proof.
intros ??. rewrite !option_included; intros [->|(a&b&->&->&?)]; naive_solver.
Qed.
-Instance option_fmap_cmra_morphism {A B : cmraT} (f: A → B) `{!CmraMorphism f} :
+Instance option_fmap_cmra_morphism {I} {A B : cmraT I} (f: A → B) `{!CmraMorphism f} :
CmraMorphism (fmap f : option A → option B).
Proof.
split; first apply _.
- - intros n [a|] ?; rewrite /cmra_validN //=. by apply (cmra_morphism_validN f).
+ - intros α [a|] ?; rewrite /cmra_validN //=. by apply (cmra_morphism_validN f).
- move=> [a|] //. by apply Some_proper, cmra_morphism_pcore.
- move=> [a|] [b|] //=. by rewrite -(cmra_morphism_op f).
Qed.
-Program Definition optionRF (F : rFunctor) : rFunctor := {|
- rFunctor_car A _ B _ := optionR (rFunctor_car F A B);
- rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := optionO_map (rFunctor_map F fg)
+Program Definition optionRF {I} (F : rFunctor I) : rFunctor I := {|
+ rFunctor_car A B := optionR (rFunctor_car F A B);
+ rFunctor_map A1 A2 B1 B2 fg := optionO_map (rFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply optionO_map_ne, rFunctor_ne.
+ by intros I F A1 A2 B1 B2 α f g Hfg; apply optionO_map_ne, rFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(option_fmap_id x).
+ intros I F A B x. rewrite /= -{2}(option_fmap_id x).
apply option_fmap_equiv_ext=>y; apply rFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -option_fmap_compose.
+ intros I F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -option_fmap_compose.
apply option_fmap_equiv_ext=>y; apply rFunctor_compose.
Qed.
-Instance optionRF_contractive F :
+Instance optionRF_contractive {I} (F: rFunctor I) :
rFunctorContractive F → rFunctorContractive (optionRF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply optionO_map_ne, rFunctor_contractive.
+ by intros ? A1 A2 B1 B2 α f g Hfg; apply optionO_map_ne, rFunctor_contractive.
Qed.
-Program Definition optionURF (F : rFunctor) : urFunctor := {|
- urFunctor_car A _ B _ := optionUR (rFunctor_car F A B);
- urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := optionO_map (rFunctor_map F fg)
+Program Definition optionURF {I} (F : rFunctor I) : urFunctor I := {|
+ urFunctor_car A B := optionUR (rFunctor_car F A B);
+ urFunctor_map A1 A2 B1 B2 fg := optionO_map (rFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply optionO_map_ne, rFunctor_ne.
+ by intros I F A1 A2 B1 B2 α f g Hfg; apply optionO_map_ne, rFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(option_fmap_id x).
+ intros I F A B x. rewrite /= -{2}(option_fmap_id x).
apply option_fmap_equiv_ext=>y; apply rFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -option_fmap_compose.
+ intros I F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -option_fmap_compose.
apply option_fmap_equiv_ext=>y; apply rFunctor_compose.
Qed.
-Instance optionURF_contractive F :
+Instance optionURF_contractive {I} (F : rFunctor I):
rFunctorContractive F → urFunctorContractive (optionURF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply optionO_map_ne, rFunctor_contractive.
+ by intros ? A1 A2 B1 B2 α f g Hfg; apply optionO_map_ne, rFunctor_contractive.
Qed.
(* Dependently-typed functions over a discrete domain *)
+
Section discrete_fun_cmra.
- Context `{B : A → ucmraT}.
+ Context {I: indexT} `{B : A → ucmraT I}.
Implicit Types f g : discrete_fun B.
Instance discrete_fun_op : Op (discrete_fun B) := λ f g x, f x ⋅ g x.
Instance discrete_fun_pcore : PCore (discrete_fun B) := λ f, Some (λ x, core (f x)).
Instance discrete_fun_valid : Valid (discrete_fun B) := λ f, ∀ x, ✓ f x.
- Instance discrete_fun_validN : ValidN (discrete_fun B) := λ n f, ∀ x, ✓{n} f x.
+ Instance discrete_fun_validN : ValidN I (discrete_fun B) := λ α f, ∀ x, ✓{α} f x.
Definition discrete_fun_lookup_op f g x : (f â‹… g) x = f x â‹… g x := eq_refl.
Definition discrete_fun_lookup_core f x : (core f) x = core (f x) := eq_refl.
@@ -1543,17 +1615,17 @@ Section discrete_fun_cmra.
intros [h ?]%finite_choice; by exists h.
Qed.
- Lemma discrete_fun_cmra_mixin : CmraMixin (discrete_fun B).
+ Lemma discrete_fun_cmra_mixin : CmraMixin I (discrete_fun B).
Proof.
apply cmra_total_mixin.
- eauto.
- - by intros n f1 f2 f3 Hf x; rewrite discrete_fun_lookup_op (Hf x).
- - by intros n f1 f2 Hf x; rewrite discrete_fun_lookup_core (Hf x).
- - by intros n f1 f2 Hf ? x; rewrite -(Hf x).
+ - by intros α f1 f2 f3 Hf x; rewrite discrete_fun_lookup_op (Hf x).
+ - by intros α f1 f2 Hf x; rewrite discrete_fun_lookup_core (Hf x).
+ - by intros α f1 f2 Hf ? x; rewrite -(Hf x).
- intros g; split.
- + intros Hg n i; apply cmra_valid_validN, Hg.
+ + intros Hg α i; apply cmra_valid_validN, Hg.
+ intros Hg i; apply cmra_valid_validN=> n; apply Hg.
- - intros n f Hf x; apply cmra_validN_S, Hf.
+ - intros α f Hf x ??; eapply cmra_validN_le; eauto.
- by intros f1 f2 f3 x; rewrite discrete_fun_lookup_op assoc.
- by intros f1 f2 x; rewrite discrete_fun_lookup_op comm.
- by intros f x; rewrite discrete_fun_lookup_op discrete_fun_lookup_core cmra_core_l.
@@ -1562,62 +1634,62 @@ Section discrete_fun_cmra.
apply (discrete_fun_included_spec_1 _ _ x), (cmra_core_mono (f1 x)) in Hf12.
rewrite !discrete_fun_lookup_core. destruct Hf12 as [? ->].
rewrite assoc -cmra_core_dup //.
- - intros n f1 f2 Hf x; apply cmra_validN_op_l with (f2 x), Hf.
- - intros n f f1 f2 Hf Hf12.
- assert (FUN := λ x, cmra_extend n (f x) (f1 x) (f2 x) (Hf x) (Hf12 x)).
+ - intros α f1 f2 Hf x; apply cmra_validN_op_l with (f2 x), Hf.
+ - intros α f f1 f2 Hf Hf12.
+ assert (FUN := λ x, cmra_extend α (f x) (f1 x) (f2 x) (Hf x) (Hf12 x)).
exists (λ x, projT1 (FUN x)), (λ x, proj1_sig (projT2 (FUN x))).
split; [|split]=>x; [rewrite discrete_fun_lookup_op| |];
by destruct (FUN x) as (?&?&?&?&?).
Qed.
- Canonical Structure discrete_funR := CmraT (discrete_fun B) discrete_fun_cmra_mixin.
+ Canonical Structure discrete_funR := CmraT I (discrete_fun B) discrete_fun_cmra_mixin.
Instance discrete_fun_unit : Unit (discrete_fun B) := λ x, ε.
Definition discrete_fun_lookup_empty x : ε x = ε := eq_refl.
- Lemma discrete_fun_ucmra_mixin : UcmraMixin (discrete_fun B).
+ Lemma discrete_fun_ucmra_mixin : UcmraMixin I (discrete_fun B).
Proof.
split.
- intros x; apply ucmra_unit_valid.
- by intros f x; rewrite discrete_fun_lookup_op left_id.
- constructor=> x. apply core_id_core, _.
Qed.
- Canonical Structure discrete_funUR := UcmraT (discrete_fun B) discrete_fun_ucmra_mixin.
+ Canonical Structure discrete_funUR := UcmraT I (discrete_fun B) discrete_fun_ucmra_mixin.
Global Instance discrete_fun_unit_discrete :
(∀ i, Discrete (ε : B i)) → Discrete (ε : discrete_fun B).
Proof. intros ? f Hf x. by apply: discrete. Qed.
End discrete_fun_cmra.
-Arguments discrete_funR {_} _.
-Arguments discrete_funUR {_} _.
+Arguments discrete_funR {_ _} _.
+Arguments discrete_funUR {_ _} _.
-Instance discrete_fun_map_cmra_morphism {A} {B1 B2 : A → ucmraT} (f : ∀ x, B1 x → B2 x) :
+Instance discrete_fun_map_cmra_morphism {I A} {B1 B2 : A → ucmraT I} (f : ∀ x, B1 x → B2 x) :
(∀ x, CmraMorphism (f x)) → CmraMorphism (discrete_fun_map f).
Proof.
split; first apply _.
- - intros n g Hg x; rewrite /discrete_fun_map; apply (cmra_morphism_validN (f _)), Hg.
+ - intros α g Hg x; rewrite /discrete_fun_map; apply (cmra_morphism_validN (f _)), Hg.
- intros. apply Some_proper=>i. apply (cmra_morphism_core (f i)).
- intros g1 g2 i. by rewrite /discrete_fun_map discrete_fun_lookup_op cmra_morphism_op.
Qed.
-Program Definition discrete_funURF {C} (F : C → urFunctor) : urFunctor := {|
- urFunctor_car A _ B _ := discrete_funUR (λ c, urFunctor_car (F c) A B);
- urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := discrete_funO_map (λ c, urFunctor_map (F c) fg)
+Program Definition discrete_funURF {I C} (F : C → urFunctor I) : urFunctor I := {|
+ urFunctor_car A B := discrete_funUR (λ c, urFunctor_car (F c) A B);
+ urFunctor_map A1 A2 B1 B2 fg := discrete_funO_map (λ c, urFunctor_map (F c) fg)
|}.
Next Obligation.
- intros C F A1 ? A2 ? B1 ? B2 ? n ?? g. by apply discrete_funO_map_ne=>?; apply urFunctor_ne.
+ intros I C F A1 A2 B1 B2 α ?? g. by apply discrete_funO_map_ne=>?; apply urFunctor_ne.
Qed.
Next Obligation.
- intros C F A ? B ? g; simpl. rewrite -{2}(discrete_fun_map_id g).
+ intros I C F A B g; simpl. rewrite -{2}(discrete_fun_map_id g).
apply discrete_fun_map_ext=> y; apply urFunctor_id.
Qed.
Next Obligation.
- intros C F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f1 f2 f1' f2' g. rewrite /=-discrete_fun_map_compose.
+ intros I C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g. rewrite /=-discrete_fun_map_compose.
apply discrete_fun_map_ext=>y; apply urFunctor_compose.
Qed.
-Instance discrete_funURF_contractive {C} (F : C → urFunctor) :
+Instance discrete_funURF_contractive {I C} (F : C → urFunctor I) :
(∀ c, urFunctorContractive (F c)) → urFunctorContractive (discrete_funURF F).
Proof.
- intros ? A1 ? A2 ? B1 ? B2 ? n ?? g.
+ intros ? A1 A2 B1 B2 α ?? g.
by apply discrete_funO_map_ne=>c; apply urFunctor_contractive.
Qed.
diff --git a/theories/algebra/cmra_big_op.v b/theories/algebra/cmra_big_op.v
deleted file mode 100644
index 6bbf5244d71c79146708ff33582370f8234cf1bf..0000000000000000000000000000000000000000
--- a/theories/algebra/cmra_big_op.v
+++ /dev/null
@@ -1,36 +0,0 @@
-From iris.algebra Require Export big_op cmra.
-From stdpp Require Import gmap gmultiset.
-Set Default Proof Using "Type*".
-
-(** Option *)
-Lemma big_opL_None {M : cmraT} {A} (f : nat → A → option M) l :
- ([^op list] k↦x ∈ l, f k x) = None ↔ ∀ k x, l !! k = Some x → f k x = None.
-Proof.
- revert f. induction l as [|x l IH]=> f //=. rewrite op_None IH. split.
- - intros [??] [|k] y ?; naive_solver.
- - intros Hl. split. by apply (Hl 0). intros k. apply (Hl (S k)).
-Qed.
-Lemma big_opM_None {M : cmraT} `{Countable K} {A} (f : K → A → option M) m :
- ([^op map] k↦x ∈ m, f k x) = None ↔ ∀ k x, m !! k = Some x → f k x = None.
-Proof.
- induction m as [|i x m ? IH] using map_ind=> //=.
- rewrite -equiv_None big_opM_insert // equiv_None op_None IH. split.
- { intros [??] k y. rewrite lookup_insert_Some; naive_solver. }
- intros Hm; split.
- - apply (Hm i). by simplify_map_eq.
- - intros k y ?. apply (Hm k). by simplify_map_eq.
-Qed.
-Lemma big_opS_None {M : cmraT} `{Countable A} (f : A → option M) X :
- ([^op set] x ∈ X, f x) = None ↔ ∀ x, x ∈ X → f x = None.
-Proof.
- induction X as [|x X ? IH] using set_ind_L; [done|].
- rewrite -equiv_None big_opS_insert // equiv_None op_None IH. set_solver.
-Qed.
-Lemma big_opMS_None {M : cmraT} `{Countable A} (f : A → option M) X :
- ([^op mset] x ∈ X, f x) = None ↔ ∀ x, x ∈ X → f x = None.
-Proof.
- induction X as [|x X IH] using gmultiset_ind.
- { rewrite big_opMS_empty. set_solver. }
- rewrite -equiv_None big_opMS_disj_union big_opMS_singleton equiv_None op_None IH.
- set_solver.
-Qed.
\ No newline at end of file
diff --git a/theories/algebra/coPset.v b/theories/algebra/coPset.v
index 326c0251dd2f0ac1123038d67b4ec2378e3695e9..eb372e58dd520c228ec2c332d9121d9f8f314f7d 100644
--- a/theories/algebra/coPset.v
+++ b/theories/algebra/coPset.v
@@ -7,9 +7,10 @@ generalize the construction without breaking canonical structures. *)
(* The union CMRA *)
Section coPset.
+ Context {SI: indexT}.
Implicit Types X Y : coPset.
- Canonical Structure coPsetO := discreteO coPset.
+ Canonical Structure coPsetO := discreteO SI coPset.
Instance coPset_valid : Valid coPset := λ _, True.
Instance coPset_unit : Unit coPset := (∅ : coPset).
@@ -37,14 +38,14 @@ Section coPset.
- intros X1 X2. by rewrite !coPset_op_union comm_L.
- intros X. by rewrite coPset_core_self idemp_L.
Qed.
- Canonical Structure coPsetR := discreteR coPset coPset_ra_mixin.
+ Canonical Structure coPsetR := discreteR SI coPset coPset_ra_mixin.
Global Instance coPset_cmra_discrete : CmraDiscrete coPsetR.
Proof. apply discrete_cmra_discrete. Qed.
- Lemma coPset_ucmra_mixin : UcmraMixin coPset.
+ Lemma coPset_ucmra_mixin : UcmraMixin SI coPset.
Proof. split. done. intros X. by rewrite coPset_op_union left_id_L. done. Qed.
- Canonical Structure coPsetUR := UcmraT coPset coPset_ucmra_mixin.
+ Canonical Structure coPsetUR := UcmraT SI coPset coPset_ucmra_mixin.
Lemma coPset_opM X mY : X ⋅? mY = X ∪ default ∅ mY.
Proof. destruct mY; by rewrite /= ?right_id_L. Qed.
@@ -60,14 +61,23 @@ Section coPset.
Qed.
End coPset.
+Arguments coPsetO : clear implicits.
+Arguments coPsetR : clear implicits.
+Arguments coPsetUR : clear implicits.
+
+
(* The disjoiny union CMRA *)
Inductive coPset_disj :=
| CoPset : coPset → coPset_disj
| CoPsetBot : coPset_disj.
+Global Instance inhabited_coPset_disj: Inhabited (coPset_disj).
+Proof. split; by constructor 2. Qed.
Section coPset_disj.
Arguments op _ _ !_ !_ /.
- Canonical Structure coPset_disjO := leibnizO coPset_disj.
+ Context {SI: indexT}.
+
+ Canonical Structure coPset_disjO := leibnizO SI coPset_disj.
Instance coPset_disj_valid : Valid coPset_disj := λ X,
match X with CoPset _ => True | CoPsetBot => False end.
@@ -110,12 +120,16 @@ Section coPset_disj.
- exists (CoPset ∅); coPset_disj_solve.
- intros [X1|] [X2|]; coPset_disj_solve.
Qed.
- Canonical Structure coPset_disjR := discreteR coPset_disj coPset_disj_ra_mixin.
+ Canonical Structure coPset_disjR := discreteR SI coPset_disj coPset_disj_ra_mixin.
Global Instance coPset_disj_cmra_discrete : CmraDiscrete coPset_disjR.
Proof. apply discrete_cmra_discrete. Qed.
- Lemma coPset_disj_ucmra_mixin : UcmraMixin coPset_disj.
+ Lemma coPset_disj_ucmra_mixin : UcmraMixin SI coPset_disj.
Proof. split; try apply _ || done. intros [X|]; coPset_disj_solve. Qed.
- Canonical Structure coPset_disjUR := UcmraT coPset_disj coPset_disj_ucmra_mixin.
+ Canonical Structure coPset_disjUR := UcmraT SI coPset_disj coPset_disj_ucmra_mixin.
End coPset_disj.
+
+Arguments coPset_disjO : clear implicits.
+Arguments coPset_disjR : clear implicits.
+Arguments coPset_disjUR : clear implicits.
diff --git a/theories/algebra/cofe_solver.v b/theories/algebra/cofe_solver.v
index eb85e390096886927603315ade17aee080ecea41..53726ee4106de0232fa09e2fb638a23b7ab5f34c 100644
--- a/theories/algebra/cofe_solver.v
+++ b/theories/algebra/cofe_solver.v
@@ -1,242 +1,3090 @@
-From iris.algebra Require Export ofe.
+From iris.algebra Require Export ofe wf_IR.
Set Default Proof Using "Type".
+Require Coq.Logic.PropExtensionality.
+Require Coq.Logic.FunctionalExtensionality.
+Require Coq.Logic.ProofIrrelevance.
-Record solution (F : oFunctor) := Solution {
- solution_car :> ofeT;
+Section cofe.
+ Context (SI : indexT).
+ (* Shorthand notation to avoid making a distinction between Cofes and ofes *)
+ Definition COFE := { C : ofeT SI & Cofe C }.
+ Global Coercion projCOFE (C: COFE) : ofeT SI := (projT1 C).
+ Global Instance COFE_cofe (C: COFE) : Cofe C := projT2 C.
+ Definition cofe (A: ofeT SI) `{C: Cofe SI A} := existT A C.
+End cofe.
+
+Definition proj_id {SI} {A B : COFE SI} (Heq : A = B) : projCOFE _ A = projCOFE _ B.
+Proof. by rewrite Heq. Qed.
+
+(* non-expansive maps commute with bounded limits only in a restricted way *)
+Lemma bounded_ne_bcompl {SI : indexT} {A B : ofeT SI} {Hc : Cofe A} {Hb : Cofe B} (f : A -n> B):
+ ∀ β (c : bchain _ β) Hβ γ (Hγ : γ ≺ β), f (bcompl Hβ c) ≡{γ}≡ bcompl Hβ (bchain_map f c).
+Proof.
+ intros β c Hβ γ Hγ.
+ etransitivity.
+ - rewrite ofe_mor_ne. 2: apply conv_bcompl. reflexivity.
+ - rewrite conv_bcompl. unfold bchain_map. cbn. reflexivity.
+ Unshelve. apply Hγ.
+Qed.
+
+Record solution {SI} (F : oFunctor SI) := Solution {
+ solution_car :> ofeT SI;
solution_cofe : Cofe solution_car;
- solution_unfold : solution_car -n> F solution_car _;
- solution_fold : F solution_car _ -n> solution_car;
+ solution_unfold : solution_car -n> F solution_car;
+ solution_fold : F 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 {_} _.
Existing Instance solution_cofe.
Module solver. Section solver.
-Context (F : oFunctor) `{Fcontr : oFunctorContractive F}.
-Context `{Fcofe : ∀ (T : ofeT) `{!Cofe T}, Cofe (F T _)}.
-Context `{Finh : Inhabited (F unitO _)}.
+Context (SI : indexT) (F : oFunctor SI) `{Fcontr : oFunctorContractive SI F}.
+Context `{Fcofe : ∀ (T1 T2 : ofeT SI), Cofe (oFunctor_car F T1 T2)}.
+Context `{Ftrunc : ∀ (T1 T2 : ofeT SI), Truncatable (oFunctor_car F T1 T2)}.
+Context `{Funique : ∀ (T1 T2 : ofeT SI), BcomplUniqueLim (oFunctor_car F T1 T2)}.
Notation map := (oFunctor_map F).
+Context (inh_Funit : F (unitO SI)).
+
+(* a version of the functor which directly integrates the Cofe instance *)
+Definition G (A: ofeT SI): COFE SI := cofe SI (F A).
+
+(** We are using proof irrelevance very much.
+ Currently, that doesn't matter much, however, as we need PE for a different reason anyways.
+ If we ever manage to kill the extensionality requirement, then it might also make sense to remove this instance
+ and see if we can prove constructively that the things which we need to be proof irrelevant are in fact irrelevant.
+*)
+Import ProofIrrelevance.
+Local Instance all_ProofIrrel (A : Prop) : ProofIrrel A.
+Proof. intros a b. apply proof_irrelevance. Qed.
+
+Lemma map_compose {A1 A2 A3 B1 B2 B3 : ofeT SI}
+ (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) :
+ map (g, g') ◎ map (f, f') ≡ map (f ◎ g, g' ◎ f').
+Proof. intros x. cbn. by setoid_rewrite <- oFunctor_compose. Qed.
+
+(* specialized version so that for dist (in principle, the previous lemma can be used, but this one is cheaper for rewriting due to TC inference *)
+Lemma map_compose_dist {A1 A2 A3 B1 B2 B3 : ofeT SI}
+ (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) α:
+ map (g, g') ◎ map (f, f') ≡{α}≡ map (f ◎ g, g' ◎ f').
+Proof. apply equiv_dist, map_compose. Qed.
+
+(* sometimes, setoid_rewrite with the above lemmas will fail for unknown reasons.
+ in these cases, we use rewrite.
+ disadvantage: we just rewrite at the first matching occurrence and rewrite is not able to
+ unify modulo β, so we have to fully instantiate & cbn first.
+*)
+Ltac map_compose_tac :=
+ match goal with
+ |- context[ofe_mor_car _ _ (map (?g0, ?g1)) (ofe_mor_car _ _ (map (?f0, ?f1)) ?x)] =>
+ let H := fresh "H" in
+ specialize (map_compose f0 g0 f1 g1 x) as H; cbn in H; rewrite H; clear H
+ end.
+
+(* somewhat costly instance which is however needed for map *)
+Local Existing Instance ne_proper_2.
+
+Ltac is_prop p :=
+ match type of p with
+ | ?Ht => match type of Ht with
+ | ?Htt => constr_eq Htt Prop
+ end
+ end.
+Ltac pi_clear := match goal with
+ | [H : (?p), H' : (?p) |- _] => is_prop H; is_prop H';
+ let Hr := fresh "H" in
+ specialize (proof_irrel H H') as Hr; subst H; try clear H' Hr
+ | [ |- context [(proof_irrel ?p ?p)]] => rewrite (proof_irrel (proof_irrel p p) eq_refl)
+ end.
+
+Ltac unify_pi H1 H2 := first
+ [ unify H1 H2
+ (* do not rewrite H1 to H2 if H1 is a subterm of H2 -- otherwise, we will fail to make H1 and H2 equal *)
+ | match H2 with context[H1] => rewrite (proof_irrel H2 H1) end
+ | rewrite (proof_irrel H1 H2) ].
-Fixpoint A' (k : nat) : { C : ofeT & Cofe C } :=
- match k with
- | 0 => existT (P:=Cofe) unitO _
- | S k => existT (P:=Cofe) (F (projT1 (A' k)) (projT2 (A' k))) _
+(* sometimes, the rewrite with trunc_map_compose doesn't work without explicitly instantiating the function arguments...
+ so we use this ugly hack to make it work in these cases *)
+Local Notation "f 'oapp' x 'opp' y" := (ofe_mor_car _ _ (ofe_mor_car _ _ f x) y) (at level 10, only parsing).
+Ltac merge_truncs :=
+ repeat match goal with
+ | |- context[(trunc_map ?a ?b) oapp ?f opp ((trunc_map ?c ?a) oapp ?g opp ?x)] =>
+ setoid_rewrite <- (dist_mono' _ _ _ _ (trunc_map_compose g f c b a _))
end.
-Notation A k := (projT1 (A' k)).
-Local Instance A_cofe k : Cofe (A k) := projT2 (A' k).
-
-Fixpoint f (k : nat) : A k -n> A (S k) :=
- match k with 0 => OfeMor (λ _, inhabitant) | S k => map (g k,f k) end
-with g (k : nat) : A (S k) -n> A k :=
- match k with 0 => OfeMor (λ _, ()) | S k => map (f k,g k) end.
-Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
-Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
-Arguments f : simpl never.
-Arguments g : simpl never.
-
-Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
+
+(** a typeclass for registering equalities between OFEs, used for the transport infrastructure *)
+(* most of the times, we give instances explicitly (as transitivity and symmetry would make life hard for TC inference), but having it as a typeclass is still sensible for a few uses *)
+Class ofe_eq (X Y : ofeT SI) := ofe_equal : X = Y.
+Hint Mode ofe_eq + + : typeclass_instances.
+Arguments ofe_eq : simpl never.
+
+(* We do not register these as instances as that would make typeclass search go south.
+ Instead, the ofe_eq hint database is used to automatically solve the obligations.
+ It is still worthwhile to have ofe_eq as a TC (not as a definition) as simple instances need not be given explicitly this way.
+*)
+Create HintDb ofe_eq.
+Lemma ofe_eq_symm {X Y} (H : ofe_eq X Y) : ofe_eq Y X.
+Proof. intros. by rewrite H. Qed.
+Lemma ofe_eq_trans {X Y Z} (H1 : ofe_eq X Y) (H2 : ofe_eq Y Z) : ofe_eq X Z.
+Proof. intros. by rewrite H1 H2. Qed.
+Lemma ofe_eq_funct {X Y : ofeT SI} {α α'} (Heq : α = α') (H : ofe_eq X Y) :
+ ofe_eq ([G X]_{α}) ([G Y]_{α'}).
+Proof. by rewrite H Heq. Qed.
+
+Hint Resolve ofe_eq_symm ofe_eq_trans ofe_eq_funct : ofe_eq.
+
+Program Definition transport_id (X Y : ofeT SI) {H : ofe_eq X Y} : X -n> Y := λne x, _ .
+Next Obligation. intros X Y Heq x. rewrite <- Heq. exact x. Defined.
+Next Obligation. intros. intros x y H1. destruct H. apply H1. Defined.
+Arguments transport_id : simpl never.
+
+(** a huge advantage of using ofe_eq with transport_id over employing full-fledged isomorphisms is that
+ the category of OFEs with transport_id arrows is thin if assuming proof irrelevance. Thus checking if
+ any two transports are equal reduces to type-checking.
+*)
+Lemma transport_id_compose (X Y Z : ofeT SI) {H1 : ofe_eq X Y} {H2 : ofe_eq Y Z} :
+ transport_id Y Z ◎ transport_id X Y ≡ @transport_id X Z (ofe_eq_trans H1 H2).
+Proof.
+ intros x; cbn. destruct H1. destruct H2.
+ by rewrite (proof_irrel (ofe_eq_trans eq_refl eq_refl) eq_refl ).
+Qed.
+
+Lemma transport_id_identity (X : ofeT SI) {H : ofe_eq X X} : @transport_id X X H ≡ cid.
+Proof. intros x; cbn. by rewrite (proof_irrel H eq_refl). Qed.
+
+Lemma transport_id_pi (X Y : ofeT SI) {H1 : ofe_eq X Y} {H2 : ofe_eq X Y}: @transport_id X Y H1 ≡ @transport_id X Y H2.
+Proof. by rewrite (proof_irrel H1 H2). Qed.
+
+(* commutation of transports with truncation/expansion *)
+Lemma transport_id_truncate (Y Z : ofeT SI) γ γ' (Heq : γ = γ') I:
+ @transport_id ([G Z]_{γ}) ([G Y]_{γ'}) (ofe_eq_funct Heq I) ◎ ofe_trunc_truncate γ
+ ≡ ofe_trunc_truncate γ' ◎ map (@transport_id Y Z (ofe_eq_symm I), transport_id Z Y).
Proof using Fcontr.
- induction k as [|k IH]; simpl in *; [by destruct x|].
- rewrite -oFunctor_compose -{2}[x]oFunctor_id. by apply (contractive_proper map).
+ destruct I. subst. rewrite !transport_id_identity.
+ intros x; cbn. by setoid_rewrite oFunctor_id.
Qed.
-Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
+
+Lemma transport_id_truncate_symm (Y Z : ofeT SI) γ γ' (Heq : γ = γ') (I : ofe_eq Y Z):
+ @transport_id ([G Z]_{γ}) ([G Y]_{γ'}) (ofe_eq_funct Heq (ofe_eq_symm I)) ◎ ofe_trunc_truncate γ
+ ≡ ofe_trunc_truncate γ' ◎ map (@transport_id Y Z I, @transport_id Z Y (ofe_eq_symm I)).
Proof using Fcontr.
- induction k as [|k IH]; simpl.
- - rewrite f_S g_S -{2}[x]oFunctor_id -oFunctor_compose.
- apply (contractive_0 map).
- - rewrite f_S g_S -{2}[x]oFunctor_id -oFunctor_compose.
- by apply (contractive_S map).
+ destruct I. subst. rewrite !transport_id_identity.
+ intros x; cbn. by setoid_rewrite oFunctor_id.
Qed.
-Record tower := {
- tower_car k :> A k;
- g_tower k : g k (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.
-Definition tower_ofe_mixin : OfeMixin 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; trans (Y n).
- - intros k X Y HXY n; apply dist_S.
- by rewrite -(g_tower X) (HXY (S n)) g_tower.
-Qed.
-Definition T : ofeT := OfeT tower tower_ofe_mixin.
-
-Program Definition tower_chain (c : chain T) (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 Definition tower_compl : Compl T := λ c,
- {| tower_car n := compl (tower_chain c n) |}.
-Next Obligation.
- intros c k; apply equiv_dist=> n.
- by rewrite (conv_compl n (tower_chain c k))
- (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
-Qed.
-Global Program Instance tower_cofe : Cofe T := { compl := tower_compl }.
-Next Obligation.
- intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
- apply (chain_cauchy c); lia.
-Qed.
-
-Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
- match i with 0 => cid | S i => f (i + k) â—Ž ff i end.
-Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
- match i with 0 => cid | S i => gg i â—Ž g (i + k) end.
-Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
-Proof using Fcontr. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
-Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
-Proof using Fcontr. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
-Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
+Lemma transport_id_truncate' (Y Z : ofeT SI) γ γ' (Heq : γ = γ') I0 I1 I2:
+ @transport_id ([G Z]_{γ}) ([G Y]_{γ'}) I0 ◎ ofe_trunc_truncate γ
+ ≡ ofe_trunc_truncate γ' ◎ map (@transport_id Y Z I1, @transport_id Z Y I2).
+Proof using Fcontr.
+ specialize (proof_irrel I0 (ofe_eq_funct Heq I2)) as H1.
+ specialize (proof_irrel I1 (ofe_eq_symm I2)) as H2.
+ subst. apply transport_id_truncate.
+Qed.
+
+Lemma transport_id_expand (Y Z : ofeT SI) γ γ' (Heq : γ' = γ) I:
+ map(@transport_id Y Z (ofe_eq_symm I), transport_id Z Y) ◎ ofe_trunc_expand γ'
+ ≡ ofe_trunc_expand γ ◎ @transport_id ([G Z]_{γ'}) ([G Y]_{γ}) (ofe_eq_funct Heq I).
+Proof using Fcontr.
+ destruct I. subst. rewrite !transport_id_identity.
+ intros x; cbn. by setoid_rewrite oFunctor_id.
+Qed.
+
+Lemma transport_id_expand_symm (Y Z : ofeT SI) γ γ' (Heq : γ' = γ) (I : ofe_eq Y Z):
+ map(@transport_id Y Z I, @transport_id Z Y (ofe_eq_symm I)) ◎ ofe_trunc_expand γ'
+ ≡ ofe_trunc_expand γ ◎ @transport_id ([G Z]_{γ'}) ([G Y]_{γ}) (ofe_eq_funct Heq (ofe_eq_symm I)).
+Proof using Fcontr.
+ destruct I. subst. rewrite !transport_id_identity.
+ intros x; cbn. by setoid_rewrite oFunctor_id.
+Qed.
+
+Lemma transport_id_expand' (Y Z : ofeT SI) γ γ' (Heq : γ' = γ) I0 I1 I2:
+ map(@transport_id Y Z I1, @transport_id Z Y I2) ◎ ofe_trunc_expand γ'
+ ≡ ofe_trunc_expand γ ◎ @transport_id ([G Z]_{γ'}) ([G Y]_{γ}) I0.
Proof using Fcontr.
- intros; induction i as [|i IH]; simpl; [done|].
- by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (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 k : NonExpansive (λ X, tower_car X k).
-Proof. by intros X Y HX. Qed.
-Definition project (k : nat) : T -n> A k := OfeMor (λ 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 j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k 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 k x) = f j (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)).
+ specialize (proof_irrel I0 (ofe_eq_funct Heq I2)) as H1.
+ specialize (proof_irrel I1 (ofe_eq_symm I2)) as H2.
+ subst. apply transport_id_expand.
+Qed.
+
+(** automation to apply transport_id_expand', transport_id_truncate' to find the right instances
+ (often setoid_rewrite isn't able to find the right way to unify) *)
+
+(* shelve a goal *)
+Ltac shelve :=
+ match goal with
+ | |- ?H => let p := fresh "p" in evar (p : H); exact p
+ end.
+
+Ltac clear_def H :=
+ generalize H; clear H; intros H.
+Ltac specialize_shelve H :=
+ let H' := fresh H in
+ refine (let H' := H ltac:(shelve) in _);
+ clear_def H'; clear H; rename H' into H.
+
+(* right to left rewrite with transport_id_truncate' *)
+Ltac transport_id_truncate_rl :=
+ match goal with
+ |- context[ofe_mor_car _ _ (ofe_trunc_truncate ?a) (ofe_mor_car _ _
+ (map (@transport_id ?A ?C ?I0, @transport_id ?B ?D ?I1)) ?x )] =>
+ unify A D; unify C B;
+ let H := fresh "H" in
+ specialize (transport_id_truncate' A C a _ eq_refl) as H; specialize_shelve H;
+ specialize (H I0 I1); setoid_rewrite <- (H x); clear H
+ end.
+(* left to right rewrite with transport_id_truncate' *)
+Ltac transport_id_truncate_lr :=
+ unshelve
+ match goal with
+ |- context[ofe_mor_car _ _ (@transport_id (@ofe_trunc_car _ _ (Ftrunc ?A ?A) ?g0) (@ofe_trunc_car _ _ (Ftrunc ?C ?C) ?g1) ?I0) (ofe_mor_car _ _ (ofe_trunc_truncate _) ?x)] =>
+ let H := fresh "H" in
+ specialize (transport_id_truncate' C A g0 g1) as H;
+ specialize_shelve H; (* shelve equality proof *)
+ specialize (H I0);
+ do 2 specialize_shelve H; (* shelve the ofe instances -- sometimes ltac:(...) will cause weird evar bugs *)
+ setoid_rewrite (H x); clear H
+ end; [eauto with ofe_eq | eauto with ofe_eq | eauto with ofe_eq | ].
+
+(* right to left rewrite with transport_id_expand' *)
+Ltac transport_id_expand_rl :=
+ unshelve
+ match goal with
+ |- context[ofe_mor_car _ _ (ofe_trunc_expand _) (ofe_mor_car _ _ (@transport_id (@ofe_trunc_car _ _ (Ftrunc ?A ?A) ?g0) (@ofe_trunc_car _ _ (Ftrunc ?B ?B) ?g1) ?I0) ?x)] =>
+ let H := fresh "H" in
+ specialize (transport_id_expand' B A g1 g0) as H;
+ specialize_shelve H; (* shelve equality *)
+ specialize (H I0);
+ do 2 specialize_shelve H;
+ setoid_rewrite <- (H x); clear H
+ end; [eauto with ofe_eq | eauto with ofe_eq | eauto with ofe_eq | ].
+
+(* left to right rewrite with transport_id_expand' *)
+Ltac transport_id_expand_lr :=
+ match goal with
+ |- context[ofe_mor_car _ _ (map (@transport_id ?A ?C ?I0, @transport_id ?B ?D ?I1)) (ofe_mor_car _ _ (ofe_trunc_expand ?a) ?x)] =>
+ unify A D; unify C B;
+ let H := fresh "H" in
+ specialize (transport_id_expand' A C _ a eq_refl) as H; specialize_shelve H;
+ specialize (H I0 I1); setoid_rewrite <- (H x); clear H
+ end.
+
+(** automation for positions at which proof irrelevance rewrites can be used to make two terms equal *)
+Ltac pi_at_compat compat :=
+ match goal with
+ | |- ?a ≡ ?b => compat a b
+ | |- ?a ≡{_}≡ ?b => compat a b
+ | |- ?a = ?b => compat a b
+ end.
+
+Ltac pi_pat_db cont H1 H2 :=
+ match H1 with
+ (* basic compatibility positions for morphisms *)
+ (* function application *)
+ | ofe_mor_car _ _ ?f ?x =>
+ match H2 with
+ | ofe_mor_car _ _ ?g ?y =>
+ cont f g; cont x y
+ end
+ (* application of the functor F *)
+ | map (?a, ?b) =>
+ match H2 with
+ | map (?c, ?d) => cont a c; cont b d
+ end
+ (* composition *)
+ | ?a â—Ž ?b => match H2 with
+ | ?c â—Ž ?d => cont a c; cont b d
+ end
+ (* basic compatibility for transports *)
+ | @transport_id ?A0 ?B0 ?I0 =>
+ match H2 with
+ | @transport_id ?A1 ?B1 ?I1 =>
+ unify A0 A1; unify B0 B1; unify_pi I0 I1
+ | @transport_id ?A1 ?B1 ?I1 =>
+ cont A0 A1; cont B0 B1
+ end
+ (* equality of truncated types *)
+ | @ofe_trunc_car _ _ (Ftrunc ?X ?X) _ =>
+ match H2 with
+ | @ofe_trunc_car _ _ (Ftrunc ?Y ?Y) _ => cont X Y
+ end
+ | ofe_mor_car _ _ ofe_trunc_truncate ?x =>
+ match H2 with
+ | ofe_mor_car _ _ ofe_trunc_truncate ?y => cont x y
+ end
+ | ofe_mor_car _ _ ofe_trunc_expand ?x =>
+ match H2 with
+ | ofe_mor_car _ _ ofe_trunc_expand ?y => cont x y
+ end
+ (* remove projections *)
+ | projCOFE _ ?X =>
+ match H2 with
+ | projCOFE _ ?Y => cont X Y
+ end
+ (* rewrite with proof irrelevance at proof arguments *)
+ | ?X ?Xapp =>
+ match H2 with
+ | ?Y ?Yapp =>
+ is_prop Xapp; unify_pi Xapp Yapp; cont X Y
+ end
+ | _ => idtac
+ end.
+
+Ltac contpat H1 H2 := pi_pat_db contpat H1 H2.
+(* for a goal which is some form of equality, try to make the heads of both sides equal using proof irrelevance *)
+Ltac equalise_pi_head := repeat pi_at_compat contpat.
+(* for a goal which is some form of equality, try to solve it using PI *)
+Ltac equalise_pi := equalise_pi_head; reflexivity.
+
+(* merge all successive transports into a single one *)
+Ltac compose_transports :=
+ repeat (cbn -[trunc_map]; match goal with
+ | |- context[ofe_mor_car _ _ (@transport_id ?W ?Z ?I) (ofe_mor_car _ _ (@transport_id ?X ?Y ?I0) ?x)]
+ => unify Y W; setoid_rewrite (@transport_id_compose X Y Z I0 I x)
+ | |- context[@transport_id ?Y ?Z ?I â—Ž @transport_id ?X ?Y ?I0] => setoid_rewrite (transport_id_compose X Y Z I0 I)
+ end).
+(* clear transports which have the same domain and codomain (up to registered PI instances) *)
+Ltac clear_id_transports :=
+ repeat (cbn -[trunc_map]; match goal with
+ | |- context[ofe_mor_car _ _ (@transport_id ?X ?Y ?I) ?x] => progress contpat constr:(X) constr:(Y)
+ | |- context[ofe_mor_car _ _ (@transport_id ?X ?Y ?I) ?x] => unify X Y; setoid_rewrite (@transport_id_identity X I x)
+ | |- context[@transport_id ?X ?X ?I] => setoid_rewrite (@transport_id_identity X I)
+ end).
+Ltac clear_transports := compose_transports; clear_id_transports; cbn -[trunc_map].
+
+
+(* shortcut definition for the often-used fold/unfold pattern *)
+Definition unfold_transport {Y Z: ofeT SI} (Heq : ofe_eq Y Z) := transport_id Y Z.
+Definition fold_transport {Y Z : ofeT SI} (Heq : ofe_eq Y Z) := @transport_id Z Y (ofe_eq_symm Heq).
+
+(** casts between OFEs commute with bcompl *)
+(*the COFEs really need to be equal so that the limits are also equal *)
+Lemma transport_id_bcompl {A B : COFE SI} (Heq : A = B) (Heq' : projCOFE _ A = projCOFE _ B) α (Hα : zero ≺ α) (ch : bchain A α)
+ : @transport_id A B Heq' (bcompl Hα ch) ≡{α}≡ bcompl Hα (bchain_map (@transport_id A B Heq') ch).
Proof.
- intros ? -> x. assert (i = i2 + i1) as -> by lia. revert j x H1.
- induction i2 as [|i2 IH]; intros j X H1; simplify_eq/=;
- [by rewrite coerce_id|by rewrite g_coerce IH].
+ unfold ofe_eq in *. subst. setoid_rewrite (transport_id_identity _ _).
+ cbn. apply bcompl_ne. intros. cbn. by clear_transports.
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)).
+
+(** * Preliminary definitions for the induction *)
+
+(** A record for the inductive hypothesis.
+ Parameterised by a predicate P (instead of an ordinal β and specialising to the predicate ⪯ β) as we have different instantiations (with ≺ β and True) for the two limit cases.
+*)
+Record is_bounded_approx {P : SI -> Prop} {X : ∀ α, P α → COFE SI}
+ {e : ∀ α₠α₂ (Hα₠: P αâ‚) (Hα₂ : P α₂), α₠≺ α₂ → X α₠Hα₠-n> X α₂ Hα₂}
+ {p : ∀ α₠α₂ (Hα₠: P αâ‚) (Hα₂ : P α₂), α₠≺ α₂ → X α₂ Hα₂ -n> X α₠Hαâ‚}
+ {ϕ : ∀ α (Hα : P α), X α Hα -n> [G (X α Hα)]_{succ α}}
+ {ψ : ∀ α (Hα : P α), [G (X α Hα)]_{succ α} -n> X α Hα}
+ := mk_is_bounded_approx
+ {
+ approx_p_e_id α₠α₂ Hα₠Hα₂ Hlt : (p α₠α₂ Hα₠Hα₂ Hlt) ◎ (e α₠α₂ Hα₠Hα₂ Hlt) ≡ cid;
+ approx_e_p_id α₠α₂ Hα₠Hα₂ Hlt : (e α₠α₂ Hα₠Hα₂ Hlt) â—Ž (p α₠α₂ Hα₠Hα₂ Hlt) ≡{αâ‚}≡ cid;
+ approx_e_funct α₠α₂ α₃ Hα₠Hα₂ Hα₃ Hlt1 Hlt2 Hlt3 :
+ (e α₂ α₃ Hα₂ Hα₃ Hlt2) ◎ (e α₠α₂ Hα₠Hα₂ Hlt1) ≡ (e α₠α₃ Hα₠Hα₃ Hlt3);
+ approx_p_funct α₠α₂ α₃ Hα₠Hα₂ Hα₃ Hlt1 Hlt2 Hlt3 :
+ (p α₠α₂ Hα₠Hα₂ Hlt1) ◎ (p α₂ α₃ Hα₂ Hα₃ Hlt2) ≡ (p α₠α₃ Hα₠Hα₃ Hlt3);
+ approx_ψ_ϕ_id α Hα: (ψ α Hα) ◎ (ϕ α Hα) ≡ cid;
+ approx_ϕ_ψ_id α Hα : (ϕ α Hα) ◎ (ψ α Hα) ≡{α}≡ cid;
+
+ approx_eq {α} Hα Hsα: projCOFE _ (X (succ α) Hsα) = [G (X α Hα)]_{succ α};
+ approx_X_truncated α Hα : OfeTruncated (X α Hα) α;
+
+
+ (* only interesting for the successor case *)
+ approx_Fep_p γ0 γ1 (Hγ0 : P γ0) (Hγ1 : P γ1) (Hsγ0 : P (succ γ0)) (Hsγ1 : P (succ γ1))
+ (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1):
+ fold_transport (approx_eq Hγ0 Hsγ0)
+ ◎ (trunc_map _ _ (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt)))
+ ◎ unfold_transport (approx_eq Hγ1 Hsγ1)
+ ≡ p (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts;
+ approx_p_ψ_unfold γ Hγ Hsγ (Hlt : γ ≺ succ γ): p γ (succ γ) Hγ Hsγ Hlt ≡ ψ γ Hγ ◎ unfold_transport (approx_eq Hγ Hsγ);
+ approx_e_fold_ϕ γ Hγ Hsγ (Hlt : γ ≺ succ γ): e γ (succ γ) Hγ Hsγ Hlt ≡ fold_transport (approx_eq Hγ Hsγ) ◎ ϕ γ Hγ;
+ approx_ϕ_succ_id γ Hle Hsle :
+ ϕ (succ γ) Hsle
+ ≡ trunc_map (succ γ) (succ (succ γ)) (map (ψ γ Hle ◎ unfold_transport (approx_eq Hle Hsle),
+ fold_transport (approx_eq Hle Hsle) ◎ ϕ γ Hle))
+ â—Ž unfold_transport (approx_eq Hle Hsle);
+ approx_ψ_succ_id γ Hle Hsle :
+ ψ (succ γ) Hsle
+ ≡ fold_transport (approx_eq Hle Hsle)
+ ◎ trunc_map (succ (succ γ)) (succ γ) (map (fold_transport (approx_eq Hle Hsle) ◎ ϕ γ Hle, ψ γ Hle ◎ unfold_transport (approx_eq Hle Hsle) ));
+
+ (* only interesting for the limit case *)
+ approx_Fep_p_limit γ0 γ1 (Hlim: index_is_limit γ1) Hγ0 Hsγ0 Hγ1 Hlt Hslt:
+ fold_transport (approx_eq Hγ0 Hsγ0)
+ ◎ (trunc_map (succ γ1) (succ γ0) (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt)))
+ ≡ p (succ γ0) γ1 Hsγ0 Hγ1 Hslt ◎ ψ γ1 Hγ1;
+ }.
+Arguments is_bounded_approx {_} _ _ _ _ _.
+
+Record bounded_approx {P : SI → Prop} := mk_bounded_approx
+ {
+ bounded_approx_X : ∀ α, P α → COFE SI;
+ bounded_approx_e : ∀ α₠α₂ (Hα₠: P αâ‚) (Hα₂ : P α₂), α₠≺ α₂ → bounded_approx_X α₠Hα₠-n> bounded_approx_X α₂ Hα₂;
+ bounded_approx_p : ∀ α₠α₂ (Hα₠: P αâ‚) (Hα₂ : P α₂), α₠≺ α₂ → bounded_approx_X α₂ Hα₂ -n> bounded_approx_X α₠Hαâ‚;
+ bounded_approx_ϕ : ∀ α (Hα : P α), bounded_approx_X α Hα -n> [G (bounded_approx_X α Hα)]_{succ α};
+ bounded_approx_ψ : ∀ α (Hα : P α), [G (bounded_approx_X α Hα)]_{succ α} -n> bounded_approx_X α Hα;
+ bounded_approx_props : is_bounded_approx bounded_approx_X bounded_approx_e bounded_approx_p bounded_approx_ϕ bounded_approx_ψ
+ }.
+Arguments bounded_approx _ : clear implicits.
+
+
+(** * Definition of agreement of approximations *)
+
+(** Consider the following for this definition of agreement:
+ For the following merger (see Section below), we will need to redefine all maps, e.g. e, p.
+ Just having isomorphisms between the different approximations will not suffice; for properties like functoriality,
+ we also need that the isomorphisms compose, e.g.: iso_γ^{γ₀, γ₂} ≡ iso_γ^{γâ‚, γ₂} â—Ž iso_γ^{γ₀, γâ‚}.
+ (here, iso_γ^{γ₀, γâ‚} denotes the iso of the γ-th components of the γ₀-th and γâ‚-st approximations)
+ Similarly, we need that (iso_γ^{γ₀, γâ‚})^{-1} ≡ iso_γ^{γâ‚, γ₀}.
+
+ Let's call this property coherence. The trouble is that coherence talks about different isomorphisms and connects them.
+ In the transfinite induction piecing the whole stuff together, we will need to come up with a proof of coherence in the limit case.
+ But the isomorphisms were defined in a previous transfinite induction (for the uniqueness of the IR predicate), after truncating the approximation, etc.
+ Looking into the definitions of those and proving properties about that would be EXTREMELY ugly and troublesome.
+
+ Instead, we use transports, which are isomorphisms which are "essentially identity" (up to typecasts).
+ They just encapsulte a typecast in a more usable way.
+
+ We implement this by requiring actual Leibniz equality between the OFEs and wrapping this equality in fold_transport, unfold_transport for easier handling.
+ That way, we can use the type cast like isomorphisms (without nasty eq_rect stuff), but can still prove properties using the information that the transports are just typecasts.
+*)
+Inductive approx_agree {P0 P1 : SI → Prop} {A0 : bounded_approx P0} {A1 : bounded_approx P1} : Type :=
+ {
+ agree_eq : ∀ γ (H0 : P0 γ) (H1 : P1 γ), projCOFE _ (bounded_approx_X A0 γ H0) = projCOFE _ (bounded_approx_X A1 γ H1);
+
+ agree_bcompl_nat : ∀ γ H0 H1,
+ ∀ α (Hα : zero ≺ α) (ch : bchain (bounded_approx_X A0 γ H0) α),
+ bcompl Hα ch ≡{α}≡ fold_transport (agree_eq γ H0 H1) (bcompl Hα (bchain_map (unfold_transport (agree_eq γ H0 H1)) ch));
+
+ agree_e_nat : ∀ γ0 γ1 (Hlt : γ0 ≺ γ1) (Hγ0 : P0 γ0) (Hγ0' : P1 γ0) (Hγ1 : P0 γ1) (Hγ1' : P1 γ1),
+ bounded_approx_e A0 γ0 γ1 Hγ0 Hγ1 Hlt ≡
+ fold_transport (agree_eq γ1 Hγ1 Hγ1')
+ ◎ bounded_approx_e A1 γ0 γ1 Hγ0' Hγ1' Hlt
+ ◎ unfold_transport (agree_eq γ0 Hγ0 Hγ0');
+
+ agree_p_nat : ∀ γ0 γ1 (Hlt : γ0 ≺ γ1) (Hγ0 : P0 γ0) (Hγ0' : P1 γ0) (Hγ1 : P0 γ1) (Hγ1' : P1 γ1),
+ bounded_approx_p A0 γ0 γ1 Hγ0 Hγ1 Hlt ≡
+ fold_transport (agree_eq γ0 Hγ0 Hγ0')
+ ◎ bounded_approx_p A1 γ0 γ1 Hγ0' Hγ1' Hlt
+ ◎ unfold_transport (agree_eq γ1 Hγ1 Hγ1');
+
+ agree_ϕ_nat : ∀ γ (Hγ : P0 γ) (Hγ' : P1 γ), bounded_approx_ϕ A0 γ Hγ ≡
+ fold_transport (ofe_eq_funct eq_refl (agree_eq γ Hγ Hγ'))
+ ◎ bounded_approx_ϕ A1 γ Hγ'
+ ◎ unfold_transport (agree_eq γ Hγ Hγ');
+
+ agree_ψ_nat : ∀ γ (Hγ : P0 γ) (Hγ' : P1 γ), bounded_approx_ψ A0 γ Hγ ≡
+ fold_transport (agree_eq γ Hγ Hγ')
+ ◎ bounded_approx_ψ A1 γ Hγ'
+ ◎ unfold_transport (ofe_eq_funct eq_refl (agree_eq γ Hγ Hγ'));
+ }.
+Arguments approx_agree {_ _} _ _.
+
+Lemma approx_agree_symmetric P0 P1 A0 A1 : @approx_agree P0 P1 A0 A1 → @approx_agree P1 P0 A1 A0.
+Proof with (cbn; unfold fold_transport, unfold_transport; by clear_transports).
+ intros H.
+ assert (X_eq : ∀ γ (H1 : P1 γ) (H0 : P0 γ), projCOFE _ (bounded_approx_X A1 γ H1) = projCOFE _ (bounded_approx_X A0 γ H0)).
+ { intros. symmetry. apply H. }
+ exists X_eq.
+ - intros. setoid_rewrite (agree_bcompl_nat H _ _ _ _ _ _).
+ unfold fold_transport; clear_transports. apply bcompl_ne. intros...
+ - intros. cbn. setoid_rewrite (agree_e_nat H _ _ _ _ _ _ _); intros x...
+ - intros. cbn. setoid_rewrite (agree_p_nat H _ _ _ _ _ _ _); intros x...
+ - intros. cbn. setoid_rewrite (agree_Ï•_nat H _ _ _); intros x...
+ - intros. cbn. setoid_rewrite (agree_ψ_nat H _ _ _); intros x...
+Qed.
+
+Lemma approx_agree_reflexive P A : @approx_agree P P A A.
Proof.
- intros ? <- x. assert (i = i1 + i2) as -> by lia.
- induction i1 as [|i1 IH]; simplify_eq/=;
- [by rewrite coerce_id|by rewrite coerce_f IH].
+ assert (X_eq : ∀ γ (H0 : P γ) (H1 : P γ), projCOFE _ (bounded_approx_X A γ H0) = projCOFE _ (bounded_approx_X A γ H1)).
+ { intros. pi_clear. reflexivity. }
+ exists X_eq.
+ 2-5: intros; unfold fold_transport, unfold_transport; intros x; cbn; repeat pi_clear; by clear_transports.
+ intros. unfold fold_transport, unfold_transport. pi_clear. clear_transports.
+ apply bcompl_ne. intros. cbn. by clear_transports.
Qed.
-Definition embed_coerce {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_coerce {k i} (x : A k) :
- g i (embed_coerce (S i) x) ≡ embed_coerce i x.
-Proof using Fcontr.
- unfold embed_coerce; 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 (k : nat) (x : A k) : T :=
- {| tower_car n := embed_coerce n x |}.
-Next Obligation. intros k x i. apply g_embed_coerce. Qed.
-Instance: Params (@embed) 1 := {}.
-Instance embed_ne k : NonExpansive (embed k).
-Proof. by intros n x y Hxy i; rewrite /= Hxy. Qed.
-Definition embed' (k : nat) : A k -n> T := OfeMor (embed k).
-Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
+(* A0 and A1 agree on P0 ∧ P1;
+ A1 and A2 agree on P1 ∧ P2;
+ thus A0 and A2 can only agree on P0 ∧ P1 ∧ P2.
+ This is captured by the requirement P0 → P2 → P1
+*)
+Lemma approx_agree_transitive (P0 P1 P2 : SI → Prop) A0 A1 A2: (∀ γ, P0 γ → P2 γ → P1 γ)
+ → @approx_agree P0 P1 A0 A1 → @approx_agree P1 P2 A1 A2 → @approx_agree P0 P2 A0 A2.
+Proof with (intros x; cbn; unfold fold_transport, unfold_transport; clear_transports; equalise_pi).
+ intros H Hag0 Hag1.
+ assert (X_eq : ∀ γ (H0 : P0 γ) (H1 : P2 γ), projCOFE _ (bounded_approx_X A0 γ H0) = projCOFE _ (bounded_approx_X A2 γ H1)).
+ { intros. rewrite (agree_eq Hag0). by apply H. intros. apply Hag1. }
+ exists X_eq.
+ - intros. setoid_rewrite (agree_bcompl_nat Hag0 _ _ _ _ _ _). setoid_rewrite (agree_bcompl_nat Hag1 _ _ _ _ _ _).
+ unfold fold_transport, unfold_transport. clear_transports. equalise_pi_head. apply ofe_mor_ne.
+ apply bcompl_ne. intros. cbn. clear_transports. equalise_pi.
+ - intros. setoid_rewrite (agree_e_nat Hag0 _ _ _ _ _ _ _).
+ setoid_rewrite (agree_e_nat Hag1 _ _ _ _ _ _ _)...
+ - intros. setoid_rewrite (agree_p_nat Hag0 _ _ _ _ _ _ _).
+ setoid_rewrite (agree_p_nat Hag1 _ _ _ _ _ _ _)...
+ - intros. setoid_rewrite (agree_Ï•_nat Hag0 _ _ _). setoid_rewrite (agree_Ï•_nat Hag1 _ _ _)...
+ - intros. setoid_rewrite (agree_ψ_nat Hag0 _ _ _). setoid_rewrite (agree_ψ_nat Hag1 _ _ _)...
+ Unshelve. all: eauto.
+Qed.
+
+Lemma bounded_approx_eq {P : SI → Prop} (A : bounded_approx P) α Hα Hsα :
+ projCOFE _ (bounded_approx_X A (succ α) Hsα) = [G (bounded_approx_X A α Hα)]_{succ α}.
+Proof. eapply approx_eq, A. Defined.
+
+Fact agree_transport_functorial P0 P1 P2 (A0 : bounded_approx P0) (A1 : bounded_approx P1) (A2 : bounded_approx P2) (H0 : approx_agree A0 A1) (H1 : approx_agree A1 A2) (H2 : approx_agree A0 A2) γ
+ (Hγ0 : P0 γ) (Hγ1 : P1 γ) (Hγ2 : P2 γ) :
+ @transport_id _ _ (agree_eq H1 γ Hγ1 Hγ2) ◎ @transport_id _ _ (agree_eq H0 γ Hγ0 Hγ1) ≡ @transport_id _ _ (agree_eq H2 γ Hγ0 Hγ2).
+Proof. rewrite transport_id_compose. apply transport_id_pi. Qed.
+
+(** * One-step Extensions *)
+Record extension {γ : SI} {A : bounded_approx (λ γ', γ' ≺ γ)} :=
+ {
+ ext_Xγ : COFE SI;
+ ext_eγ : ∀ γ0 (Hγ0 : γ0 ≺ γ), bounded_approx_X A γ0 Hγ0 -n> ext_Xγ;
+ ext_pγ : ∀ γ0 (Hγ0 : γ0 ≺ γ), ext_Xγ -n> bounded_approx_X A γ0 Hγ0;
+ ext_ϕγ : ext_Xγ -n> [G ext_Xγ]_{succ γ};
+ ext_ψγ : [G ext_Xγ]_{succ γ} -n> ext_Xγ;
+
+ ext_pγ_eγ_id γ0 Hγ0 : ext_pγ γ0 Hγ0 ◎ ext_eγ γ0 Hγ0 ≡ cid;
+ ext_eγ_pγ_id γ0 Hγ0 : ext_eγ γ0 Hγ0 ◎ ext_pγ γ0 Hγ0 ≡{γ0}≡ cid;
+ ext_eγ_funct γ0 γ1 Hγ0 Hγ1 Hlt : ext_eγ γ1 Hγ1 ◎ bounded_approx_e A γ0 γ1 Hγ0 Hγ1 Hlt ≡ ext_eγ γ0 Hγ0;
+ ext_pγ_funct γ0 γ1 Hγ0 Hγ1 Hlt : bounded_approx_p A γ0 γ1 Hγ0 Hγ1 Hlt ◎ ext_pγ γ1 Hγ1 ≡ ext_pγ γ0 Hγ0;
+
+ ext_ψγ_ϕγ_id : ext_ψγ ◎ ext_ϕγ ≡ cid;
+ ext_ϕγ_ψγ_id : ext_ϕγ ◎ ext_ψγ ≡{γ}≡ cid;
+
+ ext_Xγ_truncated : OfeTruncated ext_Xγ γ;
+
+ (* if γ is a successor ordinal....: *)
+ ext_eq γ' (Hlt : γ' ≺ γ) : γ = succ γ' → projCOFE _ ext_Xγ = [G (bounded_approx_X A γ' Hlt)]_{succ γ'};
+ ext_Fep_p γ0 γ1 (Hγ0 : γ0 ≺ γ) (Hγ1 : γ1 ≺ γ) (Hsγ0 : succ γ0 ≺ γ) (Hsγ1 : γ = succ γ1) (Hlt: γ0 ≺ γ1):
+ fold_transport (bounded_approx_eq A γ0 Hγ0 Hsγ0)
+ ◎ trunc_map (succ γ1) (succ γ0) (map (bounded_approx_e A γ0 γ1 Hγ0 Hγ1 Hlt, bounded_approx_p A γ0 γ1 Hγ0 Hγ1 Hlt))
+ ◎ unfold_transport (ext_eq γ1 Hγ1 Hsγ1)
+ ≡ ext_pγ (succ γ0) Hsγ0;
+ ext_p_ψ_unfold γ' (Hlt : γ' ≺ γ) (Heq : γ = succ γ') :
+ ext_pγ γ' Hlt ≡ bounded_approx_ψ A γ' Hlt ◎ unfold_transport (ext_eq γ' Hlt Heq);
+ ext_e_fold_ϕ γ' Hlt Heq :
+ ext_eγ γ' Hlt ≡ fold_transport (ext_eq γ' Hlt Heq) ◎ bounded_approx_ϕ A γ' Hlt;
+ ext_ϕ_succ_id γ' (Hlt : γ' ≺ γ) (Heq : γ = succ γ') :
+ ext_ϕγ
+ ≡ trunc_map (succ γ') (succ γ) (map (bounded_approx_ψ A γ' Hlt ◎ unfold_transport (ext_eq γ' Hlt Heq),
+ fold_transport (ext_eq γ' Hlt Heq) ◎ bounded_approx_ϕ A γ' Hlt))
+ ◎ unfold_transport (ext_eq γ' Hlt Heq);
+ ext_ψ_succ_id γ' Hlt Heq :
+ ext_ψγ
+ ≡ fold_transport (ext_eq γ' Hlt Heq)
+ ◎ trunc_map (succ γ) (succ γ') (map (fold_transport (ext_eq γ' Hlt Heq) ◎ bounded_approx_ϕ A γ' Hlt,
+ bounded_approx_ψ A γ' Hlt ◎ unfold_transport (ext_eq γ' Hlt Heq)));
+
+ (* if γ is a limit ordinal *)
+ ext_Fep_p_limit γ0 Hγ0 Hsγ0 : index_is_limit γ →
+ fold_transport (bounded_approx_eq A γ0 Hγ0 Hsγ0)
+ ◎ trunc_map (succ γ) (succ γ0) (map (ext_eγ γ0 Hγ0, ext_pγ γ0 Hγ0))
+ ≡ ext_pγ (succ γ0) Hsγ0 ◎ ext_ψγ;
+ }.
+Arguments extension {_} _.
+
+Record extension_agree {γ} {A0 A1 : bounded_approx (λ γ', γ' ≺ γ)} {E0 : extension A0} {E1 : extension A1} {H : approx_agree A0 A1} : Prop :=
+ {
+ eagree_eq : projCOFE _ (ext_Xγ E0) = projCOFE _ (ext_Xγ E1);
+ eagree_bcompl_nat : ∀ α (Hα : zero ≺ α) (ch : bchain (ext_Xγ E0) α),
+ bcompl Hα ch ≡{α}≡
+ fold_transport eagree_eq (bcompl Hα (bchain_map (unfold_transport eagree_eq) ch));
+ eagree_e_nat γ' Hγ' : ext_eγ E0 γ' Hγ'
+ ≡ fold_transport eagree_eq ◎ ext_eγ E1 γ' Hγ' ◎ unfold_transport (agree_eq H γ' Hγ' Hγ');
+ eagree_p_nat γ' Hγ' : ext_pγ E0 γ' Hγ'
+ ≡ fold_transport (agree_eq H γ' Hγ' Hγ') ◎ ext_pγ E1 γ' Hγ' ◎ unfold_transport eagree_eq;
+ eagree_ϕ_nat : ext_ϕγ E0 ≡ fold_transport (ofe_eq_funct (α := succ γ) (α' := succ γ) eq_refl eagree_eq)
+ ◎ ext_ϕγ E1 ◎ unfold_transport eagree_eq;
+ eagree_ψ_nat : ext_ψγ E0 ≡ fold_transport eagree_eq ◎ ext_ψγ E1 ◎ unfold_transport (ofe_eq_funct (α := succ γ) (α' := succ γ) eq_refl eagree_eq)
+ }.
+Arguments extension_agree {_ _ _} _ _ _.
+
+Lemma extension_agree_reflexive γ A E H: @extension_agree γ A A E E H.
Proof.
- rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
- 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_eq/=.
- 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 k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
+ unshelve eexists.
+ reflexivity.
+ 2-5: intros; unfold fold_transport, unfold_transport; intros x; cbn; by clear_transports.
+ intros. unfold fold_transport, unfold_transport. clear_transports.
+ apply bcompl_ne. intros. cbn. by clear_transports.
+Qed.
+
+Lemma extension_agree_symmetric γ A0 A1 E0 E1 H: @extension_agree γ A0 A1 E0 E1 H → @extension_agree γ A1 A0 E1 E0 (approx_agree_symmetric _ _ A0 A1 H).
+Proof with (cbn; unfold fold_transport, unfold_transport; by clear_transports).
+ intros H0. assert (Heq: projCOFE _ (ext_Xγ E1) = projCOFE _ (ext_Xγ E0)).
+ { symmetry. apply H0. }
+ exists Heq.
+ - intros. setoid_rewrite (eagree_bcompl_nat H0 _ _ _).
+ unfold fold_transport, unfold_transport. clear_transports.
+ apply bcompl_ne. intros; cbn...
+ - intros. setoid_rewrite (eagree_e_nat H0 _ _); intros x...
+ - intros. setoid_rewrite (eagree_p_nat H0 _ _); intros x...
+ - intros. setoid_rewrite (eagree_Ï•_nat H0); intros x...
+ - intros. setoid_rewrite (eagree_ψ_nat H0); intros x...
+Qed.
+
+Lemma extension_agree_transitive γ A0 A1 A2 E0 E1 E2 H0 H1 He :
+ @extension_agree γ A0 A1 E0 E1 H0
+ → @extension_agree γ A1 A2 E1 E2 H1
+ → @extension_agree γ A0 A2 E0 E2 (approx_agree_transitive _ _ _ A0 A1 A2 He H0 H1).
+Proof with (unfold fold_transport, unfold_transport; intros x; cbn; clear_transports; equalise_pi).
+ intros Hag0 Hag1. assert (X_eq : projCOFE _ (ext_Xγ E0) = projCOFE _ (ext_Xγ E2)).
+ { rewrite (eagree_eq Hag0). apply (eagree_eq Hag1). }
+ exists X_eq.
+ - intros. setoid_rewrite (eagree_bcompl_nat Hag0 _ _ _). setoid_rewrite (eagree_bcompl_nat Hag1 _ _ _).
+ unfold fold_transport, unfold_transport. clear_transports. equalise_pi_head. apply ofe_mor_ne.
+ apply bcompl_ne. intros. cbn. clear_transports. equalise_pi.
+ - intros. setoid_rewrite (eagree_e_nat Hag0 _ _). setoid_rewrite (eagree_e_nat Hag1 _ _)...
+ - intros. setoid_rewrite (eagree_p_nat Hag0 _ _). setoid_rewrite (eagree_p_nat Hag1 _ _)...
+ - intros. setoid_rewrite (eagree_Ï•_nat Hag0). setoid_rewrite (eagree_Ï•_nat Hag1)...
+ - intros. setoid_rewrite (eagree_ψ_nat Hag0). setoid_rewrite (eagree_ψ_nat Hag1)...
+Qed.
+
+(** * Base case *)
+Lemma zero_e_p (α₠α₂ : SI) : α₠⪯ zero → α₂ ⪯ zero → α₠≺ α₂ → False.
Proof.
- intros i; rewrite /= /embed_coerce.
- destruct (le_lt_dec i (S k)) as [H|H]; simpl.
- - rewrite -(gg_tower i (S k - i) X).
- apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
- - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
-Qed.
-
-Program Definition unfold_chain (X : T) : chain (F T _) :=
- {| chain_car n := map (project n,embed' n) (X (S 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 IH]; simpl; first done.
- rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
- rewrite f_S -oFunctor_compose.
- by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
-Qed.
-Definition unfold (X : T) : F T _ := compl (unfold_chain X).
-Instance unfold_ne : NonExpansive unfold.
+ intros Hα₠Hα₂ Hlt.
+ destruct Hα₠as [ -> | H%index_lt_zero_is_normal]; [ | easy].
+ destruct Hα₂ as [ -> | H%index_lt_zero_is_normal]; [ | easy].
+ by eapply index_lt_irrefl.
+Qed.
+
+(*FIXME: the format stuff does not work *)
+(*Notation "'[' f ']^{' a '}_{' b '}'" := (trunc_map a b f) (format "'[' f ']^{' a '}_{' b '}'").*)
+Notation "'[' f ']^{' a '}_{' b '}'" := (trunc_map a b f).
+Section base_case.
+ Let X0' : COFE SI := cofe _ (unitO SI).
+ Let X0 : COFE SI := cofe _ ([ G X0']_{zero}).
+
+ Let ϕ0' : X0' -n> X0 := λne _, ⌊inh_Funit⌋_{zero}.
+ Let ψ0' : X0 -n> X0' := λne _, ().
+
+ Let ϕ0 : X0 -n> [G X0]_{succ zero} := [map (ψ0' , ϕ0')]^{zero}_{succ zero}.
+ Let ψ0 : [G X0]_{succ zero} -n> X0 := [map (ϕ0', ψ0')]^{succ zero}_{zero}.
+
+
+ Lemma bounded_inverse_ϕ0_ψ0 : boundedInverse ϕ0 ψ0 zero.
+ Proof using Fcontr.
+ unfold ϕ0, ψ0. apply trunc_map_inv. eauto with index.
+ split; rewrite map_compose_dist.
+ - rewrite Fcontr. 2: { instantiate (1 := (cid, cid)). intros ? ?; index_contra_solve. }
+ intros x; by rewrite (oFunctor_id _ _).
+ - rewrite Fcontr. 2: { instantiate (1 := (cid, cid)). intros ? ?; index_contra_solve. }
+ intros x; by rewrite (oFunctor_id _ _).
+ Qed.
+
+ Program Definition approx_base : @bounded_approx (λ x, x ⪯ zero) := mk_bounded_approx _
+ (λ _ _, X0)
+ (λ α1 α2 Hα1 Hα2 Hlt, _)
+ (λ α1 α2 Hα1 Hα2 Hlt, _)
+ (λ α Hα, ϕ0)
+ (λ α Hα, ψ0)
+ _ .
+ Next Obligation.
+ intros; cbn in Hα1, Hα2. subst. exfalso; eapply zero_e_p; [ apply Hα1 | apply Hα2 | apply Hlt].
+ Defined.
+ Next Obligation.
+ intros; cbn in Hα1, Hα2; subst. exfalso; eapply zero_e_p; [apply Hα1 | apply Hα2 | apply Hlt].
+ Defined.
+ Next Obligation.
+ intros; cbn in Hα. destruct Hα as [-> | []%index_lt_zero_is_normal]. subst. reflexivity.
+ Defined.
+ Next Obligation.
+ intros α [-> | []%index_lt_zero_is_normal]. reflexivity.
+ Defined.
+ Next Obligation.
+ unshelve econstructor.
+ all: try (intros; subst; index_contra_solve).
+ 3: { intros; destruct Hα as [-> | []%index_lt_zero_is_normal]. apply _. }
+ all: intros; destruct Hα as [-> | Hα]; [ | exfalso; by apply index_lt_zero_is_normal in Hα]; cbn -[trunc_map].
+ rewrite ofe_truncated_equiv.
+ all: apply bounded_inverse_ϕ0_ψ0.
+ Qed.
+End base_case.
+
+(* program mode does insert quite nasty matches, we'd rather not have them as we have to reason about the functions defined in program mode *)
+Unset Program Cases.
+(* needed for some of the program definitions where two symmetric functions are defined (e.g. e, p).
+ Using transparent obligations makes some of that work without too much PI.
+*)
+Set Transparent Obligations.
+
+Ltac autorew :=
+ try (intros x; cbn);
+ repeat (
+ try rewrite oFunctor_id;
+ try setoid_rewrite (ofe_trunc_truncate_expand_id _);
+ try setoid_rewrite (ofe_trunc_expand_truncate_id _);
+ try setoid_rewrite (transport_id_identity _ _);
+ try reflexivity).
+
+(** * Successor case *)
+
+Section succ_case_X.
+ Context (β : SI).
+ Context (IH : @bounded_approx (λ γ, γ ≺ succ β)).
+
+ Let X := bounded_approx_X IH.
+ Let Ï• := bounded_approx_Ï• IH.
+ Let ψ := bounded_approx_ψ IH.
+ Let e := bounded_approx_e IH.
+ Let p := bounded_approx_p IH.
+
+ Instance Xsucc_eq α Hα Hsα : ofe_eq (X (succ α) Hsα) ([G (X α Hα)]_{succ α}).
+ Proof. eapply approx_eq, IH. Defined. (* defined transparently so the IH lemmas depending on approx_eq can be used *)
+ Arguments Xsucc_eq: simpl never.
+
+ Let unfold α Hα Hsα := unfold_transport (Xsucc_eq α Hα Hsα).
+ Let fold α Hα Hsα := fold_transport (Xsucc_eq α Hα Hsα).
+
+ Let ϕ_ψ_id : ∀ α (Hα : α ≺ succ β), ϕ α Hα ◎ ψ α Hα ≡{α}≡ cid. eapply approx_ϕ_ψ_id, IH. Qed.
+ Let ψ_ϕ_id : ∀ α (Hα : α ≺ succ β), ψ α Hα ◎ ϕ α Hα ≡ cid. eapply approx_ψ_ϕ_id, IH. Qed.
+ Let p_e_id : ∀ α1 α2 (Hα1 : α1 ≺ succ β) (Hα2 : α2 ≺ succ β) (Hlt : α1 ≺ α2), p α1 α2 Hα1 Hα2 Hlt ◎ e α1 α2 Hα1 Hα2 Hlt≡ cid. eapply approx_p_e_id, IH. Qed.
+ Let e_p_id : ∀ α1 α2 (Hα1 : α1 ≺ succ β) (Hα2 : α2 ≺ succ β) (Hlt : α1 ≺ α2), e α1 α2 Hα1 Hα2 Hlt ◎ p α1 α2 Hα1 Hα2 Hlt ≡{α1}≡ cid. eapply approx_e_p_id, IH. Qed.
+ Let e_funct : ∀ α1 α2 α3 (Hα1 : α1 ≺ succ β) (Hα2 : α2 ≺ succ β) (Hα3 : α3 ≺ succ β) (Hlt1 : α1 ≺ α2) (Hlt2 : α2 ≺ α3) (Hlt3 : α1 ≺ α3), e α2 α3 Hα2 Hα3 Hlt2 ◎ e α1 α2 Hα1 Hα2 Hlt1 ≡ e α1 α3 Hα1 Hα3 Hlt3. eapply approx_e_funct, IH. Qed.
+ Let p_funct : ∀ α1 α2 α3 (Hα1 : α1 ≺ succ β) (Hα2 : α2 ≺ succ β) (Hα3 : α3 ≺ succ β) (Hlt1 : α1 ≺ α2) (Hlt2 : α2 ≺ α3) (Hlt3 : α1 ≺ α3), p α1 α2 Hα1 Hα2 Hlt1 ◎ p α2 α3 Hα2 Hα3 Hlt2 ≡ p α1 α3 Hα1 Hα3 Hlt3. eapply approx_p_funct, IH. Qed.
+ Let X_truncated : ∀ α Hα, OfeTruncated (X α Hα) α. eapply approx_X_truncated, IH. Qed.
+ Existing Instance X_truncated.
+ Let ϕ_succ_id : ∀ γ Hle Hsle, ϕ (succ γ) Hsle ≡ trunc_map (succ γ) (succ (succ γ)) (map (ψ γ Hle ◎ unfold γ Hle Hsle, fold γ Hle Hsle ◎ ϕ γ Hle)) ◎ unfold γ Hle Hsle. eapply (approx_ϕ_succ_id (P:= λ γ, γ ≺ succ β)). Qed.
+ Let ψ_succ_id : ∀ γ Hle Hsle, ψ (succ γ) Hsle ≡ fold γ Hle Hsle ◎ trunc_map (succ (succ γ)) (succ γ) (map (fold γ Hle Hsle ◎ ϕ γ Hle, ψ γ Hle ◎ unfold γ Hle Hsle)). eapply (approx_ψ_succ_id (P:= λ γ, γ ≺ succ β)). Qed.
+ Let Fep_p : ∀ γ0 γ1 Hγ0 Hγ1 Hsγ0 Hsγ1 Hlt Hlts,
+ fold γ0 Hγ0 Hsγ0 ◎ trunc_map (succ γ1) (succ γ0) (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt)) ◎ unfold γ1 Hγ1 Hsγ1
+ ≡ p (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts.
+ eapply (approx_Fep_p (P := λ γ, γ ≺ succ β)).
+ Qed.
+ Let Fep_p_limit : ∀ γ0 γ1 (Hlim: index_is_limit γ1) Hγ0 Hsγ0 Hγ1 Hlt Hslt,
+ fold γ0 Hγ0 Hsγ0 ◎ trunc_map (succ γ1) (succ γ0) (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt))
+ ≡ p (succ γ0) γ1 Hsγ0 Hγ1 Hslt ◎ ψ γ1 Hγ1.
+ eapply (approx_Fep_p_limit (P := λ γ, γ ≺ succ β)).
+ Qed.
+ Let e_fold_ϕ : ∀ γ Hγ Hsγ Hlt, e γ (succ γ) Hγ Hsγ Hlt ≡ fold γ Hγ Hsγ ◎ ϕ γ Hγ.
+ eapply (approx_e_fold_ϕ (P := λ γ, γ ≺ succ β)). Qed.
+ Let p_ψ_unfold : ∀ γ Hγ Hsγ Hlt, p γ (succ γ) Hγ Hsγ Hlt ≡ ψ γ Hγ ◎ unfold γ Hγ Hsγ.
+ eapply (approx_p_ψ_unfold (P := λ γ, γ ≺ succ β)). Qed.
+
+ Fact succ_le_gt_eq γ : γ ⪯ succ β → β ≺ γ → γ = succ β.
+ Proof.
+ intros [-> | Hlt] H1; [reflexivity | ]. index_contra_solve.
+ Qed.
+
+ Definition β_refl : β ≺ succ β. eauto with index. Qed.
+ Definition sX' : COFE SI := cofe _ ([G (X β β_refl)]_{succ β}).
+ Lemma sX'_id Hβ : projCOFE _ sX' = [G (X β Hβ)]_{succ β}.
+ Proof. unfold sX'. set (β_refl). pi_clear. reflexivity. Qed.
+
+ Let unfold' Hβ : sX' -n> [G (X β Hβ)]_{succ β} := unfold_transport (sX'_id Hβ).
+ Let fold' Hβ : [G (X β Hβ)]_{succ β} -n> sX' := fold_transport (sX'_id Hβ).
+ Lemma unfold'_fold'_id Hβ : unfold' Hβ ◎ fold' Hβ ≡ cid.
+ Proof. unfold unfold', fold', unfold_transport, fold_transport. intros x; cbn. by clear_transports. Qed.
+ Lemma fold'_unfold'_id Hβ : fold' Hβ ◎ unfold' Hβ ≡ cid.
+ Proof. unfold unfold', fold', unfold_transport, fold_transport. intros x; cbn. by clear_transports. Qed.
+
+ Lemma fold'_id : fold' β_refl ≡ cid.
+ Proof. unfold fold', fold_transport. apply transport_id_identity. Qed.
+ Lemma unfold'_id : unfold' β_refl ≡ cid.
+ Proof. unfold unfold', unfold_transport. apply transport_id_identity. Qed.
+
+ Ltac open_folds :=
+ unfold unfold, fold, unfold', fold', unfold_transport, fold_transport.
+
+ Definition sϕ' : sX' -n> [G sX']_{succ (succ β)} :=
+ trunc_map (succ β) (succ (succ β)) (map (ψ β β_refl, ϕ β β_refl)).
+ Definition sψ' : [G sX']_{succ (succ β)} -n> sX' :=
+ trunc_map (succ (succ β)) (succ β) (map (ϕ β β_refl, ψ β β_refl)).
+
+ Lemma dist_later_succ (A : ofeT SI) (x y : A) γ : dist_later (succ γ) x y ↔ x ≡{γ}≡ y.
+ Proof.
+ split; intros H.
+ - eauto with index.
+ - intros γ' Hγ'. eapply dist_mono'. exact H. by apply index_succ_iff.
+ Qed.
+
+ Lemma sϕ'_sψ'_id : sϕ' ◎ sψ' ≡{succ β}≡ cid.
+ Proof using ϕ_ψ_id Fcontr.
+ unfold sϕ', sψ'. intros x; cbn -[trunc_map]. merge_truncs. 2: reflexivity. cbn.
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _). setoid_rewrite Fcontr.
+ 2: { apply dist_later_succ. apply pair_ne; by setoid_rewrite (ϕ_ψ_id _ _). }
+ rewrite oFunctor_id. by setoid_rewrite (ofe_trunc_truncate_expand_id _).
+ Qed.
+
+
+ Lemma sψ'_sϕ'_id : sψ' ◎ sϕ' ≡ cid.
+ Proof using ψ_ϕ_id Fcontr.
+ unfold sϕ', sψ'. intros x; cbn -[trunc_map]. rewrite ofe_truncated_equiv.
+ merge_truncs. 2: eauto with index.
+ cbn. setoid_rewrite (map_compose_dist _ _ _ _ _ _). setoid_rewrite Fcontr.
+ 2: { apply dist_later_succ. apply pair_ne; by setoid_rewrite (ψ_ϕ_id _ _). }
+ autorew.
+ Qed.
+
+ Lemma sϕ'_succ_id Hle : sϕ'
+ ≡ trunc_map (succ β) (succ (succ β)) (map (ψ β Hle ◎ unfold' Hle, fold' Hle ◎ ϕ β Hle)) ◎ unfold' Hle.
+ Proof.
+ unfold sϕ'. cbn. setoid_rewrite <- (map_compose _ _ _ _). intros x; cbn.
+ rewrite ofe_truncated_equiv. apply ofe_mor_ne. rewrite (proof_irrel Hle β_refl).
+ rewrite (unfold'_id _). setoid_rewrite oFunctor_ne at 2 .
+ 2:{ rewrite unfold'_id fold'_id. reflexivity. }
+ autorew.
+ Qed.
+
+ Lemma sψ'_succ_id Hle : sψ'
+ ≡ fold' Hle ◎ trunc_map (succ (succ β)) (succ β) (map (fold' Hle ◎ ϕ β Hle, ψ β Hle ◎ unfold' Hle)).
+ Proof.
+ unfold sψ'. cbn. setoid_rewrite <- (map_compose _ _ _ _). intros x; cbn.
+ rewrite (proof_irrel Hle β_refl).
+ rewrite ofe_truncated_equiv. setoid_rewrite (fold'_id _).
+ do 2 apply ofe_mor_ne. setoid_rewrite oFunctor_ne.
+ 2: { rewrite unfold'_id fold'_id. reflexivity. }
+ autorew.
+ Qed.
+
+ Lemma se'_ca γ (Hγ : γ ≺ succ β) : { γ ≺ β } + { γ = β}.
+ Proof.
+ destruct (index_le_lt_dec β γ) as [H1 | H1].
+ - right. apply index_succ_iff in Hγ. by apply index_le_ge_eq.
+ - by left.
+ Qed.
+
+ Lemma sX_pi_id γ γ' Hγ Hγ' (Heq : γ = γ') : ofe_eq (X γ Hγ) (X γ' Hγ').
+ Proof. subst. pi_clear. reflexivity. Qed.
+
+ Definition se' γ Hγ : X γ Hγ -n> sX' :=
+ match se'_ca γ Hγ with
+ | left Hlt => ϕ β β_refl ◎ e γ β Hγ β_refl Hlt
+ | right Heq => ϕ β β_refl ◎ @transport_id _ _ (sX_pi_id γ β Hγ β_refl Heq)
+ end.
+ Definition sp' γ Hγ : sX' -n> X γ Hγ :=
+ match se'_ca γ Hγ with
+ | left Hlt => p γ β Hγ β_refl Hlt ◎ ψ β β_refl
+ | right Heq => @transport_id _ _ (sX_pi_id β γ β_refl Hγ (symmetry Heq)) ◎ ψ β β_refl
+ end.
+
+ Lemma se'_sp'_id γ Hγ : se' γ Hγ ◎ sp' γ Hγ ≡{γ}≡ cid.
+ Proof.
+ unfold se', sp'. destruct se'_ca as [H1 | H1].
+ - intros x; cbn. setoid_rewrite (e_p_id _ _ _ _ _ _). cbn. eapply dist_mono.
+ by setoid_rewrite (ϕ_ψ_id _ _ _). assumption.
+ - intros x; cbn. clear_transports. subst. by setoid_rewrite (ϕ_ψ_id _ _ _).
+ Qed.
+ Lemma sp'_se'_id γ Hγ : sp' γ Hγ ◎ se' γ Hγ ≡ cid.
+ Proof.
+ unfold se', sp'. destruct se'_ca as [H1 | H1].
+ - intros x; cbn. setoid_rewrite (ψ_ϕ_id _ _ _). by setoid_rewrite (p_e_id _ _ _ _ _ _).
+ - intros x; cbn. setoid_rewrite (ψ_ϕ_id _ _ _). by clear_transports.
+ Qed.
+
+ Lemma sp'_ψ_unfold Hβ : sp' β Hβ ≡ ψ β Hβ ◎ unfold' Hβ.
+ Proof.
+ unfold sp'. destruct se'_ca as [H1 | H1]. index_contra_solve.
+ rewrite (proof_irrel Hβ β_refl). rewrite unfold'_id. autorew.
+ Qed.
+
+ Lemma se'_fold_ϕ Hβ : se' β Hβ ≡ fold' Hβ ◎ ϕ β Hβ.
+ Proof.
+ unfold se'. destruct se'_ca as [H1 | H1]. index_contra_solve.
+ rewrite (proof_irrel Hβ β_refl). rewrite fold'_id. autorew.
+ Qed.
+
+ Lemma se'_funct γ0 γ1 Hγ0 Hγ1 Hlt : se' γ1 Hγ1 ◎ e γ0 γ1 Hγ0 Hγ1 Hlt ≡ se' γ0 Hγ0.
+ Proof.
+ unfold se'. destruct (se'_ca γ1) as [H1 | H1], (se'_ca γ0) as [H2 | H2].
+ all: try by (exfalso; subst; index_contra_solve).
+ - intros x; cbn. f_equiv. by setoid_rewrite (e_funct _ _ _ _ _ _ _ _ _ _).
+ - intros x; cbn. f_equiv. subst. set β_refl. repeat pi_clear. by clear_transports.
+ Qed.
+
+ Lemma sp'_funct γ0 γ1 Hγ0 Hγ1 Hlt : p γ0 γ1 Hγ0 Hγ1 Hlt ◎ sp' γ1 Hγ1 ≡ sp' γ0 Hγ0.
+ Proof.
+ unfold sp'. destruct (se'_ca γ1) as [H1 | H1], (se'_ca γ0) as [H2 | H2].
+ all: try by (exfalso; subst; index_contra_solve).
+ - intros x; cbn. by setoid_rewrite (p_funct _ _ _ _ _ _ _ _ _ _).
+ - intros x; cbn. subst. set β_refl. repeat pi_clear. by clear_transports.
+ Qed.
+
+ Lemma Fep_sp' γ Hγ Hβ Hsγ Hlt :
+ fold_transport (Xsucc_eq γ Hγ Hsγ)
+ ◎ trunc_map (succ β) (succ γ) (map (e γ β Hγ Hβ Hlt, p γ β Hγ Hβ Hlt))
+ ◎ unfold' Hβ
+ ≡ sp' (succ γ) Hsγ.
+ Proof using Fcontr.
+ unfold sp', unfold'. destruct (se'_ca) as [H1 | H1].
+ - destruct (index_dec_limit β) as [[β' Hβ'] | Hlim].
+ + unfold Xsucc_eq in *.
+ generalize (sX'_id Hβ) as e0.
+ revert Hγ Hβ Hsγ Hlt H1.
+ unfold sX' in *.
+ generalize (β_refl) as H0.
+ subst unfold' fold' unfold fold.
+ generalize (Xsucc_eq) as H1.
+ subst β. intros. repeat pi_clear.
+ setoid_rewrite <- (Fep_p _ _ _ _ _ _ _ _ ).
+ intros x; cbn. rewrite ofe_truncated_equiv.
+ do 2 apply ofe_mor_ne.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne.
+ { rewrite <- (e_funct γ β' (succ β')). rewrite (e_fold_ϕ). rewrite ccompose_assoc. reflexivity. }
+ { setoid_rewrite <- (p_funct γ β' (succ β')) at 1. rewrite (p_ψ_unfold).
+ Unshelve. 2-3,5-10: abstract (eauto 3 with index).
+ apply equiv_dist. symmetry. apply ccompose_assoc.
+ }
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ cbn. equalise_pi_head.
+ apply ofe_mor_ne.
+ setoid_rewrite (ψ_succ_id _ _ _ _). cbn.
+ unfold fold_transport, unfold_transport. clear_transports.
+ setoid_rewrite (dist_mono' _ _ _ _ (ofe_trunc_expand_truncate_id _)). 2: eauto with index.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). equalise_pi.
+ + assert (Hterm : zero ≺ β).
+ { destruct (index_le_lt_dec β zero) as [H2 | H2]. 2: assumption.
+ exfalso. index_contra_solve.
+ }
+ specialize (Fep_p_limit γ β Hlim Hγ Hsγ β_refl Hlt H1) as H3.
+ cbn in H3. setoid_rewrite <- H3. intros x; cbn.
+ set β_refl. repeat pi_clear.
+ open_folds. clear_transports. equalise_pi.
+ - unfold Xsucc_eq in *.
+ match goal with
+ |- context[sX_pi_id ?a ?b ?c ?d ?e] => generalize (sX_pi_id a b c d e) as e0 end.
+ match goal with
+ |- context[sX'_id ?a] => generalize (sX'_id a) as e1 end.
+ unfold sX' in*.
+ revert Hγ Hβ Hsγ Hlt.
+ generalize (β_refl) as H0.
+ subst unfold' fold' unfold fold.
+ generalize (Xsucc_eq) as H2.
+ subst β. intros. repeat pi_clear.
+ rewrite (ψ_succ_id _ _ _). cbn.
+ intros x; cbn.
+ rewrite ofe_truncated_equiv.
+ unfold fold_transport. clear_transports.
+ equalise_pi_head. do 2 apply ofe_mor_ne.
+ unfold unfold_transport.
+ setoid_rewrite <- (transport_id_expand' _ _ _ _ _ _ _ _ _). 2: reflexivity.
+ cbn. map_compose_tac.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne.
+ { rewrite e_fold_Ï•. rewrite <- ccompose_assoc. unfold fold_transport. rewrite transport_id_compose. reflexivity. }
+ { rewrite p_ψ_unfold. rewrite ccompose_assoc. unfold unfold_transport. rewrite transport_id_compose. reflexivity. }
+ }
+ equalise_pi.
+ Qed.
+
+
+ Ltac solve_tac := intros x; cbn; repeat f_equiv; open_folds; equalise_pi.
+ Program Definition succ_extension : extension IH :=
+ {|
+ ext_Xγ := sX';
+ ext_eγ := se';
+ ext_pγ := sp';
+ ext_ϕγ := sϕ';
+ ext_ψγ := sψ';
+ |}.
+ Next Obligation. apply sp'_se'_id. Qed.
+ Next Obligation. apply se'_sp'_id. Qed.
+ Next Obligation. apply se'_funct. Qed.
+ Next Obligation. apply sp'_funct. Qed.
+ Next Obligation. apply sψ'_sϕ'_id. Qed.
+ Next Obligation. apply sϕ'_sψ'_id. Qed.
+ Next Obligation.
+ intros γ' Hlt <-%index_succ_inj. apply sX'_id.
+ Defined.
+ Next Obligation.
+ intros. specialize (index_succ_inj _ _ Hsγ1) as H1. subst γ1.
+ setoid_rewrite <- (Fep_sp' _ _ _ _ _). solve_tac.
+ Qed.
+ Next Obligation.
+ intros. specialize (index_succ_inj _ _ Heq) as <-. rewrite sp'_ψ_unfold. solve_tac.
+ Qed.
+ Next Obligation.
+ intros. specialize (index_succ_inj _ _ Heq) as <-. rewrite se'_fold_Ï•. solve_tac.
+ Qed.
+ Next Obligation.
+ intros. specialize (index_succ_inj _ _ Heq) as <-. rewrite sϕ'_succ_id. solve_tac.
+ Qed.
+ Next Obligation.
+ intros. specialize (index_succ_inj _ _ Heq) as <-. rewrite sψ'_succ_id. solve_tac.
+ Qed.
+ Next Obligation.
+ intros ? ? ? Hlim.
+ (* well, succ β certainly isn't a limit *)
+ exfalso. eapply index_lt_irrefl, (Hlim β). apply index_succ_greater.
+ Qed.
+
+End succ_case_X.
+
+Lemma succ_extension_coherent β (A0 A1 : bounded_approx (λ γ, γ ≺ succ β)) :
+ ∀ H : approx_agree A0 A1, @extension_agree (succ β) A0 A1 (succ_extension β A0) (succ_extension β A1) H.
+Proof with (unfold fold_transport, unfold_transport; intros x; cbn; clear_transports; equalise_pi).
+ intros H. destruct H as [F1 Flim F2 F3 F4 F5].
+ assert (Heq : ext_Xγ (succ_extension β A0) = ext_Xγ (succ_extension β A1)).
+ { cbn. unfold sX'. rewrite F1. by rewrite (proof_irrel (β_refl β) (index_succ_greater β)). }
+ exists (proj_id Heq). all: intros; cbn.
+ { unfold fold_transport. cbn in Heq. unfold sX' in Heq. setoid_rewrite (transport_id_bcompl (symmetry Heq) _ _ _ _).
+ apply bcompl_ne. intros. cbn. unfold unfold_transport. by clear_transports. }
+ { unfold se'. destruct (se'_ca β) as [H1 | H1].
+ + rewrite F4. rewrite F2...
+ + subst. rewrite F4... }
+ { unfold sp'. destruct (se'_ca β) as [H1 | H1].
+ + rewrite F5. rewrite F3...
+ + subst. rewrite F5... }
+ all: intros x; cbn; rewrite ofe_truncated_equiv.
+ all: setoid_rewrite oFunctor_ne at 1; [ | rewrite F4 F5; setoid_rewrite ccompose_assoc at 1; reflexivity].
+ all: setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ all: setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ all: cbn; unfold unfold_transport, fold_transport.
+ all: setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _).
+ all: setoid_rewrite (transport_id_expand _ _ _ _ _ _ _).
+ all: cbn; equalise_pi.
+ Unshelve. all: eauto.
+Qed.
+
+
+(** * Inverse Limits *)
+(* this is needed for the limit case construction *)
+Section inverse_limit.
+ (* for every index γ satisfying P, we have an OFE X_γ *)
+ Context {P : SI → Prop}.
+ Context (X : ∀ β, P β → ofeT SI).
+
+ Definition btowerO : ofeT SI := discrete_funO (λ β: SI, discrete_funO (λ (H : P β), X β H)).
+
+ Program Definition proj_tower (β :SI) (Hβ : P β) := λne (t : btowerO), t β Hβ.
+ Next Obligation.
+ intros β Hβ α' x y Heq. unfold btowerO in *. apply Heq.
+ Qed.
+
+ Context (p : ∀ γ0 γ1 (Hγ0 : P γ0) (Hγ1 : P γ1), γ0 ≺ γ1 → X γ1 Hγ1 -n> X γ0 Hγ0).
+
+ Definition inv_lim := sigO (λ f, ∀ γ0 γ1 (Hγ0γ1 : γ0 ≺ γ1) (Hγ0 : P γ0) (Hγ1 : P γ1),
+ p _ _ Hγ0 Hγ1 Hγ0γ1 (proj_tower _ Hγ1 f) ≡ proj_tower _ Hγ0 f).
+
+ Program Definition proj_lim γ Hγ := λne (x : inv_lim), proj_tower γ Hγ (proj1_sig x) .
+ Next Obligation.
+ intros γ Hγ β x y Heq. destruct x as [x x'], y as [y y']. cbn.
+ unfold dist, inv_lim, sigO, ofe_dist, sig_dist in Heq.
+ cbn in Heq. unfold btowerO in *. apply Heq.
+ Qed.
+
+ Lemma inv_lim_eq_iff (x y : inv_lim) : x ≡ y ↔ ∀ γ Hγ, proj_lim γ Hγ x ≡ proj_lim γ Hγ y.
+ Proof.
+ split.
+ - intros Heq γ Hγ. unfold proj_lim. cbn.
+ destruct x, y. cbn. unfold equiv, inv_lim, sigO, ofe_equiv, sig_equiv in Heq.
+ cbn in Heq. unfold btowerO in *. apply Heq.
+ - intros H. destruct x, y. cbn in H.
+ unfold equiv, inv_lim, sigO, ofe_equiv, sig_equiv. cbn. intros a Ha. by apply H.
+ Qed.
+
+ Lemma inv_lim_dist_iff (x y : inv_lim) β : x ≡{β}≡ y ↔ ∀ γ Hγ, proj_lim γ Hγ x ≡{β}≡ proj_lim γ Hγ y.
+ split.
+ - intros Heq γ Hγ. unfold proj_lim. cbn.
+ destruct x, y. unfold proj_tower. cbn. unfold dist, inv_lim, sigO, ofe_dist, sig_dist in Heq.
+ cbn in Heq. unfold btowerO in *. apply Heq.
+ - intros H. destruct x, y. cbn in H.
+ unfold dist, inv_lim, sigO, ofe_dist, sig_dist. cbn.
+ intros a Ha. by apply H.
+ Qed.
+
+ Lemma inv_lim_equalises γ0 γ1 (Hγ0γ1 : γ0 ≺ γ1) (Hγ0 : P γ0 ) (Hγ1 : P γ1 ) x:
+ p _ _ Hγ0 Hγ1 Hγ0γ1 (proj_lim _ Hγ1 x) ≡ proj_lim _ Hγ0 x.
+ Proof. apply (proj2_sig x). Qed.
+End inverse_limit.
+
+Section inv_lim_extensional.
+ (* This whole section is a quite a mess because of dependent typing.
+ We need to unfold all the nasty equalities below to get the required commuting property
+ and somehow be able to rewrite with the dependent equalities.
+ At least we can use abstract for the irrelevant parts of the proofs, I guess... *)
+
+ Import Coq.Logic.PropExtensionality.
+ Import Coq.Logic.FunctionalExtensionality.
+ Lemma sigO_extensional (A : ofeT SI) (P1 P2 : A → Prop) : (∀ x, P1 x ↔ P2 x) → sigO P1 = sigO P2.
+ Proof.
+ intros H. unfold sigO.
+ assert (P1 = P2).
+ { abstract (apply functional_extensionality; intros; apply propositional_extensionality, H). }
+ by subst.
+ Defined.
+
+ Context
+ {P : SI → Prop} (X1 X2 : ∀ β, P β → ofeT SI)
+ (p1 : ∀ γ γ' Hγ Hγ' (Hlt : γ ≺ γ'), X1 γ' Hγ' -n> X1 γ Hγ)
+ (p2 : ∀ γ γ' Hγ Hγ' (Hlt : γ ≺ γ'), X2 γ' Hγ' -n> X2 γ Hγ)
+ (Heq : ∀ γ Hγ, X1 γ Hγ = X2 γ Hγ).
+ (* Hmorph states that p1 and p2 essentially are the same, modulo the type equality Heq *)
+ Context
+ (Hmorph : ∀ γ0 γ1 Hγ0 Hγ1 Hγ0γ1, p1 γ0 γ1 Hγ0 Hγ1 Hγ0γ1
+ ≡ @transport_id (X2 γ0 Hγ0) (X1 γ0 Hγ0) (ofe_eq_symm (Heq γ0 Hγ0))
+ ◎ p2 γ0 γ1 Hγ0 Hγ1 Hγ0γ1
+ ◎ @transport_id (X1 γ1 Hγ1) (X2 γ1 Hγ1) (Heq γ1 Hγ1)).
+
+ Lemma Hfulleq : X1 = X2.
+ Proof using Heq.
+ eapply functional_extensionality_dep. intros. eapply functional_extensionality_dep. intros. apply Heq.
+ Defined.
+
+ Lemma inv_lim_eq : inv_lim X1 p1 = inv_lim X2 p2.
+ Proof using Hmorph Heq.
+ unfold inv_lim.
+ specialize (Hfulleq) as ->.
+ apply sigO_extensional.
+ abstract (
+ setoid_rewrite (transport_id_identity) in Hmorph;
+ setoid_rewrite (ccompose_cid_l) in Hmorph;
+ setoid_rewrite (ccompose_cid_r) in Hmorph;
+
+ intros; split; intros; [
+ by setoid_rewrite <- (Hmorph _ _ _ _ _ _) |
+ by setoid_rewrite (Hmorph _ _ _ _ _ _)]).
+ Defined.
+
+ (** we show that proj_lim commutes with transports *)
+ Lemma unfold_transport_proj_lim :
+ ∀ γ Hγ, unfold_transport (Heq γ Hγ) ◎ proj_lim X1 p1 γ Hγ
+ ≡ proj_lim X2 p2 γ Hγ ◎ unfold_transport inv_lim_eq.
+ Proof.
+ intros.
+ unfold inv_lim_eq, Hfulleq. specialize Hfulleq as ->.
+ assert (Hp1p2 : ∀ γ0 γ1 Hγ0 Hγ1 Hγ0γ1, p1 γ0 γ1 Hγ0 Hγ1 Hγ0γ1 ≡ p2 γ0 γ1 Hγ0 Hγ1 Hγ0γ1).
+ { intros. setoid_rewrite Hmorph. intros z; cbn. by clear_transports. }
+
+ unfold sigO_extensional.
+
+ set (y := eq_ind_r _ _ _). cbn in y.
+ set (e := y p1 Heq Hmorph). generalize e. clear e y.
+ (* we need to prove that the two predicates we instantiate sigO with are the same *)
+ assert ((λ f : btowerO X2,
+ ∀ (γ0 γ1 : SI) (Hγ0γ1 : γ0 ≺ γ1) (Hγ0 : P γ0) (Hγ1 : P γ1),
+ p1 γ0 γ1 Hγ0 Hγ1 Hγ0γ1 (f γ1 Hγ1) ≡ f γ0 Hγ0)
+ = (λ f : btowerO X2,
+ ∀ (γ0 γ1 : SI) (Hγ0γ1 : γ0 ≺ γ1) (Hγ0 : P γ0) (Hγ1 : P γ1),
+ p2 γ0 γ1 Hγ0 Hγ1 Hγ0γ1 (f γ1 Hγ1) ≡ f γ0 Hγ0)).
+ {
+ apply functional_extensionality_dep; intros.
+ apply propositional_extensionality.
+ split; intros.
+ - setoid_rewrite <- (Hp1p2 _ _ _ _ _ _). apply H.
+ - setoid_rewrite (Hp1p2 _ _ _ _ _ _). apply H.
+ }
+ intros e. intros x.
+ cbn. unfold unfold_transport. clear_transports. revert e x.
+ unfold unfold_transport, inv_lim in *.
+ rewrite H.
+ intros e. rewrite (proof_irrel e eq_refl).
+ intros. unfold transport_id. cbn. reflexivity.
+ Qed.
+
+ Lemma fold_transport_proj_lim :
+ ∀ γ Hγ, fold_transport (Heq γ Hγ) ◎ proj_lim X2 p2 γ Hγ ≡ proj_lim X1 p1 γ Hγ ◎ fold_transport inv_lim_eq.
+ Proof.
+ intros.
+ enough (proj_lim X1 p1 γ Hγ ≡ fold_transport (Heq γ Hγ) ◎ proj_lim X2 p2 γ Hγ ◎ unfold_transport inv_lim_eq) as ->.
+ { rewrite !ccompose_assoc. unfold fold_transport, unfold_transport. setoid_rewrite transport_id_compose.
+ setoid_rewrite transport_id_identity. rewrite ccompose_cid_r. reflexivity. }
+ rewrite ccompose_assoc. rewrite <- unfold_transport_proj_lim.
+ rewrite <- ccompose_assoc. rewrite transport_id_compose transport_id_identity. by rewrite ccompose_cid_l.
+ Qed.
+End inv_lim_extensional.
+
+
+Section limit_case.
+ (* We assume an already merged approximation.
+ Later on, when we combine the cases, we use the above merged_agree lemma + transitivity of approx_agree to show that the new approximation we define in the limit case agrees with the original, unmerged approximations*)
+ Context (β : limit_idx SI) (IH : @bounded_approx (λ γ, γ ≺ β)).
+
+ Let X α (H: α ≺ β) := bounded_approx_X IH α H.
+ Let e := bounded_approx_e IH.
+ Let p := bounded_approx_p IH.
+
+ (* we apply the functor F to every Xα and then truncate at α -- thus FX α is equal to X (α + 1) *)
+ Definition FX : ∀ α, α ≺ β → ofeT SI := λ α Hα, [G (X α Hα)]_{succ α}.
+ Instance FX_cofe α Hα : Cofe (FX α Hα) := _.
+
+ Instance lX_truncated (α: SI) Hlt : OfeTruncated (X α Hlt) α.
+ Proof. eapply approx_X_truncated, IH. Qed.
+ Instance Xeq α Hlt Hslt : ofe_eq (X (succ α) Hslt) (FX α Hlt).
+ Proof. eapply approx_eq, IH. Defined.
+
+ Definition unfold α Hlt Hslt : X (succ α) Hslt -n> [G (X α Hlt)]_{succ α} := unfold_transport (Xeq α Hlt Hslt).
+ Definition fold α Hlt Hslt : [G (X α Hlt)]_{succ α} -n> X (succ α) Hslt := fold_transport (Xeq α Hlt Hslt).
+ Ltac clear_fold := unfold fold, unfold, unfold_transport, fold_transport.
+ Lemma unfold_fold_id α Hlt Hslt : unfold α Hlt Hslt ◎ fold α Hlt Hslt ≡ cid.
+ Proof. clear_fold. intros x. by clear_transports. Qed.
+ Lemma fold_unfold_id α Hlt Hslt : fold α Hlt Hslt ◎ unfold α Hlt Hslt ≡ cid.
+ Proof. clear_fold. intros x. by clear_transports. Qed.
+
+ (* restating the fold/unfolds from the IH *)
+ Let p_functorial α₠α₂ α₃ Hα₠Hα₂ Hα₃ Hlt1 Hlt2 Hlt3 : (p α₠α₂ Hα₠Hα₂ Hlt1) ◎ (p α₂ α₃ Hα₂ Hα₃ Hlt2) ≡ (p α₠α₃ Hα₠Hα₃ Hlt3).
+ Proof. eapply approx_p_funct. apply IH. Qed.
+ Let e_functorial α₠α₂ α₃ Hα₠Hα₂ Hα₃ Hlt1 Hlt2 Hlt3 : (e α₂ α₃ Hα₂ Hα₃ Hlt2) ◎ (e α₠α₂ Hα₠Hα₂ Hlt1) ≡ (e α₠α₃ Hα₠Hα₃ Hlt3).
+ Proof. eapply approx_e_funct. apply IH. Qed.
+
+ Let e_p_id α₠α₂ Hα₠Hα₂ Hlt : (e α₠α₂ Hα₠Hα₂ Hlt) â—Ž (p α₠α₂ Hα₠Hα₂ Hlt) ≡{αâ‚}≡ cid.
+ Proof. eapply approx_e_p_id, IH. Qed.
+ Let p_e_id α₠α₂ Hα₠Hα₂ Hlt : (p α₠α₂ Hα₠Hα₂ Hlt) ◎ (e α₠α₂ Hα₠Hα₂ Hlt) ≡ cid.
+ Proof. eapply approx_p_e_id, IH. Qed.
+
+ Let ϕ : ∀ α (Hα : α ≺ β), X α Hα -n> FX α Hα. eapply bounded_approx_ϕ. Defined.
+ Let ψ : ∀ α (Hα : α ≺ β), FX α Hα -n> X α Hα. eapply bounded_approx_ψ. Defined.
+
+ Let ψ_ϕ_id α Hα: (ψ α Hα) ◎ (ϕ α Hα) ≡ cid. eapply approx_ψ_ϕ_id; apply IH. Qed.
+ Let ϕ_ψ_id α Hα : (ϕ α Hα) ◎ (ψ α Hα) ≡{α}≡ cid. eapply approx_ϕ_ψ_id, IH. Qed.
+
+ Let p_ψ_unfold γ Hγ Hsγ (Hlt : γ ≺ succ γ): p γ (succ γ) Hγ Hsγ Hlt ≡ ψ γ Hγ ◎ unfold γ Hγ Hsγ.
+ Proof. by eapply approx_p_ψ_unfold. Qed.
+ Let e_fold_ϕ γ Hγ Hsγ (Hlt : γ ≺ succ γ): e γ (succ γ) Hγ Hsγ Hlt ≡ fold γ Hγ Hsγ ◎ ϕ γ Hγ.
+ Proof. by eapply approx_e_fold_Ï•. Qed.
+
+ Let ψ_p_fold γ Hγ Hsγ (Hlt : γ ≺ succ γ): ψ γ Hγ ≡ p γ (succ γ) Hγ Hsγ Hlt ◎ fold γ Hγ Hsγ.
+ Proof. intros x. setoid_rewrite (p_ψ_unfold _ _ _ _ _). cbn. by setoid_rewrite (unfold_fold_id _ _ _ _). Qed.
+ Let ϕ_unfold_e γ Hγ Hsγ (Hlt : γ ≺ succ γ): ϕ γ Hγ ≡ unfold γ Hγ Hsγ ◎ e γ (succ γ) Hγ Hsγ Hlt.
+ Proof. intros x. cbn. setoid_rewrite (e_fold_Ï• _ _ _ _ x). by setoid_rewrite (unfold_fold_id _ _ _ _). Qed.
+
+ Let ψ_succ_id γ Hle Hsle : ψ (succ γ) Hsle ≡ fold γ Hle Hsle ◎ trunc_map (succ (succ γ)) (succ γ) (map (fold γ Hle Hsle ◎ ϕ γ Hle, ψ γ Hle ◎ unfold γ Hle Hsle)).
+ Proof. by eapply approx_ψ_succ_id. Qed.
+
+ Let X_pi_id γ γ' Hγ Hγ' : γ = γ' → ofe_eq (X γ Hγ) (X γ' Hγ').
+ Proof. intros ->. pi_clear. reflexivity. Qed.
+
+ (** the maps F(e_{αâ‚, α₂}, p_{αâ‚, α₂}) lifted to the truncation -- essentially, this is equal to p_{1+αâ‚, 1 + α₂} *)
+ Program Definition Fep : ∀ α₠α₂ Hα₠Hα₂, α₠≺ α₂ → FX α₂ Hα₂ -n> FX α₠Hαâ‚
+ := λ α₠α₂ Hα₠Hα₂ Hlt, trunc_map _ _ (map (e α₠α₂ Hα₠Hα₂ Hlt, p α₠α₂ Hα₠Hα₂ Hlt)).
+
+ (* we have the equality fold_G ◎ Fep ◎ unfold_G ≡ p (for suitable indices) *)
+ Let Fep_lifts_p γ0 γ1 (Hγ0 : γ0 ≺ β) (Hγ1 : γ1 ≺ β) (Hsγ0 : (succ γ0) ≺ β) (Hsγ1 : (succ γ1) ≺ β) (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1) :
+ (fold γ0 Hγ0 Hsγ0) ◎ (Fep γ0 γ1 Hγ0 Hγ1 Hlt) ◎ (unfold γ1 Hγ1 Hsγ1) ≡ p (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts.
+ Proof. eapply approx_Fep_p. Qed.
+
+ Lemma Fep_unfold γ0 γ1 (Hγ0 : γ0 ≺ β) (Hγ1 : γ1 ≺ β) (Hsγ0 : (succ γ0) ≺ β) (Hsγ1 : (succ γ1) ≺ β) (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1) :
+ (Fep γ0 γ1 Hγ0 Hγ1 Hlt) ◎ (unfold γ1 Hγ1 Hsγ1) ≡ (unfold γ0 Hγ0 Hsγ0) ◎ p (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts.
+ Proof.
+ intros x. cbn. setoid_rewrite <- (Fep_lifts_p _ _ _ _ _ _ _ _ x).
+ cbn -[Fep].
+ Unshelve. 2-4: eauto.
+ setoid_rewrite (unfold_fold_id _ _ _ _). cbn. reflexivity.
+ Qed.
+
+ Lemma fold_Fep γ0 γ1 (Hγ0 : γ0 ≺ β) (Hγ1 : γ1 ≺ β) (Hsγ0 : (succ γ0) ≺ β) (Hsγ1 : (succ γ1) ≺ β) (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1) :
+ (fold γ0 Hγ0 Hsγ0) ◎ (Fep γ0 γ1 Hγ0 Hγ1 Hlt) ≡ p (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts ◎ (fold γ1 Hγ1 Hsγ1).
+ Proof.
+ intros x. cbn -[Fep].
+ setoid_rewrite <- (Fep_lifts_p _ _ _ _ _ _ _ _ _).
+ cbn -[Fep]. by setoid_rewrite (unfold_fold_id _ _ _ _).
+ Qed.
+
+ Arguments Fep : simpl never.
+
+ (** The inverse limit. This definition is not a COFE and does not yet satisfy the properties we need, but it is close.
+ We will essentially apply the successor case construction once to fix this up (see below).
+ *)
+ Definition Xβ := inv_lim FX Fep.
+ Definition proj_Xβ := proj_lim FX Fep.
+ Lemma Xβ_equalises γ0 γ1 Hγ0 Hγ1 Hlt: Fep γ0 γ1 Hγ0 Hγ1 Hlt ◎ proj_Xβ γ1 Hγ1 ≡ proj_Xβ γ0 Hγ0.
+ Proof. intros x. apply (inv_lim_equalises FX Fep). Qed.
+
+ (** Definition of eβ *)
+ Program Definition eβ : ∀ γ (Hγ : γ ≺ β), (X γ Hγ) -n> Xβ
+ := λ γ Hγ, λne (x : X γ Hγ), exist _ (λ γ' Hγ',
+ match index_lt_eq_lt_dec (succ γ') γ with
+ | inl (inl Hlt) =>
+ unfold γ' _ _ (p (succ γ') γ _ Hγ Hlt x) : [G (X γ' Hγ')]_{succ γ'}
+ | inl (inr Heq) =>
+ unfold _ _ _ (@transport_id (X γ Hγ) (X (succ γ') _) (X_pi_id _ _ _ _ (symmetry Heq)) x)
+ | inr Hgt => unfold γ' _ _ (e γ (succ γ') Hγ _ Hgt x) : [G (X γ' Hγ')]_{succ γ'}
+ end : FX γ' Hγ' ) _.
+ Next Obligation. intros. by eapply limit_index_is_limit. Defined.
+ Next Obligation. intros. rewrite Heq. apply Hγ. Defined.
+ Next Obligation. intros. by eapply limit_index_is_limit. Defined.
+ Next Obligation.
+ (* equaliser property *)
+ intros. intros γ0 γ1 Hγ0γ1 Hγ0 Hγ1. cbn -[Fep].
+ destruct (index_lt_eq_lt_dec (succ γ1) γ) as [[Hlt1 | Heq1] | Hgt1],
+ (index_lt_eq_lt_dec (succ γ0) γ) as [[Hlt0 | Heq0] | Hgt0].
+ all: try by (subst; index_contra_solve).
+ - setoid_rewrite (Fep_unfold _ _ _ _ _ _ _ _ _).
+ cbn. by setoid_rewrite (p_functorial _ _ _ _ _ _ _ _ _ x).
+ Unshelve. eauto 3 with index.
+ - subst. cbn. setoid_rewrite (Fep_unfold _ _ _ _ _ _ _ _ _). cbn.
+ clear_transports. reflexivity.
+ - setoid_rewrite (Fep_unfold _ _ _ _ _ _ _ _ _).
+ cbn. apply ofe_mor_f_equal.
+ setoid_rewrite <- (p_functorial (succ γ0) γ (succ γ1) _ _ _ _ _ _ _).
+ cbn. apply ofe_mor_f_equal. by setoid_rewrite (p_e_id _ _ _ _ _ _).
+ Unshelve. by eapply index_lt_succ_mono.
+ - destruct Heq0. cbn -[Fep].
+ setoid_rewrite (Fep_unfold _ _ _ _ _ _ _ _ _). cbn. apply ofe_mor_f_equal.
+ equalise_pi_head. clear_transports. by setoid_rewrite (p_e_id _ _ _ _ _ _ ).
+ - setoid_rewrite (Fep_unfold _ _ _ _ _ _ _ _ _). cbn. apply ofe_mor_f_equal.
+ setoid_rewrite <- (e_functorial γ (succ γ0) (succ γ1) _ _ _ _ _ _ _).
+ setoid_rewrite (p_e_id _ _ _ _ _ _). cbn. reflexivity.
+ Unshelve. by apply index_lt_succ_mono.
+ Qed.
+ Next Obligation.
+ (* non-expansiveness *)
+ intros γ Hγ α. cbn. intros x y Heq i Hi. cbn.
+ destruct (index_lt_eq_lt_dec (succ i) γ) as [[Hlti | Heqi] | Hgti]; subst; by rewrite Heq.
+ Qed.
+
+ (** Definition of pβ *)
+ Definition pβ : ∀ γ (Hγ : γ ≺ β), Xβ -n> X γ Hγ :=
+ λ γ Hγ, ψ γ Hγ ◎ (proj_Xβ γ Hγ).
+
+ (** Showing that these definitions satisfy the inverse/functoriality/etc stuff *)
+
+ Hint Extern 2 => apply limit_index_is_limit : index.
+ Lemma eβ_pβ_id γ Hγ: eβ γ Hγ ◎ pβ γ Hγ ≡{γ}≡ cid.
+ Proof.
+ intros x. apply inv_lim_dist_iff. intros δ Hδ.
+ destruct x as [x Hx]. cbn.
+ destruct (index_lt_eq_lt_dec (succ δ) γ) as [[Hlt | Heq] | Hgt].
+ - setoid_rewrite (ψ_p_fold _ _ _ _ _).
+ cbn. setoid_rewrite (p_functorial _ _ _ _ _ _ _ _ _ _).
+ setoid_rewrite <- (Fep_unfold _ _ _ _ _ _ _ _ _).
+ cbn. setoid_rewrite (unfold_fold_id _ _ _ _).
+ cbn. setoid_rewrite (Hx _ _ _ _ _).
+ reflexivity.
+ Unshelve. all: eauto 4 with index.
+ - destruct Heq. cbn. setoid_rewrite (ψ_p_fold _ _ _ _ _).
+ setoid_rewrite <- (Fep_lifts_p _ _ _ _ _ _ _ _ _).
+ cbn. clear_transports. setoid_rewrite (unfold_fold_id _ _ _ _).
+ cbn. setoid_rewrite (unfold_fold_id _ _ _ _).
+ cbn. by setoid_rewrite (Hx _ _ _ _ _).
+ Unshelve. all: eauto 4 with index.
+ - setoid_rewrite (ψ_p_fold _ _ _ _ _).
+ destruct (index_lt_eq_lt_dec γ δ) as [[Hγlt | Hγeq] | Hγgt].
+ + setoid_rewrite <- (e_functorial γ (succ γ) (succ δ) _ _ _ _ _ _ _ ).
+ cbn. setoid_rewrite (e_p_id γ (succ γ) _ _ _ _). 2: auto.
+ cbn. setoid_rewrite <- (Hx _ _ _ _ _) at 1.
+ setoid_rewrite (fold_Fep _ _ _ _ _ _ _ _ _). cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (e_p_id (succ γ) (succ δ) _ _ _ _)). 2: { apply index_succ_greater. }
+ setoid_rewrite (unfold_fold_id _ _ _ _). reflexivity.
+ Unshelve. all: eauto 4 with index.
+ + subst.
+ rewrite (proof_irrel Hgt (index_succ_greater δ)).
+ rewrite (proof_irrel (eβ_obligation_3 δ Hδ) (limit_index_is_limit β δ Hγ)).
+ setoid_rewrite (e_p_id _ _ _ _ _ _).
+ cbn. rewrite (proof_irrel Hδ Hγ). by setoid_rewrite (unfold_fold_id _ _ _ _).
+ + index_contra_solve.
+ Qed.
+
+ Lemma pβ_eβ_id γ Hγ: pβ γ Hγ ◎ eβ γ Hγ ≡ cid.
+ Proof.
+ intros x.
+ cbn. destruct (index_lt_eq_lt_dec (succ γ) γ) as [[H1 | H1] | H1].
+ 1-2: index_contra_solve.
+ setoid_rewrite <- (p_ψ_unfold _ _ _ _ _). apply p_e_id.
+ Qed.
+
+ Lemma eβ_functorial γ0 γ1 Hγ0 Hγ1 Hlt: eβ γ0 Hγ0 ≡ eβ γ1 Hγ1 ◎ e γ0 γ1 Hγ0 Hγ1 Hlt .
+ Proof.
+ intros x. apply inv_lim_eq_iff. intros γ Hγ. cbn.
+ destruct (index_lt_eq_lt_dec (succ γ) γ0) as [[H1 | H1] | H1],
+ (index_lt_eq_lt_dec (succ γ) γ1) as [[H2 | H2] | H2].
+ all: try index_contra_solve.
+ - setoid_rewrite <- (p_functorial (succ γ) γ0 γ1 _ _ _ _ _ _ _).
+ cbn. setoid_rewrite (p_e_id _ _ _ _ _ _). reflexivity.
+ - subst. cbn.
+ rewrite (proof_irrel (eβ_obligation_1 _ _) Hγ0).
+ rewrite (proof_irrel H2 Hlt).
+ setoid_rewrite (p_e_id _ _ _ _ _ _).
+ clear_transports. reflexivity.
+ - setoid_rewrite <- (e_functorial γ0 (succ γ) γ1 _ _ _ _ _ _ _).
+ cbn. setoid_rewrite (p_e_id _ _ _ _ _ _). cbn. reflexivity.
+ - subst. cbn. equalise_pi_head. rewrite (proof_irrel H1 Hlt). clear_transports. reflexivity.
+ - setoid_rewrite (e_functorial _ _ _ _ _ _ _ _ _ _). reflexivity.
+ Qed.
+
+ Lemma pβ_functorial γ0 γ1 Hγ0 Hγ1 Hlt: pβ γ0 Hγ0 ≡ p γ0 γ1 Hγ0 Hγ1 Hlt ◎ pβ γ1 Hγ1.
+ Proof.
+ intros x. cbn.
+ setoid_rewrite (ψ_p_fold _ _ _ _ _). cbn. setoid_rewrite (p_functorial γ0 γ1 (succ γ1) _ _ _ _ _ _ _).
+ setoid_rewrite <- (inv_lim_equalises _ _ _ _ _ _ _ x) at 1.
+ setoid_rewrite (fold_Fep _ _ _ _ _ _ _ _ _). cbn. setoid_rewrite (p_functorial _ _ _ _ _ _ _ _ _ _).
+ reflexivity.
+ Unshelve. all: eauto 3 with index.
+ Qed.
+
+ (** We now define ϕ, ψ. These are not the final definitions yet, see below. *)
+
+ (** definition of ψ *)
+ Program Definition ψβ : [G Xβ]_{β} -n> Xβ :=
+ λne x, exist _ (λ γ' Hγ',
+ trunc_map _ _ (map (eβ γ' Hγ', pβ γ' Hγ')) x) _.
+ Next Obligation.
+ intros x γ0 γ1 Hγ0γ1 Hγ0 Hγ1.
+ unfold Fep. cbn.
+ eapply ofe_truncated_equiv. apply _.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)).
+ 2: eauto with index.
+ cbn. rewrite ofe_mor_f_equal. reflexivity.
+ apply equiv_dist => α.
+ map_compose_tac.
+ setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne.
+ by rewrite <- (eβ_functorial).
+ symmetry; apply equiv_dist. apply pβ_functorial. (* weird stuff again, rewrite does not find matching occurrence *)
+ }
+ all: reflexivity.
+ Qed.
+ Next Obligation.
+ intros α x y Heq. apply inv_lim_dist_iff. intros γ Hγ. cbn. by rewrite Heq.
+ Qed.
+
+ (** definition of Ï•*)
+ Program Definition ϕβ : Xβ -n> [G Xβ]_{β} :=
+ λne x, bcompl _ (mkbchain _ ([G Xβ]_{β}) β (λ γ Hγ,
+ trunc_map (succ γ) β (map (pβ γ Hγ, eβ γ Hγ)) (proj_lim _ _ γ _ x))_).
+ Next Obligation.
+ intros _. apply limit_index_not_zero.
+ Defined.
+ Next Obligation.
+ intros x γ' γ Hle Hγ' Hγ. cbn.
+ destruct Hle as [-> | Hlt].
+ { assert (Hγ' = Hγ) as ->. 2: reflexivity. apply proof_irrel. }
+ destruct x as [x Hx].
+ symmetry.
+ rewrite ofe_mor_ne.
+ 2: by setoid_rewrite <- Hx.
+ Unshelve. 2: exact γ. 2, 3: eauto.
+ unfold Fep. cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)).
+ 2: eauto with index.
+ cbn.
+
+ apply ofe_mor_ne. map_compose_tac.
+
+ (* now we need to use composition of functors *)
+ setoid_rewrite oFunctor_ne.
+ 2: { rewrite pair_ne.
+ 2: { rewrite ccompose_ne. 3: setoid_rewrite (pβ_functorial _ _ _ _ _); reflexivity.
+ 2: reflexivity.
+ rewrite <- ccompose_assoc.
+ setoid_rewrite (dist_mono' _ _ _ _ (e_p_id _ _ _ _ _) ).
+ by rewrite ccompose_cid_l. by left.
+ }
+ 2: { rewrite ccompose_ne. 2: setoid_rewrite (eβ_functorial _ _ _ _ _); reflexivity.
+ 2: reflexivity.
+ rewrite ccompose_assoc.
+ setoid_rewrite (dist_mono' _ _ _ _ _) at 1.
+ reflexivity.
+ rewrite ccompose_ne; [ | reflexivity | eapply e_p_id]. by rewrite ccompose_cid_r.
+ by left.
+ }
+ reflexivity.
+ }
+ all: reflexivity.
+ Qed.
+ Next Obligation.
+ intros α x y Heq.
+ destruct (index_lt_eq_lt_dec α β) as [[Hα | -> ]| Hβ].
+ - rewrite !conv_bcompl. cbn -[proj_lim].
+ apply ofe_mor_ne.
+ by rewrite Heq.
+ Unshelve. auto.
+ - apply cofe_unique_lim. apply limit_index_is_limit.
+ intros γ Hγ. cbn -[proj_lim].
+ do 3 apply ofe_mor_ne.
+ eapply dist_mono' in Heq. 2: right; apply Hγ.
+ apply (proj1 (inv_lim_dist_iff _ _ _ _ _) Heq).
+ - eapply ofe_truncated_dist. apply _. rewrite index_min_r. 2: by right.
+ apply cofe_unique_lim; [apply limit_index_is_limit |]. intros γ Hγ. cbn.
+ do 3 apply ofe_mor_ne.
+ apply (dist_mono _ _ _ _ (proj1 (inv_lim_dist_iff _ _ _ _ _) Heq γ Hγ)). by etransitivity.
+ Qed.
+
+ (** Verifying property (9) *)
+ (* first a few lemmas that will help us with one particular step of the chain of rewrites *)
+ Lemma pβ_eβ_up γ γ' Hγ Hγ' Hlt : pβ γ' Hγ' ◎ eβ γ Hγ ≡ e γ γ' Hγ Hγ' Hlt.
+ Proof.
+ setoid_rewrite (eβ_functorial γ γ' Hγ Hγ' Hlt).
+ rewrite -ccompose_assoc. setoid_rewrite (pβ_eβ_id γ' Hγ').
+ by rewrite ccompose_cid_l.
+ Qed.
+
+ Lemma pβ_eβ_down γ γ' Hγ Hγ' Hgt : pβ γ' Hγ' ◎ eβ γ Hγ ≡ p γ' γ Hγ' Hγ Hgt.
+ Proof.
+ rewrite pβ_functorial.
+ rewrite ccompose_assoc.
+ Unshelve. 4: apply Hgt. 2: apply Hγ.
+ rewrite (pβ_eβ_id γ Hγ).
+ by rewrite ccompose_cid_r.
+ Qed.
+
+ Lemma pβ_eβ_id' γ γ' Hγ Hγ' (x : Xβ): trunc_map _ _ (map (pβ γ' Hγ' ◎ eβ γ Hγ, pβ γ Hγ ◎ eβ γ' Hγ')) (proj_Xβ _ Hγ' x) ≡{γ'}≡ proj_Xβ _ Hγ x.
+ Proof using Fcontr.
+ destruct (index_lt_eq_lt_dec γ γ') as [[Hlt | Heq] | Hgt].
+ - cbn. setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne.
+ - by rewrite pβ_eβ_up.
+ - by rewrite pβ_eβ_down.
+ }
+ specialize (inv_lim_equalises _ _ γ γ' Hlt Hγ Hγ' x) as Heq.
+ unfold Fep in Heq. cbn in Heq. cbn. rewrite <- Heq. reflexivity.
+ - cbn. subst. rewrite (proof_irrel Hγ Hγ'). setoid_rewrite oFunctor_ne.
+ 2: apply pair_ne; by rewrite pβ_eβ_id.
+ rewrite oFunctor_id. cbn. by setoid_rewrite (ofe_trunc_truncate_expand_id _).
+ - specialize (inv_lim_equalises _ _ γ' γ Hgt Hγ' Hγ x) as Heq.
+ cbn. rewrite ofe_mor_ne.
+ 2: setoid_rewrite <- Heq; reflexivity.
+ cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)).
+ 2: apply index_succ_greater. cbn.
+
+ rewrite ofe_mor_ne.
+ 2: {
+ setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne.
+ - by unshelve setoid_rewrite pβ_eβ_down.
+ - by unshelve setoid_rewrite pβ_eβ_up.
+ }
+ Fail setoid_rewrite (map_compose_dist _ _ _ _ _ _).
+ map_compose_tac.
+ setoid_rewrite Fcontr.
+ 2: intros γ'' Hγ''; apply pair_ne; (eapply dist_mono; [apply e_p_id | assumption]).
+ rewrite oFunctor_id. reflexivity.
+ }
+ by setoid_rewrite (ofe_trunc_truncate_expand_id _).
+ Qed.
+
+ Instance lXβ_truncated : OfeTruncated Xβ β.
+ Proof.
+ intros x y α Hβ. split.
+ - setoid_rewrite inv_lim_dist_iff. intros Heq γ Hγ.
+ destruct x as [x Hx], y as [y Hy].
+ cbn. specialize (Heq γ Hγ).
+ cbn in Heq. rewrite ofe_truncated_dist. rewrite index_min_r.
+ 2: eauto with index.
+ eapply dist_mono; [apply Heq | by apply limit_index_is_limit, Hγ].
+ - intros Heq γ Hγ. eapply dist_mono'. apply (Heq γ). auto.
+ Qed.
+
+ Lemma ψβ_ϕβ_id : ψβ ◎ ϕβ ≡ cid.
+ Proof using Fcontr.
+ intros x. apply inv_lim_eq_iff. intros γ Hγ.
+ unfold Fep, ϕβ.
+ eapply ofe_truncated_equiv. apply _.
+ cbn -[trunc_map].
+ (* we move the truncated map inside the limit *)
+ rewrite bounded_ne_bcompl. 2: eauto 3 with index.
+ (* now we rewrite a bit inside the limit *)
+ unshelve erewrite (cofe_bcompl_weakly_unique _ _ _ _ _ _ _ _ _).
+ 1: { (* we pick the constant chain with the γ-th component of the limit x *)
+ apply bchain_const. apply (proj_lim _ _ γ Hγ x).
+ }
+ 1: {
+ intros γ' Hγ'. cbn.
+ etransitivity.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)). 2: auto.
+ setoid_rewrite (map_compose _ _ _ _ _).
+ apply pβ_eβ_id'. reflexivity.
+ }
+ 2: rewrite bcompl_bchain_const. all: eauto 3 with index.
+ Qed.
+
+ (** Verifying property (10) *)
+ Lemma ϕβ_ψβ_id : dist_later β (ϕβ ◎ ψβ) cid.
+ Proof using Fcontr.
+ intros γ Hγ x.
+ setoid_rewrite (cofe_bcompl_weakly_unique _ _ _ _ _ _ _ γ Hγ).
+
+ instantiate (1 := bchain_const _ β).
+ 2: {
+ intros γ' Hγ'. cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)).
+ 2: apply index_succ_greater.
+ cbn.
+
+ rewrite ofe_mor_ne. 2: {
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne. all: apply eβ_pβ_id. }
+ rewrite oFunctor_id.
+ reflexivity.
+ }
+ setoid_rewrite (ofe_trunc_truncate_expand_id _) at 1. cbn.
+ change x with ((λ (γ : SI) (Hγ : γ ≺ β), x) γ' Hγ') at 1.
+ reflexivity.
+ }
+ rewrite bcompl_bchain_const; auto.
+ Qed.
+
+ Lemma Fep_p_limit γ0 Hlt Hslt: (fold γ0 Hlt Hslt) ◎ (trunc_map β (succ γ0) (map (eβ γ0 Hlt, pβ γ0 Hlt))) ≡ pβ (succ γ0) Hslt ◎ ψβ.
+ Proof using ψ_succ_id Fcontr Funique.
+ (* multiply with Ï• from the right *)
+ enough (fold γ0 Hlt Hslt ◎ trunc_map β (succ γ0) (map (eβ γ0 Hlt, pβ γ0 Hlt)) ◎ ϕβ ≡ pβ (succ γ0) Hslt) as H.
+ {
+ rewrite <- H. setoid_rewrite ccompose_assoc at 2.
+ rewrite ofe_truncated_equiv.
+ setoid_rewrite (ϕβ_ψβ_id (succ γ0) Hslt). rewrite ccompose_cid_r. reflexivity.
+ }
+ setoid_rewrite ccompose_assoc.
+ rewrite ofe_truncated_equiv.
+ assert ((trunc_map β (succ γ0) (map (eβ γ0 Hlt, pβ γ0 Hlt)) ◎ ϕβ) ≡{succ γ0}≡ proj_Xβ γ0 Hlt) as ->.
+ { setoid_rewrite <- ccompose_cid_r at 7. rewrite <- ψβ_ϕβ_id.
+ intros x. reflexivity.
+ }
+ unfold pβ.
+ rewrite ψ_succ_id.
+ rewrite <- Xβ_equalises.
+ unfold Fep. Unshelve. 4: apply Hslt. 2-3: eauto 4 with index.
+ cbn. rewrite oFunctor_ne. 2: { rewrite e_fold_ϕ. rewrite p_ψ_unfold. reflexivity. }
+ intros x; reflexivity.
+ Qed.
+
+ (** Without smoothness of equality at limit ordinals, we can only get the dist_later in the statement (10) above.
+ Our fix: just apply the successor case once; as the functor is contractive, this will give us strong enough inverses. *)
+ Definition Xβ' : COFE SI := cofe _ [G Xβ]_{β}.
+
+ Definition ϕβ' : Xβ' -n> [G Xβ']_{succ β} := trunc_map β (succ β) (map (ψβ, ϕβ)).
+ Definition ψβ' : [G Xβ']_{succ β} -n> Xβ' := trunc_map (succ β) β (map (ϕβ, ψβ)).
+
+ Lemma ϕβ'_ψβ'_id: ϕβ' ◎ ψβ' ≡{β}≡ cid.
+ Proof using Fcontr.
+ intros x. unfold ϕβ', ψβ'. cbn.
+ rewrite ofe_mor_ne. 2: { rewrite ofe_mor_ne.
+ 2: { setoid_rewrite (ofe_trunc_expand_truncate_id _). cbn. reflexivity. }
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _). setoid_rewrite Fcontr.
+ 2: { instantiate (1 := (cid, cid)).
+ intros α Hα. split; intros y; cbn -[ϕβ ψβ]; apply ϕβ_ψβ_id; assumption.
+ }
+ rewrite oFunctor_id. reflexivity.
+ }
+ by setoid_rewrite (ofe_trunc_truncate_expand_id _).
+ Qed.
+
+ Lemma ψβ'_ϕβ'_id: ψβ' ◎ ϕβ' ≡ cid.
+ Proof using Fcontr.
+ intros x. unfold ψβ', ϕβ'. cbn. apply equiv_dist; intros α.
+ rewrite ofe_truncated_dist ofe_mor_ne.
+ 2: {
+ eapply dist_mono.
+ setoid_rewrite (ofe_trunc_expand_truncate_id _).
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _). setoid_rewrite Fcontr.
+ 2: { instantiate (1 := (cid, cid)).
+ intros α' Hα'. eapply dist_mono'. 2: right; apply Hα'.
+ split; intros y; cbn -[ψβ ϕβ]; by setoid_rewrite (ψβ_ϕβ_id _).
+ }
+ rewrite oFunctor_id. reflexivity.
+ unfold index_min.
+ destruct (index_le_total α β); eauto 4 with index.
+ }
+ by setoid_rewrite (ofe_trunc_truncate_expand_id _).
+ Qed.
+
+ Definition eβ' : ∀ γ (Hγ : γ ≺ β), X γ Hγ -n> Xβ'
+ := λ γ Hγ, ϕβ ◎ eβ γ Hγ.
+ Definition pβ' : ∀ γ (Hγ : γ ≺ β), Xβ' -n> X γ Hγ
+ := λ γ Hγ, pβ γ Hγ ◎ ψβ.
+
+ Lemma eβ'_pβ'_id γ Hγ : eβ' γ Hγ ◎ pβ' γ Hγ ≡{γ}≡ cid.
+ Proof using Fcontr.
+ intros x. unfold eβ', pβ'. cbn -[ϕβ ψβ eβ pβ].
+ setoid_rewrite (eβ_pβ_id _ _ _). setoid_rewrite (ϕβ_ψβ_id γ Hγ _). reflexivity.
+ Qed.
+
+ Lemma pβ'_eβ'_id γ Hγ : pβ' γ Hγ ◎ eβ' γ Hγ ≡ cid.
+ Proof using Fcontr.
+ intros x. cbn -[ϕβ ψβ eβ pβ].
+ setoid_rewrite (ψβ_ϕβ_id _). setoid_rewrite (pβ_eβ_id γ Hγ _). reflexivity.
+ Qed.
+
+ Lemma eβ'_functorial γ0 γ1 Hγ0 Hγ1 Hlt: eβ' γ1 Hγ1 ◎ e γ0 γ1 Hγ0 Hγ1 Hlt ≡ eβ' γ0 Hγ0.
+ Proof.
+ symmetry. unfold eβ'. rewrite eβ_functorial. rewrite ccompose_assoc. reflexivity.
+ Qed.
+
+ Lemma pβ'_functorial γ0 γ1 Hγ0 Hγ1 Hlt: p γ0 γ1 Hγ0 Hγ1 Hlt ◎ pβ' γ1 Hγ1 ≡ pβ' γ0 Hγ0.
+ Proof.
+ symmetry. unfold pβ'. rewrite pβ_functorial. rewrite ccompose_assoc. reflexivity.
+ Qed.
+
+ Lemma Fep_p_limit0 γ0 Hlt Hslt: (fold γ0 Hlt Hslt) ◎ (trunc_map (succ β) (succ γ0) (map (eβ' γ0 Hlt, pβ' γ0 Hlt))) ≡ pβ' (succ γ0) Hslt ◎ ψβ'.
+ Proof using ψ_succ_id Fcontr Funique.
+ unfold eβ', pβ', ψβ'.
+ rewrite <- Fep_p_limit.
+ setoid_rewrite ccompose_assoc at 3.
+ rewrite ofe_truncated_equiv.
+ setoid_rewrite <- (dist_mono _ _ _ _ (trunc_map_compose _ _ _ _ _)).
+ 2: assumption.
+ by rewrite map_compose.
+ Qed.
+
+ (** ** Defining the limit extension *)
+ Program Definition limit_extension : extension IH :=
+ {|
+ ext_Xγ := Xβ';
+ ext_eγ := eβ';
+ ext_pγ := pβ';
+ ext_ϕγ := ϕβ';
+ ext_ψγ := ψβ';
+ |}.
+ Solve Obligations with
+ (intros;
+ try match goal with
+ | H : limit_index β = succ _ |- _ =>
+ exfalso; eapply index_limit_not_succ; [ | apply H]; refine (limit_index_is_limit _)
+ end).
+ Next Obligation. apply pβ'_eβ'_id. Qed.
+ Next Obligation. apply eβ'_pβ'_id. Qed.
+ Next Obligation. apply eβ'_functorial. Qed.
+ Next Obligation. apply pβ'_functorial. Qed.
+ Next Obligation. apply ψβ'_ϕβ'_id. Qed.
+ Next Obligation. apply ϕβ'_ψβ'_id. Qed.
+ Next Obligation. intros. apply Fep_p_limit0. Qed.
+End limit_case.
+
+Section limit_coherent.
+ Context (β : limit_idx SI) (A0 A1 : bounded_approx (λ γ, γ ≺ β)) (H : approx_agree A0 A1).
+
+ Lemma FX_eq γ Hγ: FX β A0 γ Hγ = FX β A1 γ Hγ.
+ Proof using H. unfold FX. by rewrite (agree_eq H _ _ _). Qed.
+
+ Lemma Xβ_eq : Xβ β A0 = Xβ β A1.
+ Proof using H Fcontr.
+ unfold Xβ.
+ unshelve eapply inv_lim_eq. apply FX_eq.
+ intros. unfold Fep. cbn.
+ setoid_rewrite (agree_e_nat H _ _ _ _ _ _ _).
+ setoid_rewrite (agree_p_nat H _ _ _ _ _ _ _).
+ intros x; cbn. rewrite ofe_truncated_equiv.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne. { setoid_rewrite ccompose_assoc. reflexivity. } reflexivity. }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ unfold unfold_transport, fold_transport.
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _). cbn.
+ unfold FX. equalise_pi_head. do 3 apply ofe_mor_ne.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _). cbn.
+ clear_transports. equalise_pi.
+ Unshelve. all: reflexivity.
+ Defined.
+
+ (* if we plug in the same OFE into the functor, we also get the same Cofe instance out *)
+ Lemma FXβ_eq : cofe _ [G (Xβ β A0)]_{β} = cofe _ [G (Xβ β A1)]_{β}.
+ Proof using H Fcontr. by rewrite (Xβ_eq). Qed.
+
+
+ Lemma proj_Xβ_eq_fold γ' Hγ' :
+ proj_lim (FX β A0) (Fep β A0) γ' Hγ' ◎ fold_transport Xβ_eq ≡
+ fold_transport (FX_eq γ' Hγ') ◎ proj_lim (FX β A1) (Fep β A1) γ' Hγ'.
+ Proof.
+ symmetry. rewrite fold_transport_proj_lim. intros x. equalise_pi.
+ Qed.
+
+ Lemma proj_Xβ_eq_unfold γ' Hγ' :
+ proj_lim (FX β A1) (Fep β A1) γ' Hγ' ◎ unfold_transport Xβ_eq ≡
+ unfold_transport (FX_eq γ' Hγ') ◎ proj_lim (FX β A0) (Fep β A0) γ' Hγ'.
+ Proof.
+ symmetry. rewrite unfold_transport_proj_lim. intros x; equalise_pi.
+ Qed.
+
+ Lemma eβ_coherent γ Hγ : eβ β A0 γ Hγ ≡{β}≡ fold_transport (Xβ_eq) ◎ eβ β A1 γ Hγ ◎ unfold_transport (agree_eq H γ Hγ Hγ).
+ Proof with (cbn; unfold unfold, unfold_transport, fold_transport; clear_transports; equalise_pi).
+ intros x. rewrite inv_lim_dist_iff. intros γ' Hγ'.
+ setoid_rewrite (proj_Xβ_eq_fold _ _ _). cbn.
+ destruct (index_lt_eq_lt_dec (succ γ')) as [[H1 | H1] | H1].
+ - setoid_rewrite (agree_p_nat H _ _ _ _ _ _ _ _)...
+ - subst...
+ - setoid_rewrite (agree_e_nat H _ _ _ _ _ _ _ _)...
+ Qed.
+
+ Lemma pβ_coherent γ Hγ : pβ β A0 γ Hγ ≡{β}≡ fold_transport (agree_eq H γ Hγ Hγ) ◎ pβ β A1 γ Hγ ◎ unfold_transport (Xβ_eq).
+ Proof with (cbn; unfold unfold, unfold_transport, fold_transport; clear_transports; equalise_pi).
+ intros x. unfold pβ. cbn. setoid_rewrite (proj_Xβ_eq_unfold _ _ _). cbn.
+ setoid_rewrite (agree_ψ_nat H _ _ _ _)...
+ Qed.
+
+ (* this pattern is needed for the following two lemmas *)
+ Ltac eq_pβ_eβ :=
+ setoid_rewrite oFunctor_ne at 1; [ |
+ rewrite eβ_coherent pβ_coherent; rewrite ccompose_assoc; reflexivity ];
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _);
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _);
+ cbn; unfold unfold_transport, fold_transport;
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _);
+ cbn; equalise_pi_head; do 3 apply ofe_mor_ne;
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _); cbn;
+ apply ofe_mor_ne.
+
+ Lemma ϕβ_coherent : ϕβ β A0 ≡{β}≡ fold_transport (ofe_eq_funct eq_refl Xβ_eq) ◎ ϕβ β A1 ◎ unfold_transport Xβ_eq.
+ Proof.
+ intros x; cbn.
+ setoid_rewrite (transport_id_bcompl (symmetry FXβ_eq) _ _ _ _).
+ apply bcompl_ne. intros; cbn. unfold unfold_transport.
+ eq_pβ_eβ.
+ setoid_rewrite (proj_Xβ_eq_unfold _ _ _).
+ cbn. unfold unfold_transport. equalise_pi.
+ Unshelve. all: reflexivity.
+ Qed.
+
+ Lemma ψβ_coherent : ψβ β A0 ≡{β}≡ fold_transport Xβ_eq ◎ ψβ β A1 ◎ unfold_transport (ofe_eq_funct eq_refl Xβ_eq).
+ Proof.
+ intros x. rewrite inv_lim_dist_iff. intros γ Hγ.
+ setoid_rewrite (proj_Xβ_eq_fold _ _ _). cbn.
+ eq_pβ_eβ. reflexivity.
+ Unshelve. reflexivity.
+ Qed.
+
+ Instance bounded_approx_A0_truncated γ Hγ : OfeTruncated (bounded_approx_X A0 γ Hγ) γ.
+ Proof. eapply approx_X_truncated, A0. Qed.
+ Instance bounded_approx_A1_truncated γ Hγ : OfeTruncated (bounded_approx_X A1 γ Hγ) γ.
+ Proof. eapply approx_X_truncated, A1. Qed.
+
+ Arguments eβ : simpl never.
+ Arguments ϕβ : simpl never.
+ Arguments pβ : simpl never.
+ Arguments ψβ : simpl never.
+ Lemma limit_extension_coherent :
+ @extension_agree β A0 A1 (limit_extension β A0) (limit_extension β A1) H.
+ Proof with (intros x; cbn; unfold fold_transport, unfold_transport; clear_transports; equalise_pi).
+ exists (proj_id FXβ_eq).
+ - intros. cbn in *.
+ setoid_rewrite (transport_id_bcompl (symmetry FXβ_eq) _ _ _ _).
+ apply bcompl_ne. intros; cbn. unfold unfold_transport. by clear_transports.
+ - intros. cbn. rewrite ofe_truncated_equiv. unfold eβ'.
+ setoid_rewrite eβ_coherent. setoid_rewrite ϕβ_coherent...
+ - intros. cbn. rewrite ofe_truncated_equiv. unfold pβ'.
+ eapply dist_mono. 2: apply Hγ'.
+ setoid_rewrite pβ_coherent. setoid_rewrite ψβ_coherent...
+ - intros. cbn. rewrite ofe_truncated_equiv. intros x; cbn.
+ setoid_rewrite Fcontr at 1.
+ 2: { intros γ Hγ. eapply dist_mono'. 2: { apply index_succ_iff, Hγ. }
+ setoid_rewrite ϕβ_coherent. rewrite ψβ_coherent. rewrite ccompose_assoc. reflexivity.
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ cbn. unfold unfold_transport, fold_transport.
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _).
+ cbn. equalise_pi_head. do 3 apply ofe_mor_ne.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _). cbn.
+ apply ofe_mor_ne. equalise_pi.
+ Unshelve. all: reflexivity.
+ - intros. cbn. rewrite ofe_truncated_equiv. intros x; cbn.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { setoid_rewrite ϕβ_coherent. rewrite ψβ_coherent. rewrite ccompose_assoc. reflexivity.
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ cbn. unfold unfold_transport, fold_transport.
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _).
+ cbn. equalise_pi_head. do 3 apply ofe_mor_ne.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _). cbn.
+ apply ofe_mor_ne. equalise_pi.
+ Unshelve. all: reflexivity.
+ Qed.
+End limit_coherent.
+
+
+(** * Final limit *)
+
+Section final_limit.
+ (* Now that we've got approximations for every ordinal, we can take a final inverse limit to end up with the solution to the domain equation. *)
+
+ Context (IH : @bounded_approx (λ _, True)).
+
+ Let X β:= bounded_approx_X IH β I.
+ Let ϕ β := bounded_approx_ϕ IH β I.
+ Let ψ β := bounded_approx_ψ IH β I.
+
+ Let ϕ_ψ_id : ∀ β, ϕ β ◎ ψ β ≡{β}≡ cid. intros β. eapply approx_ϕ_ψ_id, IH. Qed.
+ Let ψ_ϕ_id : ∀ β, ψ β ◎ ϕ β ≡ cid. intros β. eapply approx_ψ_ϕ_id, IH. Qed.
+ Let X_eq γ : ofe_eq (X (succ γ)) ([G (X γ)]_{succ γ}).
+ Proof. apply IH. Defined.
+
+ Let fold β := fold_transport (X_eq β).
+ Let unfold β := unfold_transport (X_eq β).
+ Let fold_unfold_id : ∀ β, fold β ◎ unfold β ≡ cid.
+ Proof. intros β x; cbn. unfold fold, unfold, unfold_transport, fold_transport. by clear_transports. Qed.
+ Let unfold_fold_id : ∀ β, unfold β ◎ fold β ≡ cid.
+ Proof. intros β x; cbn. unfold fold, unfold, unfold_transport, fold_transport. by clear_transports. Qed.
+
+ Let e γ0 γ1 (Hlt : γ0 ≺ γ1) := bounded_approx_e IH γ0 γ1 I I Hlt.
+ Let p γ0 γ1 (Hlt : γ0 ≺ γ1) := bounded_approx_p IH γ0 γ1 I I Hlt.
+ Let e_p_id : ∀ γ0 γ1 Hlt, e γ0 γ1 Hlt ◎ p γ0 γ1 Hlt ≡{γ0}≡ cid. intros; eapply approx_e_p_id, IH. Qed.
+ Let p_e_id : ∀ γ0 γ1 Hlt, p γ0 γ1 Hlt ◎ e γ0 γ1 Hlt ≡ cid. intros; eapply approx_p_e_id, IH. Qed.
+ Let e_funct : ∀ γ0 γ1 γ2 H1 H2 H3, e γ1 γ2 H2 ◎ e γ0 γ1 H1 ≡ e γ0 γ2 H3. intros; eapply approx_e_funct, IH. Qed.
+ Let p_funct : ∀ γ0 γ1 γ2 H1 H2 H3, p γ0 γ1 H1 ◎ p γ1 γ2 H2 ≡ p γ0 γ2 H3. intros; eapply approx_p_funct, IH. Qed.
+
+ Let p_ψ_unfold γ Hlt : p γ (succ γ) Hlt ≡ ψ γ ◎ unfold γ. eapply approx_p_ψ_unfold. Qed.
+ Let e_fold_ϕ γ Hlt : e γ (succ γ) Hlt ≡ fold γ ◎ ϕ γ. eapply approx_e_fold_ϕ. Qed.
+
+ Let ψ_p_fold γ (Hlt : γ ≺ succ γ): ψ γ ≡ p γ (succ γ) Hlt ◎ fold γ.
+ Proof.
+ intros x.
+ setoid_rewrite (p_ψ_unfold _ _ _). cbn. by setoid_rewrite (unfold_fold_id _ x).
+ Qed.
+ Let ϕ_unfold_e γ (Hlt : γ ≺ succ γ): ϕ γ ≡ unfold γ ◎ e γ (succ γ) Hlt.
+ Proof.
+ intros x.
+ cbn. setoid_rewrite (e_fold_Ï• _ _ x). by setoid_rewrite (unfold_fold_id _ _).
+ Qed.
+
+ (* definition of the final limit *)
+ Definition FX_lim : ∀ γ, COFE SI := λ γ, cofe _ ([G (X γ)]_{succ γ}).
+ Definition Fep_lim : ∀ γ0 γ1, γ0 ≺ γ1 → FX_lim γ1 -n> FX_lim γ0
+ := λ γ0 γ1 Hlt, trunc_map _ _ (map (e γ0 γ1 Hlt, p γ0 γ1 Hlt)).
+
+ Definition Xlim := inv_lim (P := λ _, True) (λ β _, FX_lim β) (λ γ0 γ1 _ _ Hlt, Fep_lim γ0 γ1 Hlt).
+ Definition proj_Xlim γ : Xlim -n> FX_lim γ := proj_lim (P := λ _, True) (λ β _, FX_lim β) (λ γ0 γ1 _ _ Hlt, Fep_lim γ0 γ1 Hlt) γ I.
+
+ Lemma Xlim_equalises γ0 γ1 Hlt: Fep_lim γ0 γ1 Hlt ◎ proj_Xlim γ1 ≡ proj_Xlim γ0.
+ Proof.
+ intros x. cbn -[Fep_lim].
+ refine (inv_lim_equalises _ _ _ _ _ _ _ _).
+ Qed.
+
+ Lemma Xlim_dist_iff β (x y : Xlim) : x ≡{β}≡ y ↔ (∀ γ, proj_Xlim γ x ≡{β}≡ proj_Xlim γ y).
+ Proof.
+ rewrite (inv_lim_dist_iff _ _ x y β). cbn.
+ split; intros; [ | destruct Hγ ]; auto.
+ Qed.
+
+ Lemma Xlim_equiv_iff (x y : Xlim) : x ≡ y ↔ (∀ γ, proj_Xlim γ x ≡ proj_Xlim γ y).
+ Proof.
+ rewrite (inv_lim_eq_iff _ _ x y). cbn.
+ split; intros; [ | destruct Hγ]; auto.
+ Qed.
+
+ Let Fep_lim_lifts_p : ∀ γ0 γ1 (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1), fold γ0 ◎ Fep_lim γ0 γ1 Hlt ◎ unfold γ1 ≡ p (succ γ0) (succ γ1) Hlts.
+ intros; eapply approx_Fep_p.
+ Qed.
+
+ Lemma Fep_lim_unfold γ0 γ1 (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1) :
+ (Fep_lim γ0 γ1 Hlt) ◎ (unfold γ1) ≡ (unfold γ0) ◎ p (succ γ0) (succ γ1) Hlts.
+ Proof using Fep_lim_lifts_p unfold_fold_id.
+ intros x. cbn.
+ setoid_rewrite <- (Fep_lim_lifts_p _ _ _ _ x).
+ cbn -[Fep_lim].
+ Unshelve. 2-4: eauto.
+ setoid_rewrite (unfold_fold_id _ _).
+ cbn. reflexivity.
+ Qed.
+
+ Lemma fold_Fep_lim γ0 γ1 (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1) :
+ (fold γ0) ◎ (Fep_lim γ0 γ1 Hlt) ≡ p (succ γ0) (succ γ1) Hlts ◎ (fold γ1).
+ Proof.
+ intros x. cbn -[Fep_lim].
+ setoid_rewrite <- (Fep_lim_lifts_p _ _ _ _ _).
+ cbn -[Fep_lim]. by setoid_rewrite (unfold_fold_id _ _).
+ Qed.
+
+ Program Definition e_lim : ∀ γ, X γ -n> Xlim
+ := λ γ, λne (x : X γ), exist _ (λ γ' _,
+ match index_lt_eq_lt_dec (succ γ') γ with
+ | inl (inl Hlt) => unfold γ' (p (succ γ') γ Hlt x)
+ | inl (inr Heq) => _
+ | inr Hgt => unfold γ' (e γ (succ γ') Hgt x)
+ end : FX_lim γ') _.
+ Next Obligation.
+ intros γ x γ' _ _ <-. unfold FX_lim. refine (unfold _ x).
+ Defined.
+ Next Obligation.
+ (* equaliser property *)
+ intros. intros γ0 γ1 Hγ0γ1 [] [].
+ unfold proj_tower. cbn -[Fep].
+ destruct (index_lt_eq_lt_dec (succ γ1) γ) as [[Hlt1 | Heq1] | Hgt1],
+ (index_lt_eq_lt_dec (succ γ0) γ) as [[Hlt0 | Heq0] | Hgt0].
+ all: try index_contra_solve.
+ - setoid_rewrite (Fep_lim_unfold _ _ _ _ _).
+ cbn. by setoid_rewrite (p_funct _ _ _ _ _ _ _).
+ Unshelve. by apply index_lt_succ_mono.
+ - destruct Heq1. cbn -[Fep].
+ setoid_rewrite (Fep_lim_unfold _ _ _ _ _). cbn. reflexivity.
+ - setoid_rewrite (Fep_lim_unfold _ _ _ _ _).
+ cbn. apply ofe_mor_f_equal.
+ setoid_rewrite <- (p_funct (succ γ0) γ (succ γ1) _ _ _ _).
+ cbn. apply ofe_mor_f_equal. by setoid_rewrite (p_e_id _ _ _ _ ).
+ Unshelve. by eapply index_lt_succ_mono.
+ - destruct Heq0. cbn -[Fep].
+ setoid_rewrite (Fep_lim_unfold _ _ _ _ _ ). cbn. apply ofe_mor_f_equal.
+ by setoid_rewrite (p_e_id _ _ _ _ ).
+ - setoid_rewrite (Fep_lim_unfold _ _ _ _ _).
+ cbn. apply ofe_mor_f_equal.
+ setoid_rewrite <- (e_funct γ (succ γ0) (succ γ1) _ _ _ _).
+ setoid_rewrite (p_e_id _ _ _ _). cbn. reflexivity.
+ Unshelve. by apply index_lt_succ_mono.
+ Qed.
+ Next Obligation.
+ (* non-expansiveness *)
+ intros γ α. cbn. intros x y Heq i Hi. cbn.
+ destruct (index_lt_eq_lt_dec (succ i) γ) as [[Hlti | Heqi] | Hgti].
+ - by rewrite Heq.
+ - destruct Heqi. cbn. by rewrite Heq.
+ - by rewrite Heq.
+ Qed.
+
+ (** Definition of p_lim *)
+ Definition p_lim : ∀ γ, Xlim -n> X γ := λ γ, ψ γ ◎ (proj_Xlim γ).
+
+ Lemma e_lim_p_lim_id γ : e_lim γ ◎ p_lim γ ≡{γ}≡ cid.
+ Proof.
+ intros x. apply inv_lim_dist_iff. intros δ Hδ.
+ destruct x as [x Hx]. cbn.
+ destruct (index_lt_eq_lt_dec (succ δ) γ) as [[Hlt | Heq] | Hgt].
+ - setoid_rewrite (ψ_p_fold _ _ _).
+ cbn. setoid_rewrite (p_funct _ _ _ _ _ _ _).
+ setoid_rewrite <- (Fep_lim_unfold _ _ _ _ _).
+ cbn -[Fep_lim]. setoid_rewrite (unfold_fold_id _ _).
+ cbn -[Fep_lim]. setoid_rewrite (Hx _ _ _ _ _).
+ cbn. reflexivity.
+ Unshelve. all: eauto 3 with index.
+ - destruct Heq. cbn. setoid_rewrite (ψ_p_fold _ _ _).
+ setoid_rewrite <- (Fep_lim_lifts_p _ _ _ _ _).
+ setoid_rewrite (unfold_fold_id _ _).
+ cbn -[Fep_lim]. setoid_rewrite (unfold_fold_id _ _).
+ cbn -[Fep_lim]. setoid_rewrite (Hx _ _ _ _ _). cbn. reflexivity.
+ Unshelve. all: eauto with index.
+ - setoid_rewrite (ψ_p_fold _ _ _).
+ destruct (index_lt_eq_lt_dec γ δ) as [[Hγlt | Hγeq] | Hγgt].
+ + setoid_rewrite <- (e_funct γ (succ γ) (succ δ) _ _ _ _ ).
+ cbn. setoid_rewrite (e_p_id γ (succ γ) _ _). 2: auto.
+ cbn. setoid_rewrite <- (Hx _ _ _ _ _) at 1.
+ setoid_rewrite (fold_Fep_lim _ _ _ _ _). cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (e_p_id (succ γ) (succ δ) _ _)). 2: auto.
+ setoid_rewrite (unfold_fold_id _ _). cbn. reflexivity.
+ Unshelve. all: eauto with index.
+ + subst. rewrite (proof_irrel Hgt (index_succ_greater δ)).
+ setoid_rewrite (e_p_id _ _ _ _).
+ cbn. destruct Hδ. by setoid_rewrite (unfold_fold_id _ _).
+ + index_contra_solve.
+ Qed.
+
+ Lemma p_lim_e_lim_id γ: p_lim γ ◎ e_lim γ ≡ cid.
+ Proof.
+ intros x.
+ cbn. destruct (index_lt_eq_lt_dec (succ γ) γ) as [[H1 | H1] | H1].
+ 1-2: index_contra_solve.
+ setoid_rewrite <- (p_ψ_unfold _ _ _). apply p_e_id.
+ Qed.
+
+ Lemma e_lim_funct γ0 γ1 Hlt: e_lim γ0 ≡ e_lim γ1 ◎ e γ0 γ1 Hlt .
+ Proof.
+ intros x. apply inv_lim_eq_iff. intros γ Hγ. cbn.
+ destruct (index_lt_eq_lt_dec (succ γ) γ0) as [[H1 | H1] | H1],
+ (index_lt_eq_lt_dec (succ γ) γ1) as [[H2 | H2] | H2].
+ all: try index_contra_solve.
+ - setoid_rewrite <- (p_funct (succ γ) γ0 γ1 _ _ _ _).
+ cbn. setoid_rewrite (p_e_id _ _ _ _). cbn. reflexivity.
+ - subst. cbn. rewrite (proof_irrel H2 Hlt). by setoid_rewrite (p_e_id _ _ _ _).
+ - setoid_rewrite <- (e_funct γ0 (succ γ) γ1 _ _ _ _).
+ setoid_rewrite (p_e_id _ _ _ _). cbn. reflexivity.
+ - subst. cbn. rewrite (proof_irrel H1 Hlt). reflexivity.
+ - setoid_rewrite (e_funct _ _ _ _ _ _ _). reflexivity.
+ Qed.
+
+ Lemma p_lim_funct γ0 γ1 Hlt: p_lim γ0 ≡ p γ0 γ1 Hlt ◎ p_lim γ1.
+ Proof.
+ intros x. cbn.
+ setoid_rewrite (ψ_p_fold _ _ _). cbn. setoid_rewrite (p_funct γ0 γ1 (succ γ1) _ _ _ _).
+ setoid_rewrite <- (inv_lim_equalises _ _ _ _ _ _ _ x) at 1.
+ setoid_rewrite (fold_Fep_lim _ _ _ _ _). cbn. setoid_rewrite (p_funct _ _ _ _ _ _ _).
+ Unshelve. all: eauto 3 with index.
+ Qed.
+
+ (** definition of ψ *)
+ Program Definition ψ_lim : G Xlim -n> Xlim :=
+ λne x, exist _ (λ γ' _, ofe_trunc_truncate (succ γ') (map (e_lim γ', p_lim γ') x)) _.
+ Next Obligation.
+ intros x γ0 γ1 Hγ0γ1 [] [].
+ unfold Fep_lim. cbn.
+ eapply ofe_truncated_equiv. apply _.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)); [ | eauto using index_lt_succ_mono].
+ cbn. rewrite ofe_mor_f_equal. reflexivity.
+ map_compose_tac.
+ apply equiv_dist => α.
+ setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne.
+ by rewrite <- (e_lim_funct).
+ symmetry; apply equiv_dist. apply p_lim_funct.
+ }
+ all:reflexivity.
+ Qed.
+ Next Obligation.
+ intros α x y Heq. apply inv_lim_dist_iff. intros γ Hγ. cbn.
+ by rewrite Heq.
+ Qed.
+
+ (** definition of Ï•*)
+ Program Definition Ï•_lim : Xlim -n> G Xlim :=
+ λne x, compl (mkchain _ (G Xlim) (λ γ, map (p_lim γ, e_lim γ) (ofe_trunc_expand _ (proj_lim _ _ γ I x))) _).
+ Next Obligation.
+ intros x γ' γ Hle. cbn.
+ destruct Hle as [-> | Hlt]. { reflexivity. }
+ destruct x as [x Hx]. symmetry.
+ rewrite ofe_mor_ne.
+ 2: by setoid_rewrite <- Hx.
+ Unshelve. 2: exact γ. 2, 3: eauto.
+ unfold Fep. cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)).
+ 2: apply index_succ_greater.
+ cbn.
+
+ map_compose_tac.
+ (* now we need to use composition of functors *)
+ setoid_rewrite oFunctor_ne.
+ 2: { rewrite pair_ne.
+ 2: { rewrite ccompose_ne. 3: setoid_rewrite (p_lim_funct _ _ _); reflexivity.
+ 2: reflexivity.
+ rewrite <- ccompose_assoc.
+ setoid_rewrite (dist_mono' _ _ _ _ (e_p_id _ _ _) ).
+ by rewrite ccompose_cid_l. by left.
+ }
+ 2: { rewrite ccompose_ne. 2: setoid_rewrite (e_lim_funct _ _ _); reflexivity.
+ 2: reflexivity.
+ rewrite ccompose_assoc.
+ setoid_rewrite (dist_mono' _ _ _ _ _) at 1.
+ reflexivity.
+ rewrite ccompose_ne; [ | reflexivity | eapply e_p_id]. by rewrite ccompose_cid_r.
+ by left.
+ }
+ reflexivity.
+ }
+ all: reflexivity.
+ Qed.
+ Next Obligation.
+ intros α x y Heq.
+ rewrite !conv_compl. cbn.
+ do 2 apply ofe_mor_ne. apply Xlim_dist_iff, Heq.
+ Qed.
+
+ Lemma ϕ_lim_ψ_lim_id : ϕ_lim ◎ ψ_lim ≡ cid.
+ Proof.
+ intros x. cbn. apply equiv_dist => α. rewrite conv_compl; cbn.
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)). 2: auto.
+ cbn. setoid_rewrite (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne; apply e_lim_p_lim_id. }
+ rewrite oFunctor_id. reflexivity.
+ Qed.
+
+ Lemma ψ_lim_ϕ_lim_id : ψ_lim ◎ ϕ_lim ≡ cid.
+ Proof.
+ intros x. cbn. apply Xlim_equiv_iff.
+ intros γ; cbn. rewrite ofe_truncated_equiv.
+ rewrite conv_compl. cbn. rewrite ofe_mor_ne.
+ 2: {
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _). setoid_rewrite oFunctor_ne.
+ 2: { apply pair_ne.
+ - unshelve setoid_rewrite (proj1 (equiv_dist _ _) (e_lim_funct γ (succ γ) _)). auto.
+ rewrite -ccompose_assoc (p_lim_e_lim_id _) ccompose_cid_l. reflexivity.
+ - unshelve setoid_rewrite (proj1 (equiv_dist _ _) (p_lim_funct γ (succ γ) _)). auto.
+ rewrite ccompose_assoc (p_lim_e_lim_id _) ccompose_cid_r. reflexivity.
+ }
+ reflexivity.
+ }
+ apply equiv_dist. apply Xlim_equalises.
+ Qed.
+
+ Program Definition pre_solution_F : solution F := Solution _ F Xlim _ ϕ_lim ψ_lim _ _.
+ Next Obligation.
+ eapply iso_cofe_subtype with (P := λ _, True) (g := λ x, ϕ_lim x) (f := λ x _, ψ_lim x).
+ 3, 4: tauto.
+ - intros n y1 y2. split => H.
+ + apply ofe_mor_ne, H.
+ + setoid_rewrite <- (ψ_lim_ϕ_lim_id y1). setoid_rewrite <- (ψ_lim_ϕ_lim_id y2).
+ cbn -[ϕ_lim ψ_lim]. by rewrite H.
+ - intros x _. apply ϕ_lim_ψ_lim_id.
+ Qed.
+ Next Obligation. apply ψ_lim_ϕ_lim_id. Qed.
+ Next Obligation. apply ϕ_lim_ψ_lim_id. Qed.
+End final_limit.
+
+(** * Mergin an extension to an approximation *)
+Section merge_extension.
+ Context (β: SI).
+ Context (A : bounded_approx (λ γ, γ ≺ β)).
+ Context (E : extension A).
+
+ Context (succ_or_limit : {β' | β = succ β'} + {index_is_limit β}).
+
+ (** we want to define A' : bounded_approx (λ γ, γ ⪯ β) s.t. A' satisfies all sorts of agreement properties. *)
+
+ Let X : ∀ γ, γ ≺ β → COFE SI := bounded_approx_X A.
+ Let e : ∀ γ0 γ1 Hγ0 Hγ1 Hlt, X γ0 Hγ0 -n> X γ1 Hγ1 := bounded_approx_e A.
+ Let p : ∀ γ0 γ1 Hγ0 Hγ1 Hlt, X γ1 Hγ1 -n> X γ0 Hγ0 := bounded_approx_p A.
+ Let ϕ : ∀ γ Hγ, X γ Hγ -n> [G (X γ Hγ)]_{succ γ} := bounded_approx_ϕ A.
+ Let ψ : ∀ γ Hγ, [G (X γ Hγ)]_{succ γ} -n> X γ Hγ := bounded_approx_ψ A.
+
+ Let X_eq γ Hγ Hsγ: projCOFE _ (X (succ γ) Hsγ) = [G (X γ Hγ)]_{succ γ}. apply A. Defined.
+ Instance X_truncated γ Hγ : OfeTruncated (X γ Hγ) γ. apply A. Qed.
+
+ Let p_e_id γ0 γ1 Hγ0 Hγ1 Hlt : p γ0 γ1 Hγ0 Hγ1 Hlt ◎ e γ0 γ1 Hγ0 Hγ1 Hlt ≡ cid. apply A. Qed.
+ Let e_p_id γ0 γ1 Hγ0 Hγ1 Hlt : e γ0 γ1 Hγ0 Hγ1 Hlt ◎ p γ0 γ1 Hγ0 Hγ1 Hlt ≡{γ0}≡ cid. apply A. Qed.
+ Let ϕ_ψ_id γ Hγ : ϕ γ Hγ ◎ ψ γ Hγ ≡{γ}≡ cid. apply A. Qed.
+ Let ψ_ϕ_id γ Hγ : ψ γ Hγ ◎ ϕ γ Hγ ≡ cid. apply A. Qed.
+
+ Let e_funct γ0 γ1 γ2 Hγ0 Hγ1 Hγ2 Hlt0 Hlt1 Hlt2 : e γ1 γ2 Hγ1 Hγ2 Hlt1 ◎ e γ0 γ1 Hγ0 Hγ1 Hlt0 ≡ e γ0 γ2 Hγ0 Hγ2 Hlt2. apply A. Qed.
+ Let p_funct γ0 γ1 γ2 Hγ0 Hγ1 Hγ2 Hlt0 Hlt1 Hlt2 : p γ0 γ1 Hγ0 Hγ1 Hlt0 ◎ p γ1 γ2 Hγ1 Hγ2 Hlt1 ≡ p γ0 γ2 Hγ0 Hγ2 Hlt2. apply A. Qed.
+
+ Let fold γ Hγ Hsγ := fold_transport (X_eq γ Hγ Hsγ).
+ Let unfold γ Hγ Hsγ := unfold_transport (X_eq γ Hγ Hsγ).
+
+ Let Fep_p γ0 γ1 Hγ0 Hγ1 Hsγ0 Hsγ1 Hlt Hlts :
+ fold γ0 Hγ0 Hsγ0 ◎ trunc_map (succ γ1) (succ γ0) (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt)) ◎ unfold γ1 Hγ1 Hsγ1
+ ≡ p (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts.
+ apply approx_Fep_p. Qed.
+ Let Fep_p_limit γ0 γ1 (Hlim : index_is_limit γ1) Hγ0 Hsγ0 Hγ1 Hlt Hslt :
+ fold γ0 Hγ0 Hsγ0 ◎ trunc_map (succ γ1) (succ γ0) (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt))
+ ≡ p (succ γ0) γ1 Hsγ0 Hγ1 Hslt ◎ ψ γ1 Hγ1.
+ by apply approx_Fep_p_limit. Qed.
+
+ Let p_ψ_unfold γ Hγ Hsγ Hlt : p γ (succ γ) Hγ Hsγ Hlt ≡ ψ γ Hγ ◎ unfold γ Hγ Hsγ. apply approx_p_ψ_unfold. Qed.
+ Let e_fold_ϕ γ Hγ Hsγ Hlt : e γ (succ γ) Hγ Hsγ Hlt ≡ fold γ Hγ Hsγ ◎ ϕ γ Hγ. apply approx_e_fold_ϕ. Qed.
+
+ Let ϕ_succ_id γ Hle Hsle: ϕ (succ γ) Hsle
+ ≡ trunc_map (succ γ) (succ (succ γ)) (map (ψ γ Hle ◎ unfold γ Hle Hsle, fold γ Hle Hsle ◎ ϕ γ Hle))
+ ◎ unfold γ Hle Hsle.
+ eapply approx_Ï•_succ_id. Qed.
+ Let ψ_succ_id γ Hle Hsle: ψ (succ γ) Hsle
+ ≡ fold γ Hle Hsle ◎ trunc_map (succ (succ γ)) (succ γ) (map (fold γ Hle Hsle ◎ ϕ γ Hle, ψ γ Hle ◎ unfold γ Hle Hsle)).
+ eapply approx_ψ_succ_id. Qed.
+
+
+ Let Xβ : COFE SI := ext_Xγ E.
+ Let eβ : ∀ γ0 Hγ0, X γ0 Hγ0 -n> Xβ := ext_eγ E.
+ Let pβ : ∀ γ0 Hγ0, Xβ -n> X γ0 Hγ0 := ext_pγ E.
+ Let ϕβ : Xβ -n> [G Xβ]_{succ β} := ext_ϕγ E.
+ Let ψβ : [G Xβ]_{succ β} -n> Xβ := ext_ψγ E.
+
+ Let pβ_eβ_id γ0 Hγ0 : pβ γ0 Hγ0 ◎ eβ γ0 Hγ0 ≡ cid. apply E. Qed.
+ Let eβ_pβ_id γ0 Hγ0 : eβ γ0 Hγ0 ◎ pβ γ0 Hγ0 ≡{γ0}≡ cid. apply E. Qed.
+ Let eβ_funct γ0 γ1 Hγ0 Hγ1 Hlt : eβ γ1 Hγ1 ◎ e γ0 γ1 Hγ0 Hγ1 Hlt ≡ eβ γ0 Hγ0. apply E. Qed.
+ Let pβ_funct γ0 γ1 Hγ0 Hγ1 Hlt : p γ0 γ1 Hγ0 Hγ1 Hlt ◎ pβ γ1 Hγ1 ≡ pβ γ0 Hγ0. apply E. Qed.
+
+ Let ψβ_ϕβ_id : ψβ ◎ ϕβ ≡ cid. apply E. Qed.
+ Let ϕβ_ψβ_id : ϕβ ◎ ψβ ≡{β}≡ cid. apply E. Qed.
+
+ Instance Xβ_truncated : OfeTruncated Xβ β. apply E. Qed.
+
+ (* if β is a successor ordinal....: *)
+ Let Xβ_eq γ' (Hlt : γ' ≺ β) (Heq : β = succ γ'): projCOFE _ Xβ = [G (X γ' Hlt)]_{succ γ'}. by apply E. Defined.
+
+ Let foldβ γ' Hlt Heq := fold_transport (Xβ_eq γ' Hlt Heq).
+ Let unfoldβ γ' Hlt Heq := unfold_transport (Xβ_eq γ' Hlt Heq).
+
+ Let Fep_pβ γ0 γ1 Hγ0 Hγ1 Hsγ0 Hsγ1 Hlt:
+ fold γ0 Hγ0 Hsγ0
+ ◎ trunc_map (succ γ1) (succ γ0) (map (e γ0 γ1 Hγ0 Hγ1 Hlt, p γ0 γ1 Hγ0 Hγ1 Hlt))
+ ◎ unfoldβ γ1 Hγ1 Hsγ1
+ ≡ pβ (succ γ0) Hsγ0.
+ apply ext_Fep_p. Qed.
+ Let p_ψ_unfoldβ γ' Hlt Heq :
+ pβ γ' Hlt ≡ ψ γ' Hlt ◎ unfoldβ γ' Hlt Heq. apply ext_p_ψ_unfold. Qed.
+ Let e_fold_ϕβ γ' Hlt Heq : eβ γ' Hlt ≡ foldβ γ' Hlt Heq ◎ ϕ γ' Hlt. apply ext_e_fold_ϕ. Qed.
+ Let ϕβ_succ_id γ' Hlt Heq: ϕβ ≡ trunc_map (succ γ') (succ β) (map (ψ γ' Hlt ◎ unfoldβ γ' Hlt Heq,
+ foldβ γ' Hlt Heq ◎ ϕ γ' Hlt)) ◎ unfoldβ γ' Hlt Heq.
+ apply ext_Ï•_succ_id. Qed.
+ Let ψβ_succ_id γ' Hlt Heq : ψβ
+ ≡ foldβ γ' Hlt Heq
+ ◎ trunc_map (succ β) (succ γ') (map (foldβ γ' Hlt Heq ◎ ϕ γ' Hlt,
+ ψ γ' Hlt ◎ unfoldβ γ' Hlt Heq)).
+ apply ext_ψ_succ_id. Qed.
+
+ (* if β is a limit ordinal *)
+ Let Fep_pβ_limit γ0 Hγ0 Hsγ0 (Hlim : index_is_limit β) :
+ fold γ0 Hγ0 Hsγ0
+ ◎ trunc_map (succ β) (succ γ0) (map (eβ γ0 Hγ0, pβ γ0 Hγ0))
+ ≡ pβ (succ γ0) Hsγ0 ◎ ψβ.
+ by apply ext_Fep_p_limit. Qed.
+
+ (** now we can define the new stuff *)
+ Lemma le_lt_eq_dec γ (Hγ : γ ⪯ β) : {γ ≺ β} + {γ= β}.
+ Proof.
+ destruct (index_le_lt_dec β γ) as [H1 | H1].
+ - right. by apply index_le_ge_eq.
+ - by left.
+ Qed.
+
+ Definition X' γ (Hγ : γ ⪯ β) : COFE SI := match le_lt_eq_dec γ Hγ with
+ | left Hlt => X γ Hlt
+ | right Heq => Xβ
+ end.
+
+ Lemma X'_id_lt γ Hγ (Hlt : γ ≺ β): ofe_eq (X' γ Hγ) (X γ Hlt).
+ Proof.
+ unfold X'. destruct le_lt_eq_dec as [H1 | H1]. by pi_clear. index_contra_solve.
+ Qed.
+ Hint Resolve X'_id_lt : ofe_eq.
+
+ Lemma X'_id_β Hβ : ofe_eq (X' β Hβ) Xβ.
+ Proof.
+ unfold X'. destruct le_lt_eq_dec as [H1 | H1]. 2: reflexivity. index_contra_solve.
+ Qed.
+ Hint Resolve X'_id_β : ofe_eq.
+
+ Lemma X'_pi_id γ γ' Hγ Hγ' (H: γ = γ') : ofe_eq (X' γ Hγ) (X' γ' Hγ').
+ Proof.
+ intros; subst. pi_clear. reflexivity.
+ Qed.
+ Hint Resolve X'_pi_id : ofe_eq.
+
+ Instance X'_truncated γ Hγ : OfeTruncated (X' γ Hγ) γ.
+ Proof. unfold X'. destruct le_lt_eq_dec; subst; apply _. Qed.
+
+
+ Let FX γ Hγ : COFE SI := cofe _ [G (X γ Hγ)]_{succ γ}.
+
+ Unset Program Cases.
+ (** definitions of ϕ, ψ *)
+ Program Definition ϕ' γ (Hγ : γ ⪯ β) : X' γ Hγ -n> [G (X' γ Hγ)]_{succ γ} :=
+ match le_lt_eq_dec γ Hγ with
+ | left Hlt =>
+ @transport_id (FX γ Hlt) ([G (X' γ Hγ)]_{succ γ}) (ofe_eq_symm (ofe_eq_funct _ (X'_id_lt γ _ _)))
+ ◎ ϕ γ Hlt
+ ◎ @transport_id (X' γ Hγ) (X γ Hlt) (X'_id_lt γ _ _)
+ | right Heq =>
+ @transport_id ([G (X' β _)]_{succ β}) ([G (X' γ _)]_{succ γ}) (ofe_eq_funct _ (X'_pi_id _ _ _ _ _))
+ ◎ @transport_id ([G Xβ]_{succ β}) ([G (X' β _)]_{succ β}) (ofe_eq_symm (ofe_eq_funct _ (X'_id_β _)))
+ ◎ ϕβ
+ ◎ @transport_id (X' β _) Xβ (X'_id_β _)
+ ◎ @transport_id (X' γ Hγ) (X' β _) (X'_pi_id _ _ _ _ _)
+ end.
+ Solve Obligations with eauto.
+ Next Obligation.
+ intros; by subst.
+ Defined.
+
+ Program Definition ψ' γ (Hγ : γ ⪯ β) : [G (X' γ Hγ)]_{succ γ} -n> X' γ Hγ :=
+ match le_lt_eq_dec γ Hγ with
+ | left Hlt =>
+ @transport_id (X γ Hlt) (X' γ Hγ) (ofe_eq_symm (X'_id_lt γ _ _))
+ ◎ ψ γ Hlt
+ ◎ @transport_id ([G (X' γ Hγ)]_{succ γ}) (FX γ Hlt) (ofe_eq_funct _ (X'_id_lt γ _ _))
+ | right Heq =>
+ @transport_id (X' β _) (X' γ Hγ) (ofe_eq_symm (X'_pi_id _ _ _ _ _))
+ ◎ @transport_id Xβ (X' β _) (ofe_eq_symm (X'_id_β _))
+ ◎ ψβ
+ ◎ @transport_id ([G (X' β _)]_{succ β}) ([G Xβ]_{succ β}) (ofe_eq_funct _ (X'_id_β _))
+ ◎ @transport_id ([G (X' γ Hγ)]_{succ γ}) ([G (X' β _)]_{succ β}) (ofe_eq_symm (ofe_eq_funct _ (X'_pi_id _ _ _ _ _)))
+ end.
+ Solve Obligations with eauto.
+ Next Obligation.
+ intros; by subst.
+ Defined.
+
+ Lemma ϕ_ψ_id' γ Hγ : ϕ' γ Hγ ◎ ψ' γ Hγ ≡{γ}≡ cid.
+ Proof using Fcontr.
+ unfold ϕ', ψ'. destruct le_lt_eq_dec as [H1 | H1].
+ - intros x; cbn. clear_transports. setoid_rewrite (ϕ_ψ_id _ _ _). by clear_transports.
+ - intros x. cbn -[trunc_map]. clear_transports. subst. setoid_rewrite (ϕβ_ψβ_id _). by clear_transports.
+ Qed.
+
+ Lemma ψ_ϕ_id' γ Hγ : ψ' γ Hγ ◎ ϕ' γ Hγ ≡ cid.
+ Proof using Fcontr.
+ unfold ψ', ϕ'. destruct le_lt_eq_dec as [H1 | H1].
+ - intros x; cbn. clear_transports. setoid_rewrite (ψ_ϕ_id _ _ _). by clear_transports.
+ - intros x; cbn -[trunc_map]. clear_transports.
+ subst. setoid_rewrite (ψβ_ϕβ_id _). by clear_transports.
+ Qed.
+
+ Lemma X'_succ_id γ Hγ Hsγ : ofe_eq (X' (succ γ) Hsγ) ([G (X' γ Hγ)]_{succ γ}).
+ Proof using succ_or_limit Fcofe.
+ destruct succ_or_limit as [[β' H] | H].
+ - unfold X'. destruct (le_lt_eq_dec) as [H1 | H1]; destruct (le_lt_eq_dec) as [H2 | H2].
+ all: try by (exfalso; subst; index_contra_solve).
+ by apply X_eq.
+ by apply Xβ_eq.
+ - rewrite !X'_id_lt. { apply H. apply index_succ_le_lt, Hsγ. } { apply index_succ_le_lt, Hsγ. }
+ intros. apply X_eq.
+ Qed.
+ Hint Resolve X'_succ_id : ofe_eq.
+
+ Let fold' γ Hγ Hsγ := fold_transport (X'_succ_id γ Hγ Hsγ).
+ Let unfold' γ Hγ Hsγ := unfold_transport (X'_succ_id γ Hγ Hsγ).
+ Fact fold_unfold_id' γ Hγ Hsγ : fold' γ Hγ Hsγ ◎ unfold' γ Hγ Hsγ ≡ cid.
+ Proof. unfold fold', unfold', fold_transport, unfold_transport. intros x; cbn. by clear_transports. Qed.
+ Lemma unfold_fold_id' γ Hγ Hsγ : unfold' γ Hγ Hsγ ◎ fold' γ Hγ Hsγ ≡ cid.
+ Proof. unfold fold', unfold', fold_transport, unfold_transport. intros x; cbn. by clear_transports. Qed.
+
+ Ltac open_folds := unfold unfold, fold, fold', unfold', foldβ, unfoldβ, fold_transport, unfold_transport.
+
+ Lemma e'_ca γ0 γ1 (Hγ0 : γ0 ⪯ β) (Hγ1 : γ1 ⪯ β) (Hlt : γ0 ≺ γ1) : {γ0 ≺ β ∧ γ1 ≺ β} + {γ0 ≺ β ∧ γ1 = β}.
+ Proof.
+ destruct (index_le_lt_dec β γ1) as [H1 | H1].
+ - right. assert (γ1 = β) as ->. { apply index_le_ge_eq; assumption. }
+ split; auto.
+ - left. split; last assumption. etransitivity; eassumption.
+ Qed.
+
+ Program Definition e' γ0 γ1 Hγ0 Hγ1 (Hlt : γ0 ≺ γ1) : X' γ0 Hγ0 -n> X' γ1 Hγ1 :=
+ match e'_ca γ0 γ1 Hγ0 Hγ1 Hlt with
+ | left (conj H0 H1) =>
+ @transport_id (X γ1 H1) (X' γ1 Hγ1) (ofe_eq_symm (X'_id_lt _ _ _))
+ ◎ e γ0 γ1 H0 H1 Hlt
+ ◎ @transport_id (X' γ0 Hγ0) (X γ0 H0) (X'_id_lt _ _ _)
+ | right (conj H0 H1) =>
+ @transport_id (X' β _) (X' γ1 _) (X'_pi_id _ _ _ _ _)
+ ◎ @transport_id Xβ (X' β _) (ofe_eq_symm (X'_id_β _))
+ ◎ eβ γ0 H0
+ ◎ @transport_id (X' γ0 Hγ0) (X γ0 H0) (X'_id_lt _ _ _)
+ end.
+ Solve Obligations with eauto.
+
+ Program Definition p' γ0 γ1 Hγ0 Hγ1 (Hlt : γ0 ≺ γ1) : X' γ1 Hγ1 -n> X' γ0 Hγ0 :=
+ match e'_ca γ0 γ1 Hγ0 Hγ1 Hlt with
+ | left (conj H0 H1) =>
+ @transport_id (X γ0 H0) (X' γ0 Hγ0) (ofe_eq_symm (X'_id_lt _ _ _))
+ ◎ p γ0 γ1 H0 H1 Hlt
+ ◎ @transport_id (X' γ1 Hγ1) (X γ1 H1) (X'_id_lt _ _ _)
+ | right (conj H0 H1) =>
+ @transport_id (X γ0 H0) (X' γ0 Hγ0) (ofe_eq_symm (X'_id_lt _ _ _))
+ ◎ pβ γ0 H0
+ ◎ @transport_id (X' β _) Xβ (X'_id_β _)
+ ◎ @transport_id (X' γ1 _) (X' β _) (ofe_eq_symm (X'_pi_id _ _ _ _ _))
+ end.
+ Solve Obligations with eauto.
+
+ Lemma p_e_id' γ0 γ1 Hγ0 Hγ1 Hlt : p' γ0 γ1 Hγ0 Hγ1 Hlt ◎ e' γ0 γ1 Hγ0 Hγ1 Hlt ≡ cid.
+ Proof using Fcontr.
+ unfold p', e'. destruct e'_ca as [[H0 H1] | [H0 H1]].
+ - intros x; cbn. clear_transports. setoid_rewrite (p_e_id _ _ _ _ _ _). by clear_transports.
+ - intros x; cbn. clear_transports. setoid_rewrite (pβ_eβ_id _ _ _). by clear_transports.
+ Qed.
+
+ Lemma e_p_id' γ0 γ1 Hγ0 Hγ1 Hlt : e' γ0 γ1 Hγ0 Hγ1 Hlt ◎ p' γ0 γ1 Hγ0 Hγ1 Hlt ≡{γ0}≡ cid.
+ Proof using Fcontr.
+ unfold p', e'. destruct e'_ca as [[H0 H1] | [H0 H1]].
+ - intros x; cbn. clear_transports. setoid_rewrite (e_p_id _ _ _ _ _ _). by clear_transports.
+ - intros x; cbn. clear_transports. setoid_rewrite (eβ_pβ_id _ _ _). by clear_transports.
+ Qed.
+
+ Lemma p'_funct γ0 γ1 γ2 Hγ0 Hγ1 Hγ2 Hlt0 Hlt1 Hlt2 :
+ p' γ0 γ1 Hγ0 Hγ1 Hlt0 ◎ p' γ1 γ2 Hγ1 Hγ2 Hlt1 ≡ p' γ0 γ2 Hγ0 Hγ2 Hlt2.
+ Proof.
+ unfold p'. destruct (e'_ca γ0 γ1) as [[H0 H1] | [H0 H1]];
+ destruct (e'_ca γ1 γ2) as [[H3 H4] | [H3 H4]];
+ destruct (e'_ca γ0 γ2) as [[H5 H6] | [H5 H6]].
+ all: try index_contra_solve.
+ - intros x; cbn. repeat pi_clear. clear_transports.
+ setoid_rewrite (p_funct _ _ _ _ _ _ _ _ _ _). reflexivity.
+ - intros x; cbn. repeat pi_clear. clear_transports.
+ setoid_rewrite (pβ_funct _ _ _ _ _ _). reflexivity.
+ Qed.
+
+ Lemma e'_funct γ0 γ1 γ2 Hγ0 Hγ1 Hγ2 Hlt0 Hlt1 Hlt2 :
+ e' γ1 γ2 Hγ1 Hγ2 Hlt1 ◎ e' γ0 γ1 Hγ0 Hγ1 Hlt0 ≡ e' γ0 γ2 Hγ0 Hγ2 Hlt2.
+ Proof.
+ unfold e'. destruct (e'_ca γ0 γ1) as [[H0 H1] | [H0 H1]];
+ destruct (e'_ca γ1 γ2) as [[H3 H4] | [H3 H4]];
+ destruct (e'_ca γ0 γ2) as [[H5 H6] | [H5 H6]].
+ all: try index_contra_solve.
+ - intros x; cbn. repeat pi_clear. clear_transports.
+ setoid_rewrite (e_funct _ _ _ _ _ _ _ _ _ _). reflexivity.
+ - intros x; cbn. repeat pi_clear. clear_transports.
+ setoid_rewrite (eβ_funct _ _ _ _ _ _). reflexivity.
+ Qed.
+
+ Lemma fold'_eq γ (Hγ : γ ≺ β) (Hγ' : γ ⪯ β) (Hsγ : succ γ ≺ β) (Hsγ' : succ γ⪯ β): fold' γ Hγ' Hsγ'
+ ≡ @transport_id (X (succ γ) Hsγ) (X' (succ γ) Hsγ') (ofe_eq_symm (X'_id_lt (succ γ) Hsγ' Hsγ))
+ ◎ fold γ Hγ Hsγ
+ ◎ @transport_id ([G (X' γ Hγ')]_{succ γ}) ([G (X γ Hγ)]_{succ γ}) (ofe_eq_funct eq_refl (X'_id_lt γ Hγ' Hγ)).
+ Proof.
+ rewrite ofe_truncated_equiv. unfold fold', fold, fold_transport. intros x; cbn.
+ clear_transports. equalise_pi.
+ Qed.
+
+ Lemma unfold'_eq γ Hγ Hγ' Hsγ Hsγ' : unfold' γ Hγ' Hsγ'
+ ≡ @transport_id ([G (X γ Hγ)]_{succ γ}) ([G (X' γ Hγ')]_{succ γ}) (ofe_eq_symm (ofe_eq_funct eq_refl (X'_id_lt γ Hγ' Hγ)))
+ ◎ unfold γ Hγ Hsγ
+ ◎ @transport_id (X' (succ γ) Hsγ') (X (succ γ) Hsγ) (X'_id_lt (succ γ) Hsγ' Hsγ).
+ Proof.
+ rewrite ofe_truncated_equiv. unfold unfold', unfold, unfold_transport. intros x; cbn.
+ clear_transports. equalise_pi.
+ Qed.
+
+ (* I don't know what this says intuitively, but it can be reused for the two following lemmas... *)
+ Lemma pull_transports γ0 γ1 Hγ0 Hsγ0 H1 Hγ1 H0 Hlt I I1 I2 I3 I4 I5 I6:
+ @transport_id ([G (X' γ0 Hγ0)]_{succ γ0}) (X' (succ γ0) Hsγ0) I
+ ◎ trunc_map (succ γ1) (succ γ0)
+ (map
+ (@transport_id (X γ1 H1) (X' γ1 Hγ1) I1 ◎ e γ0 γ1 H0 H1 Hlt ◎ @transport_id (X' γ0 Hγ0) (X γ0 H0) I2,
+ @transport_id (X γ0 H0) (X' γ0 Hγ0) I3 ◎ p γ0 γ1 H0 H1 Hlt ◎ @transport_id (X' γ1 Hγ1) (X γ1 H1) I4))
+ ≡ @transport_id ([G (X γ0 H0)]_{succ γ0}) (X' (succ γ0) Hsγ0) I5
+ ◎ trunc_map (succ γ1) (succ γ0)
+ (map (e γ0 γ1 H0 H1 Hlt, p γ0 γ1 H0 H1 Hlt))
+ ◎ @transport_id ([G (X' γ1 Hγ1)]_{succ γ1}) ([G (X γ1 H1)]_{succ γ1}) I6.
+ Proof using succ_or_limit Fcontr Fcofe.
+ intros x; cbn. clear_transports.
+ rewrite ofe_truncated_equiv.
+ setoid_rewrite oFunctor_ne at 1; [ | setoid_rewrite (ccompose_assoc) at 2; reflexivity ].
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ unshelve transport_id_truncate_rl. eauto with ofe_eq.
+ cbn. clear_transports. equalise_pi_head. do 2 f_equiv.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ equalise_pi_head. apply ofe_mor_ne.
+ transport_id_expand_lr.
+ cbn. equalise_pi.
+ Qed.
+
+ Lemma Fep_p' γ0 γ1 (Hγ0 : γ0 ⪯ β) (Hγ1 : γ1 ⪯ β) (Hsγ0 : succ γ0 ⪯ β) (Hsγ1 : succ γ1 ⪯ β) (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1):
+ fold' γ0 Hγ0 Hsγ0
+ ◎ trunc_map (succ γ1) (succ γ0)
+ (map (e' γ0 γ1 Hγ0 Hγ1 Hlt, p' γ0 γ1 Hγ0 Hγ1 Hlt))
+ ◎ unfold' γ1 Hγ1 Hsγ1 ≡ p' (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts.
+ Proof using Fcontr.
+ destruct succ_or_limit as [[β' H] | Hlim].
+ { (* successor case *)
+ open_folds. unfold p', e'.
+ destruct (e'_ca γ0 γ1) as [[H1 H2] | [H1 H2]], (e'_ca (succ γ0) (succ γ1)) as [[H3 H4] | [H3 H4]].
+ 1: rewrite <- Fep_p.
+ 2: rewrite <- Fep_pβ.
+ 3-4: index_contra_solve.
+ all: erewrite pull_transports.
+ all: open_folds.
+ all: intros x; cbn; clear_transports.
+ all: do 3 f_equiv; equalise_pi.
+ Unshelve. by auto. all: eauto with ofe_eq.
+ }
+ {
+ (* limit case *)
+ assert (γ0 ≺ β) as T1. { apply index_succ_le_lt, Hsγ0. }
+ assert (succ γ0 ≺ β) as T2. { apply Hlim. apply index_succ_le_lt, Hsγ0. }
+ unshelve setoid_rewrite (fold'_eq _ _ _ _ _). 1-2:assumption.
+ unfold fold', unfold', e', p', fold_transport, unfold_transport.
+ destruct e'_ca as [[H0 H1] | [H0 H1]]; destruct (e'_ca) as [[H3 H4] | [H3 H4]].
+ 3-4: index_contra_solve.
+ - intros x; cbn -[trunc_map].
+ clear_transports.
+ equalise_pi_head. f_equiv.
+ setoid_rewrite <- (Fep_p _ _ _ _ _ _ _ _ _ ). cbn -[trunc_map].
+ f_equiv. unfold unfold, unfold_transport. clear_transports.
+ setoid_rewrite (transport_id_truncate _ _ _ _ _ _ _) at 1. cbn. f_equiv.
+ rewrite equiv_dist => α.
+ setoid_rewrite oFunctor_ne at 2. 2: { setoid_rewrite (ccompose_assoc _ _ _) at 1. reflexivity. }
+ setoid_rewrite <- (map_compose _ _ _ _ _).
+ setoid_rewrite (map_compose _ _ _ _ _).
+ rewrite (proof_irrel H0 T1).
+ setoid_rewrite oFunctor_ne at 1. 2: { apply pair_ne; intros y; cbn; clear_transports; reflexivity. }
+ apply ofe_mor_ne. open_folds.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _). cbn.
+ clear_transports. Unshelve. 3: reflexivity. equalise_pi.
+ - exfalso. specialize (Hlim γ1 H1) as H. rewrite H4 in H. index_contra_solve.
+ }
+ Qed.
+
+ Lemma Fep_p_limit' γ0 γ1 (Hlim : index_is_limit γ1) (Hγ0 : γ0 ⪯ β) (Hsγ0 : succ γ0 ⪯ β) (Hγ1 : γ1 ⪯ β) (Hlt : γ0 ≺ γ1) (Hslt : succ γ0 ≺ γ1):
+ fold' γ0 Hγ0 Hsγ0
+ ◎ trunc_map (succ γ1) (succ γ0)
+ (map (e' γ0 γ1 Hγ0 Hγ1 Hlt, p' γ0 γ1 Hγ0 Hγ1 Hlt))
+ ≡ p' (succ γ0) γ1 Hsγ0 Hγ1 Hslt ◎ ψ' γ1 Hγ1.
+ Proof using Fcontr.
+ unfold fold', e', p', ψ', fold_transport.
+ destruct (e'_ca γ0 γ1) as [[H0 H1] | [H0 H1]],
+ (e'_ca (succ γ0) γ1) as [[H3 H4] | [H3 H4]],
+ (le_lt_eq_dec γ1 Hγ1) as [H5 | H5].
+ all: try index_contra_solve.
+ - erewrite pull_transports. intros x; cbn -[trunc_map]. clear_transports.
+ unshelve setoid_rewrite <- (Fep_p_limit _ _ _ _ _ _ _ _ _). 1-2,4: assumption.
+ open_folds. cbn -[trunc_map]. clear_transports.
+ repeat pi_clear. equalise_pi.
+ - intros x; cbn-[trunc_map]. clear_transports.
+ setoid_rewrite <- (Fep_pβ_limit _ _ _ _ _). 2: { rewrite <- H5. assumption. }
+ open_folds. cbn-[trunc_map]. clear_transports.
+ rewrite ofe_truncated_equiv. cbn.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { split; cbn.
+ - setoid_rewrite (transport_id_compose _ _ _ ). instantiate (1 := (_, _)). cbn. reflexivity.
+ - cbn. setoid_rewrite (ccompose_assoc _ _ _). setoid_rewrite (transport_id_compose _ _ _).
+ setoid_rewrite (ccompose_assoc _ _ _). reflexivity.
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _ ) at 1.
+ cbn. clear_transports. equalise_pi_head. do 2 apply ofe_mor_ne.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ equalise_pi_head. apply ofe_mor_ne.
+ apply equiv_dist. eapply transport_id_expand'.
+ by rewrite H4.
+ Unshelve. reflexivity.
+ Qed.
+
+ Ltac equal_maps := open_folds; intros x; cbn; clear_transports; equalise_pi.
+ Lemma p_succ_id' γ (Hγ : γ ⪯ β) (Hsγ : succ γ ⪯ β) (Hlt : γ ≺ succ γ):
+ p' γ (succ γ) Hγ Hsγ Hlt ≡ ψ' γ Hγ ◎ unfold' γ Hγ Hsγ.
+ Proof.
+ unfold p', ψ', unfold'. destruct (e'_ca) as [[H1 H2] | [H1 H2]], (le_lt_eq_dec) as [H3 | H3].
+ all: try index_contra_solve.
+ - rewrite (p_ψ_unfold). equal_maps.
+ - rewrite p_ψ_unfoldβ. equal_maps.
+ Unshelve. auto.
+ Qed.
+
+ Lemma e_succ_id' γ (Hγ : γ ⪯ β) (Hsγ : succ γ ⪯ β) (Hlt : γ ≺ succ γ):
+ e' γ (succ γ) Hγ Hsγ Hlt ≡ fold' γ Hγ Hsγ ◎ ϕ' γ Hγ.
+ Proof.
+ unfold e', Ï•', fold'. destruct (e'_ca) as [[H1 H2] | [H1 H2]], (le_lt_eq_dec) as [H3 | H3].
+ all: try index_contra_solve.
+ - rewrite e_fold_Ï•. equal_maps.
+ - rewrite e_fold_ϕβ. equal_maps.
+ Unshelve. auto.
+ Qed.
+
+ Lemma ϕ_succ_id' γ (Hle : γ ⪯ β) (Hsle : succ γ ⪯ β):
+ ϕ' (succ γ) Hsle
+ ≡ trunc_map (succ γ) (succ (succ γ))
+ (map (ψ' γ Hle ◎ unfold' γ Hle Hsle, fold' γ Hle Hsle ◎ ϕ' γ Hle))
+ ◎ unfold' γ Hle Hsle.
+ Proof using Fcontr.
+ unfold ϕ', ψ'. open_folds.
+ destruct (le_lt_eq_dec (succ γ)) as [H1 | H1], (le_lt_eq_dec γ) as [H2 | H2].
+ all: try index_contra_solve.
+ - unshelve rewrite Ï•_succ_id. assumption.
+ intros x; cbn. open_folds. clear_transports.
+ transport_id_truncate_lr.
+ cbn. rewrite ofe_truncated_equiv. apply ofe_mor_ne.
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _).
+ cbn.
+ setoid_rewrite oFunctor_ne at 2. 2: {
+ apply pair_ne.
+ { rewrite ccompose_assoc. rewrite (transport_id_compose _ _ _). rewrite ccompose_assoc. reflexivity. }
+ { rewrite <- !ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _) at 2. cbn.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _).
+ cbn. clear_transports.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne.
+ { rewrite ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ { rewrite <- ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ }
+ equalise_pi.
+ - unshelve rewrite ϕβ_succ_id. 3: symmetry; apply H1. assumption.
+ intros x; cbn. open_folds. clear_transports.
+ rewrite ofe_truncated_equiv.
+ transport_id_truncate_lr. by rewrite H1.
+ cbn. apply ofe_mor_ne.
+ setoid_rewrite oFunctor_ne at 3.
+ 2: { apply pair_ne.
+ { rewrite ccompose_assoc. rewrite transport_id_compose. rewrite ccompose_assoc. reflexivity. }
+ { rewrite <- !ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _) at 2. cbn.
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _) at 1. cbn.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne.
+ { rewrite ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ { rewrite <- ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ }
+ equalise_pi_head. apply ofe_mor_ne.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _). cbn. clear_transports. equalise_pi.
+ Unshelve. all: reflexivity.
+ Qed.
+
+ Lemma ψ_succ_id' γ (Hle : γ ⪯ β) (Hsle : succ γ ⪯ β):
+ ψ' (succ γ) Hsle
+ ≡ fold' γ Hle Hsle
+ ◎ trunc_map (succ (succ γ)) (succ γ) (map (fold' γ Hle Hsle ◎ ϕ' γ Hle, ψ' γ Hle ◎ unfold' γ Hle Hsle)).
+ Proof using Fcontr.
+ unfold ϕ', ψ'. open_folds.
+ destruct (le_lt_eq_dec (succ γ)) as [H1 | H1], (le_lt_eq_dec γ) as [H2 | H2].
+ all: try solve [index_contra_solve].
+ - unshelve rewrite ψ_succ_id. assumption.
+ intros x; cbn. open_folds. clear_transports.
+ rewrite ofe_truncated_equiv.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _) at 1. cbn.
+ setoid_rewrite oFunctor_ne at 3. 2: {
+ apply pair_ne.
+ { rewrite <- !ccompose_assoc. rewrite (transport_id_compose _ _ _). rewrite ccompose_assoc. reflexivity. }
+ { rewrite !ccompose_assoc. rewrite (transport_id_compose _ _ _). rewrite <- ccompose_assoc. reflexivity. }
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _). cbn.
+ clear_transports. equalise_pi_head. do 3 apply ofe_mor_ne.
+ setoid_rewrite <- (transport_id_expand _ _ _ _ _ _ _). cbn.
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne. all: rewrite (transport_id_compose _ _ _); reflexivity. }
+ equalise_pi.
+ - unshelve rewrite ψβ_succ_id. 3: symmetry; apply H1. assumption.
+ intros x; cbn. open_folds. clear_transports.
+ rewrite ofe_truncated_equiv.
+
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _) at 1. cbn.
+ setoid_rewrite oFunctor_ne at 3. 2: {
+ apply pair_ne.
+ { rewrite <- !ccompose_assoc. rewrite (transport_id_compose _ _ _). rewrite ccompose_assoc. reflexivity. }
+ { rewrite !ccompose_assoc. rewrite (transport_id_compose _ _ _). rewrite <- ccompose_assoc. reflexivity. }
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _). cbn.
+ clear_transports. equalise_pi_head. do 3 apply ofe_mor_ne.
+
+ transport_id_expand_rl. by rewrite H1. cbn.
+
+ setoid_rewrite (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite oFunctor_ne at 1. 2: { apply pair_ne. all: rewrite (transport_id_compose _ _ _); reflexivity. }
+ equalise_pi.
+ Unshelve. all: reflexivity.
+ Qed.
+
+ Program Definition extended_approx : @bounded_approx (λ γ, γ ⪯ β) :=
+ {|
+ bounded_approx_X := X';
+ bounded_approx_e := e';
+ bounded_approx_p := p';
+ bounded_approx_Ï• := Ï•';
+ bounded_approx_ψ := ψ';
+ |}.
+ Next Obligation.
+ eexists X'_succ_id.
+ - apply p_e_id'.
+ - apply e_p_id'.
+ - apply e'_funct.
+ - apply p'_funct.
+ - apply ψ_ϕ_id'.
+ - apply ϕ_ψ_id'.
+ - intros. unfold X'. destruct le_lt_eq_dec; subst; apply _.
+ - apply Fep_p'.
+ - apply p_succ_id'.
+ - apply e_succ_id'.
+ - apply Ï•_succ_id'.
+ - apply ψ_succ_id'.
+ - apply Fep_p_limit'.
+ Qed.
+
+ Lemma extended_approx_agree : approx_agree A extended_approx.
+ Proof.
+ assert (Heq : ∀ (γ : SI) (H0 : γ ≺ β) (H1 : γ ⪯ β), bounded_approx_X A γ H0 = bounded_approx_X extended_approx γ H1).
+ { intros. cbn. unfold X'. destruct le_lt_eq_dec as [H2 | H2]. by pi_clear.
+ subst; index_contra_solve.
+ }
+ exists (λ γ H0 H1, proj_id (Heq γ H0 H1)).
+ { intros. unfold fold_transport. setoid_rewrite (transport_id_bcompl _ _ _ _). 2: symmetry; apply Heq.
+ apply bcompl_ne. intros. cbn. unfold unfold_transport. clear_transports. equalise_pi.
+ }
+ 1-2: intros; cbn; unfold e', p'; (destruct e'_ca as [[H1 H2] | [H1 H2]]; [ | subst; index_contra_solve ]).
+ 3-4: intros; cbn; unfold ϕ', ψ'; (destruct le_lt_eq_dec as [H1 | H1]; [ | subst; index_contra_solve ]).
+ all: unfold fold_transport, unfold_transport; intros x; cbn; repeat pi_clear; by clear_transports.
+ Qed.
+
+End merge_extension.
+
+Lemma cofe_eq_bcompl_nat (A B : COFE SI) (Heq : A = B) (Heq' : projCOFE _ A = projCOFE _ B):
+ ∀ α (Hα : zero ≺ α) (ch : bchain A α), bcompl Hα ch ≡{α}≡ fold_transport Heq' (bcompl Hα (bchain_map (unfold_transport Heq') ch)).
Proof.
- intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
- (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
-Qed.
-
-Program Definition fold (X : F T _) : T :=
- {| tower_car n := g n (map (embed' n,project n) X) |}.
-Next Obligation.
- intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
- rewrite g_S -oFunctor_compose.
- apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
-Qed.
-Instance fold_ne : NonExpansive fold.
-Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.
-
-Theorem result : solution F.
-Proof using Type*.
- apply (Solution F T _ (OfeMor unfold) (OfeMor fold)).
- - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
- rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
- trans (map (ff n, gg n) (X (S (n + k)))).
- { rewrite /unfold (conv_compl n (unfold_chain X)).
- rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
- rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
- rewrite f_S -!oFunctor_compose; apply (contractive_ne map); split=> Y.
- + rewrite /embed' /= /embed_coerce.
- destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
- by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
- + rewrite /embed' /= /embed_coerce.
- destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
- by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
- assert (∀ 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)) as map_ff_gg.
- { intros i; induction i as [|i IH]; intros k' x H; simpl.
- { by rewrite coerce_id oFunctor_id. }
- rewrite oFunctor_compose g_coerce; apply IH. }
- assert (H: S n + k = n + S k) by lia.
- rewrite (map_ff_gg _ _ _ H).
- apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
- - intros X; rewrite equiv_dist=> n /=.
- rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
- rewrite g_S -!oFunctor_compose -{2}[X]oFunctor_id.
- apply (contractive_ne map); split => Y /=.
- + rewrite f_tower. apply dist_S. by rewrite embed_tower.
- + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
+ intros. subst. unfold fold_transport, unfold_transport. clear_transports.
+ apply bcompl_ne. intros. cbn. by clear_transports.
+Qed.
+
+(** we need to show that merging extensions preserves agreement *)
+Lemma extension_coherent β (A0 A1 : bounded_approx (λ γ, γ ≺ β))
+ (E0 : extension A0) (E1 : extension A1) succ_or_limit :
+ ∀ H : approx_agree A0 A1,
+ @extension_agree β A0 A1 E0 E1 H
+ → approx_agree (extended_approx β A0 E0 succ_or_limit) (extended_approx β A1 E1 succ_or_limit).
+Proof with (unfold fold_transport, unfold_transport; intros x; cbn; clear_transports; equalise_pi).
+ intros H Hag.
+ unshelve refine ( let X_eq : ∀ (γ : SI) (H0 H1 : γ ⪯ β), projCOFE _ (X' β A0 E0 γ H0) = projCOFE _ (X' β A1 E1 γ H1) := _ in _).
+ { intros. unfold X'. pi_clear. destruct le_lt_eq_dec as [H2 | H2]. apply H. apply Hag. }
+ exists X_eq.
+ - intros.
+ (* this is a bit fiddly due to dependent typing. we need the X_eq equality to be transparent for this,
+ in order to make a case analysis on the def of X *)
+ repeat pi_clear. cbn in ch. unfold X' in ch.
+ unfold fold_transport, unfold_transport. cbn. unfold X' in *.
+ subst X_eq.
+ cbn. set (e := proof_irrel _ _).
+ rewrite !(proof_irrel e eq_refl). subst. cbn.
+ destruct (le_lt_eq_dec β γ H1) as [H2 | H2].
+ + apply agree_bcompl_nat.
+ + subst. apply eagree_bcompl_nat.
+ - intros. repeat pi_clear. cbn.
+ unfold e'. destruct (e'_ca) as [[F0 F1] | [F0 F1]].
+ + setoid_rewrite (agree_e_nat H _ _ _ _ _ _ _)...
+ + setoid_rewrite (eagree_e_nat Hag _ _)...
+ - intros. repeat pi_clear. cbn.
+ unfold p'. destruct (e'_ca) as [[F0 F1] | [F0 F1]].
+ + setoid_rewrite (agree_p_nat H _ _ _ _ _ _ _)...
+ + setoid_rewrite (eagree_p_nat Hag _ _)...
+ - intros. repeat pi_clear. cbn.
+ unfold Ï•'. destruct (le_lt_eq_dec) as [F0 | F0].
+ + setoid_rewrite (agree_Ï•_nat H _ _ _)...
+ + setoid_rewrite (eagree_Ï•_nat Hag)...
+ - intros. repeat pi_clear. cbn.
+ unfold ψ'. destruct (le_lt_eq_dec) as [F0 | F0].
+ + setoid_rewrite (agree_ψ_nat H _ _ _)...
+ + setoid_rewrite (eagree_ψ_nat Hag)...
Qed.
+
+(** * Proving that we can merge approximations in limit cases *)
+
+Section merge.
+ Context (P : SI → Prop).
+ Context (IH : ∀ α, P α → bounded_approx (λ γ, γ ⪯ α)).
+ Context (IH_agree : ∀ α0 α1 Hα0 Hα1, approx_agree (IH α0 Hα0) (IH α1 Hα1)).
+
+ (* we want to get merged_IH : bounded_approx P such that
+ ∀ α (Hα : P α), approx_agree (IH α Hα) merged_IH
+ *)
+
+ Program Definition mX γ (Hγ : P γ) := bounded_approx_X (IH γ Hγ) γ _.
+ Solve Obligations with cbn; eauto.
+ Instance mX_truncated γ Hγ: OfeTruncated (mX γ Hγ) γ.
+ Proof.
+ unfold mX. eapply approx_X_truncated. apply IH.
+ Qed.
+
+ Program Definition me γ0 γ1 (Hγ0 : P γ0) (Hγ1 : P γ1) (Hlt : γ0 ≺ γ1) : mX γ0 Hγ0 -n> mX γ1 Hγ1 :=
+ bounded_approx_e (IH γ1 Hγ1) γ0 γ1 _ _ Hlt
+ ◎ unfold_transport (agree_eq (IH_agree _ _ _ _) γ0 _ _).
+ Next Obligation.
+ intros; cbn. by right.
+ Defined.
+
+ Program Definition mp γ0 γ1 (Hγ0 : P γ0) (Hγ1 : P γ1) (Hlt : γ0 ≺ γ1) : mX γ1 Hγ1 -n> mX γ0 Hγ0 :=
+ fold_transport (agree_eq (IH_agree _ _ _ _) γ0 _ _)
+ ◎ bounded_approx_p (IH γ1 Hγ1) γ0 γ1 _ _ Hlt.
+ Next Obligation.
+ intros; cbn. by right.
+ Defined.
+
+ Lemma me_mp_id γ0 γ1 Hγ0 Hγ1 Hlt : me γ0 γ1 Hγ0 Hγ1 Hlt ◎ mp γ0 γ1 Hγ0 Hγ1 Hlt ≡{γ0}≡ cid.
+ Proof.
+ unfold me, mp. setoid_rewrite ccompose_assoc. setoid_rewrite <- ccompose_assoc at 2.
+ unfold unfold_transport, fold_transport. intros x; cbn. clear_transports. apply IH.
+ Qed.
+
+ Lemma mp_me_id γ0 γ1 Hγ0 Hγ1 Hlt : mp γ0 γ1 Hγ0 Hγ1 Hlt ◎ me γ0 γ1 Hγ0 Hγ1 Hlt ≡ cid.
+ Proof.
+ unfold me, mp. setoid_rewrite ccompose_assoc. setoid_rewrite <- ccompose_assoc at 2.
+ setoid_rewrite (approx_p_e_id (bounded_approx_props (IH _ _)) _ _ _ _ _).
+ setoid_rewrite ccompose_cid_l. intros x; cbn. unfold fold_transport, unfold_transport. by clear_transports.
+ Qed.
+
+ Lemma me_funct γ0 γ1 γ2 Hγ0 Hγ1 Hγ2 Hlt1 Hlt2 Hlt3 : me γ1 γ2 Hγ1 Hγ2 Hlt2 ◎ me γ0 γ1 Hγ0 Hγ1 Hlt1 ≡ me γ0 γ2 Hγ0 Hγ2 Hlt3.
+ Proof.
+ unfold me. symmetry. intros x. cbn.
+ setoid_rewrite <- (approx_e_funct (bounded_approx_props (IH _ _)) γ0 γ1 γ2 _ _ _ _ _ _ _) at 1.
+ cbn. f_equiv.
+ setoid_rewrite (agree_e_nat _ _ _ _ _ _ _ _ _) at 1. cbn.
+ unfold fold_transport, unfold_transport. compose_transports. equalise_pi.
+ Unshelve. all: apply IH_agree.
+ Qed.
+
+ Lemma mp_funct γ0 γ1 γ2 Hγ0 Hγ1 Hγ2 Hlt1 Hlt2 Hlt3 : mp γ0 γ1 Hγ0 Hγ1 Hlt1 ◎ mp γ1 γ2 Hγ1 Hγ2 Hlt2 ≡ mp γ0 γ2 Hγ0 Hγ2 Hlt3.
+ Proof.
+ unfold mp. symmetry. intros x. cbn.
+ unfold fold_transport, unfold_transport.
+ setoid_rewrite <- (approx_p_funct (bounded_approx_props (IH _ _)) γ0 γ1 γ2 _ _ _ _ _ _ _) at 1. cbn.
+ setoid_rewrite (agree_p_nat _ _ _ _ _ _ _ _ _) at 1. cbn.
+ unfold fold_transport.
+ compose_transports. equalise_pi.
+ Unshelve. apply IH_agree.
+ Qed.
+
+ Program Definition mϕ γ (Hγ : P γ) : mX γ Hγ -n> [G (mX γ Hγ)]_{succ γ} :=
+ bounded_approx_ϕ (IH γ Hγ) γ _.
+ Program Definition mψ γ (Hγ : P γ) : [G (mX γ Hγ)]_{succ γ} -n> mX γ Hγ :=
+ bounded_approx_ψ (IH γ Hγ) γ _.
+
+ Lemma mϕ_mψ_id γ Hγ : mϕ γ Hγ ◎ mψ γ Hγ ≡{γ}≡ cid.
+ Proof. apply IH. Qed.
+ Lemma mψ_mϕ_id γ Hγ : mψ γ Hγ ◎ mϕ γ Hγ ≡ cid.
+ Proof. apply IH. Qed.
+
+ Instance msucc_eq α Hα Hsα : ofe_eq (mX (succ α) Hsα) ([G (mX α Hα)]_{succ α}).
+ Proof using IH_agree.
+ unfold mX. symmetry. erewrite agree_eq. symmetry; eapply approx_eq. apply IH. apply IH_agree.
+ Unshelve. cbn; eauto.
+ Qed.
+
+
+ Lemma Fmemp_mp γ0 γ1 (Hγ0 : P γ0) (Hγ1 : P γ1) (Hsγ0 : P (succ γ0)) (Hsγ1 : P (succ γ1)) (Hlt : γ0 ≺ γ1) (Hlts : succ γ0 ≺ succ γ1):
+ fold_transport (msucc_eq γ0 Hγ0 Hsγ0)
+ ◎ trunc_map (succ γ1) (succ γ0)
+ (map (me γ0 γ1 Hγ0 Hγ1 Hlt, mp γ0 γ1 Hγ0 Hγ1 Hlt))
+ ◎ unfold_transport (msucc_eq γ1 Hγ1 Hsγ1) ≡ mp (succ γ0) (succ γ1) Hsγ0 Hsγ1 Hlts.
+ Proof using Fcontr Fcofe.
+ unfold me, mp. intros x; cbn. rewrite ofe_truncated_equiv.
+ setoid_rewrite oFunctor_ne at 1.
+ 2: { apply pair_ne.
+ { rewrite (agree_e_nat (IH_agree γ1 (succ γ1) Hγ1 Hsγ1)).
+ rewrite !ccompose_assoc. rewrite (transport_id_compose _ _ _). reflexivity. }
+ { rewrite (agree_p_nat (IH_agree γ1 (succ γ1) Hγ1 Hsγ1)).
+ rewrite <- !ccompose_assoc. rewrite (transport_id_compose _ _ _). reflexivity. }
+ }
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ setoid_rewrite <- (map_compose_dist _ _ _ _ _ _).
+ cbn.
+ transport_id_truncate_rl.
+
+ setoid_rewrite <- (approx_Fep_p (bounded_approx_props (IH (succ γ1) Hsγ1)) _ _ _ _ _ _ _ _ _).
+ cbn. unfold fold_transport, unfold_transport. clear_transports. equalise_pi_head.
+ do 3 apply ofe_mor_ne.
+ cbn.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _).
+ cbn. clear_transports. equalise_pi.
+ Unshelve. all: eauto with index.
+ apply ofe_eq_funct. reflexivity. apply IH_agree.
+ Qed.
+
+ Lemma Fmemp_mp_lim γ0 γ1 (Hlim : index_is_limit γ1) (Hγ0 : P γ0) (Hsγ0 : P (succ γ0)) (Hγ1 : P γ1) (Hlt : γ0 ≺ γ1) (Hslt : succ γ0 ≺ γ1):
+ fold_transport (msucc_eq γ0 Hγ0 Hsγ0)
+ ◎ trunc_map (succ γ1) (succ γ0)
+ (map (me γ0 γ1 Hγ0 Hγ1 Hlt, mp γ0 γ1 Hγ0 Hγ1 Hlt))
+ ≡ mp (succ γ0) γ1 Hsγ0 Hγ1 Hslt ◎ mψ γ1 Hγ1.
+ Proof using Fcontr.
+ unfold me, mp, mϕ. intros x; cbn. rewrite ofe_truncated_equiv.
+ setoid_rewrite <- (approx_Fep_p_limit (bounded_approx_props (IH γ1 Hγ1)) _ _ _ _ _ _ _ _ _); last assumption.
+ cbn.
+ rewrite <- (map_compose_dist _ _ _ _ _ _).
+ cbn. unfold unfold_transport, fold_transport.
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _).
+ cbn. clear_transports. equalise_pi.
+ Unshelve. reflexivity.
+ Qed.
+
+ Lemma mp_succ_id γ (Hγ : P γ) (Hsγ : P (succ γ)) (Hlt : γ ≺ succ γ):
+ mp γ (succ γ) Hγ Hsγ Hlt ≡ mψ γ Hγ ◎ unfold_transport (msucc_eq γ Hγ Hsγ).
+ Proof.
+ unfold mp, mψ.
+ rewrite (agree_ψ_nat (IH_agree γ (succ γ) Hγ Hsγ) _ _ _).
+ rewrite (approx_p_ψ_unfold (bounded_approx_props (IH (succ γ) Hsγ)) _ _ _ _).
+ intros x; cbn. unfold fold_transport, unfold_transport. clear_transports. equalise_pi.
+ Qed.
+
+ Lemma me_succ_id γ (Hγ : P γ) (Hsγ : P (succ γ)) (Hlt : γ ≺ succ γ):
+ me γ (succ γ) Hγ Hsγ Hlt ≡ fold_transport (msucc_eq γ Hγ Hsγ) ◎ mϕ γ Hγ.
+ Proof.
+ unfold me, mϕ.
+ rewrite (agree_ϕ_nat (IH_agree γ (succ γ) Hγ Hsγ) _ _ _).
+ rewrite (approx_e_fold_ϕ (bounded_approx_props (IH (succ γ) Hsγ)) _ _ _ _).
+ intros x; cbn. unfold fold_transport, unfold_transport. clear_transports. equalise_pi.
+ Qed.
+
+ Lemma mϕ_succ_id γ (Hle : P γ) (Hsle : P (succ γ)):
+ mϕ (succ γ) Hsle
+ ≡ trunc_map (succ γ) (succ (succ γ))
+ (map (mψ γ Hle ◎ unfold_transport (msucc_eq γ Hle Hsle), fold_transport (msucc_eq γ Hle Hsle) ◎ mϕ γ Hle))
+ ◎ unfold_transport (msucc_eq γ Hle Hsle).
+ Proof using Fcontr.
+ unfold mϕ, mψ. rewrite ofe_truncated_equiv. intros x; cbn.
+ setoid_rewrite (approx_ϕ_succ_id (bounded_approx_props (IH (succ γ) Hsle)) _ _ _ _).
+ cbn. apply ofe_mor_ne.
+ setoid_rewrite oFunctor_ne at 2.
+ 2: { apply pair_ne.
+ { rewrite (agree_ψ_nat (IH_agree γ (succ γ) Hle Hsle) _ _ _ ). unfold fold_transport, unfold_transport.
+ rewrite !ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ { rewrite (agree_ϕ_nat (IH_agree γ (succ γ) Hle Hsle) _ _ _ ). unfold fold_transport, unfold_transport.
+ rewrite <- !ccompose_assoc. rewrite transport_id_compose. reflexivity. }
+ }
+ cbn.
+ do 2 setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ unfold unfold_transport, fold_transport. equalise_pi_head. do 2 apply ofe_mor_ne.
+ setoid_rewrite (transport_id_expand _ _ _ _ _ _ _). cbn. clear_transports. equalise_pi.
+ Unshelve. all: eauto with index.
+ Qed.
+
+ Lemma mψ_succ_id γ (Hle : P γ) (Hsle : P (succ γ)):
+ mψ (succ γ) Hsle
+ ≡ fold_transport (msucc_eq γ Hle Hsle)
+ ◎ trunc_map (succ (succ γ)) (succ γ)
+ (map (fold_transport (msucc_eq γ Hle Hsle) ◎ mϕ γ Hle, mψ γ Hle ◎ unfold_transport (msucc_eq γ Hle Hsle))).
+ Proof using Fcontr.
+ unfold mψ, mϕ. rewrite ofe_truncated_equiv. intros x; cbn.
+ setoid_rewrite (approx_ψ_succ_id (bounded_approx_props (IH (succ γ) Hsle)) _ _ _ _).
+ cbn. setoid_rewrite oFunctor_ne at 2.
+ 2: { apply pair_ne.
+ { rewrite (agree_ϕ_nat (IH_agree γ (succ γ) Hle Hsle) _ _ _ ). unfold fold_transport, unfold_transport.
+ rewrite <- !ccompose_assoc. rewrite transport_id_compose. rewrite ccompose_assoc. reflexivity. }
+ { rewrite (agree_ψ_nat (IH_agree γ (succ γ) Hle Hsle) _ _ _ ). unfold fold_transport, unfold_transport.
+ rewrite !ccompose_assoc. rewrite transport_id_compose. rewrite <- ccompose_assoc. reflexivity. }
+ }
+ cbn. do 2 setoid_rewrite <- (map_compose_dist _ _ _ _ _ _). cbn.
+ setoid_rewrite <- (transport_id_truncate_symm _ _ _ _ _ _ _).
+ unfold unfold_transport, fold_transport. clear_transports. equalise_pi.
+ Unshelve. all: eauto with index.
+ Qed.
+
+ Program Definition merged_approx : bounded_approx (P) :=
+ {|
+ bounded_approx_X := mX;
+ bounded_approx_e := me;
+ bounded_approx_p := mp;
+ bounded_approx_ϕ := mϕ;
+ bounded_approx_ψ := mψ;
+ |}.
+ Next Obligation.
+ eexists msucc_eq.
+ - apply mp_me_id.
+ - apply me_mp_id.
+ - apply me_funct.
+ - apply mp_funct.
+ - apply mψ_mϕ_id.
+ - apply mϕ_mψ_id.
+ - intros. unfold mX. apply IH.
+ - apply Fmemp_mp.
+ - apply mp_succ_id.
+ - apply me_succ_id.
+ - apply mϕ_succ_id.
+ - apply mψ_succ_id.
+ - apply Fmemp_mp_lim.
+ Qed.
+
+ Lemma merged_agree γ Hγ: approx_agree (IH γ Hγ) merged_approx.
+ Proof with (unfold fold_transport, unfold_transport; intros x; cbn; clear_transports; equalise_pi).
+ assert (X_eq : ∀ (γ0 : SI) (H0 : γ0 ⪯ γ) (H1 : P γ0), projCOFE _ (bounded_approx_X (IH γ Hγ) γ0 H0) = projCOFE _ (mX γ0 H1)).
+ { intros. unfold mX. apply agree_eq, IH_agree. }
+ exists X_eq; intros; cbn.
+ - rewrite (agree_bcompl_nat (IH_agree γ γ0 Hγ H1) _ _ _ _ _ _).
+ unfold fold_transport, unfold_transport. clear_transports. equalise_pi_head. apply ofe_mor_ne. apply bcompl_ne.
+ intros. cbn. equalise_pi.
+ - unfold me. rewrite (agree_e_nat (IH_agree γ γ1 Hγ Hγ1') _ _ _ _ _ _ _)...
+ - unfold mp. rewrite (agree_p_nat (IH_agree γ γ1 Hγ Hγ1') _ _ _ _ _ _ _)...
+ - unfold mϕ. rewrite (agree_ϕ_nat (IH_agree γ γ0 Hγ Hγ') _ _ _)...
+ - unfold mψ. rewrite (agree_ψ_nat (IH_agree γ γ0 Hγ Hγ') _ _ _)...
+ Qed.
+End merge.
+
+(* we have to show that merging two coherent & agreeing chains of approximations results in two agreeing approximations *)
+Lemma merge_coherent_agree (P : SI → Prop) (IH1 IH2 : ∀ α, P α → bounded_approx (λ γ, γ ⪯ α))
+ (H1 : ∀ α0 α1 Hα0 Hα1, approx_agree (IH1 α0 Hα0) (IH1 α1 Hα1))
+ (H2 : ∀ α0 α1 Hα0 Hα1, approx_agree (IH2 α0 Hα0) (IH2 α1 Hα1)):
+ (∀ α Hα, approx_agree (IH1 α Hα) (IH2 α Hα))
+ → approx_agree (merged_approx P IH1 H1) (merged_approx P IH2 H2).
+Proof with (unfold fold_transport, unfold_transport; intros x; cbn; clear_transports; equalise_pi).
+ intros IH_agree.
+ assert (X_eq : ∀ (γ : SI) (H0 H3 : P γ), projCOFE _ (mX P IH1 γ H0) = projCOFE _ (mX P IH2 γ H3)).
+ { intros. unfold mX. pi_clear. apply IH_agree. }
+ exists X_eq; intros; cbn.
+ - repeat pi_clear. rewrite (agree_bcompl_nat (IH_agree γ H3) _ _ _ _ _ _ ).
+ unfold fold_transport, unfold_transport. clear_transports. equalise_pi_head. apply ofe_mor_ne. apply bcompl_ne.
+ intros; cbn. equalise_pi.
+ - unfold me. repeat pi_clear. rewrite (agree_e_nat (IH_agree γ1 Hγ1') _ _ _ _ _ _)...
+ - unfold mp. repeat pi_clear. rewrite (agree_p_nat (IH_agree γ1 Hγ1') _ _ _ _ _ _)...
+ - unfold mϕ. repeat pi_clear. rewrite (agree_ϕ_nat (IH_agree γ Hγ') _ _ _)...
+ - unfold mψ. repeat pi_clear. rewrite (agree_ψ_nat (IH_agree γ Hγ') _ _ _)...
+Qed.
+
+(** * Showing uniqueness of the approximations to close the induction *)
+Definition full_approximation : bounded_approx (λ _, True).
+Proof using inh_Funit Funique Fcontr.
+ unshelve eapply (full_A_transfinite SI (@bounded_approx) (@approx_agree) _ _ _ _ (@extension) (@extension_agree) (@extended_approx) _ _ (@merged_approx)).
+ - intros. unshelve eexists. all: intros; exfalso; by eapply H.
+ - eapply approx_agree_transitive.
+ - apply approx_agree_symmetric.
+ - apply approx_agree_reflexive.
+ - apply extended_approx_agree.
+ - apply extension_coherent.
+ - apply succ_extension.
+ - apply limit_extension.
+ - intros. apply merged_agree.
+ - apply merge_coherent_agree.
+ - apply approx_base.
+ - apply succ_extension_coherent.
+ - apply limit_extension_coherent.
+Qed.
+
+Definition solution_F := pre_solution_F full_approximation.
End solver. End solver.
+(*Print Assumptions solver.solution_F. *)
diff --git a/theories/algebra/csum.v b/theories/algebra/csum.v
index a16994265b4a70b12ee14caa787045e360313f25..74cbd02052fad8d03d9b9ccb04c86f52d6e20cd7 100644
--- a/theories/algebra/csum.v
+++ b/theories/algebra/csum.v
@@ -27,7 +27,7 @@ Instance maybe_Cinr {A B} : Maybe (@Cinr A B) := λ x,
match x with Cinr b => Some b | _ => None end.
Section cofe.
-Context {A B : ofeT}.
+Context {SI : indexT} {A B : ofeT SI}.
Implicit Types a : A.
Implicit Types b : B.
@@ -37,7 +37,7 @@ Inductive csum_equiv : Equiv (csum A B) :=
| Cinr_equiv b b' : b ≡ b' → Cinr b ≡ Cinr b'
| CsumBot_equiv : CsumBot ≡ CsumBot.
Existing Instance csum_equiv.
-Inductive csum_dist : Dist (csum A B) :=
+Inductive csum_dist : Dist SI (csum A B) :=
| Cinl_dist n a a' : a ≡{n}≡ a' → Cinl a ≡{n}≡ Cinl a'
| Cinr_dist n b b' : b ≡{n}≡ b' → Cinr b ≡{n}≡ Cinr b'
| CsumBot_dist n : CsumBot ≡{n}≡ CsumBot.
@@ -60,40 +60,65 @@ Proof. by inversion_clear 1. Qed.
Global Instance Cinr_inj_dist n : Inj (dist n) (dist n) (@Cinr A B).
Proof. by inversion_clear 1. Qed.
-Definition csum_ofe_mixin : OfeMixin (csum A B).
+Definition csum_ofe_mixin : OfeMixin SI (csum A B).
Proof.
split.
- intros mx my; split.
+ by destruct 1; constructor; try apply equiv_dist.
- + intros Hxy; feed inversion (Hxy 0); subst; constructor; try done;
+ + intros Hxy; feed inversion (Hxy zero); subst; constructor; try done;
apply equiv_dist=> n; by feed inversion (Hxy n).
- intros n; split.
+ by intros [|a|]; constructor.
+ by destruct 1; constructor.
+ destruct 1; inversion_clear 1; constructor; etrans; eauto.
- - by inversion_clear 1; constructor; apply dist_S.
+ - intros. inversion_clear H; constructor; by eapply dist_mono.
Qed.
-Canonical Structure csumO : ofeT := OfeT (csum A B) csum_ofe_mixin.
+Canonical Structure csumO : ofeT SI := OfeT (csum A B) csum_ofe_mixin.
Program Definition csum_chain_l (c : chain csumO) (a : A) : chain A :=
{| chain_car n := match c n return _ with Cinl a' => a' | _ => a end |}.
-Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
+Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy _ c n i). Qed.
Program Definition csum_chain_r (c : chain csumO) (b : B) : chain B :=
{| chain_car n := match c n return _ with Cinr b' => b' | _ => b end |}.
-Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
-Definition csum_compl `{Cofe A, Cofe B} : Compl csumO := λ c,
- match c 0 with
+Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy _ c n i). Qed.
+Definition csum_compl `{Cofe SI A, Cofe SI B} := λ (c : chain csumO),
+ match c zero with
| Cinl a => Cinl (compl (csum_chain_l c a))
| Cinr b => Cinr (compl (csum_chain_r c b))
| CsumBot => CsumBot
end.
-Global Program Instance csum_cofe `{Cofe A, Cofe B} : Cofe csumO :=
- {| compl := csum_compl |}.
+Program Definition csum_bchain_l {α} (c : bchain csumO α) (a : A) : bchain A α :=
+ {| bchain_car β Hβ := match c β Hβ return _ with Cinl a' => a' | _ => a end |}.
+Next Obligation. intros α c a β γ Hle Hβ Hγ. cbn. by destruct (bchain_cauchy _ _ c β γ Hle Hβ Hγ). Qed.
+Program Definition csum_bchain_r {α} (c : bchain csumO α) (b : B) : bchain B α :=
+ {| bchain_car β Hβ := match c β Hβ return _ with Cinr b' => b' | _ => b end |}.
+Next Obligation. intros α c b β γ Hle Hβ Hγ. cbn. by destruct (bchain_cauchy _ _ c β γ Hle Hβ Hγ). Qed.
+Definition csum_bcompl {HA:Cofe A} {HB: Cofe B} (α : SI):= λ (Hz : zero ≺ α) (c : bchain csumO α),
+ match c zero Hz with
+ | Cinl a => Cinl (bcompl Hz (csum_bchain_l c a))
+ | Cinr b => Cinr (bcompl Hz (csum_bchain_r c b))
+ | CsumBot => CsumBot
+ end.
+
+Global Program Instance csum_cofe `{Cofe SI A, Cofe SI B} : Cofe csumO :=
+ {| compl := csum_compl; bcompl := csum_bcompl |}.
+Next Obligation.
+ intros ?? α c; rewrite /compl /csum_compl.
+ feed inversion (chain_cauchy _ c zero α); first auto with lia; constructor.
+ + rewrite (conv_compl α (csum_chain_l c a')) /=. destruct (c α); naive_solver.
+ + rewrite (conv_compl α (csum_chain_r c b')) /=. destruct (c α); naive_solver.
+Qed.
+Next Obligation.
+ intros ?? α Hα c β Hβ. rewrite /bcompl /csum_bcompl.
+ feed inversion (bchain_cauchy _ _ c zero β ltac:(eauto with index) Hα Hβ); constructor.
+ + rewrite (conv_bcompl _ Hα (csum_bchain_l c a') β Hβ) /=. destruct (c β); naive_solver.
+ + rewrite (conv_bcompl _ Hα (csum_bchain_r c b') β Hβ) /=. destruct (c β); naive_solver.
+Qed.
Next Obligation.
- intros ?? n c; rewrite /compl /csum_compl.
- feed inversion (chain_cauchy c 0 n); first auto with lia; constructor.
- + rewrite (conv_compl n (csum_chain_l c a')) /=. destruct (c n); naive_solver.
- + rewrite (conv_compl n (csum_chain_r c b')) /=. destruct (c n); naive_solver.
+ intros ?? α Hα c d β H. rewrite /bcompl /csum_bcompl.
+ destruct (H zero Hα); constructor.
+ - apply bcompl_ne; intros; cbn. by destruct (H γ Hγ).
+ - apply bcompl_ne; intros; cbn. by destruct (H γ Hγ).
Qed.
Global Instance csum_ofe_discrete :
@@ -127,22 +152,22 @@ Lemma csum_map_compose {A A' A'' B B' B''} (f : A → A') (f' : A' → A'')
(g : B → B') (g' : B' → B'') (x : csum A B) :
csum_map (f' ∘ f) (g' ∘ g) x = csum_map f' g' (csum_map f g x).
Proof. by destruct x. Qed.
-Lemma csum_map_ext {A A' B B' : ofeT} (f f' : A → A') (g g' : B → B') x :
+Lemma csum_map_ext {SI} {A A' B B' : ofeT SI} (f f' : A → A') (g g' : B → B') x :
(∀ x, f x ≡ f' x) → (∀ x, g x ≡ g' x) → csum_map f g x ≡ csum_map f' g' x.
Proof. by destruct x; constructor. Qed.
-Instance csum_map_cmra_ne {A A' B B' : ofeT} n :
+Instance csum_map_cmra_ne {SI} {A A' B B' : ofeT SI} n :
Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==> dist n ==> dist n)
(@csum_map A A' B B').
Proof. intros f f' Hf g g' Hg []; destruct 1; constructor; by apply Hf || apply Hg. Qed.
-Definition csumO_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
- csumO A B -n> csumO A' B' :=
+Definition csumO_map {SI} {A A' B B'} (f : A -n> A') (g : B -n> B') :
+ csumO SI A B -n> csumO SI A' B' :=
OfeMor (csum_map f g).
-Instance csumO_map_ne A A' B B' :
- NonExpansive2 (@csumO_map A A' B B').
+Instance csumO_map_ne {SI} {A A' B B' : ofeT SI} :
+ NonExpansive2 (@csumO_map SI A A' B B').
Proof. by intros n f f' Hf g g' Hg []; constructor. Qed.
Section cmra.
-Context {A B : cmraT}.
+Context {SI : indexT} {A B : cmraT SI}.
Implicit Types a : A.
Implicit Types b : B.
@@ -153,24 +178,33 @@ Instance csum_valid : Valid (csum A B) := λ x,
| Cinr b => ✓ b
| CsumBot => False
end.
-Instance csum_validN : ValidN (csum A B) := λ n x,
+Local Hint Unfold csum_valid : core.
+Instance csum_validN : ValidN SI (csum A B) := λ n x,
match x with
| Cinl a => ✓{n} a
| Cinr b => ✓{n} b
| CsumBot => False
end.
+Local Hint Unfold csum_validN : core.
Instance csum_pcore : PCore (csum A B) := λ x,
match x with
| Cinl a => Cinl <$> pcore a
| Cinr b => Cinr <$> pcore b
| CsumBot => Some CsumBot
end.
+Local Hint Unfold csum_pcore : core.
Instance csum_op : Op (csum A B) := λ x y,
match x, y with
| Cinl a, Cinl a' => Cinl (a â‹… a')
| Cinr b, Cinr b' => Cinr (b â‹… b')
| _, _ => CsumBot
end.
+Local Hint Unfold csum_op : core.
+
+Lemma csum_validN_left α a : ✓{α} Cinl a ↔ ✓{α} a.
+Proof. reflexivity. Qed.
+Lemma csum_validN_right α b : ✓{α} Cinr b ↔ ✓{α} b.
+Proof. reflexivity. Qed.
Lemma Cinl_op a a' : Cinl a â‹… Cinl a' = Cinl (a â‹… a').
Proof. done. Qed.
@@ -207,7 +241,8 @@ Proof.
+ exists (Cinr c); by constructor.
Qed.
-Lemma csum_cmra_mixin : CmraMixin (csum A B).
+Local Hint Unfold validN : core.
+Lemma csum_cmra_mixin : CmraMixin SI (csum A B).
Proof.
split.
- intros [] n; destruct 1; constructor; by ofe_subst.
@@ -218,9 +253,10 @@ Proof.
+ destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
destruct (cmra_pcore_ne n b b' cb) as (cb'&->&?); auto.
exists (Cinr cb'); by repeat constructor.
- - intros ? [a|b|] [a'|b'|] H; inversion_clear H; ofe_subst; done.
- - intros [a|b|]; rewrite /= ?cmra_valid_validN; naive_solver eauto using O.
- - intros n [a|b|]; simpl; auto using cmra_validN_S.
+ - intros ? [a|b|] [a'|b'|] H; inversion_clear H; unfold validN; cbn; ofe_subst; done.
+ - intros [a|b|]; rewrite /= ?cmra_valid_validN. 1-2:naive_solver eauto using 0.
+ split; [ intros [] | intros H; apply (H zero)].
+ - intros α β [a|b|]; simpl; eauto using cmra_validN_downward.
- intros [a1|b1|] [a2|b2|] [a3|b3|]; constructor; by rewrite ?assoc.
- intros [a1|b1|] [a2|b2|]; constructor; by rewrite 1?comm.
- intros [a|b|] ? [=]; subst; auto.
@@ -241,7 +277,7 @@ Proof.
+ destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
destruct (cmra_pcore_mono b b' cb) as (cb'&->&?); auto.
exists (Cinr cb'). rewrite csum_included; eauto 10.
- - intros n [a1|b1|] [a2|b2|]; simpl; eauto using cmra_validN_op_l; done.
+ - intros α [a1|b1|] [a2|b2|]; simpl; unfold op, csum_op; eauto using cmra_validN_op_l; done.
- intros n [a|b|] y1 y2 Hx Hx'.
+ destruct y1 as [a1|b1|], y2 as [a2|b2|]; try by exfalso; inversion Hx'.
destruct (cmra_extend n a a1 a2) as (z1&z2&?&?&?); [done|apply (inj Cinl), Hx'|].
@@ -251,7 +287,7 @@ Proof.
exists (Cinr z1), (Cinr z2). by repeat constructor.
+ by exists CsumBot, CsumBot; destruct y1, y2; inversion_clear Hx'.
Qed.
-Canonical Structure csumR := CmraT (csum A B) csum_cmra_mixin.
+Canonical Structure csumR := CmraT SI (csum A B) csum_cmra_mixin.
Global Instance csum_cmra_discrete :
CmraDiscrete A → CmraDiscrete B → CmraDiscrete csumR.
@@ -361,35 +397,38 @@ End cmra.
Arguments csumR : clear implicits.
(* Functor *)
-Instance csum_map_cmra_morphism {A A' B B' : cmraT} (f : A → A') (g : B → B') :
+Instance csum_map_cmra_morphism {SI} {A A' B B' : cmraT SI} (f : A → A') (g : B → B') :
CmraMorphism f → CmraMorphism g → CmraMorphism (csum_map f g).
Proof.
split; try apply _.
- - intros n [a|b|]; simpl; auto using cmra_morphism_validN.
+ - intros n [a|b|]; simpl.
+ + rewrite !csum_validN_left; eauto using cmra_morphism_validN.
+ + rewrite !csum_validN_right; eauto using cmra_morphism_validN.
+ + eauto.
- move=> [a|b|]=>//=; rewrite cmra_morphism_pcore; by destruct pcore.
- intros [xa|ya|] [xb|yb|]=>//=; by rewrite -cmra_morphism_op.
Qed.
-Program Definition csumRF (Fa Fb : rFunctor) : rFunctor := {|
- rFunctor_car A _ B _ := csumR (rFunctor_car Fa A B) (rFunctor_car Fb A B);
- rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := csumO_map (rFunctor_map Fa fg) (rFunctor_map Fb fg)
+Program Definition csumRF {SI} (Fa Fb : rFunctor SI) : rFunctor SI := {|
+ rFunctor_car A B := csumR SI (rFunctor_car Fa A B) (rFunctor_car Fb A B);
+ rFunctor_map A1 A2 B1 B2 fg := csumO_map (rFunctor_map Fa fg) (rFunctor_map Fb fg)
|}.
Next Obligation.
- by intros Fa Fb A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply csumO_map_ne; try apply rFunctor_ne.
+ by intros SI Fa Fb A1 A2 B1 B2 n f g Hfg; apply csumO_map_ne; try apply rFunctor_ne.
Qed.
Next Obligation.
- intros Fa Fb A ? B ? x. rewrite /= -{2}(csum_map_id x).
+ intros SI Fa Fb A B x. rewrite /= -{2}(csum_map_id x).
apply csum_map_ext=>y; apply rFunctor_id.
Qed.
Next Obligation.
- intros Fa Fb A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -csum_map_compose.
+ intros SI Fa Fb A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -csum_map_compose.
apply csum_map_ext=>y; apply rFunctor_compose.
Qed.
-Instance csumRF_contractive Fa Fb :
+Instance csumRF_contractive {SI} (Fa Fb : rFunctor SI) :
rFunctorContractive Fa → rFunctorContractive Fb →
rFunctorContractive (csumRF Fa Fb).
Proof.
- intros ?? A1 ? A2 ? B1 ? B2 ? n f g Hfg.
+ intros ?? A1 A2 B1 B2 n f g Hfg.
by apply csumO_map_ne; try apply rFunctor_contractive.
Qed.
diff --git a/theories/algebra/deprecated.v b/theories/algebra/deprecated.v
deleted file mode 100644
index d91ece95affa891911e3ed583502710dbc9f953d..0000000000000000000000000000000000000000
--- a/theories/algebra/deprecated.v
+++ /dev/null
@@ -1,79 +0,0 @@
-From iris.algebra Require Import ofe cmra.
-Set Default Proof Using "Type".
-
-(* Old notation for backwards compatibility. *)
-
-(* Deprecated 2016-11-22. Use ofeT instead. *)
-Notation cofeT := ofeT (only parsing).
-
-(* Deprecated 2016-12-09. Use agree instead. *)
-Module dec_agree.
-Local Arguments validN _ _ _ !_ /.
-Local Arguments valid _ _ !_ /.
-Local Arguments op _ _ _ !_ /.
-Local Arguments pcore _ _ !_ /.
-
-(* This is isomorphic to option, but has a very different RA structure. *)
-Inductive dec_agree (A : Type) : Type :=
- | DecAgree : A → dec_agree A
- | DecAgreeBot : dec_agree A.
-Arguments DecAgree {_} _.
-Arguments DecAgreeBot {_}.
-Instance maybe_DecAgree {A} : Maybe (@DecAgree A) := λ x,
- match x with DecAgree a => Some a | _ => None end.
-
-Section dec_agree.
-Context `{EqDecision A}.
-Implicit Types a b : A.
-Implicit Types x y : dec_agree A.
-
-Instance dec_agree_valid : Valid (dec_agree A) := λ x,
- if x is DecAgree _ then True else False.
-Canonical Structure dec_agreeO : ofeT := leibnizO (dec_agree A).
-
-Instance dec_agree_op : Op (dec_agree A) := λ x y,
- match x, y with
- | DecAgree a, DecAgree b => if decide (a = b) then DecAgree a else DecAgreeBot
- | _, _ => DecAgreeBot
- end.
-Instance dec_agree_pcore : PCore (dec_agree A) := Some.
-
-Definition dec_agree_ra_mixin : RAMixin (dec_agree A).
-Proof.
- apply ra_total_mixin; apply _ || eauto.
- - intros [?|] [?|] [?|]; by repeat (simplify_eq/= || case_match).
- - intros [?|] [?|]; by repeat (simplify_eq/= || case_match).
- - intros [?|]; by repeat (simplify_eq/= || case_match).
- - by intros [?|] [?|] ?.
-Qed.
-
-Canonical Structure dec_agreeR : cmraT :=
- discreteR (dec_agree A) dec_agree_ra_mixin.
-
-Global Instance dec_agree_cmra_discrete : CmraDiscrete dec_agreeR.
-Proof. apply discrete_cmra_discrete. Qed.
-Global Instance dec_agree_cmra_total : CmraTotal dec_agreeR.
-Proof. intros x. by exists x. Qed.
-
-(* Some properties of this CMRA *)
-Global Instance dec_agree_core_id (x : dec_agreeR) : CoreId x.
-Proof. by constructor. Qed.
-
-Lemma dec_agree_ne a b : a ≠b → DecAgree a ⋅ DecAgree b = DecAgreeBot.
-Proof. intros. by rewrite /= decide_False. Qed.
-
-Lemma dec_agree_idemp (x : dec_agree A) : x â‹… x = x.
-Proof. destruct x; by rewrite /= ?decide_True. Qed.
-
-Lemma dec_agree_op_inv (x1 x2 : dec_agree A) : ✓ (x1 ⋅ x2) → x1 = x2.
-Proof. destruct x1, x2; by repeat (simplify_eq/= || case_match). Qed.
-
-Lemma DecAgree_included a b : DecAgree a ≼ DecAgree b ↔ a = b.
-Proof.
- split. intros [[c|] [=]%leibniz_equiv]. by simplify_option_eq. by intros ->.
-Qed.
-End dec_agree.
-
-Arguments dec_agreeO : clear implicits.
-Arguments dec_agreeR _ {_}.
-End dec_agree.
diff --git a/theories/algebra/dfrac.v b/theories/algebra/dfrac.v
new file mode 100644
index 0000000000000000000000000000000000000000..005bfa0e171e9528792750d2202a0659d9c1a1bc
--- /dev/null
+++ b/theories/algebra/dfrac.v
@@ -0,0 +1,217 @@
+(** Camera of discardable fractions.
+
+ This is a generalisation of the fractional camera where elements can
+ represent both ownership of a fraction (as in the fractional camera) and the
+ knowledge that a fraction has been discarded.
+
+ Ownership of a fraction is denoted [DfracOwn q] and behaves identically to
+ [q] of the fractional camera.
+
+ Knowledge that a fraction has been discarded is denoted [DfracDiscarded].
+ This elements is its own core, making ownership persistent.
+
+ One can make a frame preserving update from _owning_ a fraction to _knowing_
+ that the fraction has been discarded.
+
+ Crucially, ownership over 1 is an exclusive element just as it is in the
+ fractional camera. Hence owning 1 implies that no fraction has been
+ discarded. Conversely, knowing that a fraction has been discarded implies
+ that no one can own 1. And, since discarding is an irreversible operation,
+ it also implies that no one can own 1 in the future *)
+From Coq.QArith Require Import Qcanon.
+From iris.algebra Require Export cmra.
+From iris.algebra Require Import proofmode_classes updates frac.
+
+(** An element of dfrac denotes ownership of a fraction, knowledge that a
+ fraction has been discarded, or both. Note that [DfracBoth] can be written
+ as [DfracOwn q â‹… DfracDiscarded]. This should be used instead
+ of [DfracBoth] which is for internal use only. *)
+Inductive dfrac :=
+ | DfracOwn : Qp → dfrac
+ | DfracDiscarded : dfrac
+ | DfracBoth : Qp → dfrac.
+
+Section dfrac.
+Context {SI: indexT}.
+ Canonical Structure dfracO := leibnizO SI dfrac.
+
+ Implicit Types p q : Qp.
+ Implicit Types dp dq : dfrac.
+
+ Global Instance DfracOwn_inj : Inj (=) (=) DfracOwn.
+ Proof. by injection 1. Qed.
+ Global Instance DfracBoth_inj : Inj (=) (=) DfracBoth.
+ Proof. by injection 1. Qed.
+
+ (** An element is valid as long as the sum of its content is less than one. *)
+ Instance dfrac_valid : Valid dfrac := λ dq,
+ match dq with
+ | DfracOwn q => q ≤ 1
+ | DfracDiscarded => True
+ | DfracBoth q => q < 1
+ end%Qc.
+
+ (** As in the fractional camera the core is undefined for elements denoting
+ ownership of a fraction. For elements denoting the knowledge that a fraction has
+ been discarded the core is the identity function. *)
+ Instance dfrac_pcore : PCore dfrac := λ dq,
+ match dq with
+ | DfracOwn q => None
+ | DfracDiscarded => Some DfracDiscarded
+ | DfracBoth q => Some DfracDiscarded
+ end.
+
+ (** When elements are combined, ownership is added together and knowledge of
+ discarded fractions is combined with the max operation. *)
+ Instance dfrac_op : Op dfrac := λ dq dp,
+ match dq, dp with
+ | DfracOwn q, DfracOwn q' => DfracOwn (q + q')
+ | DfracOwn q, DfracDiscarded => DfracBoth q
+ | DfracOwn q, DfracBoth q' => DfracBoth (q + q')
+ | DfracDiscarded, DfracOwn q' => DfracBoth q'
+ | DfracDiscarded, DfracDiscarded => DfracDiscarded
+ | DfracDiscarded, DfracBoth q' => DfracBoth q'
+ | DfracBoth q, DfracOwn q' => DfracBoth (q + q')
+ | DfracBoth q, DfracDiscarded => DfracBoth q
+ | DfracBoth q, DfracBoth q' => DfracBoth (q + q')
+ end.
+
+ Lemma dfrac_op_own q p : DfracOwn p â‹… DfracOwn q = DfracOwn (p + q).
+ Proof. done. Qed.
+
+ Lemma dfrac_op_discarded :
+ DfracDiscarded â‹… DfracDiscarded = DfracDiscarded.
+ Proof. done. Qed.
+
+ Lemma dfrac_own_included q p : DfracOwn q ≼ DfracOwn p ↔ (q < p)%Qp.
+ Proof.
+ rewrite Qp_lt_sum. split.
+ - rewrite /included /op /dfrac_op. intros [[o| |?] [= ->]]. by exists o.
+ - intros [o ->]. exists (DfracOwn o). by rewrite dfrac_op_own.
+ Qed.
+
+ (* [dfrac] does not have a unit so reflexivity is not for granted! *)
+ Lemma dfrac_discarded_included :
+ DfracDiscarded ≼ DfracDiscarded.
+ Proof. exists DfracDiscarded. done. Qed.
+
+ Definition dfrac_ra_mixin : RAMixin dfrac.
+ Proof.
+ split; try apply _.
+ - intros [?| |?] ? dq <-; intros [= <-]; eexists _; done.
+ - intros [?| |?] [?| |?] [?| |?];
+ rewrite /op /dfrac_op 1?assoc_L 1?assoc_L; done.
+ - intros [?| |?] [?| |?];
+ rewrite /op /dfrac_op 1?(comm_L Qp_plus); done.
+ - intros [?| |?] dq; rewrite /pcore /dfrac_pcore; intros [= <-];
+ rewrite /op /dfrac_op; done.
+ - intros [?| |?] ? [= <-]; done.
+ - intros [?| |?] [?| |?] ? [[?| |?] [=]] [= <-]; eexists _; split; try done;
+ apply dfrac_discarded_included.
+ - intros [q| |q] [q'| |q']; rewrite /op /dfrac_op /valid /dfrac_valid //.
+ + intros. trans (q + q')%Qp; [|done].
+ apply Qclt_le_weak.
+ apply Qp_lt_sum. eauto.
+ + apply Qclt_le_weak.
+ + intros. trans (q + q')%Qp; [|by apply Qclt_le_weak].
+ apply Qclt_le_weak.
+ apply Qp_lt_sum. eauto.
+ + intros. trans (q + q')%Qp; [|by eauto].
+ apply Qp_lt_sum. eauto.
+ + intros. trans (q + q')%Qp; [|by eauto].
+ apply Qp_lt_sum. eauto.
+ Qed.
+ Canonical Structure dfracR := discreteR SI dfrac dfrac_ra_mixin.
+
+ Global Instance dfrac_cmra_discrete : CmraDiscrete dfracR.
+ Proof. apply discrete_cmra_discrete. Qed.
+
+ Global Instance dfrac_full_exclusive : Exclusive (DfracOwn 1).
+ Proof.
+ intros [q| |q];
+ rewrite /op /cmra_op -cmra_discrete_valid_iff /valid /cmra_valid //=.
+ - intros Hle.
+ assert (Qp_car 1 < (1 + q)%Qp).
+ { rewrite Qp_lt_sum. eexists. eauto. }
+ eapply Qcle_ngt in Hle. eauto.
+ - intros Hlt.
+ assert (Qp_car 1 < (1 + q)%Qp).
+ { rewrite Qp_lt_sum. eexists. eauto. }
+ apply Qclt_le_weak in Hlt.
+ eapply Qcle_ngt in Hlt. eauto.
+ Qed.
+
+ Lemma Qp_plus_id_free q p : q + p ≠q.
+ Proof.
+ intro Heq.
+ assert (Qp_car q < (q + p)%Qp).
+ { rewrite Qp_lt_sum. eexists. eauto. }
+ assert (q + p <= q)%Qp as Hle.
+ { rewrite Heq. reflexivity. }
+ eapply Qcle_ngt in Hle. eauto.
+ Qed.
+
+ Lemma Qp_to_Qc_inj_iff p q : Qp_car p = Qp_car q ↔ p = q.
+ Proof.
+ split; [|by intros ->].
+ destruct p, q; intros; simplify_eq/=; f_equal; apply (proof_irrel _).
+ Qed.
+ Instance Qp_add_inj_r p : Inj (=) (=) (Qp_plus p).
+ Proof.
+ destruct p as [p ?].
+ intros [q1 ?] [q2 ?]. rewrite <-!Qp_to_Qc_inj_iff; simpl. apply (inj (Qcplus p)).
+ Qed.
+
+ Global Instance dfrac_cancelable q : Cancelable (DfracOwn q).
+ Proof.
+ apply: discrete_cancelable.
+ intros [q1| |q1][q2| |q2] _ [=]; try (simplify_eq/=; done).
+ - f_equal. eapply (Qp_add_inj_r q); eauto.
+ apply Qp_to_Qc_inj_iff => //=.
+ rewrite /Qcplus/Q2Qc.
+ apply Qc_decomp => //=.
+ - destruct (Qp_plus_id_free q q2).
+ transitivity (Qp_plus q q2); eauto.
+ symmetry. apply Qp_to_Qc_inj_iff. apply H0.
+ - destruct (Qp_plus_id_free q q1).
+ transitivity (Qp_plus q q1); eauto.
+ apply Qp_to_Qc_inj_iff. apply H0.
+ - f_equal. eapply (Qp_add_inj_r q); eauto.
+ apply Qp_to_Qc_inj_iff => //=.
+ rewrite /Qcplus/Q2Qc.
+ apply Qc_decomp => //=.
+ Qed.
+ Global Instance frac_id_free q : IdFree (DfracOwn q).
+ Proof.
+ intros [q'| |q'] _ [=].
+ apply (Qp_plus_id_free q q').
+ transitivity (Qp_plus q q'); eauto.
+ apply Qp_to_Qc_inj_iff. apply H0.
+ Qed.
+ Global Instance dfrac_discarded_core_id : CoreId DfracDiscarded.
+ Proof. by constructor. Qed.
+
+ Lemma dfrac_valid_own p : ✓ DfracOwn p ↔ (p ≤ 1)%Qc.
+ Proof. done. Qed.
+
+ Lemma dfrac_valid_discarded p : ✓ DfracDiscarded.
+ Proof. done. Qed.
+
+ Lemma dfrac_valid_own_discarded q :
+ ✓ (DfracOwn q ⋅ DfracDiscarded) ↔ (q < 1)%Qc.
+ Proof. done. Qed.
+
+ (** Discarding a fraction is a frame preserving update. *)
+ Lemma dfrac_discard_update q : DfracOwn q ~~> DfracDiscarded.
+ Proof.
+ intros n [[q'| |q']|];
+ rewrite /op /cmra_op -!cmra_discrete_valid_iff /valid /cmra_valid //=.
+ - intros.
+ apply Qclt_le_trans with (q + q')%Qp; [| done].
+ apply Qp_lt_sum. eexists. rewrite (comm _ q q'). eauto.
+ - intros.
+ apply Qclt_trans with (q + q')%Qp; [| done].
+ apply Qp_lt_sum. eexists. rewrite (comm _ q q'). eauto.
+ Qed.
+
+End dfrac.
diff --git a/theories/algebra/dra.v b/theories/algebra/dra.v
deleted file mode 100644
index f162ca23e6fce3ee8a9f08d60454eb98d40d5399..0000000000000000000000000000000000000000
--- a/theories/algebra/dra.v
+++ /dev/null
@@ -1,217 +0,0 @@
-From iris.algebra Require Export cmra updates.
-Set Default Proof Using "Type".
-
-Record DraMixin A `{Equiv A, Core A, Disjoint A, Op A, Valid A} := {
- (* setoids *)
- mixin_dra_equivalence : Equivalence (≡@{A});
- mixin_dra_op_proper : Proper ((≡@{A}) ==> (≡) ==> (≡)) (⋅);
- mixin_dra_core_proper : Proper ((≡@{A}) ==> (≡)) core;
- mixin_dra_valid_proper : Proper ((≡@{A}) ==> impl) valid;
- mixin_dra_disjoint_proper (x : A) : Proper ((≡) ==> impl) (disjoint x);
- (* validity *)
- mixin_dra_op_valid (x y : A) : ✓ x → ✓ y → x ## y → ✓ (x ⋅ y);
- mixin_dra_core_valid (x : A) : ✓ x → ✓ core x;
- (* monoid *)
- mixin_dra_assoc (x y z : A) :
- ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ⋅ (y ⋅ z) ≡ (x ⋅ y) ⋅ z;
- mixin_dra_disjoint_ll (x y z : A) :
- ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ## z;
- mixin_dra_disjoint_move_l (x y z : A) :
- ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ## y ⋅ z;
- mixin_dra_symmetric : Symmetric (@disjoint A _);
- mixin_dra_comm (x y : A) : ✓ x → ✓ y → x ## y → x ⋅ y ≡ y ⋅ x;
- mixin_dra_core_disjoint_l (x : A) : ✓ x → core x ## x;
- mixin_dra_core_l (x : A) : ✓ x → core x ⋅ x ≡ x;
- mixin_dra_core_idemp (x : A) : ✓ x → core (core x) ≡ core x;
- mixin_dra_core_mono (x y : A) :
- ∃ z, ✓ x → ✓ y → x ## y → core (x ⋅ y) ≡ core x ⋅ z ∧ ✓ z ∧ core x ## z
-}.
-Structure draT := DraT {
- dra_car :> Type;
- dra_equiv : Equiv dra_car;
- dra_core : Core dra_car;
- dra_disjoint : Disjoint dra_car;
- dra_op : Op dra_car;
- dra_valid : Valid dra_car;
- dra_mixin : DraMixin dra_car
-}.
-Arguments DraT _ {_ _ _ _ _} _.
-Arguments dra_car : simpl never.
-Arguments dra_equiv : simpl never.
-Arguments dra_core : simpl never.
-Arguments dra_disjoint : simpl never.
-Arguments dra_op : simpl never.
-Arguments dra_valid : simpl never.
-Arguments dra_mixin : simpl never.
-Add Printing Constructor draT.
-Existing Instances dra_equiv dra_core dra_disjoint dra_op dra_valid.
-
-(** Lifting properties from the mixin *)
-Section dra_mixin.
- Context {A : draT}.
- Implicit Types x y : A.
- Global Instance dra_equivalence : Equivalence ((≡) : relation A).
- Proof. apply (mixin_dra_equivalence _ (dra_mixin A)). Qed.
- Global Instance dra_op_proper : Proper ((≡) ==> (≡) ==> (≡)) (@op A _).
- Proof. apply (mixin_dra_op_proper _ (dra_mixin A)). Qed.
- Global Instance dra_core_proper : Proper ((≡) ==> (≡)) (@core A _).
- Proof. apply (mixin_dra_core_proper _ (dra_mixin A)). Qed.
- Global Instance dra_valid_proper : Proper ((≡) ==> impl) (@valid A _).
- Proof. apply (mixin_dra_valid_proper _ (dra_mixin A)). Qed.
- Global Instance dra_disjoint_proper x : Proper ((≡) ==> impl) (disjoint x).
- Proof. apply (mixin_dra_disjoint_proper _ (dra_mixin A)). Qed.
- Lemma dra_op_valid x y : ✓ x → ✓ y → x ## y → ✓ (x ⋅ y).
- Proof. apply (mixin_dra_op_valid _ (dra_mixin A)). Qed.
- Lemma dra_core_valid x : ✓ x → ✓ core x.
- Proof. apply (mixin_dra_core_valid _ (dra_mixin A)). Qed.
- Lemma dra_assoc x y z :
- ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ⋅ (y ⋅ z) ≡ (x ⋅ y) ⋅ z.
- Proof. apply (mixin_dra_assoc _ (dra_mixin A)). Qed.
- Lemma dra_disjoint_ll x y z : ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ## z.
- Proof. apply (mixin_dra_disjoint_ll _ (dra_mixin A)). Qed.
- Lemma dra_disjoint_move_l x y z :
- ✓ x → ✓ y → ✓ z → x ## y → x ⋅ y ## z → x ## y ⋅ z.
- Proof. apply (mixin_dra_disjoint_move_l _ (dra_mixin A)). Qed.
- Global Instance dra_symmetric : Symmetric (@disjoint A _).
- Proof. apply (mixin_dra_symmetric _ (dra_mixin A)). Qed.
- Lemma dra_comm x y : ✓ x → ✓ y → x ## y → x ⋅ y ≡ y ⋅ x.
- Proof. apply (mixin_dra_comm _ (dra_mixin A)). Qed.
- Lemma dra_core_disjoint_l x : ✓ x → core x ## x.
- Proof. apply (mixin_dra_core_disjoint_l _ (dra_mixin A)). Qed.
- Lemma dra_core_l x : ✓ x → core x ⋅ x ≡ x.
- Proof. apply (mixin_dra_core_l _ (dra_mixin A)). Qed.
- Lemma dra_core_idemp x : ✓ x → core (core x) ≡ core x.
- Proof. apply (mixin_dra_core_idemp _ (dra_mixin A)). Qed.
- Lemma dra_core_mono x y :
- ∃ z, ✓ x → ✓ y → x ## y → core (x ⋅ y) ≡ core x ⋅ z ∧ ✓ z ∧ core x ## z.
- Proof. apply (mixin_dra_core_mono _ (dra_mixin A)). Qed.
-End dra_mixin.
-
-Record validity (A : draT) := Validity {
- validity_car : A;
- validity_is_valid : Prop;
- validity_prf : validity_is_valid → valid validity_car
-}.
-Add Printing Constructor validity.
-Arguments Validity {_} _ _ _.
-Arguments validity_car {_} _.
-Arguments validity_is_valid {_} _.
-
-Definition to_validity {A : draT} (x : A) : validity A :=
- Validity x (valid x) id.
-
-(* The actual construction *)
-Section dra.
-Context (A : draT).
-Implicit Types a b : A.
-Implicit Types x y z : validity A.
-Arguments valid _ _ !_ /.
-
-Instance validity_valid : Valid (validity A) := validity_is_valid.
-Instance validity_equiv : Equiv (validity A) := λ x y,
- (valid x ↔ valid y) ∧ (valid x → validity_car x ≡ validity_car y).
-Instance validity_equivalence : Equivalence (@equiv (validity A) _).
-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; trans y]; tauto.
-Qed.
-Canonical Structure validityO : ofeT := discreteO (validity A).
-
-Instance dra_valid_proper' : Proper ((≡) ==> iff) (valid : A → Prop).
-Proof. by split; apply: dra_valid_proper. Qed.
-Global Instance to_validity_proper : Proper ((≡) ==> (≡)) to_validity.
-Proof. by intros x1 x2 Hx; split; rewrite /= Hx. Qed.
-Instance: Proper ((≡) ==> (≡) ==> iff) (disjoint : relation A).
-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 a b c : ✓ a → ✓ b → ✓ c → b ## c → a ## b ⋅ c → a ## b.
-Proof. intros ???. rewrite !(symmetry_iff _ a). by apply dra_disjoint_ll. Qed.
-Lemma dra_disjoint_lr a b c : ✓ a → ✓ b → ✓ c → a ## b → a ⋅ b ## c → b ## c.
-Proof. intros ????. rewrite dra_comm //. by apply dra_disjoint_ll. Qed.
-Lemma dra_disjoint_move_r a b c :
- ✓ a → ✓ b → ✓ c → b ## c → a ## b ⋅ c → a ⋅ b ## c.
-Proof.
- intros; symmetry; rewrite dra_comm; eauto using dra_disjoint_rl.
- apply dra_disjoint_move_l; auto; by rewrite dra_comm.
-Qed.
-Hint Immediate dra_disjoint_move_l dra_disjoint_move_r : core.
-
-Lemma validity_valid_car_valid z : ✓ z → ✓ validity_car z.
-Proof. apply validity_prf. Qed.
-Hint Resolve validity_valid_car_valid : core.
-Program Instance validity_pcore : PCore (validity A) := λ x,
- Some (Validity (core (validity_car x)) (✓ x) _).
-Solve Obligations with naive_solver eauto using dra_core_valid.
-Program Instance validity_op : Op (validity A) := λ x y,
- Validity (validity_car x â‹… validity_car y)
- (✓ x ∧ ✓ y ∧ validity_car x ## validity_car y) _.
-Solve Obligations with naive_solver eauto using dra_op_valid.
-
-Definition validity_ra_mixin : RAMixin (validity A).
-Proof.
- apply ra_total_mixin; first eauto.
- - intros ??? [? Heq]; split; simpl; [|by intros (?&?&?); rewrite Heq].
- split; intros (?&?&?); split_and!;
- first [rewrite ?Heq; tauto|rewrite -?Heq; tauto|tauto].
- - by intros ?? [? Heq]; split; [done|]; simpl; intros ?; rewrite Heq.
- - intros ?? [??]; naive_solver.
- - intros [x px ?] [y py ?] [z pz ?]; split; simpl;
- [intuition eauto 2 using dra_disjoint_lr, dra_disjoint_rl
- |intuition eauto using dra_assoc, dra_disjoint_rl].
- - intros [x px ?] [y py ?]; split; naive_solver eauto using dra_comm.
- - intros [x px ?]; split;
- naive_solver eauto using dra_core_l, dra_core_disjoint_l.
- - intros [x px ?]; split; naive_solver eauto using dra_core_idemp.
- - intros [x px ?] [y py ?] [[z pz ?] [? Hy]]; simpl in *.
- destruct (dra_core_mono x z) as (z'&Hz').
- unshelve eexists (Validity z' (px ∧ py ∧ pz) _).
- { intros (?&?&?); apply Hz'; tauto. }
- split; simpl; first tauto.
- intros. rewrite Hy //. tauto.
- - by intros [x px ?] [y py ?] (?&?&?).
-Qed.
-Canonical Structure validityR : cmraT :=
- discreteR (validity A) validity_ra_mixin.
-
-Global Instance validity_disrete_cmra : CmraDiscrete validityR.
-Proof. apply discrete_cmra_discrete. Qed.
-Global Instance validity_cmra_total : CmraTotal validityR.
-Proof. rewrite /CmraTotal; eauto. Qed.
-
-Lemma validity_update x y :
- (∀ c, ✓ x → ✓ c → validity_car x ## c → ✓ y ∧ validity_car y ## c) → x ~~> y.
-Proof.
- intros Hxy; apply cmra_discrete_update=> z [?[??]].
- split_and!; try eapply Hxy; eauto.
-Qed.
-
-Lemma to_validity_op a b :
- (✓ (a ⋅ b) → ✓ a ∧ ✓ b ∧ a ## b) →
- to_validity (a ⋅ b) ≡ to_validity a ⋅ to_validity b.
-Proof. split; naive_solver eauto using dra_op_valid. Qed.
-
-(* TODO: This has to be proven again. *)
-(*
-Lemma to_validity_included x y:
- (✓ y ∧ to_validity x ≼ to_validity y)%stdpp ↔ (✓ x ∧ x ≼ y).
-Proof.
- split.
- - move=>[Hvl [z [Hvxz EQ]]]. move:(Hvl)=>Hvl'. apply Hvxz in Hvl'.
- destruct Hvl' as [? [? ?]]; split; first done.
- exists (validity_car z); eauto.
- - intros (Hvl & z & EQ & ? & ?).
- assert (✓ y) by (rewrite EQ; by apply dra_op_valid).
- split; first done. exists (to_validity z). split; first split.
- + intros _. simpl. by split_and!.
- + intros _. setoid_subst. by apply dra_op_valid.
- + intros _. rewrite /= EQ //.
-Qed.
-*)
-End dra.
diff --git a/theories/algebra/excl.v b/theories/algebra/excl.v
index 6467624323e8915259dde9528e4a56be58ad5d90..5c0f3c36bbf9d97a96aaefab35e61feec1f2b6bf 100644
--- a/theories/algebra/excl.v
+++ b/theories/algebra/excl.v
@@ -21,7 +21,7 @@ Instance maybe_Excl {A} : Maybe (@Excl A) := λ x,
match x with Excl a => Some a | _ => None end.
Section excl.
-Context {A : ofeT}.
+Context {SI} {A : ofeT SI}.
Implicit Types a b : A.
Implicit Types x y : excl A.
@@ -30,7 +30,7 @@ Inductive excl_equiv : Equiv (excl A) :=
| Excl_equiv a b : a ≡ b → Excl a ≡ Excl b
| ExclBot_equiv : ExclBot ≡ ExclBot.
Existing Instance excl_equiv.
-Inductive excl_dist : Dist (excl A) :=
+Inductive excl_dist : Dist SI (excl A) :=
| Excl_dist a b n : a ≡{n}≡ b → Excl a ≡{n}≡ Excl b
| ExclBot_dist n : ExclBot ≡{n}≡ ExclBot.
Existing Instance excl_dist.
@@ -44,13 +44,13 @@ Proof. by inversion_clear 1. Qed.
Global Instance Excl_dist_inj n : Inj (dist n) (dist n) (@Excl A).
Proof. by inversion_clear 1. Qed.
-Definition excl_ofe_mixin : OfeMixin (excl A).
+Definition excl_ofe_mixin : OfeMixin SI (excl A).
Proof.
apply (iso_ofe_mixin (maybe Excl)).
- by intros [a|] [b|]; split; inversion_clear 1; constructor.
- by intros n [a|] [b|]; split; inversion_clear 1; constructor.
Qed.
-Canonical Structure exclO : ofeT := OfeT (excl A) excl_ofe_mixin.
+Canonical Structure exclO : ofeT SI := OfeT (excl A) excl_ofe_mixin.
Global Instance excl_cofe `{!Cofe A} : Cofe exclO.
Proof.
@@ -72,24 +72,24 @@ Proof. by inversion_clear 1; constructor. Qed.
(* CMRA *)
Instance excl_valid : Valid (excl A) := λ x,
match x with Excl _ => True | ExclBot => False end.
-Instance excl_validN : ValidN (excl A) := λ n x,
+Instance excl_validN : ValidN SI (excl A) := λ n x,
match x with Excl _ => True | ExclBot => False end.
Instance excl_pcore : PCore (excl A) := λ _, None.
Instance excl_op : Op (excl A) := λ x y, ExclBot.
-Lemma excl_cmra_mixin : CmraMixin (excl A).
+Lemma excl_cmra_mixin : CmraMixin SI (excl A).
Proof.
split; try discriminate.
- - by intros n []; destruct 1; constructor.
+ - intros [] n; destruct 1; constructor.
- by destruct 1; intros ?.
- - intros x; split. done. by move=> /(_ 0).
- - intros n [?|]; simpl; auto with lia.
+ - intros x; split. done. by move=> /(_ zero).
+ - intros n m [?|]; simpl; auto.
- by intros [?|] [?|] [?|]; constructor.
- by intros [?|] [?|]; constructor.
- by intros n [?|] [?|].
- intros n x [?|] [?|] ? Hx; eexists _, _; inversion_clear Hx; eauto.
Qed.
-Canonical Structure exclR := CmraT (excl A) excl_cmra_mixin.
+Canonical Structure exclR := CmraT SI (excl A) excl_cmra_mixin.
Global Instance excl_cmra_discrete : OfeDiscrete A → CmraDiscrete exclR.
Proof. split. apply _. by intros []. Qed.
@@ -124,8 +124,8 @@ Lemma Excl_included a b : Excl' a ≼ Excl' b → a ≡ b.
Proof. by intros [[c|] Hb%(inj Some)]; inversion_clear Hb. Qed.
End excl.
-Arguments exclO : clear implicits.
-Arguments exclR : clear implicits.
+Arguments exclO {_} _.
+Arguments exclR {_} _.
(* Functor *)
Definition excl_map {A B} (f : A → B) (x : excl A) : excl B :=
@@ -135,38 +135,38 @@ Proof. by destruct x. Qed.
Lemma excl_map_compose {A B C} (f : A → B) (g : B → C) (x : excl A) :
excl_map (g ∘ f) x = excl_map g (excl_map f x).
Proof. by destruct x. Qed.
-Lemma excl_map_ext {A B : ofeT} (f g : A → B) x :
+Lemma excl_map_ext {SI} {A B : ofeT SI} (f g : A → B) x :
(∀ x, f x ≡ g x) → excl_map f x ≡ excl_map g x.
Proof. by destruct x; constructor. Qed.
-Instance excl_map_ne {A B : ofeT} n :
+Instance excl_map_ne {SI} {A B : ofeT SI} n :
Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@excl_map A B).
Proof. by intros f f' Hf; destruct 1; constructor; apply Hf. Qed.
-Instance excl_map_cmra_morphism {A B : ofeT} (f : A → B) :
+Instance excl_map_cmra_morphism {SI} {A B : ofeT SI} (f : A → B) :
NonExpansive f → CmraMorphism (excl_map f).
Proof. split; try done; try apply _. by intros n [a|]. Qed.
-Definition exclO_map {A B} (f : A -n> B) : exclO A -n> exclO B :=
+Definition exclO_map {SI} {A B: ofeT SI} (f : A -n> B) : exclO A -n> exclO B :=
OfeMor (excl_map f).
-Instance exclO_map_ne A B : NonExpansive (@exclO_map A B).
+Instance exclO_map_ne {SI} (A B: ofeT SI) : NonExpansive (@exclO_map SI A B).
Proof. by intros n f f' Hf []; constructor; apply Hf. Qed.
-Program Definition exclRF (F : oFunctor) : rFunctor := {|
- rFunctor_car A _ B _ := (exclR (oFunctor_car F A B));
- rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := exclO_map (oFunctor_map F fg)
+Program Definition exclRF {SI} (F : oFunctor SI) : rFunctor SI := {|
+ rFunctor_car A B := (exclR (oFunctor_car F A B));
+ rFunctor_map A1 A2 B1 B2 fg := exclO_map (oFunctor_map F fg)
|}.
Next Obligation.
- intros F A1 ? A2 ? B1 ? B2 ? n x1 x2 ??. by apply exclO_map_ne, oFunctor_ne.
+ intros SI F A1 A2 B1 B2 n x1 x2 ??. by apply exclO_map_ne, oFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x; simpl. rewrite -{2}(excl_map_id x).
+ intros SI F A B x; simpl. rewrite -{2}(excl_map_id x).
apply excl_map_ext=>y. by rewrite oFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl. rewrite -excl_map_compose.
+ intros SI F A1 A2 A3 B1 B2 B3 f g f' g' x; simpl. rewrite -excl_map_compose.
apply excl_map_ext=>y; apply oFunctor_compose.
Qed.
-Instance exclRF_contractive F :
+Instance exclRF_contractive {SI} (F: oFunctor SI) :
oFunctorContractive F → rFunctorContractive (exclRF F).
Proof.
- intros A1 ? A2 ? B1 ? B2 ? n x1 x2 ??. by apply exclO_map_ne, oFunctor_contractive.
+ intros A1 A2 B1 B2 n x1 x2 ??. by apply exclO_map_ne, oFunctor_contractive.
Qed.
diff --git a/theories/algebra/frac.v b/theories/algebra/frac.v
index 737208fd782cbdde15c2bb482b3692257e1613cf..98adf31f1695a4c0ea043f6c449dacf4cccca247 100644
--- a/theories/algebra/frac.v
+++ b/theories/algebra/frac.v
@@ -14,7 +14,8 @@ Set Default Proof Using "Type".
Notation frac := Qp (only parsing).
Section frac.
-Canonical Structure fracO := leibnizO frac.
+Context {SI: indexT}.
+Canonical Structure fracO := leibnizO SI frac.
Instance frac_valid : Valid frac := λ x, (x ≤ 1)%Qc.
Instance frac_pcore : PCore frac := λ _, None.
@@ -32,31 +33,34 @@ Proof.
unfold valid, op, frac_op, frac_valid. intros x y. trans (x+y)%Qp; last done.
rewrite -{1}(Qcplus_0_r x) -Qcplus_le_mono_l; auto using Qclt_le_weak.
Qed.
-Canonical Structure fracR := discreteR frac frac_ra_mixin.
+Canonical Structure fracR := discreteR SI frac frac_ra_mixin.
Global Instance frac_cmra_discrete : CmraDiscrete fracR.
Proof. apply discrete_cmra_discrete. Qed.
End frac.
-Global Instance frac_full_exclusive : Exclusive 1%Qp.
+Arguments fracR : clear implicits.
+Arguments fracO : clear implicits.
+
+Global Instance frac_full_exclusive {SI}: @Exclusive SI _ 1%Qp.
Proof.
move=> y /Qcle_not_lt [] /=. by rewrite -{1}(Qcplus_0_r 1) -Qcplus_lt_mono_l.
Qed.
-Global Instance frac_cancelable (q : frac) : Cancelable q.
+Global Instance frac_cancelable {SI} (q : Qp) : @Cancelable SI _ q.
Proof. intros ?????. by apply Qp_eq, (inj (Qcplus q)), (Qp_eq (q+y) (q+z))%Qp. Qed.
-Global Instance frac_id_free (q : frac) : IdFree q.
+Global Instance frac_id_free {SI} (q : Qp) : @IdFree SI _ q.
Proof.
intros [q0 Hq0] ? EQ%Qp_eq. rewrite -{1}(Qcplus_0_r q) in EQ.
eapply Qclt_not_eq; first done. by apply (inj (Qcplus q)).
Qed.
-Lemma frac_op' (q p : Qp) : (p â‹… q) = (p + q)%Qp.
+Lemma frac_op' {SI} (q p : fracR SI) : (p â‹… q) = (p + q)%Qp.
Proof. done. Qed.
-Lemma frac_valid' (p : Qp) : ✓ p ↔ (p ≤ 1%Qp)%Qc.
+Lemma frac_valid' {SI} (p : fracR SI) : ✓ p ↔ (p ≤ 1%Qp)%Qc.
Proof. done. Qed.
-Global Instance is_op_frac q : IsOp' q (q/2)%Qp (q/2)%Qp.
+Global Instance is_op_frac {SI} (q : fracR SI) : IsOp' q (q/2)%Qp (q/2)%Qp.
Proof. by rewrite /IsOp' /IsOp frac_op' Qp_div_2. Qed.
diff --git a/theories/algebra/frac_auth.v b/theories/algebra/frac_auth.v
index 3f7d27c3cdcdd5066af33f9240ec3abafcfe715f..3d3efeecc9e5ce0b3c61201dbd27213ebe3586d5 100644
--- a/theories/algebra/frac_auth.v
+++ b/theories/algebra/frac_auth.v
@@ -9,14 +9,14 @@ From iris.algebra Require Import proofmode_classes.
split the authoritative part into fractions.
*)
-Definition frac_authR (A : cmraT) : cmraT :=
- authR (optionUR (prodR fracR A)).
-Definition frac_authUR (A : cmraT) : ucmraT :=
- authUR (optionUR (prodR fracR A)).
+Definition frac_authR {SI} (A : cmraT SI) : cmraT SI :=
+ authR (optionUR (prodR (fracR SI) A)).
+Definition frac_authUR {SI} (A : cmraT SI) : ucmraT SI :=
+ authUR (optionUR (prodR (fracR SI) A)).
-Definition frac_auth_auth {A : cmraT} (x : A) : frac_authR A :=
+Definition frac_auth_auth {SI} {A : cmraT SI} (x : A) : frac_authR A :=
â— (Some (1%Qp,x)).
-Definition frac_auth_frag {A : cmraT} (q : frac) (x : A) : frac_authR A :=
+Definition frac_auth_frag {SI} {A : cmraT SI} (q : frac) (x : A) : frac_authR A :=
â—¯ (Some (q,x)).
Typeclasses Opaque frac_auth_auth frac_auth_frag.
@@ -29,16 +29,16 @@ Notation "â—¯F{ q } a" := (frac_auth_frag q a) (at level 10, format "â—¯F{ q }
Notation "â—¯F a" := (frac_auth_frag 1 a) (at level 10).
Section frac_auth.
- Context {A : cmraT}.
+ Context {SI} {A : cmraT SI}.
Implicit Types a b : A.
- Global Instance frac_auth_auth_ne : NonExpansive (@frac_auth_auth A).
+ Global Instance frac_auth_auth_ne : NonExpansive (@frac_auth_auth SI A).
Proof. solve_proper. Qed.
- Global Instance frac_auth_auth_proper : Proper ((≡) ==> (≡)) (@frac_auth_auth A).
+ Global Instance frac_auth_auth_proper : Proper ((≡) ==> (≡)) (@frac_auth_auth SI A).
+ Proof. intros ?? H. split; simpl; by rewrite ?H. Qed.
+ Global Instance frac_auth_frag_ne q : NonExpansive (@frac_auth_frag SI A q).
Proof. solve_proper. Qed.
- Global Instance frac_auth_frag_ne q : NonExpansive (@frac_auth_frag A q).
- Proof. solve_proper. Qed.
- Global Instance frac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@frac_auth_frag A q).
+ Global Instance frac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@frac_auth_frag SI A q).
Proof. solve_proper. Qed.
Global Instance frac_auth_auth_discrete a : Discrete a → Discrete (â—F a).
@@ -65,13 +65,13 @@ Section frac_auth.
Lemma frac_auth_includedN n q a b : ✓{n} (â—F a â‹… â—¯F{q} b) → Some b ≼{n} Some a.
Proof. by rewrite auth_both_validN /= => -[/Some_pair_includedN [_ ?] _]. Qed.
- Lemma frac_auth_included `{CmraDiscrete A} q a b :
+ Lemma frac_auth_included `{CmraDiscrete SI A} q a b :
✓ (â—F a â‹… â—¯F{q} b) → Some b ≼ Some a.
Proof. by rewrite auth_both_valid /= => -[/Some_pair_included [_ ?] _]. Qed.
- Lemma frac_auth_includedN_total `{CmraTotal A} n q a b :
+ Lemma frac_auth_includedN_total `{CmraTotal SI A} n q a b :
✓{n} (â—F a â‹… â—¯F{q} b) → b ≼{n} a.
Proof. intros. by eapply Some_includedN_total, frac_auth_includedN. Qed.
- Lemma frac_auth_included_total `{CmraDiscrete A, CmraTotal A} q a b :
+ Lemma frac_auth_included_total `{CmraDiscrete SI A, CmraTotal SI A} q a b :
✓ (â—F a â‹… â—¯F{q} b) → b ≼ a.
Proof. intros. by eapply Some_included_total, frac_auth_included. Qed.
@@ -85,7 +85,7 @@ Section frac_auth.
Lemma frac_auth_frag_validN n q a : ✓{n} (◯F{q} a) ↔ ✓{n} q ∧ ✓{n} a.
Proof. done. Qed.
- Lemma frac_auth_frag_valid q a : ✓ (◯F{q} a) ↔ ✓ q ∧ ✓ a.
+ Lemma frac_auth_frag_valid q (a: A) (n: SI) : ✓ (◯F{q} a) ↔ ✓ (q: fracR SI) ∧ ✓ a.
Proof. done. Qed.
Lemma frac_auth_frag_op q1 q2 a1 a2 : ◯F{q1+q2} (a1 ⋅ a2) ≡ ◯F{q1} a1 ⋅ ◯F{q2} a2.
@@ -94,14 +94,14 @@ Section frac_auth.
Lemma frac_auth_frag_validN_op_1_l n q a b : ✓{n} (◯F{1} a ⋅ ◯F{q} b) → False.
Proof. rewrite -frac_auth_frag_op frac_auth_frag_validN=> -[/exclusiveN_l []]. Qed.
Lemma frac_auth_frag_valid_op_1_l q a b : ✓ (◯F{1} a ⋅ ◯F{q} b) → False.
- Proof. rewrite -frac_auth_frag_op frac_auth_frag_valid=> -[/exclusive_l []]. Qed.
+ Proof. rewrite -frac_auth_frag_op frac_auth_frag_valid; eauto using zero=> -[/exclusive_l []]. Qed.
Global Instance is_op_frac_auth (q q1 q2 : frac) (a a1 a2 : A) :
- IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯F{q} a) (◯F{q1} a1) (◯F{q2} a2).
+ IsOp (q: fracR SI) q1 q2 → IsOp a a1 a2 → IsOp' (◯F{q} a) (◯F{q1} a1) (◯F{q2} a2).
Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.
Global Instance is_op_frac_auth_core_id (q q1 q2 : frac) (a : A) :
- CoreId a → IsOp q q1 q2 → IsOp' (◯F{q} a) (◯F{q1} a) (◯F{q2} a).
+ CoreId a → IsOp (q: fracR SI) q1 q2 → IsOp' (◯F{q} a) (◯F{q1} a) (◯F{q2} a).
Proof.
rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
by rewrite -frac_auth_frag_op -core_id_dup.
diff --git a/theories/algebra/functions.v b/theories/algebra/functions.v
index 3e66c877b8d091658989405848a03a337687daab..be52d0a0a5bb3c0a647595f479993874ef99b754 100644
--- a/theories/algebra/functions.v
+++ b/theories/algebra/functions.v
@@ -3,17 +3,17 @@ From iris.algebra Require Import updates.
From stdpp Require Import finite.
Set Default Proof Using "Type".
-Definition discrete_fun_insert `{EqDecision A} {B : A → ofeT}
+Definition discrete_fun_insert `{EqDecision A} {SI} {B : A → ofeT SI}
(x : A) (y : B x) (f : discrete_fun B) : discrete_fun B := λ x',
match decide (x = x') with left H => eq_rect _ B y _ H | right _ => f x' end.
Instance: Params (@discrete_fun_insert) 5 := {}.
-Definition discrete_fun_singleton `{EqDecision A} {B : A → ucmraT}
+Definition discrete_fun_singleton `{EqDecision A} {SI} {B : A → ucmraT SI}
(x : A) (y : B x) : discrete_fun B := discrete_fun_insert x y ε.
Instance: Params (@discrete_fun_singleton) 5 := {}.
Section ofe.
- Context `{Heqdec : EqDecision A} {B : A → ofeT}.
+ Context `{Heqdec : EqDecision A} {SI} {B : A → ofeT SI}.
Implicit Types x : A.
Implicit Types f g : discrete_fun B.
@@ -52,7 +52,7 @@ Section ofe.
End ofe.
Section cmra.
- Context `{EqDecision A} {B : A → ucmraT}.
+ Context `{EqDecision A} {SI} {B : A → ucmraT SI}.
Implicit Types x : A.
Implicit Types f g : discrete_fun B.
diff --git a/theories/algebra/gmap.v b/theories/algebra/gmap.v
index b41d6458a13b1cedbf814f7d541a25d35d4e8adc..a3b8bab69586ac2125839b8c30f242d36a923a14 100644
--- a/theories/algebra/gmap.v
+++ b/theories/algebra/gmap.v
@@ -6,13 +6,13 @@ From iris.algebra Require Import proofmode_classes.
Set Default Proof Using "Type".
Section cofe.
-Context `{Countable K} {A : ofeT}.
+Context `{Countable K} {SI} {A : ofeT SI}.
Implicit Types m : gmap K A.
Implicit Types i : K.
-Instance gmap_dist : Dist (gmap K A) := λ n m1 m2,
+Instance gmap_dist : Dist SI (gmap K A) := λ n m1 m2,
∀ i, m1 !! i ≡{n}≡ m2 !! i.
-Definition gmap_ofe_mixin : OfeMixin (gmap K A).
+Definition gmap_ofe_mixin : OfeMixin SI (gmap K A).
Proof.
split.
- intros m1 m2; split.
@@ -22,26 +22,47 @@ Proof.
+ by intros m k.
+ by intros m1 m2 ? k.
+ by intros m1 m2 m3 ?? k; trans (m2 !! k).
- - by intros n m1 m2 ? k; apply dist_S.
+ - intros n n' m1 m2 ? k ?; eapply dist_le; eauto.
Qed.
-Canonical Structure gmapO : ofeT := OfeT (gmap K A) gmap_ofe_mixin.
+Canonical Structure gmapO : ofeT SI := OfeT (gmap K A) gmap_ofe_mixin.
-Program Definition gmap_chain (c : chain gmapO)
- (k : K) : chain (optionO A) := {| chain_car n := c n !! k |}.
-Next Obligation. by intros c k n i ?; apply (chain_cauchy c). Qed.
-Definition gmap_compl `{Cofe A} : Compl gmapO := λ c,
- map_imap (λ i _, compl (gmap_chain c i)) (c 0).
-Global Program Instance gmap_cofe `{Cofe A} : Cofe gmapO :=
- {| compl := gmap_compl |}.
+
+Program Definition gmap_chain (c: chain gmapO) (k: K) : chain (optionO A) :=
+ mkchain _ _ (λ n, c n !! k) _.
+Next Obligation. intros c k α β Hβ. by apply c. Qed.
+Program Definition gmap_bchain {α} (c: bchain gmapO α) (k: K) : bchain (optionO A) α :=
+ mkbchain _ _ _ (λ β Hβ, c β Hβ !! k) _.
+Next Obligation. intros α c k β γ Hβγ Hβ Hγ; by apply c. Qed.
+
+Definition gmap_compl `{Cofe SI A} : (chain gmapO) → gmapO := λ c,
+ map_imap (λ i _, compl (gmap_chain c i)) (c zero).
+Definition gmap_bcompl `{Cofe SI A} : ∀ α Hα , (bchain gmapO α) → gmapO := λ α Hα c,
+ map_imap (λ i _, bcompl Hα (gmap_bchain c i)) (c zero Hα).
+
+Global Program Instance gmap_cofe `{Cofe SI A} : Cofe gmapO :=
+ {| compl := gmap_compl; bcompl := gmap_bcompl |}.
+Next Obligation.
+ intros ? n c k. rewrite /gmap_compl map_lookup_imap.
+ feed inversion (λ H, chain_cauchy' c zero n H k); simplify_option_eq; auto.
+ rewrite conv_compl /=. by apply reflexive_eq.
+Qed.
+Next Obligation.
+ intros ? α Hα c β Hβ k. rewrite /bcompl /gmap_bcompl.
+ rewrite map_lookup_imap.
+ specialize (bchain_cauchy' _ c zero β Hα Hβ (index_zero_minimum β) k) as H'.
+ inversion H'; simplify_option_eq; auto.
+ unshelve rewrite conv_bcompl /=; eauto. by apply reflexive_eq.
+Qed.
Next Obligation.
- intros ? n c k. rewrite /compl /gmap_compl lookup_imap.
- feed inversion (λ H, chain_cauchy c 0 n H k);simplify_option_eq;auto with lia.
- by rewrite conv_compl /=; apply reflexive_eq.
+ intros ? α Hα c d β Hne k; rewrite /gmap_bcompl.
+ rewrite !map_lookup_imap.
+ feed inversion (Hne zero Hα k); eauto; cbn.
+ eapply bcompl_ne; intros ??; apply Hne.
Qed.
Global Instance gmap_ofe_discrete : OfeDiscrete A → OfeDiscrete gmapO.
Proof. intros ? m m' ? i. by apply (discrete _). Qed.
-(* why doesn't this go automatic? *)
+(*TODO: why doesn't this go automatically? *)
Global Instance gmapO_leibniz: LeibnizEquiv A → LeibnizEquiv gmapO.
Proof. intros; change (LeibnizEquiv (gmap K A)); apply _. Qed.
@@ -80,7 +101,7 @@ Qed.
Global Instance gmap_lookup_discrete m i : Discrete m → Discrete (m !! i).
Proof.
intros ? [x|] Hx; [|by symmetry; apply: discrete].
- assert (m ≡{0}≡ <[i:=x]> m)
+ assert (m ≡{zero}≡ <[i:=x]> m)
by (by symmetry in Hx; inversion Hx; ofe_subst; rewrite insert_id).
by rewrite (discrete m (<[i:=x]>m)) // lookup_insert.
Qed.
@@ -98,18 +119,18 @@ Lemma insert_idN n m i x :
Proof. intros (y'&?&->)%dist_Some_inv_r'. by rewrite insert_id. Qed.
End cofe.
-Arguments gmapO _ {_ _} _.
+Arguments gmapO _ {_ _ _} _.
(* CMRA *)
Section cmra.
-Context `{Countable K} {A : cmraT}.
+Context `{Countable K} {SI} {A : cmraT SI}.
Implicit Types m : gmap K A.
Instance gmap_unit : Unit (gmap K A) := (∅ : gmap K A).
Instance gmap_op : Op (gmap K A) := merge op.
Instance gmap_pcore : PCore (gmap K A) := λ m, Some (omap pcore m).
Instance gmap_valid : Valid (gmap K A) := λ m, ∀ i, ✓ (m !! i).
-Instance gmap_validN : ValidN (gmap K A) := λ n m, ∀ i, ✓{n} (m !! i).
+Instance gmap_validN : ValidN SI (gmap K A) := λ n m, ∀ i, ✓{n} (m !! i).
Lemma lookup_op m1 m2 i : (m1 â‹… m2) !! i = m1 !! i â‹… m2 !! i.
Proof. by apply lookup_merge. Qed.
@@ -132,7 +153,7 @@ Proof.
lookup_insert_ne // lookup_partial_alter_ne.
Qed.
-Lemma gmap_cmra_mixin : CmraMixin (gmap K A).
+Lemma gmap_cmra_mixin : CmraMixin SI (gmap K A).
Proof.
apply cmra_total_mixin.
- eauto.
@@ -142,7 +163,7 @@ Proof.
- intros m; split.
+ by intros ? n i; apply cmra_valid_validN.
+ intros Hm i; apply cmra_valid_validN=> n; apply Hm.
- - intros n m Hm i; apply cmra_validN_S, Hm.
+ - intros n m Hm i ? ?; eauto using cmra_validN_le.
- by intros m1 m2 m3 i; rewrite !lookup_op assoc.
- by intros m1 m2 i; rewrite !lookup_op comm.
- intros m i. by rewrite lookup_op lookup_core cmra_core_l.
@@ -156,25 +177,25 @@ Proof.
last by rewrite -lookup_op.
exists (map_imap (λ i _, projT1 (FUN i)) y1).
exists (map_imap (λ i _, proj1_sig (projT2 (FUN i))) y2).
- split; [|split]=>i; rewrite ?lookup_op !lookup_imap;
+ split; [|split]=>i; rewrite ?lookup_op !map_lookup_imap;
destruct (FUN i) as (z1i&z2i&Hmi&Hz1i&Hz2i)=>/=.
+ destruct (y1 !! i), (y2 !! i); inversion Hz1i; inversion Hz2i; subst=>//.
+ revert Hz1i. case: (y1!!i)=>[?|] //.
+ revert Hz2i. case: (y2!!i)=>[?|] //.
Qed.
-Canonical Structure gmapR := CmraT (gmap K A) gmap_cmra_mixin.
+Canonical Structure gmapR := CmraT SI (gmap K A) gmap_cmra_mixin.
Global Instance gmap_cmra_discrete : CmraDiscrete A → CmraDiscrete gmapR.
Proof. split; [apply _|]. intros m ? i. by apply: cmra_discrete_valid. Qed.
-Lemma gmap_ucmra_mixin : UcmraMixin (gmap K A).
+Lemma gmap_ucmra_mixin : UcmraMixin SI (gmap K A).
Proof.
split.
- by intros i; rewrite lookup_empty.
- by intros m i; rewrite /= lookup_op lookup_empty (left_id_L None _).
- constructor=> i. by rewrite lookup_omap lookup_empty.
Qed.
-Canonical Structure gmapUR := UcmraT (gmap K A) gmap_ucmra_mixin.
+Canonical Structure gmapUR := UcmraT SI (gmap K A) gmap_ucmra_mixin.
(** Internalized properties *)
Lemma gmap_equivI {M} m1 m2 : m1 ≡ m2 ⊣⊢@{uPredI M} ∀ i, m1 !! i ≡ m2 !! i.
@@ -183,11 +204,11 @@ Lemma gmap_validI {M} m : ✓ m ⊣⊢@{uPredI M} ∀ i, ✓ (m !! i).
Proof. by uPred.unseal. Qed.
End cmra.
-Arguments gmapR _ {_ _} _.
-Arguments gmapUR _ {_ _} _.
+Arguments gmapR _ {_ _ _} _.
+Arguments gmapUR _ {_ _ _} _.
Section properties.
-Context `{Countable K} {A : cmraT}.
+Context `{Countable K} {SI} {A : cmraT SI}.
Implicit Types m : gmap K A.
Implicit Types i : K.
Implicit Types x y : A.
@@ -196,7 +217,7 @@ Global Instance lookup_op_homomorphism :
MonoidHomomorphism op op (≡) (lookup i : gmap K A → option A).
Proof. split; [split|]; try apply _. intros m1 m2; by rewrite lookup_op. done. Qed.
-Lemma lookup_opM m1 mm2 i : (m1 ⋅? mm2) !! i = m1 !! i ⋅ (mm2 ≫= (!! i)).
+Lemma lookup_opM m1 mm2 i : (m1 ⋅? mm2) !! i = m1 !! i ⋅ (mm2 ≫= (lookup i)).
Proof. destruct mm2; by rewrite /= ?lookup_op ?right_id_L. Qed.
Lemma lookup_validN_Some n m i x : ✓{n} m → m !! i ≡{n}≡ Some x → ✓{n} x.
@@ -214,7 +235,7 @@ Proof.
- move=>/(_ i); by simplify_map_eq.
- intros. apply insert_validN. done. apply: ucmra_unit_validN.
Qed.
-Lemma singleton_valid i x : ✓ ({[ i := x ]} : gmap K A) ↔ ✓ x.
+Lemma singleton_valid i x :✓ ({[ i := x ]} : gmap K A) ↔ ✓ x.
Proof. rewrite !cmra_valid_validN. by setoid_rewrite singleton_validN. Qed.
Lemma delete_validN n m i : ✓{n} m → ✓{n} (delete i m).
@@ -404,7 +425,7 @@ Lemma alloc_unit_singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) u i
Proof.
intros ?? Hx HQ. apply cmra_total_updateP=> n gf Hg.
destruct (Hx n (gf !! i)) as (y&?&Hy).
- { move:(Hg i). rewrite !left_id.
+ { move:(Hg i). rewrite ![∅ ⋅ gf]left_id; last apply _.
case: (gf !! i)=>[x|]; rewrite /= ?left_id //.
intros; by apply cmra_valid_validN. }
exists {[ i := y ]}; split; first by auto.
@@ -503,7 +524,7 @@ Proof.
[done|by rewrite lookup_singleton].
Qed.
-Lemma gmap_fmap_mono {B : cmraT} (f : A → B) m1 m2 :
+Lemma gmap_fmap_mono {B : cmraT SI} (f : A → B) m1 m2 :
Proper ((≡) ==> (≡)) f →
(∀ x y, x ≼ y → f x ≼ f y) → m1 ≼ m2 → fmap f m1 ≼ fmap f m2.
Proof.
@@ -513,7 +534,7 @@ Qed.
End properties.
Section unital_properties.
-Context `{Countable K} {A : ucmraT}.
+Context `{Countable K} {SI} {A : ucmraT SI}.
Implicit Types m : gmap K A.
Implicit Types i : K.
Implicit Types x y : A.
@@ -536,10 +557,10 @@ Qed.
End unital_properties.
(** Functor *)
-Instance gmap_fmap_ne `{Countable K} {A B : ofeT} (f : A → B) n :
+Instance gmap_fmap_ne `{Countable K} {SI} {A B : ofeT SI} (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.
-Instance gmap_fmap_cmra_morphism `{Countable K} {A B : cmraT} (f : A → B)
+Instance gmap_fmap_cmra_morphism `{Countable K} {SI} {A B : cmraT SI} (f : A → B)
`{!CmraMorphism f} : CmraMorphism (fmap f : gmap K A → gmap K B).
Proof.
split; try apply _.
@@ -548,53 +569,53 @@ Proof.
case: (m!!i)=>//= ?. apply cmra_morphism_pcore, _.
- intros m1 m2 i. by rewrite lookup_op !lookup_fmap lookup_op cmra_morphism_op.
Qed.
-Definition gmapO_map `{Countable K} {A B} (f: A -n> B) :
+Definition gmapO_map `{Countable K} {SI} {A B: ofeT SI} (f: A -n> B) :
gmapO K A -n> gmapO K B := OfeMor (fmap f : gmapO K A → gmapO K B).
-Instance gmapO_map_ne `{Countable K} {A B} :
- NonExpansive (@gmapO_map K _ _ A B).
+Instance gmapO_map_ne `{Countable K} {SI} {A B: ofeT SI} :
+ NonExpansive (@gmapO_map K _ _ SI A B).
Proof.
intros n f g Hf m k; rewrite /= !lookup_fmap.
destruct (_ !! k) eqn:?; simpl; constructor; apply Hf.
Qed.
-Program Definition gmapOF K `{Countable K} (F : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := gmapO K (oFunctor_car F A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (oFunctor_map F fg)
+Program Definition gmapOF K `{Countable K} {SI} (F : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := gmapO K (oFunctor_car F A B);
+ oFunctor_map A1 A2 B1 B2 fg := gmapO_map (oFunctor_map F fg)
|}.
Next Obligation.
- by intros K ?? F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, oFunctor_ne.
+ by intros K SI ?? F A1 A2 B1 B2 n f g Hfg; apply gmapO_map_ne, oFunctor_ne.
Qed.
Next Obligation.
- intros K ?? F A ? B ? x. rewrite /= -{2}(map_fmap_id x).
+ intros K SI ?? F A B x. rewrite /= -{2}(map_fmap_id x).
apply map_fmap_equiv_ext=>y ??; apply oFunctor_id.
Qed.
Next Obligation.
- intros K ?? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -map_fmap_compose.
+ intros K SI ?? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -map_fmap_compose.
apply map_fmap_equiv_ext=>y ??; apply oFunctor_compose.
Qed.
-Instance gmapOF_contractive K `{Countable K} F :
+Instance gmapOF_contractive K `{Countable K} {SI} (F: oFunctor SI) :
oFunctorContractive F → oFunctorContractive (gmapOF K F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, oFunctor_contractive.
+ by intros ? A1 A2 B1 B2 n f g Hfg; apply gmapO_map_ne, oFunctor_contractive.
Qed.
-Program Definition gmapURF K `{Countable K} (F : rFunctor) : urFunctor := {|
- urFunctor_car A _ B _ := gmapUR K (rFunctor_car F A B);
- urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (rFunctor_map F fg)
+Program Definition gmapURF K `{Countable K} {SI} (F : rFunctor SI) : urFunctor SI := {|
+ urFunctor_car A B := gmapUR K (rFunctor_car F A B);
+ urFunctor_map A1 A2 B1 B2 fg := gmapO_map (rFunctor_map F fg)
|}.
Next Obligation.
- by intros K ?? F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, rFunctor_ne.
+ by intros K SI ?? F A1 A2 B1 B2 n f g Hfg; apply gmapO_map_ne, rFunctor_ne.
Qed.
Next Obligation.
- intros K ?? F A ? B ? x. rewrite /= -{2}(map_fmap_id x).
+ intros K SI ?? F A B x. rewrite /= -{2}(map_fmap_id x).
apply map_fmap_equiv_ext=>y ??; apply rFunctor_id.
Qed.
Next Obligation.
- intros K ?? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -map_fmap_compose.
+ intros K SI ?? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -map_fmap_compose.
apply map_fmap_equiv_ext=>y ??; apply rFunctor_compose.
Qed.
-Instance gmapRF_contractive K `{Countable K} F :
+Instance gmapRF_contractive K `{Countable K} {SI} (F: rFunctor SI) :
rFunctorContractive F → urFunctorContractive (gmapURF K F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, rFunctor_contractive.
+ by intros ? A1 A2 B1 B2 n f g Hfg; apply gmapO_map_ne, rFunctor_contractive.
Qed.
diff --git a/theories/algebra/gmultiset.v b/theories/algebra/gmultiset.v
index bd463713475cc7e0bfbbdcb600de60d61f4d627a..22d325acc2a3e863f08cfda19810fe0e54425f38 100644
--- a/theories/algebra/gmultiset.v
+++ b/theories/algebra/gmultiset.v
@@ -5,17 +5,21 @@ Set Default Proof Using "Type".
(* The multiset union CMRA *)
Section gmultiset.
- Context `{Countable K}.
+ Context `{SI : indexT} `{Countable K}.
Implicit Types X Y : gmultiset K.
- Canonical Structure gmultisetO := discreteO (gmultiset K).
+ Canonical Structure gmultisetO := discreteO SI (gmultiset K).
Instance gmultiset_valid : Valid (gmultiset K) := λ _, True.
- Instance gmultiset_validN : ValidN (gmultiset K) := λ _ _, True.
+ Instance gmultiset_validN : ValidN SI (gmultiset K) := λ _ _, True.
Instance gmultiset_unit : Unit (gmultiset K) := (∅ : gmultiset K).
Instance gmultiset_op : Op (gmultiset K) := disj_union.
Instance gmultiset_pcore : PCore (gmultiset K) := λ X, Some ∅.
+ (* TODO: seems like these were in stdpp at some point, but they are not anymore *)
+ Notation "⊎ Y" := (λ x, disj_union x Y) (at level 50).
+ Notation "X ⊎" := (disj_union X) (at level 50).
+
Lemma gmultiset_op_disj_union X Y : X ⋅ Y = X ⊎ Y.
Proof. done. Qed.
Lemma gmultiset_core_empty X : core X = ∅.
@@ -41,14 +45,14 @@ Section gmultiset.
by rewrite left_id.
Qed.
- Canonical Structure gmultisetR := discreteR (gmultiset K) gmultiset_ra_mixin.
+ Canonical Structure gmultisetR := discreteR SI (gmultiset K) gmultiset_ra_mixin.
Global Instance gmultiset_cmra_discrete : CmraDiscrete gmultisetR.
Proof. apply discrete_cmra_discrete. Qed.
- Lemma gmultiset_ucmra_mixin : UcmraMixin (gmultiset K).
+ Lemma gmultiset_ucmra_mixin : UcmraMixin SI (gmultiset K).
Proof. split. done. intros X. by rewrite gmultiset_op_disj_union left_id_L. done. Qed.
- Canonical Structure gmultisetUR := UcmraT (gmultiset K) gmultiset_ucmra_mixin.
+ Canonical Structure gmultisetUR := UcmraT SI (gmultiset K) gmultiset_ucmra_mixin.
Global Instance gmultiset_cancelable X : Cancelable X.
Proof.
diff --git a/theories/algebra/gset.v b/theories/algebra/gset.v
index b0b7fc5121f062bb799434d4978f9f6951b9d646..a9399b38765222d59c1f6052e11e86777844675f 100644
--- a/theories/algebra/gset.v
+++ b/theories/algebra/gset.v
@@ -5,10 +5,10 @@ Set Default Proof Using "Type".
(* The union CMRA *)
Section gset.
- Context `{Countable K}.
+ Context {SI: indexT} `{Countable K}.
Implicit Types X Y : gset K.
- Canonical Structure gsetO := discreteO (gset K).
+ Canonical Structure gsetO := discreteO SI (gset K).
Instance gset_valid : Valid (gset K) := λ _, True.
Instance gset_unit : Unit (gset K) := (∅ : gset K).
@@ -36,14 +36,14 @@ Section gset.
- intros X1 X2. by rewrite !gset_op_union comm_L.
- intros X. by rewrite gset_core_self idemp_L.
Qed.
- Canonical Structure gsetR := discreteR (gset K) gset_ra_mixin.
+ Canonical Structure gsetR := discreteR SI (gset K) gset_ra_mixin.
Global Instance gset_cmra_discrete : CmraDiscrete gsetR.
Proof. apply discrete_cmra_discrete. Qed.
- Lemma gset_ucmra_mixin : UcmraMixin (gset K).
+ Lemma gset_ucmra_mixin : UcmraMixin SI (gset K).
Proof. split. done. intros X. by rewrite gset_op_union left_id_L. done. Qed.
- Canonical Structure gsetUR := UcmraT (gset K) gset_ucmra_mixin.
+ Canonical Structure gsetUR := UcmraT SI (gset K) gset_ucmra_mixin.
Lemma gset_opM X mY : X ⋅? mY = X ∪ default ∅ mY.
Proof. destruct mY; by rewrite /= ?right_id_L. Qed.
@@ -62,9 +62,9 @@ Section gset.
Proof. by apply core_id_total; rewrite gset_core_self. Qed.
End gset.
-Arguments gsetO _ {_ _}.
-Arguments gsetR _ {_ _}.
-Arguments gsetUR _ {_ _}.
+Arguments gsetO {_} _ {_ _}.
+Arguments gsetR {_} _ {_ _}.
+Arguments gsetUR {_} _ {_ _}.
(* The disjoint union CMRA *)
Inductive gset_disj K `{Countable K} :=
@@ -73,13 +73,16 @@ Inductive gset_disj K `{Countable K} :=
Arguments GSet {_ _ _} _.
Arguments GSetBot {_ _ _}.
+Global Instance gset_disj_inhab K `{Countable K}: Inhabited (gset_disj K).
+Proof. constructor. exact GSetBot. Qed.
+
Section gset_disj.
- Context `{Countable K}.
+ Context {SI: indexT} `{Countable K}.
Arguments op _ _ !_ !_ /.
Arguments cmra_op _ !_ !_ /.
Arguments ucmra_op _ !_ !_ /.
- Canonical Structure gset_disjO := leibnizO (gset_disj K).
+ Canonical Structure gset_disjO := leibnizO SI (gset_disj K).
Instance gset_disj_valid : Valid (gset_disj K) := λ X,
match X with GSet _ => True | GSetBot => False end.
@@ -121,14 +124,14 @@ Section gset_disj.
- exists (GSet ∅); gset_disj_solve.
- intros [X1|] [X2|]; gset_disj_solve.
Qed.
- Canonical Structure gset_disjR := discreteR (gset_disj K) gset_disj_ra_mixin.
+ Canonical Structure gset_disjR := discreteR SI (gset_disj K) gset_disj_ra_mixin.
Global Instance gset_disj_cmra_discrete : CmraDiscrete gset_disjR.
Proof. apply discrete_cmra_discrete. Qed.
- Lemma gset_disj_ucmra_mixin : UcmraMixin (gset_disj K).
+ Lemma gset_disj_ucmra_mixin : UcmraMixin SI (gset_disj K).
Proof. split; try apply _ || done. intros [X|]; gset_disj_solve. Qed.
- Canonical Structure gset_disjUR := UcmraT (gset_disj K) gset_disj_ucmra_mixin.
+ Canonical Structure gset_disjUR := UcmraT SI (gset_disj K) gset_disj_ucmra_mixin.
Arguments op _ _ _ _ : simpl never.
@@ -227,6 +230,6 @@ Section gset_disj.
Qed.
End gset_disj.
-Arguments gset_disjO _ {_ _}.
-Arguments gset_disjR _ {_ _}.
-Arguments gset_disjUR _ {_ _}.
+Arguments gset_disjO {_} _ {_ _}.
+Arguments gset_disjR {_} _ {_ _}.
+Arguments gset_disjUR {_} _ {_ _}.
diff --git a/theories/algebra/list.v b/theories/algebra/list.v
index 0d3d22a06c7fb097755cb758cccdd9ed41f2bdef..805a4064818215cb059296543cb7afafac01e5a7 100644
--- a/theories/algebra/list.v
+++ b/theories/algebra/list.v
@@ -5,10 +5,10 @@ From iris.algebra Require Import updates local_updates.
Set Default Proof Using "Type".
Section cofe.
-Context {A : ofeT}.
+Context {SI} {A : ofeT SI}.
Implicit Types l : list A.
-Instance list_dist : Dist (list A) := λ n, Forall2 (dist n).
+Instance list_dist : Dist SI (list A) := λ n, Forall2 (dist n).
Lemma list_dist_lookup n l1 l2 : l1 ≡{n}≡ l2 ↔ ∀ i, l1 !! i ≡{n}≡ l2 !! i.
Proof. setoid_rewrite dist_option_Forall2. apply Forall2_lookup. Qed.
@@ -53,13 +53,13 @@ Lemma list_dist_cons_inv_r n l k y :
l ≡{n}≡ y :: k → ∃ x l', x ≡{n}≡ y ∧ l' ≡{n}≡ k ∧ l = x :: l'.
Proof. apply Forall2_cons_inv_r. Qed.
-Definition list_ofe_mixin : OfeMixin (list A).
+Definition list_ofe_mixin : OfeMixin SI (list A).
Proof.
split.
- intros l k. rewrite equiv_Forall2 -Forall2_forall.
- split; induction 1; constructor; intros; try apply equiv_dist; auto.
+ split; induction 1; try constructor; intros; try apply equiv_dist; auto.
- apply _.
- - rewrite /dist /list_dist. eauto using Forall2_impl, dist_S.
+ - rewrite /dist /list_dist. eauto using Forall2_impl, dist_le.
Qed.
Canonical Structure listO := OfeT (list A) list_ofe_mixin.
@@ -75,18 +75,47 @@ Fixpoint list_compl_go `{!Cofe A} (c0 : list A) (c : chain listO) : listO :=
| x :: c0 => compl (chain_map (default x ∘ head) c) :: list_compl_go c0 (chain_map tail c)
end.
+Fixpoint list_bcompl_go `{!Cofe A} (c0 : list A) {α} Hα (c : bchain listO α) : listO :=
+ match c0 with
+ | [] => []
+ | x :: c0 => bcompl Hα (bchain_map (default x ∘ head) c) :: list_bcompl_go c0 Hα (bchain_map tail c)
+ end.
+
Global Program Instance list_cofe `{!Cofe A} : Cofe listO :=
- {| compl c := list_compl_go (c 0) c |}.
+ {|
+ compl c := list_compl_go (c zero) c;
+ bcompl α Hα c := list_bcompl_go (c zero Hα) Hα c
+ |}.
+Next Obligation.
+ intros ? α c; simpl.
+ assert (c zero ≡{zero}≡ c α) as Hc0 by (symmetry; apply chain_cauchy, index_zero_minimum).
+ revert Hc0. generalize (c zero)=> c0. revert c.
+ induction c0 as [|x c0 IH]=> c Hc0 /=.
+ { by inversion Hc0. }
+ apply list_dist_cons_inv_l in Hc0 as (x' & xs' & Hx & Hc0 & Hcn).
+ rewrite Hcn. f_equiv.
+ - rewrite conv_compl.
+ by rewrite /chain_map //= Hcn.
+ - rewrite IH. all: rewrite /chain_map /= ?Hcn //.
+Qed.
Next Obligation.
- intros ? n c; rewrite /compl.
- assert (c 0 ≡{0}≡ c n) as Hc0 by (symmetry; apply chain_cauchy; lia).
- revert Hc0. generalize (c 0)=> c0. revert c.
+ intros ? α Hα c β Hβ; simpl.
+ assert (c zero Hα ≡{zero}≡ c β Hβ) as Hc0 by (symmetry; apply bchain_cauchy, index_zero_minimum).
+ revert Hc0. generalize (c zero Hα)=> c0. revert c.
induction c0 as [|x c0 IH]=> c Hc0 /=.
{ by inversion Hc0. }
apply list_dist_cons_inv_l in Hc0 as (x' & xs' & Hx & Hc0 & Hcn).
rewrite Hcn. f_equiv.
- - by rewrite conv_compl /= Hcn /=.
- - rewrite IH /= ?Hcn //.
+ - rewrite (conv_bcompl _ _ _ β Hβ). by rewrite /bchain_map //= Hcn.
+ - rewrite IH. all: rewrite /bchain_map /= ?Hcn //.
+Qed.
+Next Obligation.
+ intros ? α Hα c d β Hne; simpl. specialize (Hne zero Hα) as H'.
+ remember (c zero Hα) as c0. remember (d zero Hα) as d0. clear Heqc0 Heqd0.
+ induction H' in c, d, Hne |-*; simpl; eauto.
+ constructor.
+ - apply: bcompl_ne=> γ Hγ. by rewrite /bchain_map //= Hne H.
+ - apply: IHH'=> γ Hγ. rewrite /bchain_map. cbn; by rewrite Hne.
Qed.
Global Instance list_ofe_discrete : OfeDiscrete A → OfeDiscrete listO.
@@ -98,45 +127,45 @@ Global Instance cons_discrete x l : Discrete x → Discrete l → Discrete (x ::
Proof. intros ??; inversion_clear 1; constructor; by apply discrete. Qed.
End cofe.
-Arguments listO : clear implicits.
+Arguments listO {_} _.
(** Functor *)
-Lemma list_fmap_ext_ne {A} {B : ofeT} (f g : A → B) (l : list A) n :
+Lemma list_fmap_ext_ne {SI} {A} {B : ofeT SI} (f g : A → B) (l : list A) n :
(∀ x, f x ≡{n}≡ g x) → f <$> l ≡{n}≡ g <$> l.
Proof. intros Hf. by apply Forall2_fmap, Forall_Forall2, Forall_true. Qed.
-Instance list_fmap_ne {A B : ofeT} (f : A → B) n:
+Instance list_fmap_ne {SI} {A B : ofeT SI} (f : A → B) n:
Proper (dist n ==> dist n) f → Proper (dist n ==> dist n) (fmap (M:=list) f).
Proof. intros Hf l k ?; by eapply Forall2_fmap, Forall2_impl; eauto. Qed.
-Definition listO_map {A B} (f : A -n> B) : listO A -n> listO B :=
+Definition listO_map {SI} {A B: ofeT SI} (f : A -n> B) : listO A -n> listO B :=
OfeMor (fmap f : listO A → listO B).
-Instance listO_map_ne A B : NonExpansive (@listO_map A B).
+Instance listO_map_ne SI A B : NonExpansive (@listO_map SI A B).
Proof. intros n f g ? l. by apply list_fmap_ext_ne. Qed.
-Program Definition listOF (F : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := listO (oFunctor_car F A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := listO_map (oFunctor_map F fg)
+Program Definition listOF {SI} (F : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := listO (oFunctor_car F A B);
+ oFunctor_map A1 A2 B1 B2 fg := listO_map (oFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply listO_map_ne, oFunctor_ne.
+ by intros ? F A1 A2 B1 B2 n f g Hfg; apply listO_map_ne, oFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(list_fmap_id x).
+ intros ? F A B x. rewrite /= -{2}(list_fmap_id x).
apply list_fmap_equiv_ext=>y. apply oFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -list_fmap_compose.
+ intros ? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -list_fmap_compose.
apply list_fmap_equiv_ext=>y; apply oFunctor_compose.
Qed.
-Instance listOF_contractive F :
+Instance listOF_contractive {SI} (F: oFunctor SI) :
oFunctorContractive F → oFunctorContractive (listOF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply listO_map_ne, oFunctor_contractive.
+ by intros ? A1 A2 B1 B2 n f g Hfg; apply listO_map_ne, oFunctor_contractive.
Qed.
(* CMRA *)
Section cmra.
- Context {A : ucmraT}.
+ Context {SI} {A : ucmraT SI}.
Implicit Types l : list A.
Local Arguments op _ _ !_ !_ / : simpl nomatch.
@@ -150,7 +179,7 @@ Section cmra.
Instance list_pcore : PCore (list A) := λ l, Some (core <$> l).
Instance list_valid : Valid (list A) := Forall (λ x, ✓ x).
- Instance list_validN : ValidN (list A) := λ n, Forall (λ x, ✓{n} x).
+ Instance list_validN : ValidN SI (list A) := λ n, Forall (λ x, ✓{n} x).
Lemma cons_valid l x : ✓ (x :: l) ↔ ✓ x ∧ ✓ l.
Proof. apply Forall_cons. Qed.
@@ -198,7 +227,7 @@ Section cmra.
+ exists (core x :: l3); constructor; by rewrite ?cmra_core_r.
Qed.
- Definition list_cmra_mixin : CmraMixin (list A).
+ Definition list_cmra_mixin : CmraMixin SI (list A).
Proof.
apply cmra_total_mixin.
- eauto.
@@ -209,7 +238,7 @@ Section cmra.
by rewrite -Hl.
- intros l. rewrite list_lookup_valid. setoid_rewrite list_lookup_validN.
setoid_rewrite cmra_valid_validN. naive_solver.
- - intros n x. rewrite !list_lookup_validN. auto using cmra_validN_S.
+ - intros n m x. rewrite !list_lookup_validN. eauto using cmra_validN_le.
- intros l1 l2 l3; rewrite list_equiv_lookup=> i.
by rewrite !list_lookup_op assoc.
- intros l1 l2; rewrite list_equiv_lookup=> i.
@@ -233,17 +262,17 @@ Section cmra.
[by inversion_clear Heq; inversion_clear Hl..|].
exists (y1' :: l1'), (y2' :: l2'); repeat constructor; auto.
Qed.
- Canonical Structure listR := CmraT (list A) list_cmra_mixin.
+ Canonical Structure listR := CmraT SI (list A) list_cmra_mixin.
Global Instance list_unit : Unit (list A) := [].
- Definition list_ucmra_mixin : UcmraMixin (list A).
+ Definition list_ucmra_mixin : UcmraMixin SI (list A).
Proof.
split.
- constructor.
- by intros l.
- by constructor.
Qed.
- Canonical Structure listUR := UcmraT (list A) list_ucmra_mixin.
+ Canonical Structure listUR := UcmraT SI (list A) list_ucmra_mixin.
Global Instance list_cmra_discrete : CmraDiscrete A → CmraDiscrete listR.
Proof.
@@ -264,21 +293,21 @@ Section cmra.
Proof. uPred.unseal; constructor=> n x ?. apply list_lookup_validN. Qed.
End cmra.
-Arguments listR : clear implicits.
-Arguments listUR : clear implicits.
+Arguments listR {_} _.
+Arguments listUR {_} _.
-Instance list_singletonM {A : ucmraT} : SingletonM nat A (list A) := λ n x,
+Instance list_singletonM {SI} {A : ucmraT SI} : SingletonM nat A (list A) := λ n x,
replicate n ε ++ [x].
Section properties.
- Context {A : ucmraT}.
+ Context {SI} {A : ucmraT SI}.
Implicit Types l : list A.
Implicit Types x y z : A.
Local Arguments op _ _ !_ !_ / : simpl nomatch.
Local Arguments cmra_op _ !_ !_ / : simpl nomatch.
Local Arguments ucmra_op _ !_ !_ / : simpl nomatch.
- Lemma list_lookup_opM l mk i : (l ⋅? mk) !! i = l !! i ⋅ (mk ≫= (!! i)).
+ Lemma list_lookup_opM l mk i : (l ⋅? mk) !! i = l !! i ⋅ (mk ≫= (lookup i)).
Proof. destruct mk; by rewrite /= ?list_lookup_op ?right_id_L. Qed.
Global Instance list_op_nil_l : LeftId (=) (@nil A) op.
@@ -307,7 +336,7 @@ Section properties.
Lemma replicate_valid n (x : A) : ✓ x → ✓ replicate n x.
Proof. apply Forall_replicate. Qed.
Global Instance list_singletonM_ne i :
- NonExpansive (@list_singletonM A i).
+ NonExpansive (@list_singletonM SI A i).
Proof. intros n l1 l2 ?. apply Forall2_app; by repeat constructor. Qed.
Global Instance list_singletonM_proper i :
Proper ((≡) ==> (≡)) (list_singletonM i) := ne_proper _.
@@ -449,7 +478,7 @@ Section properties.
End properties.
(** Functor *)
-Instance list_fmap_cmra_morphism {A B : ucmraT} (f : A → B)
+Instance list_fmap_cmra_morphism {SI} {A B : ucmraT SI} (f : A → B)
`{!CmraMorphism f} : CmraMorphism (fmap f : list A → list B).
Proof.
split; try apply _.
@@ -461,24 +490,24 @@ Proof.
by rewrite list_lookup_op !list_lookup_fmap list_lookup_op cmra_morphism_op.
Qed.
-Program Definition listURF (F : urFunctor) : urFunctor := {|
- urFunctor_car A _ B _ := listUR (urFunctor_car F A B);
- urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := listO_map (urFunctor_map F fg)
+Program Definition listURF {SI} (F : urFunctor SI) : urFunctor SI := {|
+ urFunctor_car A B := listUR (urFunctor_car F A B);
+ urFunctor_map A1 A2 B1 B2 fg := listO_map (urFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply listO_map_ne, urFunctor_ne.
+ by intros ? F A1 A2 B1 B2 n f g Hfg; apply listO_map_ne, urFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(list_fmap_id x).
+ intros ? F A B x. rewrite /= -{2}(list_fmap_id x).
apply list_fmap_equiv_ext=>y. apply urFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -list_fmap_compose.
+ intros ? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -list_fmap_compose.
apply list_fmap_equiv_ext=>y; apply urFunctor_compose.
Qed.
-Instance listURF_contractive F :
+Instance listURF_contractive {SI} (F: urFunctor SI) :
urFunctorContractive F → urFunctorContractive (listURF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply listO_map_ne, urFunctor_contractive.
+ by intros ? A1 A2 B1 B2 n f g Hfg; apply listO_map_ne, urFunctor_contractive.
Qed.
diff --git a/theories/algebra/local_updates.v b/theories/algebra/local_updates.v
index 93f185ff38674f14528be5db66c23f3301b8981a..64260d37228257122e98baf08db1687dc5b888c1 100644
--- a/theories/algebra/local_updates.v
+++ b/theories/algebra/local_updates.v
@@ -2,20 +2,20 @@ From iris.algebra Require Export cmra.
Set Default Proof Using "Type".
(** * Local updates *)
-Definition local_update {A : cmraT} (x y : A * A) := ∀ n mz,
+Definition local_update `{A : cmraT SI} (x y : A * A) := ∀ n mz,
✓{n} x.1 → x.1 ≡{n}≡ x.2 ⋅? mz → ✓{n} y.1 ∧ y.1 ≡{n}≡ y.2 ⋅? mz.
-Instance: Params (@local_update) 1 := {}.
+Instance: Params (@local_update) 2 := {}.
Infix "~l~>" := local_update (at level 70).
Section updates.
- Context {A : cmraT}.
+ Context `{A : cmraT SI}.
Implicit Types x y : A.
Global Instance local_update_proper :
- Proper ((≡) ==> (≡) ==> iff) (@local_update A).
+ Proper ((≡) ==> (≡) ==> iff) (@local_update SI A).
Proof. unfold local_update. by repeat intro; setoid_subst. Qed.
- Global Instance local_update_preorder : PreOrder (@local_update A).
+ Global Instance local_update_preorder : PreOrder (@local_update SI A).
Proof. split; unfold local_update; red; naive_solver. Qed.
Lemma exclusive_local_update `{!Exclusive y} x x' : ✓ x' → (x,y) ~l~> (x',x').
@@ -72,31 +72,31 @@ Section updates.
Proof.
rewrite /local_update /=. setoid_rewrite <-cmra_discrete_valid_iff.
setoid_rewrite <-(λ n, discrete_iff n x).
- setoid_rewrite <-(λ n, discrete_iff n x'). naive_solver eauto using 0.
+ setoid_rewrite <-(λ n, discrete_iff n x'). naive_solver eauto using zero.
Qed.
Lemma local_update_valid0 x y x' y' :
- (✓{0} x → ✓{0} y → x ≡{0}≡ y ∨ y ≼{0} x → (x,y) ~l~> (x',y')) →
+ (✓{zero} x → ✓{zero} y → x ≡{zero}≡ y ∨ y ≼{zero} x → (x,y) ~l~> (x',y')) →
(x,y) ~l~> (x',y').
Proof.
intros Hup n mz Hmz Hz; simpl in *. apply Hup; auto.
- - by apply (cmra_validN_le n); last lia.
- - apply (cmra_validN_le n); last lia.
+ - by apply (cmra_validN_le n); auto.
+ - apply (cmra_validN_le n); last auto.
move: Hmz; rewrite Hz. destruct mz; simpl; eauto using cmra_validN_op_l.
- destruct mz as [z|].
- + right. exists z. apply dist_le with n; auto with lia.
- + left. apply dist_le with n; auto with lia.
+ + right. exists z. apply dist_le with n; auto.
+ + left. apply dist_le with n; auto.
Qed.
Lemma local_update_valid `{!CmraDiscrete A} x y x' y' :
(✓ x → ✓ y → x ≡ y ∨ y ≼ x → (x,y) ~l~> (x',y')) → (x,y) ~l~> (x',y').
Proof.
- rewrite !(cmra_discrete_valid_iff 0)
- (cmra_discrete_included_iff 0) (discrete_iff 0).
+ rewrite !(cmra_discrete_valid_iff zero)
+ (cmra_discrete_included_iff zero) (discrete_iff zero).
apply local_update_valid0.
Qed.
Lemma local_update_total_valid0 `{!CmraTotal A} x y x' y' :
- (✓{0} x → ✓{0} y → y ≼{0} x → (x,y) ~l~> (x',y')) → (x,y) ~l~> (x',y').
+ (✓{zero} x → ✓{zero} y → y ≼{zero} x → (x,y) ~l~> (x',y')) → (x,y) ~l~> (x',y').
Proof.
intros Hup. apply local_update_valid0=> ?? [Hx|?]; apply Hup; auto.
by rewrite Hx.
@@ -104,13 +104,13 @@ Section updates.
Lemma local_update_total_valid `{!CmraTotal A, !CmraDiscrete A} x y x' y' :
(✓ x → ✓ y → y ≼ x → (x,y) ~l~> (x',y')) → (x,y) ~l~> (x',y').
Proof.
- rewrite !(cmra_discrete_valid_iff 0) (cmra_discrete_included_iff 0).
+ rewrite !(cmra_discrete_valid_iff zero) (cmra_discrete_included_iff zero).
apply local_update_total_valid0.
Qed.
End updates.
Section updates_unital.
- Context {A : ucmraT}.
+ Context `{A : ucmraT SI}.
Implicit Types x y : A.
Lemma local_update_unital x y x' y' :
@@ -137,70 +137,74 @@ Section updates_unital.
Proof. rewrite -{2}(right_id ε op x). by apply cancel_local_update. Qed.
End updates_unital.
-(** * Product *)
-Lemma prod_local_update {A B : cmraT} (x y x' y' : A * B) :
- (x.1,y.1) ~l~> (x'.1,y'.1) → (x.2,y.2) ~l~> (x'.2,y'.2) →
- (x,y) ~l~> (x',y').
-Proof.
- intros Hup1 Hup2 n mz [??] [??]; simpl in *.
- destruct (Hup1 n (fst <$> mz)); [done|by destruct mz|].
- destruct (Hup2 n (snd <$> mz)); [done|by destruct mz|].
- by destruct mz.
-Qed.
-
-Lemma prod_local_update' {A B : cmraT} (x1 y1 x1' y1' : A) (x2 y2 x2' y2' : B) :
- (x1,y1) ~l~> (x1',y1') → (x2,y2) ~l~> (x2',y2') →
- ((x1,x2),(y1,y2)) ~l~> ((x1',x2'),(y1',y2')).
-Proof. intros. by apply prod_local_update. Qed.
-Lemma prod_local_update_1 {A B : cmraT} (x1 y1 x1' y1' : A) (x2 y2 : B) :
- (x1,y1) ~l~> (x1',y1') → ((x1,x2),(y1,y2)) ~l~> ((x1',x2),(y1',y2)).
-Proof. intros. by apply prod_local_update. Qed.
-Lemma prod_local_update_2 {A B : cmraT} (x1 y1 : A) (x2 y2 x2' y2' : B) :
- (x2,y2) ~l~> (x2',y2') → ((x1,x2),(y1,y2)) ~l~> ((x1,x2'),(y1,y2')).
-Proof. intros. by apply prod_local_update. Qed.
-
-(** * Option *)
-(* TODO: Investigate whether we can use these in proving the very similar local
+Section local_update_instances.
+ Context {SI: indexT}.
+
+ (** * Product *)
+ Lemma prod_local_update {A B : cmraT SI} (x y x' y' : A * B) :
+ (x.1,y.1) ~l~> (x'.1,y'.1) → (x.2,y.2) ~l~> (x'.2,y'.2) →
+ (x,y) ~l~> (x',y').
+ Proof.
+ intros Hup1 Hup2 n mz [??] [??]; simpl in *.
+ destruct (Hup1 n (fst <$> mz)); [done|by destruct mz|].
+ destruct (Hup2 n (snd <$> mz)); [done|by destruct mz|].
+ by destruct mz.
+ Qed.
+
+ Lemma prod_local_update' {A B : cmraT SI} (x1 y1 x1' y1' : A) (x2 y2 x2' y2' : B) :
+ (x1,y1) ~l~> (x1',y1') → (x2,y2) ~l~> (x2',y2') →
+ ((x1,x2),(y1,y2)) ~l~> ((x1',x2'),(y1',y2')).
+ Proof. intros. by apply prod_local_update. Qed.
+ Lemma prod_local_update_1 {A B : cmraT SI} (x1 y1 x1' y1' : A) (x2 y2 : B) :
+ (x1,y1) ~l~> (x1',y1') → ((x1,x2),(y1,y2)) ~l~> ((x1',x2),(y1',y2)).
+ Proof. intros. by apply prod_local_update. Qed.
+ Lemma prod_local_update_2 {A B : cmraT SI} (x1 y1 : A) (x2 y2 x2' y2' : B) :
+ (x2,y2) ~l~> (x2',y2') → ((x1,x2),(y1,y2)) ~l~> ((x1,x2'),(y1,y2')).
+ Proof. intros. by apply prod_local_update. Qed.
+
+ (** * Option *)
+ (* TODO: Investigate whether we can use these in proving the very similar local
updates on finmaps. *)
-Lemma option_local_update {A : cmraT} (x y x' y' : A) :
- (x, y) ~l~> (x',y') →
- (Some x, Some y) ~l~> (Some x', Some y').
-Proof.
- intros Hup. apply local_update_unital=>n mz Hxv Hx; simpl in *.
- destruct (Hup n mz); first done.
- { destruct mz as [?|]; inversion_clear Hx; auto. }
- split; first done. destruct mz as [?|]; constructor; auto.
-Qed.
-
-Lemma alloc_option_local_update {A : cmraT} (x : A) y :
- ✓ x →
- (None, y) ~l~> (Some x, Some x).
-Proof.
- move=>Hx. apply local_update_unital=> n z _ /= Heq. split.
- { rewrite Some_validN. apply cmra_valid_validN. done. }
- destruct z as [z|]; last done. destruct y; inversion Heq.
-Qed.
-
-Lemma delete_option_local_update {A : cmraT} (x : option A) (y : A) :
- Exclusive y → (x, Some y) ~l~> (None, None).
-Proof.
- move=>Hex. apply local_update_unital=>n z /= Hy Heq. split; first done.
- destruct z as [z|]; last done. exfalso.
- move: Hy. rewrite Heq /= -Some_op=>Hy. eapply Hex.
- eapply cmra_validN_le. eapply Hy. lia.
-Qed.
-
-(** * Natural numbers *)
-Lemma nat_local_update (x y x' y' : nat) :
- x + y' = x' + y → (x,y) ~l~> (x',y').
-Proof.
- intros ??; apply local_update_unital_discrete=> z _.
- compute -[minus plus]; lia.
-Qed.
-
-Lemma mnat_local_update (x y x' : mnatUR) :
- x ≤ x' → (x,y) ~l~> (x',x').
-Proof.
- intros ??; apply local_update_unital_discrete=> z _.
- compute -[max]; lia.
-Qed.
+ Lemma option_local_update {A : cmraT SI} (x y x' y' : A) :
+ (x, y) ~l~> (x',y') →
+ (Some x, Some y) ~l~> (Some x', Some y').
+ Proof.
+ intros Hup. apply local_update_unital=>n mz Hxv Hx; simpl in *.
+ destruct (Hup n mz); first done.
+ { destruct mz as [?|]; inversion_clear Hx; auto. }
+ split; first done. destruct mz as [?|]; constructor; auto.
+ Qed.
+
+ Lemma alloc_option_local_update {A : cmraT SI} (x : A) y :
+ ✓ x →
+ (None, y) ~l~> (Some x, Some x).
+ Proof.
+ move=>Hx. apply local_update_unital=> n z _ /= Heq. split.
+ { rewrite Some_validN. apply cmra_valid_validN. done. }
+ destruct z as [z|]; last done. destruct y; inversion Heq.
+ Qed.
+
+ Lemma delete_option_local_update {A : cmraT SI} (x : option A) (y : A) :
+ Exclusive y → (x, Some y) ~l~> (None, None).
+ Proof.
+ move=>Hex. apply local_update_unital=>n z /= Hy Heq. split; first done.
+ destruct z as [z|]; last done. exfalso.
+ move: Hy. rewrite Heq /= -Some_op=>Hy. eapply Hex.
+ eapply cmra_validN_le. eapply Hy. auto.
+ Qed.
+
+ (** * Natural numbers *)
+ Lemma nat_local_update (x y x' y' : nat) :
+ x + y' = x' + y → (x: natO SI,y) ~l~> (x',y').
+ Proof.
+ intros ??; apply local_update_unital_discrete=> z _.
+ compute -[minus plus]; lia.
+ Qed.
+
+ Lemma mnat_local_update (x y x' : mnatUR SI) :
+ x ≤ x' → (x,y) ~l~> (x',x').
+ Proof.
+ intros ??; apply local_update_unital_discrete=> z _.
+ compute -[max]; lia.
+ Qed.
+End local_update_instances.
diff --git a/theories/algebra/mlist.v b/theories/algebra/mlist.v
new file mode 100644
index 0000000000000000000000000000000000000000..3199eda8e63d9cb1e3218fac2b0948c0ad18f2f1
--- /dev/null
+++ b/theories/algebra/mlist.v
@@ -0,0 +1,346 @@
+From iris.base_logic.lib Require Import iprop own.
+From iris.proofmode Require Import base tactics classes.
+From iris.algebra Require Import auth gmap auth_frac.
+From iris.base_logic Require Import lib.own.
+From iris.bi.lib Require Import fractional.
+
+(* Monotone list. Almost exactly the "mlist" construction code by Hai Dang from the sra-gps proof of RCU,
+ just generalized slightly to operate over arbitrary lists instead of RCU data *)
+
+Section cmra_mlist.
+
+ Context (A: Type) `{EqDecision A} {SI: indexT}.
+ Implicit Types (D: list A).
+
+ Inductive mlist :=
+ | MList D : mlist
+ | MListBot : mlist.
+
+ Inductive mlist_equiv : Equiv mlist :=
+ | MList_equiv D1 D2:
+ D1 = D2 → MList D1 ≡ MList D2
+ | MListBot_equiv : MListBot ≡ MListBot.
+
+ Existing Instance mlist_equiv.
+ Instance mlist_equiv_Equivalence : @Equivalence mlist equiv.
+ Proof.
+ split.
+ - move => [|]; by constructor.
+ - move => [?|] [?|]; inversion 1; subst; by constructor.
+ - move => [?|] [?|] [?|];
+ inversion 1; inversion 1; subst; by constructor.
+ Qed.
+
+ Canonical Structure mlistC : ofeT SI := discreteO SI mlist.
+
+ Instance mlist_valid : Valid mlist :=
+ λ x, match x with MList _ => True | MListBot => False end.
+
+ Instance mlist_op : Op mlist := λ x y,
+ match x, y with
+ | MList D1, MList D2 =>
+ if (decide (D1 `prefix_of` D2))
+ then MList D2
+ else
+ if (decide (D2 `prefix_of` D1))
+ then MList D1
+ else MListBot
+ | _, _ => MListBot
+ end.
+
+ Arguments op _ _ !_ !_ /.
+
+ Instance mlist_PCore : PCore mlist := Some.
+
+ Instance anti_symm_prefix_of : AntiSymm eq (@list.prefix A).
+ Proof.
+ intros l1 l2 Hpre1 Hpre2.
+ destruct Hpre1 as (D1'&Hpre1). destruct Hpre2 as (D2'&Hpre2).
+ rewrite Hpre2 in Hpre1.
+ apply (f_equal (length)) in Hpre1. rewrite ?app_length in Hpre1.
+ destruct D2', D1'; simpl in Hpre1; try lia.
+ by rewrite Hpre2 right_id.
+ Qed.
+
+ Global Instance mlist_op_comm: Comm equiv mlist_op.
+ Proof.
+ intros [D1|] [D2|]; auto. simpl.
+ destruct (decide _) as [Hpre1|Hnpre]; last auto.
+ destruct (decide _) as [Hpre2|Hnpre]; last auto.
+ constructor.
+ apply (anti_symm list.prefix); auto.
+ Qed.
+
+ Global Instance mlist_op_idemp : IdemP eq mlist_op.
+ Proof. intros [|]; [by simpl; rewrite decide_True|auto]. Qed.
+
+ Lemma mlist_op_l D1 D2 (Le: D1 `prefix_of` D2) :
+ MList D1 â‹… MList D2 = MList D2.
+ Proof. simpl. case_decide; done. Qed.
+
+ Lemma mlist_op_r D1 D2 (Le: D1 `prefix_of` D2) :
+ MList D2 ⋅ MList D1 ≡ MList D2.
+ Proof. by rewrite (comm (op: Op mlist)) mlist_op_l. Qed.
+
+ Lemma prefix_of_down_total {X: Type} (l1 l2 l3: list X):
+ l1 `prefix_of` l3 →
+ l2 `prefix_of` l3 →
+ (l1 `prefix_of` l2 ∨ l2 `prefix_of` l1).
+ Proof.
+ destruct 1 as (l1'&Heq1).
+ destruct 1 as (l2'&Heq2).
+ rewrite Heq2 in Heq1.
+ apply app_eq_inv in Heq1 as [H2_is_prefix|H1_is_prefix].
+ { left. destruct H2_is_prefix as (k&?&?). exists k. eauto. }
+ { right. destruct H1_is_prefix as (k&?&?). exists k. eauto. }
+ Qed.
+
+ Global Instance mlist_op_assoc: Assoc equiv (op: Op mlist).
+ Proof.
+ intros [D1|] [D2|] [D3|]; eauto; simpl.
+ - repeat (case_decide; auto).
+ + rewrite !mlist_op_l; auto. etrans; eauto.
+ + simpl. repeat case_decide; last done; exfalso.
+ * feed pose proof (prefix_of_down_total D1 D2 D3); auto.
+ intuition.
+ * apply H1. by etrans.
+ + rewrite mlist_op_l; [by rewrite mlist_op_r|auto].
+ + rewrite !mlist_op_r; auto. by etrans.
+ + simpl. rewrite !decide_False; auto.
+ + simpl. rewrite !decide_False; auto.
+ + simpl. case_decide.
+ * exfalso. apply H. by etrans.
+ * case_decide; last done. exfalso.
+ feed pose proof (prefix_of_down_total D2 D3 D1); auto.
+ intuition.
+ - simpl. repeat case_decide; auto.
+ Qed.
+
+ Lemma mlist_included D1 D2 :
+ MList D1 ≼ MList D2 ↔ D1 `prefix_of` D2.
+ Proof.
+ split.
+ - move => [[?|]]; simpl; last inversion 1.
+ case_decide; first by (inversion 1; subst).
+ case_decide; inversion 1. by subst.
+ - intros. exists (MList D2). by rewrite mlist_op_l.
+ Qed.
+
+ Lemma mlist_valid_op D1 D2 :
+ ✓ (MList D1 ⋅ MList D2) → D1 `prefix_of` D2 ∨ D2 `prefix_of` D1.
+ Proof. simpl. case_decide; first by left. case_decide; [by right|done]. Qed.
+
+ Lemma mlist_core_self (X: mlist) : core X = X.
+ Proof. done. Qed.
+
+ Instance mlist_unit : Unit mlist := MList [].
+
+ Definition mlist_ra_mixin : RAMixin mlist.
+ Proof.
+ apply ra_total_mixin; eauto.
+ - intros [?|] [?|] [?|]; auto; inversion 1.
+ subst. simpl. repeat case_decide; done.
+ - by destruct 1; constructor.
+ - by destruct 1.
+ - apply mlist_op_assoc.
+ - apply mlist_op_comm.
+ - intros ?. by rewrite mlist_core_self idemp_L.
+ - intros [|] [|]; simpl; done.
+ Qed.
+
+ Canonical Structure mlistR := discreteR SI mlist mlist_ra_mixin.
+
+ Global Instance mlistR_cmra_discrete : CmraDiscrete mlistR.
+ Proof. apply discrete_cmra_discrete. Qed.
+
+ Definition mlist_ucmra_mixin : UcmraMixin SI mlistR.
+ Proof.
+ split; [done| |auto]. intros [|]; [simpl|done].
+ reflexivity.
+ Qed.
+
+ Canonical Structure mlistUR :=
+ UcmraT SI mlist mlist_ucmra_mixin.
+
+ Lemma mlist_local_update D1 X D2 :
+ D1 `prefix_of` D2 → (MList D1, X) ~l~> (MList D2, MList D2).
+ Proof.
+ intros Le. rewrite local_update_discrete.
+ move => [[D3|]|] /= ? Eq; split => //; last first; move : Eq.
+ - destruct X; by inversion 1.
+ - destruct X; rewrite /cmra_op /= => Eq;
+ repeat case_decide; auto; inversion Eq; subst.
+ + constructor. by apply: anti_symm.
+ + by exfalso.
+ + constructor. apply : anti_symm; [done|by etrans].
+ + exfalso. apply H2. by etrans.
+ Qed.
+
+ Global Instance mlist_core_id (x : mlist) : CoreId x.
+ Proof. by constructor. Qed.
+
+End cmra_mlist.
+
+Arguments MList {_} _.
+
+Definition fmlistUR {SI} (A: Type) {Heq: EqDecision A} := (@authUR SI (mlistUR A)).
+Class fmlistG {SI} (A: Type) {Heq: EqDecision A} (Σ: gFunctors SI) :=
+ { fmlist_inG :> inG Σ (fmlistUR A) }.
+Definition fmlistΣ {SI} (A: Type) {Heq: EqDecision A} : gFunctors SI :=
+ #[GFunctor (fmlistUR A)].
+
+Instance subG_fmlistΣ {SI} (A: Type) {Heq: EqDecision A} {Σ : gFunctors SI} :
+ subG (fmlistΣ A) Σ → (fmlistG (SI:=SI) A) Σ.
+Proof. solve_inG. Qed.
+
+Section fmlist_props.
+ Context `{Σ : gFunctors SI}.
+ Context `{@fmlistG SI A Heq Σ}.
+Implicit Types l : list A.
+
+Definition fmlist γ q l:= own γ (â—{q} (MList l)).
+Definition fmlist_lb γ l := own γ (◯ (MList l)).
+Definition fmlist_idx γ i a := (∃ l, ⌜ l !! i = Some a ⌠∗ fmlist_lb γ l)%I.
+
+Instance inj_MList_equiv : Inj eq (@equiv _ (mlist_equiv _)) (@MList A).
+Proof. intros l1 l2. inversion 1. subst; eauto. Qed.
+
+Lemma fmlist_agree_1 γ q1 q2 l1 l2:
+ fmlist γ q1 l1 -∗ fmlist γ q2 l2 -∗ ⌜ l1 = l2 âŒ.
+Proof.
+ iIntros "Hγ1 Hγ2". iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval.
+ apply auth_auth_frac_op_inv in Hval.
+ iPureIntro. apply (inj MList); auto.
+Qed.
+
+Lemma fmlist_agree_2 γ q1 l1 l2 :
+ fmlist γ q1 l1 -∗ fmlist_lb γ l2 -∗ ⌜ l2 `prefix_of` l1 âŒ.
+Proof.
+ iIntros "Hγ1 Hγ2". iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval.
+ by apply @auth_both_frac_valid in Hval as (?&Hle%mlist_included&?); last apply _.
+Qed.
+
+Lemma fmlist_lb_agree γ l1 l2 :
+ fmlist_lb γ l1 -∗ fmlist_lb γ l2 -∗ ⌜ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1âŒ.
+Proof.
+ iIntros "Hγ1 Hγ2". iDestruct (own_valid_2 with "Hγ1 Hγ2") as %Hval.
+ rewrite -auth_frag_op auth_frag_valid in Hval * => Hval.
+ iPureIntro. by apply mlist_valid_op in Hval.
+Qed.
+
+Lemma fmlist_idx_agree_1 γ i a1 a2:
+ fmlist_idx γ i a1 -∗ fmlist_idx γ i a2 -∗ ⌜ a1 = a2 âŒ.
+Proof.
+ iDestruct 1 as (l1 Hlookup1) "H1".
+ iDestruct 1 as (l2 Hlookup2) "H2".
+ iDestruct (fmlist_lb_agree with "H1 H2") as %Hprefix.
+ iPureIntro.
+ destruct Hprefix as [Hpre|Hpre]; eapply prefix_lookup in Hpre; eauto; congruence.
+Qed.
+
+Lemma fmlist_idx_agree_2 γ q l i a :
+ fmlist γ q l -∗ fmlist_idx γ i a -∗ ⌜ l !! i = Some a âŒ.
+Proof.
+ iIntros "H1".
+ iDestruct 1 as (l2 Hlookup2) "H2".
+ iDestruct (fmlist_agree_2 with "H1 H2") as %Hpre.
+ iPureIntro.
+ eapply prefix_lookup in Hpre; eauto; congruence.
+Qed.
+
+Lemma fmlist_lb_mono γ l1 l2:
+ l1 `prefix_of` l2 ->
+ fmlist_lb γ l2 -∗ fmlist_lb γ l1.
+Proof.
+ iIntros (Hle) "Hlb".
+ rewrite /fmlist_lb.
+ iApply (own_mono with "Hlb").
+ apply @auth_frag_mono.
+ apply mlist_included; auto.
+Qed.
+
+Lemma fmlist_sep γ q1 q2 l:
+ fmlist γ (q1 + q2) l ⊣⊢ fmlist γ q1 l ∗ fmlist γ q2 l.
+Proof.
+ iSplit.
+ - iIntros "(Hm1&Hm2)". iFrame.
+ - iIntros "(Hm1&Hm2)". iCombine "Hm1 Hm2" as "$".
+Qed.
+
+Lemma fmlist_to_lb γ q l:
+ fmlist γ q l ==∗ fmlist_lb γ l.
+Proof.
+ iIntros "Hm".
+ iMod (own_update _ _ ((â—{q} (MList l)) â‹… â—¯ (MList l)) with "Hm") as "(?&$)"; last done.
+ { apply auth_frac_update_core_id; eauto. apply _. }
+Qed.
+
+Lemma fmlist_get_lb γ q l:
+ fmlist γ q l ==∗ fmlist γ q l ∗ fmlist_lb γ l.
+Proof.
+ iIntros "Hm".
+ iMod (own_update _ _ ((â—{q} (MList l)) â‹… â—¯ (MList l)) with "Hm") as "(?&$)"; last done.
+ { apply auth_frac_update_core_id; eauto. apply _. }
+Qed.
+
+Lemma fmlist_lb_to_idx γ l i a:
+ l !! i = Some a →
+ fmlist_lb γ l -∗ fmlist_idx γ i a.
+Proof. iIntros (Hlookup) "H". iExists l. iFrame. eauto. Qed.
+
+Lemma fmlist_update l' γ l:
+ l `prefix_of` l' ->
+ fmlist γ 1 l ==∗ fmlist γ 1 l' ∗ fmlist_lb γ l'.
+Proof.
+ iIntros (Hlt) "Hm".
+ iMod (own_update with "Hm") as "($&?)"; last done.
+ apply auth_update_alloc, mlist_local_update; auto.
+Qed.
+
+Lemma fmlist_update_snoc x γ l:
+ fmlist γ 1 l ==∗ fmlist γ 1 (l ++ [x]) ∗ fmlist_lb γ (l ++ [x]).
+Proof.
+ iIntros "Hm". iMod (fmlist_update with "[$]") as "($&$)"; last done.
+ by exists [x].
+Qed.
+
+Lemma fmlist_alloc l :
+ ⊢ |==> ∃ γ, fmlist γ 1 l.
+Proof.
+ iStartProof.
+ iMod (own_alloc (â—{1} (MList l))) as (γ) "H".
+ { apply auth_auth_valid.
+ cbv; auto. }
+ iModIntro.
+ iExists _; iFrame.
+Qed.
+
+Global Instance fmlist_lb_pers γ l: Persistent (fmlist_lb γ l).
+Proof. rewrite /fmlist_lb. apply _. Qed.
+
+Global Instance fmlist_lb_timeless γ l: Timeless (fmlist_lb γ l).
+Proof. apply _. Qed.
+
+Global Instance fmlist_idx_pers γ i a: Persistent (fmlist_idx γ i a).
+Proof. apply _. Qed.
+
+Global Instance fmlist_idx_timeless γ i a: Timeless (fmlist_idx γ i a).
+Proof. apply _. Qed.
+
+Global Instance fmlist_timeless γ q n: Timeless (fmlist γ q n).
+Proof. apply _. Qed.
+
+Global Instance fmlist_fractional γ n: Fractional (λ q, fmlist γ q n).
+Proof. intros p q. apply fmlist_sep. Qed.
+
+Global Instance fmlist_as_fractional γ q n :
+ AsFractional (fmlist γ q n) (λ q, fmlist γ q n) q.
+Proof. split; first by done. apply _. Qed.
+
+Global Instance fmlist_into_sep γ n :
+ IntoSep (fmlist γ 1 n) (fmlist γ (1/2) n) (fmlist γ (1/2) n).
+Proof. apply _. Qed.
+
+End fmlist_props.
+
+Typeclasses Opaque fmlist fmlist_lb fmlist_idx.
diff --git a/theories/algebra/monoid.v b/theories/algebra/monoid.v
index 57e6a5efd54dfe26518127b8a8c50ff8794b8819..9238dccf01d4d99b4c94a7526f073bcb55526429 100644
--- a/theories/algebra/monoid.v
+++ b/theories/algebra/monoid.v
@@ -17,24 +17,24 @@ we do not have a canonical structure for setoids, we do not go that way.
Note that we do not declare any of the projections as type class instances. That
is because we only need them in the [big_op] file, and nowhere else. Hence, we
declare these instances locally there to avoid them being used elsewhere. *)
-Class Monoid {M : ofeT} (o : M → M → M) := {
+Class Monoid {I: indexT} {M : ofeT I} (o : M → M → M) := {
monoid_unit : M;
monoid_ne : NonExpansive2 o;
monoid_assoc : Assoc (≡) o;
monoid_comm : Comm (≡) o;
monoid_left_id : LeftId (≡) monoid_unit o;
}.
-Lemma monoid_proper `{Monoid M o} : Proper ((≡) ==> (≡) ==> (≡)) o.
+Lemma monoid_proper {I: indexT} `{Monoid I M o} : Proper ((≡) ==> (≡) ==> (≡)) o.
Proof. apply ne_proper_2, monoid_ne. Qed.
-Lemma monoid_right_id `{Monoid M o} : RightId (≡) monoid_unit o.
+Lemma monoid_right_id {I: indexT} `{Monoid I M o} : RightId (≡) monoid_unit o.
Proof. intros x. etrans; [apply monoid_comm|apply monoid_left_id]. Qed.
(** The [Homomorphism] classes give rise to generic lemmas about big operators
commuting with each other. We also consider a [WeakMonoidHomomorphism] which
does not necesarrily commute with unit; an example is the [own] connective: we
only have `True ==∗ own γ ∅`, not `True ↔ own γ ∅`. *)
-Class WeakMonoidHomomorphism {M1 M2 : ofeT}
- (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{Monoid M1 o1, Monoid M2 o2}
+Class WeakMonoidHomomorphism {I: indexT} {M1 M2 : ofeT I}
+ (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{Monoid I M1 o1, Monoid I M2 o2}
(R : relation M2) (f : M1 → M2) := {
monoid_homomorphism_rel_po : PreOrder R;
monoid_homomorphism_rel_proper : Proper ((≡) ==> (≡) ==> iff) R;
@@ -43,13 +43,13 @@ Class WeakMonoidHomomorphism {M1 M2 : ofeT}
monoid_homomorphism x y : R (f (o1 x y)) (o2 (f x) (f y))
}.
-Class MonoidHomomorphism {M1 M2 : ofeT}
- (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{Monoid M1 o1, Monoid M2 o2}
+Class MonoidHomomorphism {I: indexT} {M1 M2 : ofeT I}
+ (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{Monoid I M1 o1, Monoid I M2 o2}
(R : relation M2) (f : M1 → M2) := {
monoid_homomorphism_weak :> WeakMonoidHomomorphism o1 o2 R f;
monoid_homomorphism_unit : R (f monoid_unit) monoid_unit
}.
-Lemma weak_monoid_homomorphism_proper
- `{WeakMonoidHomomorphism M1 M2 o1 o2 R f} : Proper ((≡) ==> (≡)) f.
+Lemma weak_monoid_homomorphism_proper {I: indexT}
+ `{WeakMonoidHomomorphism I M1 M2 o1 o2 R f} : Proper ((≡) ==> (≡)) f.
Proof. apply ne_proper, monoid_homomorphism_ne. Qed.
diff --git a/theories/algebra/namespace_map.v b/theories/algebra/namespace_map.v
index 93c2ff11755541bd73630f61c0ed5e7799a44d4a..436583e0865e92f0f25e00e7dffb7bb83c85adb6 100644
--- a/theories/algebra/namespace_map.v
+++ b/theories/algebra/namespace_map.v
@@ -29,21 +29,21 @@ Instance: Params (@namespace_map_data_proj) 1 := {}.
Instance: Params (@namespace_map_token_proj) 1 := {}.
(** TODO: [positives_flatten] violates the namespace abstraction. *)
-Definition namespace_map_data {A : cmraT} (N : namespace) (a : A) : namespace_map A :=
- NamespaceMap {[ positives_flatten N := a ]} ε.
-Definition namespace_map_token {A : cmraT} (E : coPset) : namespace_map A :=
+Definition namespace_map_data {SI} {A : cmraT SI} (N : namespace) (a : A) : namespace_map A :=
+ NamespaceMap {[ positives_flatten N := a ]} (ε : coPset_disjUR SI).
+Definition namespace_map_token {SI} {A : cmraT SI} (E : coPset) : namespace_map A :=
NamespaceMap ∅ (CoPset E).
Instance: Params (@namespace_map_data) 2 := {}.
(* Ofe *)
Section ofe.
-Context {A : ofeT}.
+Context {SI} {A : ofeT SI}.
Implicit Types x y : namespace_map A.
Instance namespace_map_equiv : Equiv (namespace_map A) := λ x y,
namespace_map_data_proj x ≡ namespace_map_data_proj y ∧
namespace_map_token_proj x = namespace_map_token_proj y.
-Instance namespace_map_dist : Dist (namespace_map A) := λ n x y,
+Instance namespace_map_dist : Dist SI (namespace_map A) := λ n x y,
namespace_map_data_proj x ≡{n}≡ namespace_map_data_proj y ∧
namespace_map_token_proj x = namespace_map_token_proj y.
@@ -57,7 +57,7 @@ Global Instance namespace_map_data_proj_proper :
Proper ((≡) ==> (≡)) (@namespace_map_data_proj A).
Proof. by destruct 1. Qed.
-Definition namespace_map_ofe_mixin : OfeMixin (namespace_map A).
+Definition namespace_map_ofe_mixin : OfeMixin SI (namespace_map A).
Proof.
by apply (iso_ofe_mixin
(λ x, (namespace_map_data_proj x, namespace_map_token_proj x))).
@@ -66,30 +66,30 @@ Canonical Structure namespace_mapO :=
OfeT (namespace_map A) namespace_map_ofe_mixin.
Global Instance NamespaceMap_discrete a b :
- Discrete a → Discrete b → Discrete (NamespaceMap a b).
-Proof. intros ?? [??] [??]; split; unfold_leibniz; by eapply discrete. Qed.
+ @Discrete SI _ a → @Discrete SI _ b → Discrete (NamespaceMap a b).
+Proof. intros ?? [??] [??]; split; simpl in *; eauto. Qed.
Global Instance namespace_map_ofe_discrete :
OfeDiscrete A → OfeDiscrete namespace_mapO.
Proof. intros ? [??]; apply _. Qed.
End ofe.
-Arguments namespace_mapO : clear implicits.
+Arguments namespace_mapO {_} _.
(* Camera *)
Section cmra.
-Context {A : cmraT}.
+Context {SI} {A : cmraT SI}.
Implicit Types a b : A.
Implicit Types x y : namespace_map A.
-Global Instance namespace_map_data_ne i : NonExpansive (@namespace_map_data A i).
+Global Instance namespace_map_data_ne i : NonExpansive (@namespace_map_data SI A i).
Proof. solve_proper. Qed.
Global Instance namespace_map_data_proper N :
- Proper ((≡) ==> (≡)) (@namespace_map_data A N).
-Proof. solve_proper. Qed.
+ Proper ((≡) ==> (≡)) (@namespace_map_data SI A N).
+Proof. intros ?? H; split; simpl; by rewrite ?H. Qed.
Global Instance namespace_map_data_discrete N a :
Discrete a → Discrete (namespace_map_data N a).
Proof. intros. apply NamespaceMap_discrete; apply _. Qed.
-Global Instance namespace_map_token_discrete E : Discrete (@namespace_map_token A E).
+Global Instance namespace_map_token_discrete E : Discrete (@namespace_map_token SI A E).
Proof. intros. apply NamespaceMap_discrete; apply _. Qed.
Instance namespace_map_valid : Valid (namespace_map A) := λ x,
@@ -101,7 +101,7 @@ Instance namespace_map_valid : Valid (namespace_map A) := λ x,
| CoPsetBot => False
end.
Global Arguments namespace_map_valid !_ /.
-Instance namespace_map_validN : ValidN (namespace_map A) := λ n x,
+Instance namespace_map_validN : ValidN SI (namespace_map A) := λ n x,
match namespace_map_token_proj x with
| CoPset E =>
✓{n} (namespace_map_data_proj x) ∧
@@ -111,10 +111,11 @@ Instance namespace_map_validN : ValidN (namespace_map A) := λ n x,
end.
Global Arguments namespace_map_validN !_ /.
Instance namespace_map_pcore : PCore (namespace_map A) := λ x,
- Some (NamespaceMap (core (namespace_map_data_proj x)) ε).
-Instance namespace_map_op : Op (namespace_map A) := λ x y,
+ Some (NamespaceMap (core (namespace_map_data_proj x)) (ε: coPset_disjUR SI)).
+
+Instance namespace_map_op : Op (namespace_map A) := λ (x y: namespace_mapO A),
NamespaceMap (namespace_map_data_proj x â‹… namespace_map_data_proj y)
- (namespace_map_token_proj x â‹… namespace_map_token_proj y).
+ ((namespace_map_token_proj x: coPset_disjR SI) â‹… (namespace_map_token_proj y)).
Definition namespace_map_valid_eq :
valid = λ x, match namespace_map_token_proj x with
@@ -133,10 +134,10 @@ Definition namespace_map_validN_eq :
| CoPsetBot => False
end := eq_refl _.
-Lemma namespace_map_included x y :
+Lemma namespace_map_included x y:
x ≼ y ↔
namespace_map_data_proj x ≼ namespace_map_data_proj y ∧
- namespace_map_token_proj x ≼ namespace_map_token_proj y.
+ (namespace_map_token_proj x: coPset_disjR SI) ≼ (namespace_map_token_proj y).
Proof.
split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
intros [[z1 Hz1] [z2 Hz2]]; exists (NamespaceMap z1 z2); split; auto.
@@ -147,7 +148,7 @@ Proof. by destruct x as [? [?|]]=> // -[??]. Qed.
Lemma namespace_map_token_proj_validN n x : ✓{n} x → ✓{n} namespace_map_token_proj x.
Proof. by destruct x as [? [?|]]=> // -[??]. Qed.
-Lemma namespace_map_cmra_mixin : CmraMixin (namespace_map A).
+Lemma namespace_map_cmra_mixin : CmraMixin SI (namespace_map A).
Proof.
apply cmra_total_mixin.
- eauto.
@@ -157,12 +158,12 @@ Proof.
+ by rewrite -Hm.
+ intros i. by rewrite -(dist_None n) -Hm dist_None.
- intros [m [E|]]; rewrite namespace_map_valid_eq namespace_map_validN_eq /=
- ?cmra_valid_validN; naive_solver eauto using 0.
- - intros n [m [E|]]; rewrite namespace_map_validN_eq /=;
- naive_solver eauto using cmra_validN_S.
+ ?cmra_valid_validN; naive_solver eauto using zero.
+ - intros α β [m [E|]]; rewrite namespace_map_validN_eq /=;
+ naive_solver eauto using cmra_validN_le.
- split; simpl; [by rewrite assoc|by rewrite assoc_L].
- split; simpl; [by rewrite comm|by rewrite comm_L].
- - split; simpl; [by rewrite cmra_core_l|by rewrite left_id_L].
+ - intros; split; simpl; [by rewrite cmra_core_l|by rewrite left_id_L].
- split; simpl; [by rewrite cmra_core_idemp|done].
- intros ??; rewrite! namespace_map_included; intros [??].
by split; simpl; apply: cmra_core_mono. (* FIXME: FIXME(Coq #6294): needs new unification *)
@@ -182,7 +183,7 @@ Proof.
by exists (NamespaceMap m1 E1), (NamespaceMap m2 E2).
Qed.
Canonical Structure namespace_mapR :=
- CmraT (namespace_map A) namespace_map_cmra_mixin.
+ CmraT SI (namespace_map A) namespace_map_cmra_mixin.
Global Instance namespace_map_cmra_discrete :
CmraDiscrete A → CmraDiscrete namespace_mapR.
@@ -192,8 +193,8 @@ Proof.
naive_solver eauto using (cmra_discrete_valid m).
Qed.
-Instance namespace_map_empty : Unit (namespace_map A) := NamespaceMap ε ε.
-Lemma namespace_map_ucmra_mixin : UcmraMixin (namespace_map A).
+Instance namespace_map_empty : Unit (namespace_map A) := NamespaceMap ε (ε: coPset_disjUR SI).
+Lemma namespace_map_ucmra_mixin : UcmraMixin SI (namespace_map A).
Proof.
split; simpl.
- rewrite namespace_map_valid_eq /=. split. apply ucmra_unit_valid. set_solver.
@@ -201,7 +202,7 @@ Proof.
- do 2 constructor; [apply (core_id_core _)|done].
Qed.
Canonical Structure namespace_mapUR :=
- UcmraT (namespace_map A) namespace_map_ucmra_mixin.
+ UcmraT SI (namespace_map A) namespace_map_ucmra_mixin.
Global Instance namespace_map_data_core_id N a :
CoreId a → CoreId (namespace_map_data N a).
@@ -260,7 +261,6 @@ Proof.
rewrite namespace_map_validN_eq /= {1}/op /cmra_op /=. case_decide; last done.
rewrite left_id_L {1}left_id. intros [Hmf Hdisj]; split.
- destruct (Hdisj (positives_flatten N)) as [Hmfi|]; last set_solver.
- move: Hmfi. rewrite lookup_op lookup_empty left_id_L=> Hmfi.
intros j. rewrite lookup_op.
destruct (decide (positives_flatten N = j)) as [<-|].
+ rewrite Hmfi lookup_singleton right_id_L. by apply cmra_valid_validN.
@@ -268,7 +268,7 @@ Proof.
- intros j. destruct (decide (positives_flatten N = j)); first set_solver.
rewrite lookup_op lookup_singleton_ne //.
destruct (Hdisj j) as [Hmfi|?]; last set_solver.
- move: Hmfi. rewrite lookup_op lookup_empty; auto.
+ rewrite Hmfi; auto.
Qed.
Lemma namespace_map_updateP P (Q : namespace_map A → Prop) N a :
a ~~>: P →
@@ -295,5 +295,5 @@ Proof.
Qed.
End cmra.
-Arguments namespace_mapR : clear implicits.
-Arguments namespace_mapUR : clear implicits.
+Arguments namespace_mapR {_} _.
+Arguments namespace_mapUR {_} _.
diff --git a/theories/algebra/ofe.v b/theories/algebra/ofe.v
index ffaa9239f7fc9798da6f4b41589b64c06dc2c19a..ca352e551e0a0ed217aaa8b54c6dfea2446c0eed 100644
--- a/theories/algebra/ofe.v
+++ b/theories/algebra/ofe.v
@@ -1,9 +1,9 @@
-From iris.algebra Require Export base.
+From iris.algebra Require Export stepindex base.
Set Default Proof Using "Type".
Set Primitive Projections.
(** This files defines (a shallow embedding of) the category of OFEs:
- Complete ordered families of equivalences. This is a cartesian closed
+ Ordered families of equivalences. This is a cartesian closed
category, and mathematically speaking, the entire development lives
in this category. However, we will generally prefer to work with raw
Coq functions plus some registered Proper instances for non-expansiveness.
@@ -11,49 +11,55 @@ Set Primitive Projections.
cases, we do not even need non-expansiveness.
*)
-(** Unbundled 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").
-Notation "x ≡{ n }@{ A }≡ y" := (dist (A:=A) n x y)
- (at level 70, n at next level, only parsing).
+(** Unbundeled version *)
+Class Dist (SI: indexT) A := dist : SI → relation A.
+
+Instance: Params (@dist) 4 := {}.
+Notation "x ≡{ α }≡ y" := (dist α x y)
+ (at level 70, α at next level, format "x ≡{ α }≡ y").
+Notation "x ≡{ α }@{ A }≡ y" := (dist (A:=A) α x y)
+ (at level 70, α at next level, only parsing).
Hint Extern 0 (_ ≡{_}≡ _) => reflexivity : core.
Hint Extern 0 (_ ≡{_}≡ _) => symmetry; assumption : core.
-Notation NonExpansive f := (∀ n, Proper (dist n ==> dist n) f).
-Notation NonExpansive2 f := (∀ n, Proper (dist n ==> dist n ==> dist n) f).
+Notation NonExpansive f := (∀ α, Proper (dist α ==> dist α) f).
+Notation NonExpansive2 f := (∀ α, Proper (dist α ==> dist α ==> dist α) f).
+
+Lemma ne_apply {SI: indexT} `{Dist SI A} `{Dist SI B} {f: A → B} `{NonExpansive f} (α: SI):
+ Proper (dist (A:=A) α ==> dist (A:=B) α) f.
+Proof. typeclasses eauto. Qed.
Tactic Notation "ofe_subst" ident(x) :=
repeat match goal with
| _ => progress simplify_eq/=
- | 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
+ | H:@dist ?SI ?A ?d ?α x _ |- _ => setoid_subst_aux (@dist SI A d α) x
+ | H:@dist ?SI ?A ?d ?α _ x |- _ => symmetry in H; setoid_subst_aux (@dist SI A d α) x
end.
Tactic Notation "ofe_subst" :=
repeat match goal with
| _ => progress simplify_eq/=
- | 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
+ | H:@dist ?SI ?A ?d ?α ?x _ |- _ => setoid_subst_aux (@dist SI A d α) x
+ | H:@dist ?SI ?A ?d ?α _ ?x |- _ => symmetry in H;setoid_subst_aux (@dist SI A d α) x
end.
-Record OfeMixin A `{Equiv A, Dist 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
+Record OfeMixin (SI: indexT) A `{Equiv A, Dist SI A} := {
+ mixin_equiv_dist x y : x ≡ y ↔ ∀ (α: SI), x ≡{α}≡ y;
+ mixin_dist_equivalence (α : SI): Equivalence (dist α);
+ mixin_dist_mono (α β: SI) x y : x ≡{α}≡ y → β ≺ α → x ≡{β}≡ y
}.
-(** Bundled version *)
-Structure ofeT := OfeT {
+
+(** Bundeled version *)
+Structure ofeT (SI: indexT) := OfeT {
ofe_car :> Type;
ofe_equiv : Equiv ofe_car;
- ofe_dist : Dist ofe_car;
- ofe_mixin : OfeMixin ofe_car
+ ofe_dist : Dist SI ofe_car;
+ ofe_mixin : OfeMixin SI ofe_car
}.
-Arguments OfeT _ {_ _} _.
+Arguments OfeT {_} _ {_ _} _.
Add Printing Constructor ofeT.
-Hint Extern 0 (Equiv _) => eapply (@ofe_equiv _) : typeclass_instances.
-Hint Extern 0 (Dist _) => eapply (@ofe_dist _) : typeclass_instances.
+Hint Extern 0 (Equiv _) => eapply (@ofe_equiv _ _) : typeclass_instances.
+Hint Extern 0 (Dist _ _) => eapply (@ofe_dist _ _) : typeclass_instances.
Arguments ofe_car : simpl never.
Arguments ofe_equiv : simpl never.
Arguments ofe_dist : simpl never.
@@ -80,68 +86,110 @@ The notation [ofe_mixin_of A] that we define on top of [ofe_mixin_of' A id]
hides the [id] and normalizes the mixin to head normal form. The latter is to
ensure that we do not end up with redundant canonical projections to the mixin,
i.e. them all being of the shape [ofe_mixin_of' A id]. *)
-Definition ofe_mixin_of' A {Ac : ofeT} (f : Ac → A) : OfeMixin Ac := ofe_mixin Ac.
-Notation ofe_mixin_of A :=
- ltac:(let H := eval hnf in (ofe_mixin_of' A id) in exact H) (only parsing).
+Definition ofe_mixin_of' SI A {Ac : ofeT SI} (f : Ac → A) : OfeMixin SI Ac := ofe_mixin SI Ac.
+Notation ofe_mixin_of SI A :=
+ ltac:(let H := eval hnf in (ofe_mixin_of' SI A id) in exact H) (only parsing).
+
(** Lifting properties from the mixin *)
Section ofe_mixin.
- Context {A : ofeT}.
+ Context {SI} {A : ofeT SI}.
Implicit Types x y : A.
- Lemma equiv_dist x y : x ≡ y ↔ ∀ n, x ≡{n}≡ y.
- Proof. apply (mixin_equiv_dist _ (ofe_mixin A)). Qed.
- Global Instance dist_equivalence n : Equivalence (@dist A _ n).
- Proof. apply (mixin_dist_equivalence _ (ofe_mixin A)). Qed.
- Lemma dist_S n x y : x ≡{S n}≡ y → x ≡{n}≡ y.
- Proof. apply (mixin_dist_S _ (ofe_mixin A)). Qed.
+ Lemma equiv_dist x y : x ≡ y ↔ ∀ (α: SI), x ≡{α}≡ y.
+ Proof. apply (mixin_equiv_dist _ _ (ofe_mixin SI A)). Qed.
+ Global Instance dist_equivalence α : Equivalence (@dist SI A _ α).
+ Proof. apply (mixin_dist_equivalence _ _ (ofe_mixin SI A)). Qed.
+ Lemma dist_mono (α β: SI) x y : x ≡{α}≡ y → β ≺ α → x ≡{β}≡ y.
+ Proof. apply (mixin_dist_mono _ _ (ofe_mixin SI A)). Qed.
+ Lemma dist_mono' (α β: SI) x y : x ≡{α}≡ y → β ⪯ α → x ≡{β}≡ y.
+ Proof. intros H [-> | Hβ]; [auto | by eapply dist_mono]. Qed.
End ofe_mixin.
+
Hint Extern 1 (_ ≡{_}≡ _) => apply equiv_dist; assumption : core.
(** Discrete OFEs and discrete OFE elements *)
-Class Discrete {A : ofeT} (x : A) := discrete y : x ≡{0}≡ y → x ≡ y.
-Arguments discrete {_} _ {_} _ _.
-Hint Mode Discrete + ! : typeclass_instances.
-Instance: Params (@Discrete) 1 := {}.
+Class Discrete {SI: indexT} {A : ofeT SI} (x : A) := discrete y : x ≡{zero}≡ y → x ≡ y.
+Arguments discrete {_ _} _ {_} _ _.
+Hint Mode Discrete - + ! : typeclass_instances.
+Instance: Params (@Discrete) 2 := {}.
-Class OfeDiscrete (A : ofeT) := ofe_discrete_discrete (x : A) :> Discrete x.
+Class OfeDiscrete {SI: indexT} (A : ofeT SI) := ofe_discrete_discrete (x : A) :> Discrete x.
+Hint Mode OfeDiscrete - ! : typeclass_instances.
(** OFEs with a completion *)
-Record chain (A : ofeT) := {
- chain_car :> nat → A;
- chain_cauchy n i : n ≤ i → chain_car i ≡{n}≡ chain_car n
-}.
-Arguments chain_car {_} _ _.
-Arguments chain_cauchy {_} _ _ _ _.
-
-Program Definition chain_map {A B : ofeT} (f : A → B)
- `{!NonExpansive 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.
-
-Notation Compl A := (chain A%type → A).
-Class Cofe (A : ofeT) := {
- compl : Compl A;
- conv_compl n c : compl c ≡{n}≡ c n;
-}.
+Record chain {SI: indexT} (A : ofeT SI) := mkchain
+ {
+ chain_car :> SI → A;
+ chain_cauchy : ∀ α β, α ⪯ β → chain_car β ≡{α}≡ chain_car α
+ }.
+
+Record bchain {SI: indexT} (A : ofeT SI) (α: SI) := mkbchain
+ {
+ bchain_car :> ∀ β, β ≺ α → A;
+ bchain_cauchy : ∀ β γ, β ⪯ γ → ∀ Hβ Hγ, bchain_car γ Hγ ≡{β}≡ bchain_car β Hβ
+ }.
+
+Program Definition chain_map {SI: indexT} {A B : ofeT SI} (f : A → B) `{NonExpansive f} (c: chain A) : chain B :=
+ {| chain_car α := f (c α) |}.
+Next Obligation. by intros SI A B f Hf c n i ?; apply Hf, chain_cauchy. Qed.
+
+Program Definition bchain_map {SI: indexT} {A B : ofeT SI} (f : A → B) `{NonExpansive f} {α} (c: bchain A α) : bchain B α :=
+ {| bchain_car β Hβ := f (c β Hβ) |}.
+Next Obligation. by intros SI A B f Hf α c β γ ? Hβ Hγ; apply Hf, bchain_cauchy. Qed.
+
+(* simplify rewriting: *)
+Lemma chain_cauchy' {SI: indexT} {A: ofeT SI} (c: chain A) α β: α ⪯ β → c β ≡{α}≡ c α.
+Proof. eapply chain_cauchy. Qed.
+Lemma bchain_cauchy' {SI: indexT} {A: ofeT SI} α (c: bchain A α) β γ Hβ Hγ: β ⪯ γ → c γ Hγ ≡{β}≡ c β Hβ.
+Proof. intros; by eapply bchain_cauchy. Qed.
+
+
+Class Cofe {SI: indexT} (A : ofeT SI) :=
+ {
+ compl : chain A → A;
+ bcompl {α}: zero ≺ α → bchain A α → A;
+ conv_compl α c: compl c ≡{α}≡ c α;
+ conv_bcompl α Hα (c: bchain A α) β Hβ: bcompl Hα c ≡{β}≡ c β Hβ;
+ bcompl_ne {α Hα} (c d: bchain A α) β: (∀ γ (Hγ: γ ≺ α), c γ Hγ ≡{β}≡ d γ Hγ) → bcompl Hα c ≡{β}≡ bcompl Hα d
+ }.
Arguments compl : simpl never.
-Hint Mode Cofe ! : typeclass_instances.
+Arguments bcompl : simpl never.
+Hint Mode Cofe - ! : typeclass_instances.
+
+Lemma chain_conv_compl {SI: indexT} `{Cofe SI A} (c: chain A) α : compl c ≡{α}≡ c α.
+Proof. rewrite conv_compl; eauto using chain_cauchy. Qed.
-Lemma compl_chain_map `{Cofe A, Cofe B} (f : A → B) c `(NonExpansive f) :
+Lemma bchain_conv_bcompl {SI: indexT} `{Cofe SI A} α Hα (c: bchain A α) β Hβ: bcompl Hα c ≡{β}≡ c β Hβ.
+Proof. rewrite conv_bcompl; eauto using bchain_cauchy. Qed.
+
+Lemma compl_chain_map {SI: indexT} `{Cofe SI A, Cofe SI B} (f : A → B) (c: chain A) `(NonExpansive f) :
compl (chain_map f c) ≡ f (compl c).
-Proof. apply equiv_dist=>n. by rewrite !conv_compl. Qed.
+Proof. apply equiv_dist=>α. by rewrite !chain_conv_compl. Qed.
-Program Definition chain_const {A : ofeT} (a : A) : chain A :=
- {| chain_car n := a |}.
-Next Obligation. by intros A a n i _. Qed.
+(* constant chains *)
+Program Definition chain_const {SI: indexT} {A : ofeT SI} (a : A) : chain A := {| chain_car α := a |}.
+Next Obligation. by intros ??????. Qed.
-Lemma compl_chain_const {A : ofeT} `{!Cofe A} (a : A) :
+Lemma compl_chain_const {I: indexT} {A : ofeT I} `{!Cofe A} (a : A) :
compl (chain_const a) ≡ a.
-Proof. apply equiv_dist=>n. by rewrite conv_compl. Qed.
+Proof. apply equiv_dist=>α. by rewrite chain_conv_compl. Qed.
+
+Program Definition bchain_const {SI : indexT} {A : ofeT SI} (a : A) α : bchain A α :=
+ {| bchain_car β _ := a |}.
+Next Obligation.
+ by intros ????????.
+Qed.
+
+Lemma bcompl_bchain_const {I: indexT} {A : ofeT I} `{!Cofe A} (a : A) (α : I) Hα:
+ ∀ γ, γ ≺ α → bcompl Hα (bchain_const a α) ≡{γ}≡ a.
+Proof.
+ intros γ Hγ. by unshelve rewrite bchain_conv_bcompl.
+Qed.
(** General properties *)
Section ofe.
- Context {A : ofeT}.
+ Context {SI: indexT} {A : ofeT SI}.
Implicit Types x y : A.
Global Instance ofe_equivalence : Equivalence ((≡) : relation A).
Proof.
@@ -150,88 +198,106 @@ Section ofe.
- by intros x y; rewrite !equiv_dist.
- by intros x y z; rewrite !equiv_dist; intros; trans y.
Qed.
- Global Instance dist_ne n : Proper (dist n ==> dist n ==> iff) (@dist A _ n).
+ Global Instance dist_ne α : Proper (dist α ==> dist α ==> iff) (@dist SI A _ α).
Proof.
intros x1 x2 ? y1 y2 ?; split; intros.
- by trans x1; [|trans y1].
- by trans x2; [|trans y2].
Qed.
- Global Instance dist_proper n : Proper ((≡) ==> (≡) ==> iff) (@dist A _ n).
+ Global Instance dist_proper α : Proper ((≡) ==> (≡) ==> iff) (@dist SI A _ α).
Proof.
- by move => x1 x2 /equiv_dist Hx y1 y2 /equiv_dist Hy; rewrite (Hx n) (Hy n).
+ by move => x1 x2 /equiv_dist Hx y1 y2 /equiv_dist Hy; rewrite (Hx α) (Hy α).
Qed.
- Global Instance dist_proper_2 n x : Proper ((≡) ==> iff) (dist n x).
+ Global Instance dist_proper_2 α x : Proper ((≡) ==> iff) (dist α x).
Proof. by apply dist_proper. Qed.
- Global Instance Discrete_proper : Proper ((≡) ==> iff) (@Discrete A).
+ Global Instance Discrete_proper : Proper ((≡) ==> iff) (@Discrete SI A).
Proof. intros x y Hxy. rewrite /Discrete. by setoid_rewrite Hxy. Qed.
- Lemma dist_le n n' x y : x ≡{n}≡ y → n' ≤ n → x ≡{n'}≡ y.
- Proof. induction 2; eauto using dist_S. Qed.
- Lemma dist_le' n n' x y : n' ≤ n → x ≡{n}≡ y → x ≡{n'}≡ y.
+ Lemma dist_le α α' x y : x ≡{α}≡ y → α' ⪯ α → x ≡{α'}≡ y.
+ Proof. destruct 2; eauto using dist_mono; congruence. Qed.
+ Lemma dist_le' α α' x y : α' ⪯ α → x ≡{α}≡ y → x ≡{α'}≡ y.
Proof. intros; eauto using dist_le. Qed.
- Instance ne_proper {B : ofeT} (f : A → B) `{!NonExpansive f} :
+ Instance ne_proper {B : ofeT SI} (f : A → B) `{!NonExpansive 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 : ofeT} (f : A → B → C) `{!NonExpansive2 f} :
+ Instance ne_proper_2 {B C : ofeT SI} (f : A → B → C) `{!NonExpansive2 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 conv_compl' `{Cofe A} n (c : chain A) : compl c ≡{n}≡ c (S n).
+ Lemma conv_compl' `{Cofe SI A} (α β: SI) (c: chain A) : α ⪯ β → compl c ≡{α}≡ c β.
Proof.
- transitivity (c n); first by apply conv_compl. symmetry.
- apply chain_cauchy. lia.
+ transitivity (c α); first by apply chain_conv_compl. symmetry. by rewrite chain_cauchy.
Qed.
- Lemma discrete_iff n (x : A) `{!Discrete x} y : x ≡ y ↔ x ≡{n}≡ y.
+ Lemma discrete_iff α (x : A) `{!Discrete x} y : x ≡ y ↔ x ≡{α}≡ y.
Proof.
- split; intros; auto. apply (discrete _), dist_le with n; auto with lia.
+ split; intros; auto. apply (discrete _), dist_le with α; auto.
Qed.
- Lemma discrete_iff_0 n (x : A) `{!Discrete x} y : x ≡{0}≡ y ↔ x ≡{n}≡ y.
+ Lemma discrete_iff_0 α (x : A) `{!Discrete x} y : x ≡{zero}≡ y ↔ x ≡{α}≡ y.
Proof. by rewrite -!discrete_iff. Qed.
End ofe.
(** Contractive functions *)
-Definition dist_later `{Dist A} (n : nat) (x y : A) : Prop :=
- match n with 0 => True | S n => x ≡{n}≡ y end.
-Arguments dist_later _ _ !_ _ _ /.
+Definition dist_later {SI: indexT} `{Dist SI A} (α : SI) (x y : A) : Prop :=
+ ∀ β, β ≺ α → x ≡{β}≡ y.
-Global Instance dist_later_equivalence (A : ofeT) n : Equivalence (@dist_later A _ n).
-Proof. destruct n as [|n]. by split. apply dist_equivalence. Qed.
+Arguments dist_later _ _ _ !_ _ _ /.
-Lemma dist_dist_later {A : ofeT} n (x y : A) : dist n x y → dist_later n x y.
-Proof. intros Heq. destruct n; first done. exact: dist_S. Qed.
+Global Instance dist_later_equivalence {SI} (A : ofeT SI) α : Equivalence (@dist_later SI A _ α).
+Proof.
+ split.
+ - now intros ???.
+ - unfold dist_later; intros ?? H ??; now rewrite H.
+ - unfold dist_later; intros ??? H1 H2 ??; now rewrite H1 ?H2.
+Qed.
-Lemma dist_later_dist {A : ofeT} n (x y : A) : dist_later (S n) x y → dist n x y.
-Proof. done. Qed.
+Lemma dist_dist_later {SI: indexT} {A : ofeT SI} α (x y : A) : dist α x y → dist_later α x y.
+Proof. intros Heq ??; eapply dist_mono; eauto. Qed.
+
+Lemma dist_later_dist {SI: indexT} {A : ofeT SI} α β (x y : A) : β ≺ α → dist_later α x y → dist β x y.
+Proof. intros ? H; by apply H. Qed.
-(* We don't actually need this lemma (as our tactics deal with this through
- other means), but technically speaking, this is the reason why
- pre-composing a non-expansive function to a contractive function
- preserves contractivity. *)
-Lemma ne_dist_later {A B : ofeT} (f : A → B) :
- NonExpansive f → ∀ n, Proper (dist_later n ==> dist_later n) f.
-Proof. intros Hf [|n]; last exact: Hf. hnf. by intros. Qed.
+Lemma dist_later_zero {SI: indexT} {A : ofeT SI} (x y : A): dist_later zero x y.
+Proof. intros ? [] % index_lt_zero_is_normal. Qed.
-Notation Contractive f := (∀ n, Proper (dist_later n ==> dist n) f).
+Global Instance ne_dist_later {SI: indexT} {A B : ofeT SI} (f : A → B) :
+ NonExpansive f → ∀ (α: SI), Proper (dist_later α ==> dist_later α) f.
+Proof. intros Hf ??????; by eapply Hf, H. Qed.
-Instance const_contractive {A B : ofeT} (x : A) : Contractive (@const A B x).
-Proof. by intros n y1 y2. Qed.
+Global Instance ne2_dist_later_l {SI} {A B C: ofeT SI} (f : A → B → C) :
+ NonExpansive2 f → ∀ α, Proper (dist_later α ==> dist α ==> dist_later α) f.
+Proof. intros H α a b H1 c d H2 β Hβ. apply H; by eauto using dist_mono. Qed.
+Global Instance ne2_dist_later_r {SI} {A B C: ofeT SI} (f : A → B → C) :
+ NonExpansive2 f → ∀ α, Proper (dist α ==> dist_later α ==> dist_later α) f.
+Proof. intros H α a b H1 c d H2 β Hβ. apply H; by eauto using dist_mono. Qed.
+
+
+Notation Contractive f := (∀ α, Proper (dist_later α ==> dist α) f).
+
+Instance const_contractive {I: indexT} {A B : ofeT I} (x : A) : Contractive (@const A B x).
+Proof. by intros α y1 y2. Qed.
Section contractive.
Local Set Default Proof Using "Type*".
- Context {A B : ofeT} (f : A → B) `{!Contractive f}.
+ Context {SI: indexT} {A B : ofeT SI} (f : A → B) `{!Contractive f}.
Implicit Types x y : A.
- Lemma contractive_0 x y : f x ≡{0}≡ f y.
+ Lemma contractive_0 x y : f x ≡{zero}≡ f y.
+ Proof. by apply (_ : Contractive f), dist_later_zero. Qed.
+ Lemma contractive_mono α x y : dist_later α x y → f x ≡{α}≡ f y.
Proof. by apply (_ : Contractive f). Qed.
- Lemma contractive_S n x y : x ≡{n}≡ y → f x ≡{S n}≡ f y.
- Proof. intros. by apply (_ : Contractive f). Qed.
Global Instance contractive_ne : NonExpansive f | 100.
- Proof. by intros n x y ?; apply dist_S, contractive_S. Qed.
+ Proof.
+ intros n x y ?; eapply dist_mono with (α := succ n).
+ 2: eapply index_succ_greater.
+ eapply contractive_mono.
+ intros ??. eapply dist_le; eauto.
+ Qed.
+
Global Instance contractive_proper : Proper ((≡) ==> (≡)) f | 100.
Proof. apply (ne_proper _). Qed.
End contractive.
@@ -241,128 +307,267 @@ Ltac f_contractive :=
| |- ?f _ ≡{_}≡ ?f _ => simple apply (_ : Proper (dist_later _ ==> _) f)
| |- ?f _ _ ≡{_}≡ ?f _ _ => simple apply (_ : Proper (dist_later _ ==> _ ==> _) f)
| |- ?f _ _ ≡{_}≡ ?f _ _ => simple apply (_ : Proper (_ ==> dist_later _ ==> _) f)
- end;
- try match goal with
- | |- @dist_later ?A _ ?n ?x ?y =>
- destruct n as [|n]; [exact I|change (@dist A _ n x y)]
+ | |- dist_later _ (?f _) (?f _) => simple apply (_ : Proper (dist_later _ ==> dist_later _) f)
+ | |- dist_later _ (?f _ _) (?f _ _) => simple apply (_ : Proper (dist_later _ ==> _ ==> dist_later _) f)
+ | |- dist_later _ (?f _ _) (?f _ _) => simple apply (_ : Proper (_ ==> dist_later _ ==> dist_later _) f)
end;
try simple apply reflexivity.
+(* FIXME: the last clause is a hacky addition since the approach for dealing this from finite Iris (destructing the index) cannot be directly translated.
+ we might want to look for a smarter solution. *)
Ltac solve_contractive :=
- solve_proper_core ltac:(fun _ => first [f_contractive | f_equiv]).
+ solve_proper_core ltac:(fun _ => first [f_contractive | f_equiv |
+ try match goal with
+ | H : @dist_later _ ?A _ _ ?x ?y |- ?x ≡{_}≡ ?y =>
+ by (apply H; eauto 3 with index)
+ end]).
+
+(* without smoothness, we only get uniqueness at ≺ α *)
+Lemma cofe_bcompl_weakly_unique {SI : indexT} (A : ofeT SI) (HA : Cofe A) (α: SI) Hα (c d : bchain A α):
+ (∀ γ (Hγ : γ ≺ α), c γ Hγ ≡{γ}≡ d γ Hγ) → dist_later α (bcompl Hα c) (bcompl Hα d).
+Proof.
+ intros H γ Hγ. unshelve rewrite !conv_bcompl; [assumption | assumption | apply H].
+Qed.
(** Limit preserving predicates *)
-Class LimitPreserving `{!Cofe A} (P : A → Prop) : Prop :=
- limit_preserving (c : chain A) : (∀ n, P (c n)) → P (compl c).
-Hint Mode LimitPreserving + + ! : typeclass_instances.
+Class LimitPreserving {SI: indexT} `{Cofe SI A} (P : A → Prop) : Prop :=
+ limit_preserving (c: chain A) : (∀ α, P (c α)) → P (compl c).
+Hint Mode LimitPreserving - + + ! : typeclass_instances.
Section limit_preserving.
- Context `{Cofe A}.
+ Context {SI: indexT} `{Cofe SI A}.
(* These are not instances as they will never fire automatically...
but they can still be helpful in proving things to be limit preserving. *)
Lemma limit_preserving_ext (P Q : A → Prop) :
(∀ x, P x ↔ Q x) → LimitPreserving P → LimitPreserving Q.
- Proof. intros HP Hlimit c ?. apply HP, Hlimit=> n; by apply HP. Qed.
+ Proof. intros HP Hlimit c ?. apply HP, Hlimit; eauto=> n. by apply HP. Qed.
Global Instance limit_preserving_const (P : Prop) : LimitPreserving (λ _ : A, P).
- Proof. intros c HP. apply (HP 0). Qed.
+ Proof. intros c HP. apply (HP zero). Qed.
Lemma limit_preserving_discrete (P : A → Prop) :
- Proper (dist 0 ==> impl) P → LimitPreserving P.
- Proof. intros PH c Hc. by rewrite (conv_compl 0). Qed.
+ Proper (dist zero ==> impl) P → LimitPreserving P.
+ Proof. intros PH c HP. by rewrite (conv_compl zero c). Qed.
Lemma limit_preserving_and (P1 P2 : A → Prop) :
LimitPreserving P1 → LimitPreserving P2 →
LimitPreserving (λ x, P1 x ∧ P2 x).
- Proof. intros Hlim1 Hlim2 c Hc. split. apply Hlim1, Hc. apply Hlim2, Hc. Qed.
+ Proof. intros Hlim1 Hlim2 c HC. split. apply Hlim1; apply HC. apply Hlim2; apply HC. Qed.
Lemma limit_preserving_impl (P1 P2 : A → Prop) :
- Proper (dist 0 ==> impl) P1 → LimitPreserving P2 →
+ Proper (dist zero ==> impl) P1 → LimitPreserving P2 →
LimitPreserving (λ x, P1 x → P2 x).
Proof.
- intros Hlim1 Hlim2 c Hc HP1. apply Hlim2=> n; apply Hc.
- eapply Hlim1, HP1. apply dist_le with n; last lia. apply (conv_compl n).
+ intros Hlim1 Hlim2 c HP HP1. apply Hlim2; eauto; intros n; apply HP.
+ eapply Hlim1, HP1. apply dist_le with n; last eapply index_zero_minimum.
+ apply (conv_compl n c); eauto.
Qed.
Lemma limit_preserving_forall {B} (P : B → A → Prop) :
(∀ y, LimitPreserving (P y)) →
LimitPreserving (λ x, ∀ y, P y x).
- Proof. intros Hlim c Hc y. by apply Hlim. Qed.
+ Proof. intros Hlim c HC y. by apply Hlim. Qed.
End limit_preserving.
-(** Fixpoint *)
-Program Definition fixpoint_chain {A : ofeT} `{Inhabited A} (f : A → A)
- `{!Contractive f} : chain A := {| chain_car i := Nat.iter (S i) f inhabitant |}.
-Next Obligation.
- intros A ? f ? n.
- induction n as [|n IH]=> -[|i] //= ?; try lia.
- - apply (contractive_0 f).
- - apply (contractive_S f), IH; auto with lia.
-Qed.
-Program Definition fixpoint_def `{Cofe A, Inhabited A} (f : A → A)
- `{!Contractive f} : A := compl (fixpoint_chain f).
-Definition fixpoint_aux : seal (@fixpoint_def). by eexists. Qed.
-Definition fixpoint {A AC AiH} f {Hf} := fixpoint_aux.(unseal) A AC AiH f Hf.
-Definition fixpoint_eq : @fixpoint = @fixpoint_def := fixpoint_aux.(seal_eq).
+(** Bounded limit preserving predicates *)
+Class BoundedLimitPreserving {SI: indexT} `{Cofe SI A} (P : A → Prop) : Prop :=
+ bounded_limit_preserving α Hα (c: bchain A α) : (∀ β Hβ, P (c β Hβ)) → P (bcompl Hα c).
+Hint Mode BoundedLimitPreserving - + + ! : typeclass_instances.
+
+Section bounded_limit_preserving.
+ Context {SI: indexT} `{Cofe SI A}.
+ (* These are not instances as they will never fire automatically...
+ but they can still be helpful in proving things to be limit preserving. *)
+
+ Lemma bounded_limit_preserving_ext (P Q : A → Prop) :
+ (∀ x, P x ↔ Q x) → BoundedLimitPreserving P → BoundedLimitPreserving Q.
+ Proof. intros HP Hlimit α Hα c HC. apply HP, Hlimit; eauto=> β Hβ. by apply HP. Qed.
+
+ Global Instance bounded_limit_preserving_const (P : Prop) : P → BoundedLimitPreserving (λ _: A, P).
+ Proof. intros c HP ?; eauto. Qed.
+
+
+ Lemma bounded_limit_preserving_and (P1 P2 : A → Prop) :
+ BoundedLimitPreserving P1 → BoundedLimitPreserving P2 →
+ BoundedLimitPreserving (λ x, P1 x ∧ P2 x).
+ Proof. intros Hlim1 Hlim2 α c Hα HC. split. apply Hlim1; apply HC. apply Hlim2; apply HC. Qed.
+
+ Lemma bounded_limit_preserving_forall {B} (P : B → A → Prop) :
+ (∀ y, BoundedLimitPreserving (P y)) →
+ BoundedLimitPreserving (λ x, ∀ y, P y x).
+ Proof. intros Hlim c ? ? ? y. by apply Hlim. Qed.
+End bounded_limit_preserving.
+
+
+(** Fixpoint *)
Section fixpoint.
- Context `{Cofe A, Inhabited A} (f : A → A) `{!Contractive f}.
- Lemma fixpoint_unfold : fixpoint f ≡ f (fixpoint f).
+ Context {SI: indexT} `{Cofe SI A} (f: A → A) `{C: Contractive f} `{In: Inhabited A}.
+
+ Record is_bounded_fixpoint_chain α (ch : ∀ β, β ≺ α -> A) := mk_is_bounded_fixpoint_chain
+ {
+ ch_cauchy : ∀ β γ, β ⪯ γ -> ∀ (Hβ : β ≺ α) (Hγ : γ ≺ α), ch γ Hγ ≡{β}≡ ch β Hβ;
+ is_fp : forall Hα, dist_later α (f (bcompl Hα (mkbchain SI A α ch ch_cauchy))) (bcompl Hα (mkbchain SI A α ch ch_cauchy));
+ }.
+
+ Definition bounded_fixpoint_chain α := {ch : ∀ β, β ≺ α -> A & is_bounded_fixpoint_chain α ch}.
+ Program Definition mk_bounded_fixpoint_chain α (ch : bchain A α) (fp : ∀ Hα, dist_later α (f (bcompl Hα ch)) (bcompl Hα ch)) :=
+ existT (bchain_car A α ch) (mk_is_bounded_fixpoint_chain α (bchain_car A α ch) _ _).
+ Next Obligation. intros α ch _. apply ch. Defined.
+ Next Obligation. intros α ch fp Hα. cbn. apply fp. Defined.
+
+ Definition get_chain α (bfc : bounded_fixpoint_chain α) := mkbchain SI A α (projT1 bfc) (@ch_cauchy α (projT1 bfc) (projT2 bfc)).
+ Coercion get_chain : bounded_fixpoint_chain >-> bchain.
+
+ Program Definition cast {α} (c: bounded_fixpoint_chain α) β (Hβ: β ⪯ α): bounded_fixpoint_chain β :=
+ mk_bounded_fixpoint_chain β (mkbchain SI A β (λ γ Hγ, projT1 c γ _) _) _.
+ Next Obligation. intros ??????; eauto using index_lt_le_trans. Qed.
+ Next Obligation.
+ intros α c β Hβ γ1 γ2 Hγ Hγ1 Hγ2; simpl.
+ specialize (bchain_cauchy' α c); eauto.
+ Qed.
+ Next Obligation.
+ intros α c β Hβ Hα γ Hγ; simpl. unshelve rewrite !bchain_conv_bcompl; simpl; eauto.
+ specialize (@bchain_conv_bcompl SI A _ α ltac:(eauto using index_lt_le_trans) c) as Hx. cbn in Hx. rewrite -Hx.
+ eapply is_fp. eauto using index_lt_le_trans.
+ Qed.
+
+ Lemma cast_chain α (Hα: zero ≺ α) β (Hβ: zero ≺ β) (Hβα: β ⪯ α) (c: bounded_fixpoint_chain α):
+ dist_later β (bcompl Hβ (cast c β Hβα)) (bcompl Hα c).
+ Proof.
+ intros γ Hγ. unshelve rewrite !bchain_conv_bcompl; eauto using index_lt_le_trans.
+ simpl. specialize (bchain_cauchy' α c); eauto.
+ Qed.
+
+ Lemma fp_chain_is_fp α (ch : bounded_fixpoint_chain α) (Hα : zero ≺ α): dist_later α (f (bcompl Hα ch)) (bcompl Hα ch).
Proof.
- apply equiv_dist=>n.
- rewrite fixpoint_eq /fixpoint_def (conv_compl n (fixpoint_chain f)) //.
- induction n as [|n IH]; simpl; eauto using contractive_0, contractive_S.
+ destruct ch as (ch & (cauchy & fp)). apply fp.
Qed.
+ Lemma bounded_fixpoint_chain_unique α (Hα: zero ≺ α) (c: bounded_fixpoint_chain α) β (Hβ: zero ≺ β) (Hβα: β ⪯ α) (d: bounded_fixpoint_chain β) :
+ dist_later β (bcompl Hα c) (bcompl Hβ d).
+ Proof using A C H SI f.
+ revert Hβα d. induction (index_lt_wf SI β) as [β _ IH]. intros Hβα d γ Hγ.
+ rewrite -(fp_chain_is_fp _ d Hβ γ Hγ). rewrite -(fp_chain_is_fp _ c Hα γ _); eauto using index_lt_le_trans.
+ destruct (index_is_zero γ) as [->|NT].
+ - by apply contractive_0.
+ - eapply contractive_mono; eauto.
+ assert (γ ⪯ β) as Hγβ by eauto.
+ pose (e := cast d γ Hγβ).
+ transitivity (bcompl NT e).
+ + eapply IH; eauto using index_lt_le_trans.
+ + apply cast_chain.
+ Qed.
+
+
+ Section inductive_step.
+
+
+ Local Definition patch_base_case {α: SI} (g: zero ≺ α → A) : A :=
+ match index_is_zero α with
+ | left H => inhabitant
+ | right NT => g NT
+ end.
+
+ Program Definition bfpc : ∀ (α: SI), bounded_fixpoint_chain α :=
+ index_cumulative_rec (fun _ => A) is_bounded_fixpoint_chain
+ (fun α IH => f (patch_base_case (fun NT => bcompl NT (get_chain α IH)))) _.
+ Next Obligation.
+ intros α G. cbn in *. unshelve econstructor; first last.
+ - intros Hα β Hβ; simpl. unshelve rewrite bchain_conv_bcompl; simpl; eauto.
+ unfold patch_base_case. destruct index_is_zero; subst.
+ + by eapply contractive_0.
+ + apply contractive_mono; eauto. by eapply is_fp.
+ - intros β γ Hle Hβ Hγ. unfold patch_base_case.
+ repeat destruct index_is_zero; eauto; subst.
+ + destruct Hle; subst; by exfalso; eapply index_lt_zero_is_normal.
+ + by eapply contractive_0.
+ + apply contractive_mono; eauto. apply bounded_fixpoint_chain_unique, Hle.
+ Qed.
+ End inductive_step.
+
+ Program Definition fixpoint_chain: chain A := mkchain _ _ (λ α, f (patch_base_case (λ Hα, bcompl Hα (get_chain α (bfpc α))))) _.
+ Next Obligation.
+ intros β α Hαβ; simpl. unfold patch_base_case. repeat destruct index_is_zero; eauto; subst.
+ - destruct Hαβ; subst; by exfalso; eapply index_lt_zero_is_normal.
+ - subst. by eapply contractive_0.
+ - apply contractive_mono; eauto. apply bounded_fixpoint_chain_unique; eauto using is_fp.
+ Qed.
+
+ Program Definition fixpoint_def : A := compl fixpoint_chain.
+ Definition fixpoint_aux : seal (@fixpoint_def). by eexists. Qed.
+ Definition fixpoint := fixpoint_aux.(unseal).
+ Definition fixpoint_eq : @fixpoint = @fixpoint_def := fixpoint_aux.(seal_eq).
+
+ Lemma fixpoint_unfold :
+ fixpoint ≡ f (fixpoint).
+ Proof.
+ apply equiv_dist=>α.
+ rewrite fixpoint_eq /fixpoint_def; cbn.
+ erewrite !conv_compl. unfold fixpoint_chain; simpl.
+ unfold patch_base_case; destruct index_is_zero; subst.
+ - by apply contractive_0.
+ - eapply contractive_mono; eauto. symmetry. eapply is_fp.
+ Qed.
+
+End fixpoint.
+
+Section fixpoint.
+ Context {SI: indexT} `{Cofe SI A} (f : A → A) `{!Contractive f} `{Inhabited A}.
+
Lemma fixpoint_unique (x : A) : x ≡ f x → x ≡ fixpoint f.
Proof.
- rewrite !equiv_dist=> Hx n. induction n as [|n IH]; simpl in *.
- - rewrite Hx fixpoint_unfold; eauto using contractive_0.
- - rewrite Hx fixpoint_unfold. apply (contractive_S _), IH.
+ rewrite !equiv_dist=> Hx α. induction (index_lt_wf SI α) as [α _ IH].
+ rewrite Hx fixpoint_unfold. eapply contractive_mono; eauto.
Qed.
- Lemma fixpoint_ne (g : A → A) `{!Contractive g} n :
- (∀ z, f z ≡{n}≡ g z) → fixpoint f ≡{n}≡ fixpoint g.
+ Lemma fixpoint_ne (g : A → A) `{!Contractive g} α :
+ (∀ z, f z ≡{α}≡ g z) → fixpoint f ≡{α}≡ fixpoint g.
Proof.
- intros Hfg. rewrite fixpoint_eq /fixpoint_def
- (conv_compl n (fixpoint_chain f)) (conv_compl n (fixpoint_chain g)) /=.
- induction n as [|n IH]; simpl in *; [by rewrite !Hfg|].
- rewrite Hfg; apply contractive_S, IH; auto using dist_S.
+ intros Hfg. induction (index_lt_wf SI α) as [α _ IH].
+ do 2 (rewrite fixpoint_unfold; symmetry). etransitivity. eapply Hfg.
+ eapply contractive_mono; eauto.
+ intros ??; eapply IH; eauto.
+ intros; eapply dist_le', Hfg; eauto.
Qed.
- Lemma fixpoint_proper (g : A → A) `{!Contractive g} :
+
+ 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.
Lemma fixpoint_ind (P : A → Prop) :
Proper ((≡) ==> impl) P →
- (∃ x, P x) → (∀ x, P x → P (f x)) →
+ (∃ x, P x) →
+ (∀ x, P x → P (f x)) →
LimitPreserving P →
+ BoundedLimitPreserving P →
P (fixpoint f).
Proof.
- intros ? [x Hx] Hincr Hlim. set (chcar i := Nat.iter (S i) f x).
- assert (Hcauch : ∀ n i : nat, n ≤ i → chcar i ≡{n}≡ chcar n).
- { intros n. rewrite /chcar. induction n as [|n IH]=> -[|i] //=;
- eauto using contractive_0, contractive_S with lia. }
- set (fp2 := compl {| chain_cauchy := Hcauch |}).
- assert (f fp2 ≡ fp2).
- { apply equiv_dist=>n. rewrite /fp2 (conv_compl n) /= /chcar.
- induction n as [|n IH]; simpl; eauto using contractive_0, contractive_S. }
- rewrite -(fixpoint_unique fp2) //.
- apply Hlim=> n /=. by apply Nat_iter_ind.
+ intros Pr [x Hx] Hincr Hlim Hblim.
+ eapply Pr.
+ { eapply fixpoint_unique, (@fixpoint_unfold SI A _ f _ {| inhabitant := x |}). }
+ rewrite fixpoint_eq /fixpoint_def.
+ eapply Hlim. intros β; simpl.
+ apply Hincr.
+ rewrite /bfpc. apply index_cumulative_rec_unfold.
+ intros γ succs H1.
+ unfold patch_base_case at 1. destruct index_is_zero; subst.
+ - apply Hx.
+ - eapply Hblim. intros. rewrite index_cumulative_rec_dep_step; cbn. apply Hincr, H1.
Qed.
End fixpoint.
(** Fixpoint of f when f^k is contractive. **)
-Definition fixpointK `{Cofe A, Inhabited A} k (f : A → A)
+Definition fixpointK `{Cofe SI A, Inhabited A} k (f : A → A)
`{!Contractive (Nat.iter k f)} := fixpoint (Nat.iter k f).
Section fixpointK.
Local Set Default Proof Using "Type*".
- Context `{Cofe A, Inhabited A} (f : A → A) (k : nat).
+ Context `{Cofe SI A, Inhabited A} (f : A → A) (k : nat).
Context {f_contractive : Contractive (Nat.iter k f)} {f_ne : NonExpansive f}.
(* Note than f_ne is crucial here: there are functions f such that f^2 is contractive,
but f is not non-expansive.
@@ -421,6 +626,7 @@ Section fixpointK.
Proper ((≡) ==> impl) P →
(∃ x, P x) → (∀ x, P x → P (f x)) →
LimitPreserving P →
+ BoundedLimitPreserving P →
P (fixpointK k f).
Proof.
intros. rewrite /fixpointK. apply fixpoint_ind; eauto.
@@ -432,7 +638,7 @@ End fixpointK.
Section fixpointAB.
Local Unset Default Proof Using.
- Context `{Cofe A, Cofe B, !Inhabited A, !Inhabited B}.
+ Context {SI} `{Cofe SI A, Cofe SI B, !Inhabited A, !Inhabited B}.
Context (fA : A → B → A).
Context (fB : A → B → B).
Context `{∀ n, Proper (dist_later n ==> dist n ==> dist n) fA}.
@@ -442,7 +648,7 @@ Section fixpointAB.
Local Instance fixpoint_AB_contractive : Contractive fixpoint_AB.
Proof.
intros n x x' Hx; rewrite /fixpoint_AB.
- apply fixpoint_ne=> y. by f_contractive.
+ apply fixpoint_ne=> y. solve_contractive.
Qed.
Local Definition fixpoint_AA (x : A) : A := fA x (fixpoint_AB x).
@@ -459,11 +665,11 @@ Section fixpointAB.
Instance: Proper ((≡) ==> (≡) ==> (≡)) fA.
Proof.
- apply ne_proper_2=> n x x' ? y y' ?. f_contractive; auto using dist_S.
+ apply ne_proper_2=> n x x' ? y y' ?. f_contractive; eauto using dist_dist_later.
Qed.
Instance: Proper ((≡) ==> (≡) ==> (≡)) fB.
Proof.
- apply ne_proper_2=> n x x' ? y y' ?. f_contractive; auto using dist_S.
+ apply ne_proper_2=> n x x' ? y y' ?. f_contractive; auto using dist_dist_later.
Qed.
Lemma fixpoint_A_unique p q : fA p q ≡ p → fB p q ≡ q → p ≡ fixpoint_A.
@@ -476,7 +682,7 @@ Section fixpointAB.
End fixpointAB.
Section fixpointAB_ne.
- Context `{Cofe A, Cofe B, !Inhabited A, !Inhabited B}.
+ Context {SI} `{Cofe SI A, Cofe SI B, !Inhabited A, !Inhabited B}.
Context (fA fA' : A → B → A).
Context (fB fB' : A → B → B).
Context `{∀ n, Proper (dist_later n ==> dist n ==> dist n) fA}.
@@ -496,7 +702,7 @@ Section fixpointAB_ne.
fixpoint_B fA fB ≡{n}≡ fixpoint_B fA' fB'.
Proof.
intros HfA HfB. apply fixpoint_ne=> z. rewrite HfB. f_contractive.
- apply fixpoint_A_ne; auto using dist_S.
+ eapply dist_dist_later, fixpoint_A_ne; auto.
Qed.
Lemma fixpoint_A_proper :
@@ -509,94 +715,131 @@ Section fixpointAB_ne.
Proof. setoid_rewrite equiv_dist; naive_solver eauto using fixpoint_B_ne. Qed.
End fixpointAB_ne.
+
(** Non-expansive function space *)
-Record ofe_mor (A B : ofeT) : Type := OfeMor {
+Record ofe_mor {I: indexT} (A B : ofeT I) : Type := OfeMor {
ofe_mor_car :> A → B;
- ofe_mor_ne : NonExpansive ofe_mor_car
+ ofe_mor_ne : NonExpansive ofe_mor_car
}.
-Arguments OfeMor {_ _} _ {_}.
+Arguments OfeMor {_ _ _} _ {_}.
Add Printing Constructor ofe_mor.
Existing Instance ofe_mor_ne.
Notation "'λne' x .. y , t" :=
- (@OfeMor _ _ (λ x, .. (@OfeMor _ _ (λ y, t) _) ..) _)
+ (@OfeMor _ _ _ (λ x, .. (@OfeMor _ _ _ (λ y, t) _) ..) _)
(at level 200, x binder, y binder, right associativity).
Section ofe_mor.
- Context {A B : ofeT}.
+ Context {SI: indexT} {A B : ofeT SI}.
Global Instance ofe_mor_proper (f : ofe_mor A B) : Proper ((≡) ==> (≡)) f.
Proof. apply ne_proper, ofe_mor_ne. Qed.
Instance ofe_mor_equiv : Equiv (ofe_mor A B) := λ f g, ∀ x, f x ≡ g x.
- Instance ofe_mor_dist : Dist (ofe_mor A B) := λ n f g, ∀ x, f x ≡{n}≡ g x.
- Definition ofe_mor_ofe_mixin : OfeMixin (ofe_mor A B).
+ Instance ofe_mor_dist : Dist SI (ofe_mor A B) := λ α f g, ∀ x, f x ≡{α}≡ g x.
+ Definition ofe_mor_ofe_mixin : OfeMixin SI (ofe_mor A B).
Proof.
split.
- - intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
- intros Hfg k; apply equiv_dist=> n; apply Hfg.
- - intros n; split.
+ - intros f g; split; [intros Hfg α l; apply equiv_dist, Hfg|].
+ intros Hfg l; apply equiv_dist=> α; apply Hfg.
+ - intros α; split.
+ by intros f x.
+ by intros f g ? x.
+ by intros f g h ?? x; trans (g x).
- - by intros n f g ? x; apply dist_S.
+ - intros α β f g ? x ?; by eapply dist_mono.
Qed.
Canonical Structure ofe_morO := OfeT (ofe_mor A B) ofe_mor_ofe_mixin.
Program Definition ofe_mor_chain (c : chain ofe_morO)
(x : A) : chain B := {| chain_car n := c n x |}.
- Next Obligation. intros c x n i ?. by apply (chain_cauchy c). Qed.
- Program Definition ofe_mor_compl `{Cofe B} : Compl ofe_morO := λ c,
+ Next Obligation. intros c x n i ?. by apply (chain_cauchy' c). Qed.
+ Program Definition ofe_mor_compl `{Cofe SI B} : chain ofe_morO → ofe_morO := λ c,
{| ofe_mor_car x := compl (ofe_mor_chain c x) |}.
Next Obligation.
intros ? c n x y Hx. by rewrite (conv_compl n (ofe_mor_chain c x))
(conv_compl n (ofe_mor_chain c y)) /= Hx.
Qed.
- Global Program Instance ofe_mor_cofe `{Cofe B} : Cofe ofe_morO :=
- {| compl := ofe_mor_compl |}.
+
+ Program Definition ofe_mor_bchain {α} (c : bchain ofe_morO α) (x : A) : bchain B α :=
+ {| bchain_car n Hn := c n Hn x |}.
+ Next Obligation. intros α c x n Hn i ??. by apply (bchain_cauchy' α c). Qed.
+ Program Definition ofe_mor_bcompl `{Cofe SI B} α : zero ≺ α → bchain ofe_morO α → ofe_morO := λ Hα c,
+ {| ofe_mor_car x := bcompl Hα (ofe_mor_bchain c x) |}.
+ Next Obligation.
+ intros ? α Hα c n x y Hx. eapply bcompl_ne.
+ by intros; unfold ofe_mor_bchain; simpl; rewrite Hx.
+ Qed.
+
+
+ Global Program Instance ofe_mor_cofe `{Cofe SI B} : Cofe ofe_morO :=
+ {| compl := ofe_mor_compl; bcompl := ofe_mor_bcompl |}.
+ Next Obligation.
+ intros ? α c x; cbn. rewrite conv_compl //=.
+ Qed.
+ Next Obligation.
+ intros ? α c β Hβ H x; cbn. rewrite (conv_bcompl α) //=.
+ Qed.
Next Obligation.
- intros ? n c x; simpl.
- by rewrite (conv_compl n (ofe_mor_chain c x)) /=.
+ move=> ? α Hα c d β Heq x //=. eapply bcompl_ne.
+ intros γ Hγ; eapply Heq.
Qed.
Global Instance ofe_mor_car_ne :
- NonExpansive2 (@ofe_mor_car A B).
+ NonExpansive2 (@ofe_mor_car SI A B).
Proof. intros n f g Hfg x y Hx; rewrite Hx; apply Hfg. Qed.
Global Instance ofe_mor_car_proper :
- Proper ((≡) ==> (≡) ==> (≡)) (@ofe_mor_car A B) := ne_proper_2 _.
+ Proper ((≡) ==> (≡) ==> (≡)) (@ofe_mor_car SI A B) := ne_proper_2 _.
Lemma ofe_mor_ext (f g : ofe_mor A B) : f ≡ g ↔ ∀ x, f x ≡ g x.
Proof. done. Qed.
+
+ Lemma ofe_mor_f_equal (f : ofe_mor A B) x y : x ≡ y → f x ≡ f y.
+ Proof. intros H. by rewrite H. Qed.
+ Lemma ofe_mor_f_equal_dist (f : ofe_mor A B) x y α : x ≡{α}≡ y → f x ≡{α}≡ f y.
+ Proof. intros H. by rewrite H. Qed.
End ofe_mor.
+
Arguments ofe_morO : clear implicits.
Notation "A -n> B" :=
- (ofe_morO A B) (at level 99, B at level 200, right associativity).
-Instance ofe_mor_inhabited {A B : ofeT} `{Inhabited B} :
+ (ofe_morO _ A B) (at level 99, B at level 200, right associativity).
+Instance ofe_mor_inhabited {SI: indexT} {A B : ofeT SI} `{Inhabited B} :
Inhabited (A -n> B) := populate (λne _, inhabitant).
+
(** Identity and composition and constant function *)
-Definition cid {A} : A -n> A := OfeMor id.
-Instance: Params (@cid) 1 := {}.
-Definition cconst {A B : ofeT} (x : B) : A -n> B := OfeMor (const x).
-Instance: Params (@cconst) 2 := {}.
+Definition cid {SI} {A: ofeT SI} : A -n> A := OfeMor id.
+Instance: Params (@cid) 2 := {}.
+Definition cconst {SI} {A B : ofeT SI} (x : B) : A -n> B := OfeMor (const x).
+Instance: Params (@cconst) 3 := {}.
-Definition ccompose {A B C}
+Definition ccompose {SI: indexT} {A B C: ofeT SI}
(f : B -n> C) (g : A -n> B) : A -n> C := OfeMor (f ∘ g).
-Instance: Params (@ccompose) 3 := {}.
+Instance: Params (@ccompose) 4 := {}.
+
Infix "â—Ž" := ccompose (at level 40, left associativity).
-Global Instance ccompose_ne {A B C} :
- NonExpansive2 (@ccompose A B C).
+Global Instance ccompose_ne SI {A B C: ofeT SI} :
+ NonExpansive2 (@ccompose SI A B C).
Proof. intros n ?? Hf g1 g2 Hg x. rewrite /= (Hg x) (Hf (g2 x)) //. Qed.
+Lemma ccompose_assoc {SI : indexT} {A B C D : ofeT SI} (f : C -n> D) (g : B -n> C) (h : A -n> B) :
+ (f ◎ g) ◎ h ≡ f ◎ (g ◎ h).
+Proof. intros x. by cbn. Qed.
+
+Lemma ccompose_cid_l {SI : indexT} {A B : ofeT SI} (f : A -n> B ) : cid ◎ f ≡ f.
+Proof. intros x. by cbn. Qed.
+
+Lemma ccompose_cid_r {SI : indexT} {A B : ofeT SI} (f : A -n> B ) : f ◎ cid ≡ f.
+Proof. intros x. by cbn. Qed.
+
(* Function space maps *)
-Definition ofe_mor_map {A A' B B'} (f : A' -n> A) (g : B -n> B')
+Definition ofe_mor_map {SI: indexT} {A A' B B': ofeT SI} (f : A' -n> A) (g : B -n> B')
(h : A -n> B) : A' -n> B' := g â—Ž h â—Ž f.
-Instance ofe_mor_map_ne {A A' B B'} n :
- Proper (dist n ==> dist n ==> dist n ==> dist n) (@ofe_mor_map A A' B B').
+Instance ofe_mor_map_ne SI {A A' B B': ofeT SI} α :
+ Proper (dist α ==> dist α ==> dist α ==> dist α) (@ofe_mor_map SI A A' B B').
Proof. intros ??? ??? ???. by repeat apply ccompose_ne. Qed.
-Definition ofe_morO_map {A A' B B'} (f : A' -n> A) (g : B -n> B') :
+Definition ofe_morO_map {SI: indexT} {A A' B B': ofeT SI} (f : A' -n> A) (g : B -n> B') :
(A -n> B) -n> (A' -n> B') := OfeMor (ofe_mor_map f g).
-Instance ofe_morO_map_ne {A A' B B'} :
- NonExpansive2 (@ofe_morO_map A A' B B').
+Instance ofe_morO_map_ne {SI: indexT} {A A' B B': ofeT SI} :
+ NonExpansive2 (@ofe_morO_map SI A A' B B').
Proof.
intros n f f' Hf g g' Hg ?. rewrite /= /ofe_mor_map.
by repeat apply ccompose_ne.
@@ -604,44 +847,56 @@ Qed.
(** unit *)
Section unit.
- Instance unit_dist : Dist unit := λ _ _ _, True.
- Definition unit_ofe_mixin : OfeMixin unit.
- Proof. by repeat split; try exists 0. Qed.
- Canonical Structure unitO : ofeT := OfeT unit unit_ofe_mixin.
+ Context {SI: indexT}.
+ Instance unit_dist k : Dist k () := λ _ _ _, True.
+ Definition unit_ofe_mixin : OfeMixin SI ().
+ Proof. by repeat split. Qed.
+ Canonical Structure unitO : ofeT SI := OfeT () unit_ofe_mixin.
- Global Program Instance unit_cofe : Cofe unitO := { compl x := () }.
- Next Obligation. by repeat split; try exists 0. Qed.
+ Global Program Instance unit_cofe : Cofe unitO := { compl x := () }.
+ Solve All Obligations with by repeat split.
Global Instance unit_ofe_discrete : OfeDiscrete unitO.
Proof. done. Qed.
End unit.
+Arguments unitO : clear implicits.
+
+
+
(** Product *)
Section product.
- Context {A B : ofeT}.
+ Context {SI: indexT} {A B : ofeT SI}.
- Instance prod_dist : Dist (A * B) := λ n, prod_relation (dist n) (dist n).
+ Instance prod_dist : Dist SI (A * B) := λ n, prod_relation (dist n) (dist n).
Global Instance pair_ne :
NonExpansive2 (@pair A B) := _.
- Global Instance fst_ne : NonExpansive (@fst A B) := _.
- Global Instance snd_ne : NonExpansive (@snd A B) := _.
- Definition prod_ofe_mixin : OfeMixin (A * B).
+ Global Instance fst_ne : NonExpansive (@fst A B) := _.
+ Global Instance snd_ne : NonExpansive (@snd A B) := _.
+ Definition prod_ofe_mixin : OfeMixin SI (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 intros α β [x1 y1] [x2 y2] [??]; split; eapply dist_mono.
Qed.
- Canonical Structure prodO : ofeT := OfeT (A * B) prod_ofe_mixin.
+ Canonical Structure prodO : ofeT SI := OfeT (A * B) prod_ofe_mixin.
- Global Program Instance prod_cofe `{Cofe A, Cofe B} : Cofe prodO :=
- { compl c := (compl (chain_map fst c), compl (chain_map snd c)) }.
+ Global Program Instance prod_cofe `{Cofe SI A, Cofe SI B} : Cofe prodO :=
+ { compl c := (compl (chain_map fst c), compl (chain_map snd c));
+ bcompl α Hα c := (bcompl Hα (bchain_map fst c), bcompl Hα (bchain_map snd c)) }.
+ Next Obligation.
+ repeat split; cbn; by rewrite conv_compl.
+ Qed.
+ Next Obligation.
+ repeat split; cbn; by rewrite conv_bcompl; simpl.
+ Qed.
Next Obligation.
- intros ?? n c; split. apply (conv_compl n (chain_map fst c)).
- apply (conv_compl n (chain_map snd c)).
+ intros; cbn; split; cbn; eapply bcompl_ne; intros; simpl; eapply ne_apply; eauto.
Qed.
+
Global Instance prod_discrete (x : A * B) :
Discrete (x.1) → Discrete (x.2) → Discrete x.
Proof. by intros ???[??]; split; apply (discrete _). Qed.
@@ -650,154 +905,184 @@ Section product.
Proof. intros ?? [??]; apply _. Qed.
End product.
-Arguments prodO : clear implicits.
+Arguments prodO {_} _ _.
Typeclasses Opaque prod_dist.
-Instance prod_map_ne {A A' B B' : ofeT} n :
+Instance prod_map_ne {SI: indexT} {A A' B B' : ofeT SI} 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 prodO_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
+Definition prodO_map {SI: indexT} {A A' B B': ofeT SI} (f : A -n> A') (g : B -n> B') :
prodO A B -n> prodO A' B' := OfeMor (prod_map f g).
-Instance prodO_map_ne {A A' B B'} :
- NonExpansive2 (@prodO_map A A' B B').
+Instance prodO_map_ne {SI: indexT} {A A' B B': ofeT SI} :
+ NonExpansive2 (@prodO_map SI A A' B B').
Proof. intros n f f' Hf g g' Hg [??]; split; [apply Hf|apply Hg]. Qed.
(** Functors *)
-Record oFunctor := OFunctor {
- oFunctor_car : ∀ A `{!Cofe A} B `{!Cofe B}, ofeT;
- oFunctor_map `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
+Record oFunctor {SI} := OFunctor {
+ oFunctor_car : ∀ A B, ofeT SI;
+ oFunctor_map {A1 A2 B1 B2}:
((A2 -n> A1) * (B1 -n> B2)) → oFunctor_car A1 B1 -n> oFunctor_car A2 B2;
- oFunctor_ne `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :
- NonExpansive (@oFunctor_map A1 _ A2 _ B1 _ B2 _);
- oFunctor_id `{!Cofe A, !Cofe B} (x : oFunctor_car A B) :
+ oFunctor_ne {A1 A2 B1 B2}:
+ NonExpansive (@oFunctor_map A1 A2 B1 B2);
+ oFunctor_id {A B} (x : oFunctor_car A B) :
oFunctor_map (cid,cid) x ≡ x;
- oFunctor_compose `{!Cofe A1, !Cofe A2, !Cofe A3, !Cofe B1, !Cofe B2, !Cofe B3}
+ oFunctor_compose {A1 A2 A3 B1 B2 B3}
(f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x :
oFunctor_map (f◎g, g'◎f') x ≡ oFunctor_map (g,g') (oFunctor_map (f,f') x)
}.
Existing Instance oFunctor_ne.
-Instance: Params (@oFunctor_map) 9 := {}.
+Instance: Params (@oFunctor_map) 6 := {}.
+Arguments oFunctor : clear implicits.
+
Delimit Scope oFunctor_scope with OF.
Bind Scope oFunctor_scope with oFunctor.
-Class oFunctorContractive (F : oFunctor) :=
- oFunctor_contractive `{!Cofe A1, !Cofe A2, !Cofe B1, !Cofe B2} :>
- Contractive (@oFunctor_map F A1 _ A2 _ B1 _ B2 _).
-Hint Mode oFunctorContractive ! : typeclass_instances.
+Class oFunctorContractive {I: indexT} (F : oFunctor I) :=
+ oFunctor_contractive `{A1 : ofeT I} `{A2 : ofeT I} `{B1 : ofeT I} `{B2 : ofeT I} :>
+ Contractive (@oFunctor_map I F A1 A2 B1 B2).
+Hint Mode oFunctorContractive - ! : typeclass_instances.
-Definition oFunctor_diag (F: oFunctor) (A: ofeT) `{!Cofe A} : ofeT :=
- oFunctor_car F A A.
-(** Note that the implicit argument [Cofe A] is not taken into account when
-[oFunctor_diag] is used as a coercion. So, given [F : oFunctor] and [A : ofeT]
-one has to write [F A _]. *)
+Definition oFunctor_diag {SI: indexT} (F: oFunctor SI) (A: ofeT SI) : ofeT SI := oFunctor_car F A A.
Coercion oFunctor_diag : oFunctor >-> Funclass.
-Program Definition constOF (B : ofeT) : oFunctor :=
- {| oFunctor_car A1 A2 _ _ := B; oFunctor_map A1 _ A2 _ B1 _ B2 _ f := cid |}.
+Program Definition constOF {SI} (B : ofeT SI) : oFunctor SI :=
+ {| oFunctor_car A1 A2 := B; oFunctor_map A1 A2 B1 B2 f := cid |}.
Solve Obligations with done.
Coercion constOF : ofeT >-> oFunctor.
-Instance constOF_contractive B : oFunctorContractive (constOF B).
+Instance constOF_Contractive {SI} B : @oFunctorContractive SI (constOF B).
Proof. rewrite /oFunctorContractive; apply _. Qed.
-Program Definition idOF : oFunctor :=
- {| oFunctor_car A1 _ A2 _ := A2; oFunctor_map A1 _ A2 _ B1 _ B2 _ f := f.2 |}.
+Program Definition idOF SI : oFunctor SI :=
+ {| oFunctor_car A1 A2 := A2; oFunctor_map A1 A2 B1 B2 f := f.2 |}.
Solve Obligations with done.
Notation "∙" := idOF : oFunctor_scope.
-Program Definition prodOF (F1 F2 : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := prodO (oFunctor_car F1 A B) (oFunctor_car F2 A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
+Program Definition prodOF {SI} (F1 F2 : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := prodO (oFunctor_car F1 A B) (oFunctor_car F2 A B);
+ oFunctor_map A1 A2 B1 B2 fg :=
prodO_map (oFunctor_map F1 fg) (oFunctor_map F2 fg)
|}.
Next Obligation.
- intros ?? A1 ? A2 ? B1 ? B2 ? n ???; by apply prodO_map_ne; apply oFunctor_ne.
+ intros k ?? A1 A2 B1 B2 n ???; by apply prodO_map_ne; apply oFunctor_ne.
Qed.
-Next Obligation. by intros F1 F2 A ? B ? [??]; rewrite /= !oFunctor_id. Qed.
+Next Obligation. by intros k F1 F2 A B [??]; rewrite /= !oFunctor_id. Qed.
Next Obligation.
- intros F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [??]; simpl.
+ intros k F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [??]; simpl.
by rewrite !oFunctor_compose.
Qed.
Notation "F1 * F2" := (prodOF F1%OF F2%OF) : oFunctor_scope.
-Instance prodOF_contractive F1 F2 :
+Instance prodOF_Contractive {SI} {F1 F2 : ofeT SI}:
oFunctorContractive F1 → oFunctorContractive F2 →
oFunctorContractive (prodOF F1 F2).
Proof.
- intros ?? A1 ? A2 ? B1 ? B2 ? n ???;
+ intros ?? A1 A2 B1 B2 n ???;
by apply prodO_map_ne; apply oFunctor_contractive.
Qed.
-Program Definition ofe_morOF (F1 F2 : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := oFunctor_car F1 B A -n> oFunctor_car F2 A B;
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
+Program Definition ofe_morOF {SI: indexT} (F1 F2 : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := oFunctor_car F1 B A -n> oFunctor_car F2 A B;
+ oFunctor_map A1 A2 B1 B2 fg :=
ofe_morO_map (oFunctor_map F1 (fg.2, fg.1)) (oFunctor_map F2 fg)
|}.
Next Obligation.
- intros F1 F2 A1 ? A2 ? B1 ? B2 ? n [f g] [f' g'] Hfg; simpl in *.
+ intros k F1 F2 A1 A2 B1 B2 n [f g] [f' g'] Hfg; simpl in *.
apply ofe_morO_map_ne; apply oFunctor_ne; split; by apply Hfg.
Qed.
Next Obligation.
- intros F1 F2 A ? B ? [f ?] ?; simpl. rewrite /= !oFunctor_id.
+ intros k F1 F2 A B [f ?] ?; simpl. rewrite /= !oFunctor_id.
apply (ne_proper f). apply oFunctor_id.
Qed.
Next Obligation.
- intros F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [h ?] ?; simpl in *.
+ intros k F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [h ?] ?; simpl in *.
rewrite -!oFunctor_compose. do 2 apply (ne_proper _). apply oFunctor_compose.
Qed.
Notation "F1 -n> F2" := (ofe_morOF F1%OF F2%OF) : oFunctor_scope.
-Instance ofe_morOF_contractive F1 F2 :
+Instance ofe_morOF_Contractive {I: indexT} (F1 F2 : oFunctor I):
oFunctorContractive F1 → oFunctorContractive F2 →
oFunctorContractive (ofe_morOF F1 F2).
Proof.
- intros ?? A1 ? A2 ? B1 ? B2 ? n [f g] [f' g'] Hfg; simpl in *.
- apply ofe_morO_map_ne; apply oFunctor_contractive; destruct n, Hfg; by split.
+ intros ?? A1 A2 B1 B2 n [f g] [f' g'] Hfg; simpl in *.
+ apply ofe_morO_map_ne; apply oFunctor_contractive; unfold dist_later; intros; split; cbn; eauto.
+ all: destruct (Hfg β); auto.
Qed.
+
(** Sum *)
+
Section sum.
- Context {A B : ofeT}.
+ Context {SI: indexT} {A B : ofeT SI}.
+
+ Instance sum_dist : Dist SI (A + B) := λ n, sum_relation (dist n) (dist n).
+
- Instance sum_dist : Dist (A + B) := λ n, sum_relation (dist n) (dist n).
Global Instance inl_ne : NonExpansive (@inl A B) := _.
Global Instance inr_ne : NonExpansive (@inr A B) := _.
Global Instance inl_ne_inj : Inj (dist n) (dist n) (@inl A B) := _.
Global Instance inr_ne_inj : Inj (dist n) (dist n) (@inr A B) := _.
- Definition sum_ofe_mixin : OfeMixin (A + B).
+ Definition sum_ofe_mixin : OfeMixin SI (A + B).
Proof.
split.
- intros x y; split=> Hx.
+ destruct Hx=> n; constructor; by apply equiv_dist.
- + destruct (Hx 0); constructor; apply equiv_dist=> n; by apply (inj _).
+ + destruct (Hx zero); constructor; apply equiv_dist=> n; by apply (inj _).
- apply _.
- - destruct 1; constructor; by apply dist_S.
+ - destruct 1; constructor; eapply dist_mono; eauto.
Qed.
- Canonical Structure sumO : ofeT := OfeT (A + B) sum_ofe_mixin.
+
+ Canonical Structure sumO : ofeT SI := OfeT (A + B) sum_ofe_mixin.
Program Definition inl_chain (c : chain sumO) (a : A) : chain A :=
{| chain_car n := match c n return _ with inl a' => a' | _ => a end |}.
- Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
+ Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy' c n i). Qed.
Program Definition inr_chain (c : chain sumO) (b : B) : chain B :=
{| chain_car n := match c n return _ with inr b' => b' | _ => b end |}.
- Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
-
- Definition sum_compl `{Cofe A, Cofe B} : Compl sumO := λ c,
- match c 0 with
+ Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy' c n i). Qed.
+ Definition sum_compl `{Cofe SI A, Cofe SI B} : chain sumO → sumO := λ c,
+ match c zero with
| inl a => inl (compl (inl_chain c a))
| inr b => inr (compl (inr_chain c b))
end.
- Global Program Instance sum_cofe `{Cofe A, Cofe B} : Cofe sumO :=
- { compl := sum_compl }.
+
+ Program Definition inl_bchain {α} (c : bchain sumO α) (a : A) : bchain A α :=
+ {| bchain_car n Hn := match c n Hn return _ with inl a' => a' | _ => a end |}.
+ Next Obligation. intros α c a β γ ? Hβ Hγ; simpl. by destruct (bchain_cauchy' α c β γ Hβ Hγ). Qed.
+ Program Definition inr_bchain {α} (c : bchain sumO α) (b : B) : bchain B α :=
+ {| bchain_car n Hn := match c n Hn return _ with inr b' => b' | _ => b end |}.
+ Next Obligation. intros α c b β γ ? Hβ Hγ; simpl. by destruct (bchain_cauchy' α c β γ Hβ Hγ). Qed.
+ Definition sum_bcompl `{Cofe SI A, Cofe SI B} α : zero ≺ α → bchain sumO α → sumO :=
+ λ Hα c,
+ match c zero Hα with
+ | inl a => inl (bcompl Hα (inl_bchain c a))
+ | inr b => inr (bcompl Hα (inr_bchain c b))
+ end.
+
+ Global Program Instance sum_cofe `{Cofe SI A, Cofe SI B} : Cofe sumO :=
+ { compl := sum_compl; bcompl := sum_bcompl }.
Next Obligation.
intros ?? n c; rewrite /compl /sum_compl.
- feed inversion (chain_cauchy c 0 n); first by auto with lia; constructor.
+ feed inversion (chain_cauchy' c zero n).
+ - apply index_zero_minimum.
- rewrite (conv_compl n (inl_chain c _)) /=. destruct (c n); naive_solver.
- rewrite (conv_compl n (inr_chain c _)) /=. destruct (c n); naive_solver.
Qed.
+ Next Obligation.
+ intros ?? α Hα c β Hβ. rewrite /sum_bcompl.
+ feed inversion (bchain_cauchy' α c zero β Hα Hβ).
+ - apply index_zero_minimum.
+ - rewrite (conv_bcompl α _ _ _ Hβ) /=. destruct (c β _); naive_solver.
+ - rewrite (conv_bcompl α _ _ _ Hβ) /=. destruct (c β _); naive_solver.
+ Qed.
+ Next Obligation.
+ intros ?????? β H1. unfold sum_bcompl.
+ destruct (H1 zero Hα); simpl; rewrite bcompl_ne; eauto.
+ all: intros γ Hγ; simpl; destruct (H1 γ Hγ); eauto.
+ Qed.
Global Instance inl_discrete (x : A) : Discrete x → Discrete (inl x).
Proof. inversion_clear 2; constructor; by apply (discrete _). Qed.
@@ -808,53 +1093,54 @@ Section sum.
Proof. intros ?? [?|?]; apply _. Qed.
End sum.
-Arguments sumO : clear implicits.
+Arguments sumO {_} _ _.
Typeclasses Opaque sum_dist.
-Instance sum_map_ne {A A' B B' : ofeT} n :
+Instance sum_map_ne {SI: indexT} {A A' B B' : ofeT SI} n :
Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==>
dist n ==> dist n) (@sum_map A A' B B').
Proof.
intros f f' Hf g g' Hg ??; destruct 1; constructor; [by apply Hf|by apply Hg].
Qed.
-Definition sumO_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
+Definition sumO_map {SI: indexT} {A A' B B': ofeT SI} (f : A -n> A') (g : B -n> B') :
sumO A B -n> sumO A' B' := OfeMor (sum_map f g).
-Instance sumO_map_ne {A A' B B'} :
- NonExpansive2 (@sumO_map A A' B B').
+Instance sumO_map_ne {SI} {A A' B B'} :
+ NonExpansive2 (@sumO_map SI A A' B B').
Proof. intros n f f' Hf g g' Hg [?|?]; constructor; [apply Hf|apply Hg]. Qed.
-Program Definition sumOF (F1 F2 : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := sumO (oFunctor_car F1 A B) (oFunctor_car F2 A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg :=
+Program Definition sumOF {SI: indexT} (F1 F2 : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := sumO (oFunctor_car F1 A B) (oFunctor_car F2 A B);
+ oFunctor_map A1 A2 B1 B2 fg :=
sumO_map (oFunctor_map F1 fg) (oFunctor_map F2 fg)
|}.
Next Obligation.
- intros ?? A1 ? A2 ? B1 ? B2 ? n ???; by apply sumO_map_ne; apply oFunctor_ne.
+ intros ??? A1 A2 B1 B2 n ???; by apply sumO_map_ne; apply oFunctor_ne.
Qed.
-Next Obligation. by intros F1 F2 A ? B ? [?|?]; rewrite /= !oFunctor_id. Qed.
+Next Obligation. by intros ? F1 F2 A B [?|?]; rewrite /= !oFunctor_id. Qed.
Next Obligation.
- intros F1 F2 A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' [?|?]; simpl;
+ intros ? F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [?|?]; simpl;
by rewrite !oFunctor_compose.
Qed.
Notation "F1 + F2" := (sumOF F1%OF F2%OF) : oFunctor_scope.
-Instance sumOF_contractive F1 F2 :
+Instance sumOF_contractive {SI: indexT} (F1 F2 : oFunctor SI):
oFunctorContractive F1 → oFunctorContractive F2 →
oFunctorContractive (sumOF F1 F2).
Proof.
- intros ?? A1 ? A2 ? B1 ? B2 ? n ???;
+ intros ?? A1 A2 B1 B2 n ???;
by apply sumO_map_ne; apply oFunctor_contractive.
Qed.
+
(** Discrete OFE *)
Section discrete_ofe.
- Context `{Equiv A} (Heq : @Equivalence A (≡)).
+ Context {SI: indexT} {A: Type} `{Equiv A} (Heq : @Equivalence A (≡)).
- Instance discrete_dist : Dist A := λ n x y, x ≡ y.
- Definition discrete_ofe_mixin : OfeMixin A.
+ Instance discrete_dist : Dist SI A := λ n x y, x ≡ y.
+ Definition discrete_ofe_mixin : OfeMixin SI A.
Proof using Type*.
split.
- - intros x y; split; [done|intros Hn; apply (Hn 0)].
+ - intros x y; split; [done|intros Hn; apply (Hn zero)].
- done.
- done.
Qed.
@@ -862,16 +1148,28 @@ Section discrete_ofe.
Global Instance discrete_ofe_discrete : OfeDiscrete (OfeT A discrete_ofe_mixin).
Proof. by intros x y. Qed.
- Global Program Instance discrete_cofe : Cofe (OfeT A discrete_ofe_mixin) :=
- { compl c := c 0 }.
+ Global Program Instance discrete_cofe : Cofe (OfeT A discrete_ofe_mixin) :=
+ { compl c := c zero;
+ bcompl α Hα c := c zero Hα
+ }.
+ Next Obligation.
+ intros α c; simpl.
+ symmetry; apply (chain_cauchy' c zero α).
+ eapply index_zero_minimum.
+ Qed.
+ Next Obligation.
+ intros α Hα c; simpl.
+ symmetry; apply (bchain_cauchy' α c zero β).
+ eapply index_zero_minimum.
+ Qed.
Next Obligation.
- intros n c. rewrite /compl /=;
- symmetry; apply (chain_cauchy c 0 n). lia.
+ intros; simpl; eauto.
Qed.
+
End discrete_ofe.
-Notation discreteO A := (OfeT A (discrete_ofe_mixin _)).
-Notation leibnizO A := (OfeT A (@discrete_ofe_mixin _ equivL _)).
+Notation discreteO SI A := (OfeT A (discrete_ofe_mixin _): ofeT SI).
+Notation leibnizO SI A := (OfeT A (@discrete_ofe_mixin SI _ equivL _): ofeT SI).
(** In order to define a discrete CMRA with carrier [A] (in the file [cmra.v])
we need to determine the [Equivalence A] proof that was used to construct the
@@ -881,62 +1179,82 @@ via [ofe_equivalence]).
We obtain the proof of [Equivalence A] by inferring the canonical OFE mixin
using [ofe_mixin_of A], and then check whether it is indeed a discrete OFE. This
will fail if no OFE, or an OFE other than the discrete OFE, was registered. *)
-Notation discrete_ofe_equivalence_of A := ltac:(
- match constr:(ofe_mixin_of A) with
+Notation discrete_ofe_equivalence_of SI A := ltac:(
+ match constr:(ofe_mixin_of SI A) with
| discrete_ofe_mixin ?H => exact H
end) (only parsing).
-Instance leibnizO_leibniz A : LeibnizEquiv (leibnizO A).
+Instance leibnizO_leibniz A {SI} : LeibnizEquiv (leibnizO SI A : ofeT SI).
Proof. by intros x y. Qed.
-Canonical Structure boolO := leibnizO bool.
-Canonical Structure natO := leibnizO nat.
-Canonical Structure positiveO := leibnizO positive.
-Canonical Structure NO := leibnizO N.
-Canonical Structure ZO := leibnizO Z.
+Canonical Structure boolO SI : ofeT SI := leibnizO SI bool.
+Canonical Structure natO SI : ofeT SI := leibnizO SI nat.
+Canonical Structure positiveO SI : ofeT SI := leibnizO SI positive.
+Canonical Structure NO SI : ofeT SI := leibnizO SI N.
+Canonical Structure ZO SI : ofeT SI := leibnizO SI Z.
(* Option *)
Section option.
- Context {A : ofeT}.
+ Context {SI: indexT} {A : ofeT SI}.
- Instance option_dist : Dist (option A) := λ n, option_Forall2 (dist n).
- Lemma dist_option_Forall2 n mx my : mx ≡{n}≡ my ↔ option_Forall2 (dist n) mx my.
+ Instance option_dist : Dist SI (option A) := λ α, option_Forall2 (dist α).
+ Lemma dist_option_Forall2 α mx my : mx ≡{α}≡ my ↔ option_Forall2 (dist α) mx my.
Proof. done. Qed.
- Definition option_ofe_mixin : OfeMixin (option A).
+ Definition option_ofe_mixin : OfeMixin SI (option A).
Proof.
split.
- intros mx my; split; [by destruct 1; constructor; apply equiv_dist|].
- intros Hxy; destruct (Hxy 0); constructor; apply equiv_dist.
- by intros n; feed inversion (Hxy n).
+ intros Hxy; destruct (Hxy zero); constructor; apply equiv_dist.
+ by intros α; feed inversion (Hxy α).
- apply _.
- - destruct 1; constructor; by apply dist_S.
+ - destruct 1; constructor; eapply dist_le; eauto.
Qed.
Canonical Structure optionO := OfeT (option A) option_ofe_mixin.
+
+ Global Instance Some_ne : NonExpansive (@Some A).
+ Proof. intros ????. by econstructor. Qed.
+ Global Instance Some_ne_inj : Inj (dist n) (dist n) (@Some A).
+ Proof. intros ??? H. by inversion H. Qed.
+
Program Definition option_chain (c : chain optionO) (x : A) : chain A :=
{| chain_car n := default x (c n) |}.
- Next Obligation. intros c x n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
- Definition option_compl `{Cofe A} : Compl optionO := λ c,
- match c 0 with Some x => Some (compl (option_chain c x)) | None => None end.
- Global Program Instance option_cofe `{Cofe A} : Cofe optionO :=
- { compl := option_compl }.
+ Next Obligation. intros c x n i ?; simpl. by destruct (chain_cauchy' c n i). Qed.
+ Definition option_compl `{Cofe SI A} : (chain optionO) → optionO := λ c,
+ match c zero with Some x => Some (compl (option_chain c x)) | None => None end.
+
+ Program Definition option_bchain α (c : bchain optionO α) (x : A) : bchain A α :=
+ {| bchain_car n Hn := default x (c n Hn) |}.
+ Next Obligation. intros α c x β γ ? Hβ Hγ; simpl. by destruct (bchain_cauchy' α c β γ Hβ Hγ). Qed.
+ Definition option_bcompl `{Cofe SI A} α (Hα: zero ≺ α): (bchain optionO α) → optionO := λ c,
+ match c zero Hα with Some x => Some (bcompl Hα (option_bchain α c x)) | None => None end.
+
+ Global Program Instance option_cofe `{Cofe SI A} : Cofe optionO :=
+ { compl := option_compl; bcompl := option_bcompl }.
Next Obligation.
intros ? n c; rewrite /compl /option_compl.
- feed inversion (chain_cauchy c 0 n); auto with lia; [].
+ feed inversion (chain_cauchy' c zero n); auto using index_zero_minimum.
constructor. rewrite (conv_compl n (option_chain c _)) /=.
destruct (c n); naive_solver.
Qed.
+ Next Obligation.
+ intros ? α Hα c β Hβ; rewrite /bcompl /option_bcompl.
+ feed inversion (bchain_cauchy' α c zero β Hα Hβ); auto using index_zero_minimum.
+ constructor. unshelve rewrite conv_bcompl; eauto; simpl.
+ destruct (c β Hβ); naive_solver.
+ Qed.
+ Next Obligation.
+ intros ? α Hα c d β Hc; rewrite /bcompl /option_bcompl.
+ destruct (Hc zero Hα); auto. rewrite bcompl_ne; eauto.
+ intros γ Hγ; simpl. destruct (Hc γ Hγ); eauto.
+ Qed.
Global Instance option_ofe_discrete : OfeDiscrete A → OfeDiscrete optionO.
Proof. destruct 2; constructor; by apply (discrete _). Qed.
- Global Instance Some_ne : NonExpansive (@Some A).
- Proof. by constructor. Qed.
Global Instance is_Some_ne n : Proper (dist n ==> iff) (@is_Some A).
Proof. destruct 1; split; eauto. Qed.
- Global Instance Some_dist_inj : Inj (dist n) (dist n) (@Some A).
- Proof. by inversion_clear 1. Qed.
Global Instance from_option_ne {B} (R : relation B) (f : A → B) n :
Proper (dist n ==> R) f → Proper (R ==> dist n ==> R) (from_option f).
Proof. destruct 3; simpl; auto. Qed.
@@ -946,58 +1264,60 @@ Section option.
Global Instance Some_discrete x : Discrete x → Discrete (Some x).
Proof. by intros ?; inversion_clear 1; constructor; apply discrete. Qed.
- Lemma dist_None n mx : mx ≡{n}≡ None ↔ mx = None.
+ Lemma dist_None α mx : mx ≡{α}≡ None ↔ mx = None.
Proof. split; [by inversion_clear 1|by intros ->]. Qed.
- Lemma dist_Some_inv_l n mx my x :
- mx ≡{n}≡ my → mx = Some x → ∃ y, my = Some y ∧ x ≡{n}≡ y.
+ Lemma dist_Some α x y : Some x ≡{α}≡ Some y ↔ x ≡{α}≡ y.
+ Proof. split; [by inversion_clear 1 | by intros ->]. Qed.
+ Lemma dist_Some_inv_l α mx my x :
+ mx ≡{α}≡ my → mx = Some x → ∃ y, my = Some y ∧ x ≡{α}≡ y.
Proof. destruct 1; naive_solver. Qed.
- Lemma dist_Some_inv_r n mx my y :
- mx ≡{n}≡ my → my = Some y → ∃ x, mx = Some x ∧ x ≡{n}≡ y.
+ Lemma dist_Some_inv_r α mx my y :
+ mx ≡{α}≡ my → my = Some y → ∃ x, mx = Some x ∧ x ≡{α}≡ y.
Proof. destruct 1; naive_solver. Qed.
- Lemma dist_Some_inv_l' n my x : Some x ≡{n}≡ my → ∃ x', Some x' = my ∧ x ≡{n}≡ x'.
+ Lemma dist_Some_inv_l' α my x : Some x ≡{α}≡ my → ∃ x', Some x' = my ∧ x ≡{α}≡ x'.
Proof. intros ?%(dist_Some_inv_l _ _ _ x); naive_solver. Qed.
- Lemma dist_Some_inv_r' n mx y : mx ≡{n}≡ Some y → ∃ y', mx = Some y' ∧ y ≡{n}≡ y'.
+ Lemma dist_Some_inv_r' α mx y : mx ≡{α}≡ Some y → ∃ y', mx = Some y' ∧ y ≡{α}≡ y'.
Proof. intros ?%(dist_Some_inv_r _ _ _ y); naive_solver. Qed.
End option.
Typeclasses Opaque option_dist.
-Arguments optionO : clear implicits.
+Arguments optionO {_} _.
-Instance option_fmap_ne {A B : ofeT} n:
- Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@fmap option _ A B).
+Instance option_fmap_ne {SI} {A B : ofeT SI} α:
+ Proper ((dist α ==> dist α) ==> dist α ==> dist α) (@fmap option _ A B).
Proof. intros f f' Hf ?? []; constructor; auto. Qed.
-Instance option_mbind_ne {A B : ofeT} n:
- Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@mbind option _ A B).
+Instance option_mbind_ne {SI} {A B : ofeT SI} α:
+ Proper ((dist α ==> dist α) ==> dist α ==> dist α) (@mbind option _ A B).
Proof. destruct 2; simpl; auto. Qed.
-Instance option_mjoin_ne {A : ofeT} n:
- Proper (dist n ==> dist n) (@mjoin option _ A).
+Instance option_mjoin_ne {SI} {A : ofeT SI} α:
+ Proper (dist α ==> dist α) (@mjoin option _ A).
Proof. destruct 1 as [?? []|]; simpl; by constructor. Qed.
-Definition optionO_map {A B} (f : A -n> B) : optionO A -n> optionO B :=
+Definition optionO_map {SI} {A B: ofeT SI} (f : A -n> B) : optionO A -n> optionO B :=
OfeMor (fmap f : optionO A → optionO B).
-Instance optionO_map_ne A B : NonExpansive (@optionO_map A B).
+Instance optionO_map_ne {SI} (A B: ofeT SI) : NonExpansive (@optionO_map _ A B).
Proof. by intros n f f' Hf []; constructor; apply Hf. Qed.
-Program Definition optionOF (F : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := optionO (oFunctor_car F A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := optionO_map (oFunctor_map F fg)
+Program Definition optionOF {SI: indexT} (F : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := optionO (oFunctor_car F A B);
+ oFunctor_map A1 A2 B1 B2 fg := optionO_map (oFunctor_map F fg)
|}.
Next Obligation.
- by intros F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply optionO_map_ne, oFunctor_ne.
+ by intros SI F A1 A2 B1 B2 n f g Hfg; apply optionO_map_ne, oFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x. rewrite /= -{2}(option_fmap_id x).
+ intros SI F A B x. rewrite /= -{2}(option_fmap_id x).
apply option_fmap_equiv_ext=>y; apply oFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -option_fmap_compose.
+ intros SI F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -option_fmap_compose.
apply option_fmap_equiv_ext=>y; apply oFunctor_compose.
Qed.
-Instance optionOF_contractive F :
+Instance optionOF_contractive {SI} (F : oFunctor SI):
oFunctorContractive F → oFunctorContractive (optionOF F).
Proof.
- by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply optionO_map_ne, oFunctor_contractive.
+ by intros ? ? A1 A2 B1 B2 n f g Hfg; apply optionO_map_ne, oFunctor_contractive.
Qed.
(** Later *)
@@ -1011,37 +1331,76 @@ Arguments Next {_} _.
Arguments later_car {_} _.
Instance: Params (@Next) 1 := {}.
+
+
Section later.
- Context {A : ofeT}.
+ Context {SI: indexT} {A : ofeT SI}.
Instance later_equiv : Equiv (later A) := λ x y, later_car x ≡ later_car y.
- Instance later_dist : Dist (later A) := λ n x y,
- dist_later n (later_car x) (later_car y).
- Definition later_ofe_mixin : OfeMixin (later A).
+ Instance later_dist : Dist SI (later A) := λ α x y,
+ dist_later α (later_car x) (later_car y).
+ Definition later_ofe_mixin : OfeMixin SI (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)).
+ split; first by intros Hxy α β Hβ.
+ intros H α; eapply (H (succ α)). by eapply index_succ_iff.
- split; rewrite /dist /later_dist.
+ by intros [x].
+ by intros [x] [y].
+ by intros [x] [y] [z] ??; trans y.
- - intros [|n] [x] [y] ?; [done|]; rewrite /dist /later_dist; by apply dist_S.
+ - intros α β [x] [y] H ? γ Hγ. eapply H; by transitivity β.
+ Qed.
+ Canonical Structure laterO : ofeT SI := OfeT (later A) later_ofe_mixin.
+
+ Lemma later_car_bounded_expansive (a b : laterO) α: a ≡{succ α}≡ b → later_car a ≡{α}≡ later_car b.
+ Proof.
+ intros H. destruct a as [a], b as [b]; cbn in *. apply (H α (index_succ_greater _)).
Qed.
- Canonical Structure laterO : ofeT := OfeT (later A) later_ofe_mixin.
+
+ Lemma later_dist_unfold (a b : laterO) α : a ≡{α}≡ b ↔ dist_later α (later_car a) (later_car b).
+ Proof. tauto. Qed.
Program Definition later_chain (c : chain laterO) : chain A :=
- {| chain_car n := later_car (c (S n)) |}.
- Next Obligation. intros c n i ?; apply (chain_cauchy c (S n)); lia. Qed.
- Global Program Instance later_cofe `{Cofe A} : Cofe laterO :=
- { compl c := Next (compl (later_chain c)) }.
+ {| chain_car n := later_car (c (succ n)) |}.
Next Obligation.
- intros ? [|n] c; [done|by apply (conv_compl n (later_chain c))].
+ intros c n i ?; apply (chain_cauchy' c (succ n)); eauto with index.
+ Qed.
+
+ Program Definition later_limit_bchain {α} (c : bchain laterO α) (islim: ∀ β, β ≺ α → succ β ≺ α) : bchain A α :=
+ {| bchain_car β Hβ := later_car (c (succ β) (islim β Hβ)) |}.
+ Next Obligation.
+ intros α c islim β γ ? Hβ Hγ; apply (bchain_cauchy' α c (succ β) (succ γ)); eauto with index.
Qed.
- Global Instance Next_contractive : Contractive (@Next A).
- Proof. by intros [|n] x y. Qed.
- Global Instance Later_inj n : Inj (dist n) (dist (S n)) (@Next A).
- Proof. by intros x y. Qed.
+
+ Global Instance Next_contractive : Contractive (@Next A).
+ Proof. by intros α x y. Qed.
+
+ Global Program Instance later_cofe `{Cofe SI A} : Cofe laterO :=
+ { compl c := Next (compl (later_chain c));
+ bcompl α Hα c :=
+ match index_dec_limit α with
+ | inl (exist _ β H) => c β (index_succ_greater' _ _ H)
+ | inr islim => Next (bcompl Hα (later_limit_bchain c islim))
+ end
+ }.
+ Next Obligation.
+ intros ? α c β Hβ; simpl. rewrite conv_compl /=.
+ symmetry; apply (chain_cauchy' c (succ β) α); eauto with index.
+ Qed.
+ Next Obligation.
+ intros ? α Hα c β Hβ; simpl; destruct index_dec_limit as [[γ ?]|islim]; subst.
+ - by eapply bchain_cauchy, index_succ_iff.
+ - intros γ Hγ; simpl. unshelve rewrite conv_bcompl; simpl.
+ eauto using index_lt_le_trans. symmetry. eapply (bchain_cauchy' α c (succ γ)); eauto with index.
+ Qed.
+ Next Obligation.
+ intros ? α Hα c d β H; simpl; destruct index_dec_limit as [[γ ->]|islim]; eauto.
+ intros γ Hγ; simpl; eapply bcompl_ne; intros δ Hδ; simpl; by eapply H.
+ Qed.
+
+ Global Instance Later_inj n : Inj (dist_later n) (dist n) (@Next A).
+ Proof. by intros x y H. Qed.
Lemma Next_uninj x : ∃ a, x ≡ Next a.
Proof. by exists (later_car x). Qed.
@@ -1050,75 +1409,81 @@ Section later.
Proof. move=> [x] [y] /= Hxy. done. Qed.
(* f is contractive iff it can factor into `Next` and a non-expansive function. *)
- Lemma contractive_alt {B : ofeT} (f : A → B) :
- Contractive f ↔ ∃ g : later A → B, NonExpansive g ∧ ∀ x, f x ≡ g (Next x).
+ Lemma contractive_alt {B : ofeT SI} (f : A → B) :
+ Contractive f ↔ ∃ g : later A → B, NonExpansive g ∧ ∀ x, f x ≡ g (Next x).
Proof.
split.
- - intros Hf. exists (f ∘ later_car); split=> // n x y ?. by f_equiv.
+ - intros Hf. exists (f ∘ later_car); split=> // n x y ?. by eapply ne_apply.
- intros (g&Hg&Hf) n x y Hxy. rewrite !Hf. by apply Hg.
Qed.
End later.
-Arguments laterO : clear implicits.
+Arguments laterO {_} _.
Definition later_map {A B} (f : A → B) (x : later A) : later B :=
Next (f (later_car x)).
-Instance later_map_ne {A B : ofeT} (f : A → B) n :
- Proper (dist (pred n) ==> dist (pred n)) f →
+Instance later_map_ne {I: indexT} {A B : ofeT I} (f : A → B) n :
+ Proper (dist_later n ==> dist_later 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.
+Proof. intros P [x] [y] H; rewrite /later_map //=.
+ intros α Hα; apply P, Hα. apply H.
+Qed.
+
+Instance later_map_ne' {SI: indexT} {A B : ofeT SI} (f : A → B) `{NonExpansive f} : NonExpansive (later_map f).
+Proof. intros ?[x][y]H. unfold later_map; simpl.
+ intros ??; cbn. by eapply ne_apply, H.
+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.
-Lemma later_map_ext {A B : ofeT} (f g : A → B) x :
+Lemma later_map_ext {SI: indexT} {A B : ofeT SI} (f g : A → B) x :
(∀ x, f x ≡ g x) → later_map f x ≡ later_map g x.
Proof. destruct x; intros Hf; apply Hf. Qed.
-Definition laterO_map {A B} (f : A -n> B) : laterO A -n> laterO B :=
+Definition laterO_map {SI: indexT} {A B: ofeT SI} (f : A -n> B) : laterO A -n> laterO B :=
OfeMor (later_map f).
-Instance laterO_map_contractive (A B : ofeT) : Contractive (@laterO_map A B).
-Proof. intros [|n] f g Hf n'; [done|]; apply Hf; lia. Qed.
+Instance laterO_map_contractive {SI: indexT} (A B : ofeT SI) : Contractive (@laterO_map SI A B).
+Proof. intros α f g ? [x] ??; simpl. by apply H. Qed.
-Program Definition laterOF (F : oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := laterO (oFunctor_car F A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := laterO_map (oFunctor_map F fg)
+Program Definition laterOF {SI: indexT} (F : oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := laterO (oFunctor_car F A B);
+ oFunctor_map A1 A2 B1 B2 fg := laterO_map (oFunctor_map F fg)
|}.
Next Obligation.
- intros F A1 ? A2 ? B1 ? B2 ? n fg fg' ?.
+ intros k F A1 A2 B1 B2 n fg fg' ?.
by apply (contractive_ne laterO_map), oFunctor_ne.
Qed.
Next Obligation.
- intros F A ? B ? x; simpl. rewrite -{2}(later_map_id x).
+ intros k F A B x; simpl. rewrite -{2}(later_map_id x).
apply later_map_ext=>y. by rewrite oFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl. rewrite -later_map_compose.
+ intros k F A1 A2 A3 B1 B2 B3 f g f' g' x; simpl. rewrite -later_map_compose.
apply later_map_ext=>y; apply oFunctor_compose.
Qed.
Notation "â–¶ F" := (laterOF F%OF) (at level 20, right associativity) : oFunctor_scope.
-Instance laterOF_contractive F : oFunctorContractive (laterOF F).
+Instance laterOF_contractive {SI: indexT} {F :oFunctor SI} : oFunctorContractive (laterOF F).
Proof.
- intros A1 ? A2 ? B1 ? B2 ? n fg fg' Hfg. apply laterO_map_contractive.
- destruct n as [|n]; simpl in *; first done. apply oFunctor_ne, Hfg.
+ intros A1 A2 B1 B2 n fg fg' Hfg. apply laterO_map_contractive.
+ intros ???; simpl. by eapply oFunctor_ne, Hfg.
Qed.
-(** Dependently-typed functions over a discrete domain *)
-(** We make [discrete_fun] a definition so that we can register it as a
-canonical structure. Note that non-dependent functions over a discrete domain,
-[discrete_fun (λ _, A) B] (or [A -d> B] following the notation we introduce
-below) are isomorphic to [leibnizO A -n> B]. In other words, since the domain
-is discrete, we get non-expansiveness for free. *)
-Definition discrete_fun {A} (B : A → ofeT) := ∀ x : A, B x.
+
+(* Dependently-typed functions over a discrete domain *)
+(* We make [discrete_fun] a definition so that we can register it as a canonical
+structure. *)
+Definition discrete_fun {SI: indexT} {A} (B : A → ofeT SI) := ∀ x : A, B x.
Section discrete_fun.
- Context {A : Type} {B : A → ofeT}.
+ Context {SI: indexT} {A : Type} {B : A → ofeT SI}.
Implicit Types f g : discrete_fun B.
Instance discrete_fun_equiv : Equiv (discrete_fun B) := λ f g, ∀ x, f x ≡ g x.
- Instance discrete_fun_dist : Dist (discrete_fun B) := λ n f g, ∀ x, f x ≡{n}≡ g x.
- Definition discrete_fun_ofe_mixin : OfeMixin (discrete_fun B).
+ Instance discrete_fun_dist : Dist SI (discrete_fun B) := λ n f g, ∀ x, f x ≡{n}≡ g x.
+ Definition discrete_fun_ofe_mixin : OfeMixin SI (discrete_fun B).
Proof.
split.
- intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
@@ -1127,16 +1492,29 @@ Section discrete_fun.
+ by intros f x.
+ by intros f g ? x.
+ by intros f g h ?? x; trans (g x).
- - by intros n f g ? x; apply dist_S.
+ - intros n m f g ? H x. eauto using dist_le.
Qed.
Canonical Structure discrete_funO := OfeT (discrete_fun B) discrete_fun_ofe_mixin.
- Program Definition discrete_fun_chain `(c : chain discrete_funO)
- (x : A) : chain (B x) := {| chain_car n := c n x |}.
- Next Obligation. intros c x n i ?. by apply (chain_cauchy c). Qed.
+ Program Definition discrete_fun_chain `(c : chain discrete_funO) (x : A) : chain (B x) :=
+ {| chain_car n := c n x |}.
+ Next Obligation. intros c x n i ?. by apply (chain_cauchy' c). Qed.
+ Program Definition discrete_fun_bchain {α} `(c : bchain discrete_funO α) (x : A) : bchain (B x) α :=
+ {| bchain_car n Hn := c n Hn x |}.
+ Next Obligation. intros α c x β γ ? Hβ Hγ. by apply (bchain_cauchy' α c _ _ Hβ Hγ). Qed.
+
+
Global Program Instance discrete_fun_cofe `{∀ x, Cofe (B x)} : Cofe discrete_funO :=
- { compl c x := compl (discrete_fun_chain c x) }.
- Next Obligation. intros ? n c x. apply (conv_compl n (discrete_fun_chain c x)). Qed.
+ { compl c x := compl (discrete_fun_chain c x); bcompl α Hα c x := bcompl Hα (discrete_fun_bchain c x) }.
+ Next Obligation.
+ intros ? α c x. by apply conv_compl.
+ Qed.
+ Next Obligation.
+ intros ? α Hα c β Hβ x. unshelve rewrite conv_bcompl; eauto.
+ Qed.
+ Next Obligation.
+ intros ? α Hα c d β H x. eapply bcompl_ne; intros; simpl; by eapply H.
+ Qed.
Global Instance discrete_fun_inhabited `{∀ x, Inhabited (B x)} : Inhabited discrete_funO :=
populate (λ _, inhabitant).
@@ -1152,66 +1530,68 @@ Section discrete_fun.
Qed.
End discrete_fun.
-Arguments discrete_funO {_} _.
+Arguments discrete_funO {_ _} _.
Notation "A -d> B" :=
- (@discrete_funO A (λ _, B)) (at level 99, B at level 200, right associativity).
+ (@discrete_funO _ A (λ _, B)) (at level 99, B at level 200, right associativity).
-Definition discrete_fun_map {A} {B1 B2 : A → ofeT} (f : ∀ x, B1 x → B2 x)
+Definition discrete_fun_map {SI A} {B1 B2 : A → ofeT SI} (f : ∀ x, B1 x → B2 x)
(g : discrete_fun B1) : discrete_fun B2 := λ x, f _ (g x).
-Lemma discrete_fun_map_ext {A} {B1 B2 : A → ofeT} (f1 f2 : ∀ x, B1 x → B2 x)
+Lemma discrete_fun_map_ext {SI A} {B1 B2 : A → ofeT SI} (f1 f2 : ∀ x, B1 x → B2 x)
(g : discrete_fun B1) :
(∀ x, f1 x (g x) ≡ f2 x (g x)) → discrete_fun_map f1 g ≡ discrete_fun_map f2 g.
Proof. done. Qed.
-Lemma discrete_fun_map_id {A} {B : A → ofeT} (g : discrete_fun B) :
+Lemma discrete_fun_map_id {SI A} {B : A → ofeT SI} (g : discrete_fun B) :
discrete_fun_map (λ _, id) g = g.
Proof. done. Qed.
-Lemma discrete_fun_map_compose {A} {B1 B2 B3 : A → ofeT}
+Lemma discrete_fun_map_compose {SI A} {B1 B2 B3 : A → ofeT SI}
(f1 : ∀ x, B1 x → B2 x) (f2 : ∀ x, B2 x → B3 x) (g : discrete_fun B1) :
discrete_fun_map (λ x, f2 x ∘ f1 x) g = discrete_fun_map f2 (discrete_fun_map f1 g).
Proof. done. Qed.
-Instance discrete_fun_map_ne {A} {B1 B2 : A → ofeT} (f : ∀ x, B1 x → B2 x) n :
+Instance discrete_fun_map_ne {SI A} {B1 B2 : A → ofeT SI} (f : ∀ x, B1 x → B2 x) n :
(∀ x, Proper (dist n ==> dist n) (f x)) →
Proper (dist n ==> dist n) (discrete_fun_map f).
Proof. by intros ? y1 y2 Hy x; rewrite /discrete_fun_map (Hy x). Qed.
-Definition discrete_funO_map {A} {B1 B2 : A → ofeT} (f : discrete_fun (λ x, B1 x -n> B2 x)) :
+Definition discrete_funO_map {SI A} {B1 B2 : A → ofeT SI} (f : discrete_fun (λ x, B1 x -n> B2 x)) :
discrete_funO B1 -n> discrete_funO B2 := OfeMor (discrete_fun_map f).
-Instance discrete_funO_map_ne {A} {B1 B2 : A → ofeT} :
- NonExpansive (@discrete_funO_map A B1 B2).
+Instance discrete_funO_map_ne {SI A} {B1 B2 : A → ofeT SI} :
+ NonExpansive (@discrete_funO_map SI A B1 B2).
Proof. intros n f1 f2 Hf g x; apply Hf. Qed.
-Program Definition discrete_funOF {C} (F : C → oFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := discrete_funO (λ c, oFunctor_car (F c) A B);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := discrete_funO_map (λ c, oFunctor_map (F c) fg)
+Program Definition discrete_funOF {SI C} (F : C → oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := discrete_funO (λ c, oFunctor_car (F c) A B);
+ oFunctor_map A1 A2 B1 B2 fg := discrete_funO_map (λ c, oFunctor_map (F c) fg)
|}.
Next Obligation.
- intros C F A1 ? A2 ? B1 ? B2 ? n ?? g. by apply discrete_funO_map_ne=>?; apply oFunctor_ne.
+ intros SI C F A1 A2 B1 B2 n ?? g. by apply discrete_funO_map_ne=>?; apply oFunctor_ne.
Qed.
Next Obligation.
- intros C F A ? B ? g; simpl. rewrite -{2}(discrete_fun_map_id g).
+ intros SI C F A B g; simpl. rewrite -{2}(discrete_fun_map_id g).
apply discrete_fun_map_ext=> y; apply oFunctor_id.
Qed.
Next Obligation.
- intros C F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f1 f2 f1' f2' g.
+ intros SI C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g.
rewrite /= -discrete_fun_map_compose.
apply discrete_fun_map_ext=>y; apply oFunctor_compose.
Qed.
-Notation "T -d> F" := (@discrete_funOF T%type (λ _, F%OF)) : oFunctor_scope.
+Notation "T -d> F" := (@discrete_funOF _ T%type (λ _, F%OF)) : oFunctor_scope.
-Instance discrete_funOF_contractive {C} (F : C → oFunctor) :
+Instance discrete_funOF_contractive {SI C} (F : C → oFunctor SI) :
(∀ c, oFunctorContractive (F c)) → oFunctorContractive (discrete_funOF F).
Proof.
- intros ? A1 ? A2 ? B1 ? B2 ? n ?? g.
+ intros ? A1 A2 B1 B2 n ?? g.
by apply discrete_funO_map_ne=>c; apply oFunctor_contractive.
Qed.
+
+
(** Constructing isomorphic OFEs *)
-Lemma iso_ofe_mixin {A : ofeT} `{Equiv B, Dist B} (g : B → A)
+Lemma iso_ofe_mixin {SI} {A : ofeT SI} `{Equiv B, Dist SI B} (g : B → A)
(g_equiv : ∀ y1 y2, y1 ≡ y2 ↔ g y1 ≡ g y2)
- (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2) : OfeMixin B.
+ (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2) : OfeMixin SI B.
Proof.
split.
- intros y1 y2. rewrite g_equiv. setoid_rewrite g_dist. apply equiv_dist.
@@ -1219,47 +1599,51 @@ Proof.
+ intros y. by apply g_dist.
+ intros y1 y2. by rewrite !g_dist.
+ intros y1 y2 y3. rewrite !g_dist. intros ??; etrans; eauto.
- - intros n y1 y2. rewrite !g_dist. apply dist_S.
+ - intros n m y1 y2. rewrite !g_dist. intros; eapply dist_le; eauto.
Qed.
Section iso_cofe_subtype.
- Context {A B : ofeT} `{Cofe A} (P : A → Prop) (f : ∀ x, P x → B) (g : B → A).
+ Context {SI} {A B : ofeT SI} `{Cofe SI A} (P : A → Prop) (f : ∀ x, P x → B) (g : B → A).
Context (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2).
Let Hgne : NonExpansive g.
Proof. intros n y1 y2. apply g_dist. Qed.
Existing Instance Hgne.
Context (gf : ∀ x Hx, g (f x Hx) ≡ x).
Context (Hlimit : ∀ c : chain B, P (compl (chain_map g c))).
+ Context (Hblimit : ∀ α (Hα : zero ≺ α) c, P (bcompl Hα (bchain_map g c))).
Program Definition iso_cofe_subtype : Cofe B :=
- {| compl c := f (compl (chain_map g c)) _ |}.
+ {| compl c := f (compl (chain_map g c)) _; bcompl α Hα c := f (bcompl Hα (bchain_map g c)) _ |}.
Next Obligation. apply Hlimit. Qed.
- Next Obligation.
- intros n c; simpl. apply g_dist. by rewrite gf conv_compl.
- Qed.
+ Next Obligation. apply Hblimit. Qed.
+ Next Obligation. intros n c; simpl. apply g_dist. by rewrite gf conv_compl. Qed.
+ Next Obligation. intros α Hα c β Hβ; simpl. apply g_dist. by unshelve rewrite gf conv_bcompl. Qed.
+ Next Obligation. intros α Hα c d β Heq; simpl. apply g_dist. rewrite !gf. apply bcompl_ne. intros ??; simpl; by rewrite Heq. Qed.
+
End iso_cofe_subtype.
-Lemma iso_cofe_subtype' {A B : ofeT} `{Cofe A}
+Lemma iso_cofe_subtype' {SI} {A B : ofeT SI} `{Cofe SI A}
(P : A → Prop) (f : ∀ x, P x → B) (g : B → A)
(Pg : ∀ y, P (g y))
(g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
(gf : ∀ x Hx, g (f x Hx) ≡ x)
- (Hlimit : LimitPreserving P) : Cofe B.
-Proof. apply: (iso_cofe_subtype P f g)=> // c. apply Hlimit=> ?; apply Pg. Qed.
+ (Hlimit : LimitPreserving P)
+ (Hblimit : BoundedLimitPreserving P) : Cofe B.
+Proof. apply: (iso_cofe_subtype P f g)=> //; eauto. Qed.
-Definition iso_cofe {A B : ofeT} `{Cofe A} (f : A → B) (g : B → A)
+Definition iso_cofe {SI} {A B : ofeT SI} `{Cofe SI A} (f : A → B) (g : B → A)
(g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
(gf : ∀ x, g (f x) ≡ x) : Cofe B.
Proof. by apply (iso_cofe_subtype (λ _, True) (λ x _, f x) g). Qed.
(** Sigma *)
Section sigma.
- Context {A : ofeT} {P : A → Prop}.
+ Context {SI} {A : ofeT SI} {P : A → Prop}.
Implicit Types x : sig P.
(* TODO: Find a better place for this Equiv instance. It also
should not depend on A being an OFE. *)
Instance sig_equiv : Equiv (sig P) := λ x1 x2, `x1 ≡ `x2.
- Instance sig_dist : Dist (sig P) := λ n x1 x2, `x1 ≡{n}≡ `x2.
+ Instance sig_dist : Dist SI (sig P) := λ n x1 x2, `x1 ≡{n}≡ `x2.
Definition sig_equiv_alt x y : x ≡ y ↔ `x ≡ `y := reflexivity _.
Definition sig_dist_alt n x y : x ≡{n}≡ y ↔ `x ≡{n}≡ `y := reflexivity _.
@@ -1270,11 +1654,11 @@ Section sigma.
Global Instance proj1_sig_ne : NonExpansive (@proj1_sig _ P).
Proof. by intros n [a Ha] [b Hb] ?. Qed.
- Definition sig_ofe_mixin : OfeMixin (sig P).
+ Definition sig_ofe_mixin : OfeMixin SI (sig P).
Proof. by apply (iso_ofe_mixin proj1_sig). Qed.
- Canonical Structure sigO : ofeT := OfeT (sig P) sig_ofe_mixin.
+ Canonical Structure sigO : ofeT SI := OfeT (sig P) sig_ofe_mixin.
- Global Instance sig_cofe `{Cofe A, !LimitPreserving P} : Cofe sigO.
+ Global Instance sig_cofe `{Cofe SI A, !LimitPreserving P, !BoundedLimitPreserving P} : Cofe sigO.
Proof. apply (iso_cofe_subtype' P (exist P) proj1_sig)=> //. by intros []. Qed.
Global Instance sig_discrete (x : sig P) : Discrete (`x) → Discrete x.
@@ -1283,14 +1667,14 @@ Section sigma.
Proof. intros ??. apply _. Qed.
End sigma.
-Arguments sigO {_} _.
+Arguments sigO {_ _} _.
(** Ofe for [sigT]. The first component must be discrete
and use Leibniz equality, while the second component might be any OFE. *)
Section sigT.
Import EqNotations.
- Context {A : Type} {P : A → ofeT}.
+ Context {SI} {A : Type} {P : A → ofeT SI}.
Implicit Types x : sigT P.
(**
@@ -1300,7 +1684,7 @@ Section sigT.
Unlike in the topos of trees, with (C)OFEs we cannot use step-indexed equality
on the first component.
*)
- Instance sigT_dist : Dist (sigT P) := λ n x1 x2,
+ Instance sigT_dist : Dist SI (sigT P) := λ n x1 x2,
∃ Heq : projT1 x1 = projT1 x2, rew Heq in projT2 x1 ≡{n}≡ projT2 x2.
(**
@@ -1323,9 +1707,9 @@ Section sigT.
reflexivity _.
Definition sigT_dist_proj1 n {x y} : x ≡{n}≡ y → projT1 x = projT1 y := proj1_ex.
- Definition sigT_equiv_proj1 {x y} : x ≡ y → projT1 x = projT1 y := λ H, proj1_ex (H 0).
+ Definition sigT_equiv_proj1 {x y} : x ≡ y → projT1 x = projT1 y := λ H, proj1_ex (H zero).
- Definition sigT_ofe_mixin : OfeMixin (sigT P).
+ Definition sigT_ofe_mixin : OfeMixin SI (sigT P).
Proof.
split => // n.
- split; hnf; setoid_rewrite sigT_dist_eq.
@@ -1336,28 +1720,28 @@ Section sigT.
destruct 1 as [-> Heq1].
destruct 1 as [-> Heq2]. exists eq_refl => /=. by trans y.
- setoid_rewrite sigT_dist_eq.
- move => [xa x] [ya y] /=. destruct 1 as [-> Heq].
- exists eq_refl. exact: dist_S.
+ move => β [xa x] [ya y] /=. destruct 1 as [-> Heq].
+ exists eq_refl. by eapply dist_dist_later.
Qed.
- Canonical Structure sigTO : ofeT := OfeT (sigT P) sigT_ofe_mixin.
+ Canonical Structure sigTO : ofeT SI := OfeT (sigT P) sigT_ofe_mixin.
Lemma sigT_equiv_eq_alt `{!∀ a b : A, ProofIrrel (a = b)} x1 x2 :
x1 ≡ x2 ↔
∃ Heq : projT1 x1 = projT1 x2, rew Heq in projT2 x1 ≡ projT2 x2.
Proof.
- setoid_rewrite equiv_dist; setoid_rewrite sigT_dist_eq; split => Heq.
- - move: (Heq 0) => [H0eq1 _].
+ setoid_rewrite equiv_dist. setoid_rewrite sigT_dist_eq. split => Heq.
+ - move: (Heq zero) => [H0eq1 _].
exists H0eq1 => n. move: (Heq n) => [] Hneq1.
by rewrite (proof_irrel H0eq1 Hneq1).
- move: Heq => [Heq1 Heqn2] n. by exists Heq1.
Qed.
(** [projT1] is non-expansive and proper. *)
- Global Instance projT1_ne : NonExpansive (projT1 : sigTO → leibnizO A).
+ Global Instance projT1_ne : NonExpansive (projT1 : sigTO → leibnizO SI A).
Proof. solve_proper. Qed.
- Global Instance projT1_proper : Proper ((≡) ==> (≡)) (projT1 : sigTO → leibnizO A).
+ Global Instance projT1_proper : Proper ((≡) ==> (≡)) (projT1 : sigTO → leibnizO SI A).
Proof. apply ne_proper, projT1_ne. Qed.
(** [projT2] is "non-expansive"; the properness lemma [projT2_ne] requires UIP. *)
@@ -1402,8 +1786,11 @@ Section sigT.
Global Instance sigT_ofe_discrete : (∀ a, OfeDiscrete (P a)) → OfeDiscrete sigTO.
Proof. intros ??. apply _. Qed.
- Lemma sigT_chain_const_proj1 c n : projT1 (c n) = projT1 (c 0).
- Proof. refine (sigT_dist_proj1 _ (chain_cauchy c 0 n _)). lia. Qed.
+ Lemma sigT_chain_const_proj1 c n : projT1 (c n) = projT1 (c zero).
+ Proof. refine (sigT_dist_proj1 _ (chain_cauchy' c zero n _)). apply index_zero_minimum. Qed.
+
+ Lemma sigT_bchain_const_proj1 α Hα (c: bchain sigTO α) n Hn: projT1 (c n Hn) = projT1 (c zero Hα).
+ Proof. refine (sigT_dist_proj1 _ (bchain_cauchy' α c zero n _ _ _)). apply index_zero_minimum. Qed.
(* For this COFE construction we need UIP (Uniqueness of Identity Proofs)
on [A] (i.e. [∀ x y : A, ProofIrrel (x = y)]. UIP is most commonly obtained
@@ -1412,25 +1799,44 @@ Section sigT.
Section cofe.
Context `{!∀ a b : A, ProofIrrel (a = b)} `{!∀ a, Cofe (P a)}.
- Program Definition chain_map_snd c : chain (P (projT1 (c 0))) :=
+ Program Definition chain_map_snd c : chain (P (projT1 (c zero))) :=
{| chain_car n := rew (sigT_chain_const_proj1 c n) in projT2 (c n) |}.
Next Obligation.
move => c n i Hle /=.
(* [Hgoal] is our thesis, up to casts: *)
- case: (chain_cauchy c n i Hle) => [Heqin Hgoal] /=.
- (* Pretty delicate. We have two casts to [projT1 (c 0)].
+ case: (chain_cauchy' c n i Hle) => [Heqin Hgoal] /=.
+ (* Pretty delicate. We have two casts to [projT1 (c zero)].
We replace those by one cast. *)
move: (sigT_chain_const_proj1 c i) (sigT_chain_const_proj1 c n)
=> Heqi0 Heqn0.
- (* Rewrite [projT1 (c 0)] to [projT1 (c n)] in goal and [Heqi0]: *)
+ (* Rewrite [projT1 (c zero)] to [projT1 (c n)] in goal and [Heqi0]: *)
destruct Heqn0.
by rewrite /= (proof_irrel Heqi0 Heqin).
Qed.
- Definition sigT_compl : Compl sigTO :=
- λ c, existT (projT1 (chain_car c 0)) (compl (chain_map_snd c)).
+ Definition sigT_compl : chain sigTO → sigTO :=
+ λ c, existT (projT1 (c zero)) (compl (chain_map_snd c)).
+
+ Program Definition bchain_map_snd α Hα (c: bchain sigTO α): bchain (P (projT1 (c zero Hα))) α :=
+ {| bchain_car n Hn := rew (sigT_bchain_const_proj1 α Hα c n Hn) in projT2 (c n Hn) |}.
+ Next Obligation.
+ move => α Hα c β γ Hle Hβ Hγ /=.
+ (* [Hgoal] is our thesis, up to casts: *)
+ case: (bchain_cauchy' α c β γ Hβ Hγ Hle) => [Heqin Hgoal] /=.
+ (* Pretty delicate. We have two casts to [projT1 (c zero)].
+ We replace those by one cast. *)
+ move: (sigT_bchain_const_proj1 α Hα c β Hβ ) (sigT_bchain_const_proj1 α Hα c γ Hγ)
+ => Heqβ0 Heqγ0.
+ (* Rewrite [projT1 (c zero)] to [projT1 (c n)] in goal and [Heqi0]: *)
+ destruct Heqβ0.
+ by rewrite /= (proof_irrel Heqγ0 Heqin).
+ Qed.
+
+ Definition sigT_bcompl α (Hα: zero ≺ α) (c: bchain sigTO α): sigTO :=
+ existT (projT1 (c zero Hα)) (bcompl Hα (bchain_map_snd α Hα c)).
- Global Program Instance sigT_cofe : Cofe sigTO := { compl := sigT_compl }.
+
+ Global Program Instance sigT_cofe : Cofe sigTO := { compl := sigT_compl; bcompl := sigT_bcompl }.
Next Obligation.
intros n c. rewrite /sigT_compl sigT_dist_eq /=.
exists (symmetry (sigT_chain_const_proj1 c n)).
@@ -1439,15 +1845,35 @@ Section sigT.
move: (compl (chain_map_snd c)) Hgoal => pc0 /=.
destruct (sigT_chain_const_proj1 c n); simpl. done.
Qed.
+ Next Obligation.
+ intros α Hα c β Hβ. rewrite /sigT_bcompl sigT_dist_eq /=.
+ exists (symmetry (sigT_bchain_const_proj1 α Hα c β Hβ)).
+ (* Our thesis, up to casts: *)
+ pose proof (conv_bcompl α Hα (bchain_map_snd α Hα c) β Hβ) as Hgoal.
+ move: (bcompl Hα (bchain_map_snd α Hα c)) Hgoal => pc0 /=.
+ destruct (sigT_bchain_const_proj1 α Hα c β Hβ); simpl. done.
+ Qed.
+ Next Obligation.
+ intros α Hα c d β Heq; rewrite /sigT_bcompl sigT_dist_eq /=.
+ destruct (Heq zero Hα) as [eq Ht]. exists eq; simpl.
+ enough (bcompl Hα (rew [λ x : A, bchain (P x) α] eq in bchain_map_snd α Hα c) ≡{β}≡ bcompl Hα (bchain_map_snd α Hα d)) as Hbcompl.
+ { rewrite <-Hbcompl. clear Ht Hbcompl. by destruct eq. }
+ apply bcompl_ne; simpl. intros γ Hγ. destruct (Heq γ Hγ) as [eq' H'].
+ rewrite <-(@map_subst _ (λ y, bchain (P y) α) P (λ y d, d γ Hγ) _ _ eq); simpl.
+ rewrite rew_compose. revert H'.
+ move: (sigT_bchain_const_proj1 α Hα d γ Hγ) (eq_trans (sigT_bchain_const_proj1 α Hα c γ Hγ) eq) => e1 e2.
+ destruct e1; simpl. intros <-.
+ by rewrite /= (proof_irrel e2 eq').
+ Qed.
End cofe.
End sigT.
-Arguments sigTO {_} _.
+Arguments sigTO {_ _} _.
Section sigTOF.
- Context {A : Type}.
+ Context {SI: indexT} {A : Type}.
- Program Definition sigT_map {P1 P2 : A → ofeT} :
+ Program Definition sigT_map {P1 P2 : A → ofeT SI} :
discrete_funO (λ a, P1 a -n> P2 a) -n>
sigTO P1 -n> sigTO P2 :=
λne f xpx, existT _ (f _ (projT2 xpx)).
@@ -1459,9 +1885,9 @@ Section sigTOF.
move => ?? n f g Heq [x px] /=. exists eq_refl => /=. apply Heq.
Qed.
- Program Definition sigTOF (F : A → oFunctor) : oFunctor := {|
- oFunctor_car A CA B CB := sigTO (λ a, oFunctor_car (F a) A _ B CB);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := sigT_map (λ a, oFunctor_map (F a) fg)
+ Program Definition sigTOF (F : A → oFunctor SI) : oFunctor SI := {|
+ oFunctor_car A B := sigTO (λ a, oFunctor_car (F a) A B);
+ oFunctor_map A1 A2 B1 B2 fg := sigT_map (λ a, oFunctor_map (F a) fg)
|}.
Next Obligation.
repeat intro. exists eq_refl => /=. solve_proper.
@@ -1479,11 +1905,539 @@ Section sigTOF.
repeat intro. apply sigT_map => a. exact: oFunctor_contractive.
Qed.
End sigTOF.
-Arguments sigTOF {_} _%OF.
+Arguments sigTOF {_ _} _%OF.
(*
FIXME: Notation disabled because it causes strange conflicts in Coq 8.7.
Enable again once we drop support for that version.
Notation "{ x & P }" := (sigTOF (λ x, P%OF)) : oFunctor_scope.
Notation "{ x : A & P }" := (@sigTOF A%type (λ x, P%OF)) : oFunctor_scope.
+<<<<<<< HEAD
+*)
+
+(** different notions of limit uniqueness *)
+Class BcomplStronglyUnique {SI : indexT} (A : ofeT SI) `{Cofe SI A} :=
+ cofe_strongly_unique (α : SI) Hα (c d : bchain A α) :
+ (∀ β (Hβ : β ≺ α), c β Hβ ≡{β}≡ d β Hβ) → bcompl Hα c ≡ bcompl Hα d.
+Hint Mode BcomplStronglyUnique - + + : typeclass_instances.
+
+Class BcomplUnique {SI : indexT} (A : ofeT SI) `{Cofe SI A} :=
+ cofe_unique (α : SI) Hα (c d : bchain A α) :
+ (∀ β (Hβ : β ≺ α), c β Hβ ≡{β}≡ d β Hβ) → bcompl Hα c ≡{α}≡ bcompl Hα d.
+Hint Mode BcomplUnique - + + : typeclass_instances.
+
+Class BcomplUniqueLim {SI : indexT} (A : ofeT SI) `{Cofe SI A} :=
+ cofe_unique_lim (α : SI) (αlim : index_is_limit α) Hα (c d : bchain A α) :
+ (∀ β (Hβ : β ≺ α), c β Hβ ≡{β}≡ d β Hβ) → bcompl Hα c ≡{α}≡ bcompl Hα d.
+Hint Mode BcomplUniqueLim - + + : typeclass_instances.
+
+Instance unique_unique_lim {SI : indexT} (A : ofeT SI) `{Cofe SI A} (H1 : BcomplUnique A) :
+ BcomplUniqueLim A.
+Proof. intros α _. apply H1. Qed.
+
+(** OFEs truncated at a stepindex α*)
+(* Equality at ordinals above α is fully determined by equality at α *)
+Class Truncated {SI : indexT} {A : ofeT SI} (α : SI) (x : A) := truncated y β: α ⪯ β → x ≡{α}≡ y ↔ x ≡{β}≡ y.
+Arguments truncated {_ _} _ _ {_ } _ _ _.
+Hint Mode Truncated - + ! ! : typeclass_instances.
+Instance : Params (@Truncated) 2 := {}.
+
+Class OfeTruncated {SI : indexT} (A : ofeT SI) (α : SI) := ofe_truncated_truncated (x : A) :> Truncated α x.
+Hint Mode OfeTruncated - + - : typeclass_instances.
+Arguments OfeTruncated {_} _ _.
+
+Lemma ofe_truncated_equiv {SI : indexT} (A : ofeT SI) (α : SI) {H : OfeTruncated A α} :
+ ∀ (x y : A), x ≡ y ↔ x ≡{α}≡ y.
+Proof.
+ intros x y. rewrite equiv_dist. split.
+ - intros Hall. by apply Hall.
+ - intros Hα β. destruct (index_le_total α β) as [He | He].
+ + by apply ofe_truncated_truncated.
+ + by eapply dist_mono'.
+Qed.
+
+Lemma ofe_truncated_dist {SI : indexT} (A : ofeT SI) (α : SI) {H : OfeTruncated A α}:
+ ∀ (x y : A) β, x ≡{β}≡ y ↔ x ≡{index_min β α}≡ y.
+Proof.
+ intros x y β. split; intros Heq.
+ - eapply dist_mono'; [apply Heq | eapply index_min_le_l].
+ - unfold index_min in Heq. destruct (index_le_total β α) as [H1 | H1]. 1: apply Heq.
+ by eapply H.
+Qed.
+
+Instance discrete_is_truncated {SI : indexT} (A : ofeT SI) (α : SI) (H: OfeDiscrete A) : OfeTruncated A α.
+Proof.
+ intros x y β Hα. split; intros H0.
+ all: apply equiv_dist, ofe_discrete_discrete; (eapply dist_mono'; [apply H0 | apply index_zero_minimum]).
+Qed.
+
+Instance ofe_mor_truncated {SI: indexT} {A B : ofeT SI} α {H : OfeTruncated B α} : OfeTruncated (A -n> B) α.
+Proof.
+ intros f g β Hβ. split; intros Heq x.
+ - apply ofe_truncated_truncated; auto.
+ - rewrite ofe_truncated_truncated; eauto.
+Qed.
+
+(** Truncatable OFEs -- an OFE A is truncatable if, for every ordinal α, it admits a truncation [A]_{α} (again an OFE)
+ and a bounded isomorphism (equality up to α) between A and [A]_{α}
*)
+Definition boundedInverse {SI: indexT} {X1 X2: ofeT SI} (f : X2 -n> X1) (g : X1 -n> X2) (α : SI) :=
+ f ◎ g ≡{α}≡ cid ∧ g ◎ f ≡{α}≡ cid.
+Lemma boundedInverse_antimono {SI : indexT} {X1 X2 : ofeT SI} (f : X2 -n> X1) (g : X1 -n> X2) (α β : SI) :
+ α ⪯ β → boundedInverse f g β → boundedInverse f g α.
+Proof. intros Hle [H1 H2]. split; eapply dist_mono'; eauto. Qed.
+
+Class Truncatable {SI : indexT} (A : ofeT SI):=
+ {
+ ofe_trunc_car (α : SI) : ofeT SI;
+ ofe_trunc_truncated (α : SI) : OfeTruncated (ofe_trunc_car α) α;
+ ofe_trunc_truncate (α : SI) : A -n> ofe_trunc_car α;
+ ofe_trunc_expand (α : SI) : ofe_trunc_car α -n> A;
+ ofe_trunc_inverse (α : SI) : boundedInverse (ofe_trunc_truncate α) (ofe_trunc_expand α) α;
+ }.
+Hint Mode Truncatable - - : typeclass_instances.
+Arguments ofe_trunc_car {_ _ _} _.
+
+(* FIXME: when printing, usually A is implicit (inferred from the Truncatable instance) and an underscore is printed.
+ can we force Coq to infer & print the implicit argument ?*)
+Notation "'[' A ']_{' α '}'" := (@ofe_trunc_car _ A _ α) (only parsing).
+Notation "'⌊' a '⌋_{' α '}'" := (ofe_trunc_truncate α a) (format "'⌊' a '⌋_{' α '}'").
+Notation "'⌈' a '⌉_{' α '}'" := (ofe_trunc_expand α a) (format "'⌈' a '⌉_{' α '}'").
+
+Section truncatable_props.
+ Context {SI : indexT} {A : ofeT SI} {Htrunc : Truncatable A}.
+ Lemma ofe_trunc_truncate_expand_id {α} :
+ ofe_trunc_truncate α ◎ ofe_trunc_expand α ≡ cid.
+ Proof. intros x. cbn. eapply ofe_truncated_equiv. apply Htrunc. apply ofe_trunc_inverse. Qed.
+
+ Lemma ofe_trunc_expand_truncate_id {α} : ofe_trunc_expand α ◎ ofe_trunc_truncate α ≡{α}≡ cid.
+ Proof. apply ofe_trunc_inverse. Qed.
+
+ Global Instance Truncatable_truncated (α : SI) : OfeTruncated (ofe_trunc_car (A := A) α) α
+ := (@ofe_trunc_truncated _ A _ α).
+
+ Section truncatable_cofe.
+ Context (γ: SI) {Ha : Cofe A}.
+
+ Program Definition trunc_chain (c : chain ([A]_{γ})) : chain A :=
+ mkchain _ A (λ α, ofe_trunc_expand γ (c α)) _.
+ Next Obligation. intros c α' β Hle. cbn. by rewrite (chain_cauchy _ c α' β Hle). Qed.
+ Program Definition trunc_bchain β (c : bchain ([A]_{γ}) β) : bchain A β :=
+ mkbchain _ A β (λ γ' Hγ', ofe_trunc_expand γ (c γ' Hγ')) _.
+ Next Obligation. intros β c β' γ' Hle Hβ Hγ'. cbn. f_equiv. by apply bchain_cauchy. Qed.
+
+ Global Program Instance Truncatable_cofe : Cofe ([A]_{γ}) :=
+ {
+ compl c := ⌊compl (trunc_chain c)⌋_{γ};
+ bcompl β Hβ c := ⌊bcompl Hβ (trunc_bchain β c)⌋_{γ};
+ }.
+ Next Obligation.
+ intros α' c. cbn.
+ rewrite ofe_truncated_dist.
+ setoid_rewrite (dist_mono' _ _ _ _ (conv_compl α' _)). 2: apply index_min_le_l.
+ cbn. eapply dist_mono'.
+ - apply equiv_dist, ofe_trunc_truncate_expand_id.
+ - apply index_min_le_r.
+ Qed.
+ Next Obligation.
+ intros α' Hα' c β Hβ. cbn. rewrite ofe_truncated_dist.
+ unshelve setoid_rewrite (dist_mono' _ _ _ _ (conv_bcompl _ _ _ β Hβ)). 2: apply index_min_le_l.
+ cbn. eapply dist_mono'.
+ - apply equiv_dist, ofe_trunc_truncate_expand_id.
+ - apply index_min_le_r.
+ Qed.
+ Next Obligation.
+ intros α' Hα' c d β Heq. cbn. f_equiv.
+ apply bcompl_ne. intros γ' Hγ'. cbn. by f_equiv.
+ Qed.
+
+ Global Instance Truncatable_unique {H : BcomplUnique A}: BcomplUnique ([A]_{γ}).
+ Proof.
+ intros β Hβ c d Heq. unfold bcompl, Truncatable_cofe.
+ f_equiv. apply H. intros β' Hβ'. cbn. apply ofe_mor_ne, Heq.
+ Qed.
+
+ Global Instance Truncatable_unique_lim {H : BcomplUniqueLim A}: BcomplUniqueLim ([A]_{γ}).
+ Proof.
+ intros β Hlim Hβ c d Heq. unfold bcompl, Truncatable_cofe.
+ f_equiv. apply H. assumption.
+ intros β' Hβ'. cbn. by f_equiv.
+ Qed.
+
+ Global Instance Truncatable_strongly_unique {H : BcomplStronglyUnique A}: BcomplStronglyUnique ([A]_{γ}).
+ Proof.
+ intros β Hβ c d Heq. unfold bcompl, Truncatable_cofe. f_equiv.
+ apply H. intros β' Hβ'. cbn. apply ofe_mor_ne, Heq.
+ Qed.
+ End truncatable_cofe.
+End truncatable_props.
+
+Section truncatable.
+ Context {SI : indexT} .
+
+ Program Definition trunc_map {A : ofeT SI} {HtruncA : Truncatable A} {B : ofeT SI} {HtruncB : Truncatable B}
+ (α β : SI) : (A -n> B) -n> ([A]_{α} -n> [B]_{β}) := λne f, ofe_trunc_truncate β ◎ f ◎ ofe_trunc_expand α.
+ Next Obligation.
+ intros A HtrucA B HtruncB α β γ f g Heq.
+ apply ccompose_ne; [ | reflexivity ]. apply ccompose_ne; auto.
+ Qed.
+
+ Context {A : ofeT SI} {HtruncA : Truncatable A}.
+ Context {B : ofeT SI} {HtruncB : Truncatable B}.
+ Lemma trunc_map_inv (f : A -n> B) (g : B -n> A) α β:
+ α ⪯ β → boundedInverse f g α → boundedInverse (trunc_map α β f) (trunc_map β α g) α.
+ Proof.
+ intros Hle [H1 H2]. split; intros x.
+ - unfold trunc_map. cbn.
+ rewrite ofe_truncated_dist.
+ rewrite ofe_mor_ne. 2: { eapply dist_mono'. 2: apply index_min_le_l.
+ setoid_rewrite (ofe_trunc_expand_truncate_id _). apply H1.
+ }
+ cbn. apply equiv_dist, ofe_trunc_truncate_expand_id.
+ - cbn. rewrite ofe_mor_ne.
+ 2: { rewrite ofe_mor_ne. 2: { eapply dist_mono'. setoid_rewrite (ofe_trunc_expand_truncate_id _). cbn. all: eauto. }
+ apply H2.
+ }
+ apply equiv_dist, ofe_trunc_truncate_expand_id.
+ Qed.
+
+ Context {C : ofeT SI} {HtruncC : Truncatable C}.
+ Lemma trunc_map_compose (f : A -n> B) (g : B -n> C) α β γ :
+ trunc_map α β (g ◎ f) ≡{γ}≡ trunc_map γ β g ◎ trunc_map α γ f.
+ Proof.
+ cbn. setoid_rewrite ccompose_assoc at 2. setoid_rewrite (proj1 (equiv_dist _ _) (ccompose_assoc _ _ _)) at 3.
+ setoid_rewrite <- (proj1 (equiv_dist _ _) (ccompose_assoc _ _ _)) at 3.
+ setoid_rewrite (dist_mono' _ _ _ _ (ofe_trunc_expand_truncate_id)); [ | auto].
+ by intros x.
+ Qed.
+End truncatable.
+
+
+(** a more elementary property than Truncatable. Essentially, proto_trunc α chooses a unique representative of each equivalence class of ≡{α}≡ *)
+Class ProtoTruncatable {SI : indexT} (A : ofeT SI) :=
+ {
+ proto_trunc α : A -n> A;
+ proto_compat α (x y : A) : x ≡{α}≡ y → proto_trunc α x ≡ proto_trunc α y;
+ proto_ne α x : proto_trunc α x ≡{α}≡ x;
+ }.
+Hint Mode ProtoTruncatable - + : typeclass_instances.
+
+Section strict_is_proto.
+ Context {SI : indexT} (A : ofeT SI) `{Cofe SI A} {Hstrong : BcomplStronglyUnique A}.
+ Program Instance StronglyUnique_ProtoTruncatable : ProtoTruncatable A :=
+ {
+ proto_trunc α := λne a, bcompl (α := succ α) _ (bchain_const a (succ α));
+ }.
+ Next Obligation.
+ intros α _. apply index_succ_iff, index_zero_minimum.
+ Qed.
+ Next Obligation.
+ intros α α' x y Heq.
+ destruct (index_le_lt_dec α' α) as [Hle | Hlt].
+ - unshelve rewrite !conv_bcompl. 1-2: eapply index_succ_iff, Hle. apply Heq.
+ - apply equiv_dist. eapply Hstrong. intros β Hβ; cbn.
+ eapply dist_mono. exact Heq. eapply index_lt_le_trans. apply Hβ. eauto with index.
+ Qed.
+ Next Obligation.
+ intros α x y Heq. cbn. apply Hstrong. intros β Hβ. cbn. eapply dist_mono'; eauto with index.
+ Qed.
+ Next Obligation.
+ intros α x. cbn. unshelve rewrite conv_bcompl. apply index_succ_greater. reflexivity.
+ Qed.
+End strict_is_proto.
+
+Section proto.
+ Context {SI : indexT} (A : ofeT SI) {Hcofe : Cofe A} {Htrunc : ProtoTruncatable A}.
+
+ (** basic facts about proto truncatability *)
+ Fact proto_trunc_idempotent (a : A) α: proto_trunc α (proto_trunc α a) ≡ proto_trunc α a.
+ Proof. apply proto_compat. apply proto_ne. Qed.
+
+ Lemma proto_trunc_dist_min (a b : A) α γ : a ≡{index_min α γ}≡ b → proto_trunc α a ≡{γ}≡ proto_trunc α b.
+ Proof.
+ intros H. unfold index_min in H. destruct (index_le_total α γ) as [Hle | Hgt].
+ - eapply equiv_dist, proto_compat, H.
+ - apply ofe_mor_ne, H.
+ Qed.
+
+ (** we can also get that ProtoTruncatability implies strong uniqueness of limits,
+ if we assume the weaker uniqueness of limits*)
+ Program Instance strict_cofe' : Cofe A :=
+ { compl := @compl SI A _;
+ bcompl α Hα c := proto_trunc α (bcompl Hα c) ;
+ }.
+ Next Obligation. apply conv_compl. Qed.
+ Next Obligation.
+ intros α Hα c β Hβ. cbn. rewrite (dist_mono _ _ _ _ (proto_ne _ _)). by apply conv_bcompl. apply Hβ.
+ Qed.
+ Next Obligation.
+ intros α Hα c d β Heq. cbn.
+ unshelve eapply bcompl_ne in Heq. exact Hα.
+ rewrite ofe_mor_ne. 2: apply Heq. reflexivity.
+ Qed.
+
+ Instance ProtoTruncatable_StronglyUnique (Hunique : @BcomplUnique _ A Hcofe):
+ @BcomplStronglyUnique _ A strict_cofe'.
+ Proof.
+ intros α Hα c d H1. unfold strict_cofe', bcompl. apply proto_compat.
+ unfold BcomplUnique in Hunique. apply (Hunique α Hα c d H1).
+ Qed.
+End proto.
+
+Section strict_lim.
+ (** we can prove that Truncatability implies strong uniqueness of limits given that we have unique limits *)
+ Context {SI : indexT} (A : ofeT SI) `{Cofe SI A}
+ (Htrunc : Truncatable A) (Hun : ∀ α, BcomplUnique (ofe_trunc_car α)).
+
+ Program Definition strict_bcompl α (Hα : zero ≺ α) (c : bchain A α) :=
+ ⌈bcompl Hα (mkbchain SI ([A]_{α}) α (λ β Hβ, ⌊c β Hβ⌋_{α}) _)⌉_{α}.
+ Next Obligation.
+ intros α Hα c β γ Hβ Hlt Hγ. cbn. apply ofe_mor_ne. by apply bchain_cauchy.
+ Qed.
+
+ Program Instance strict_cofe : Cofe A :=
+ { compl := @compl SI A _;
+ bcompl := strict_bcompl;
+ }.
+ Next Obligation. apply conv_compl. Qed.
+ Next Obligation.
+ intros α Hα c β Hβ. unfold strict_bcompl.
+ rewrite ofe_mor_ne. 2: { rewrite conv_bcompl. cbn. reflexivity. }
+ setoid_rewrite (dist_mono _ _ _ _ (ofe_trunc_expand_truncate_id _)). 2: apply Hβ.
+ cbn. reflexivity.
+ Qed.
+ Next Obligation.
+ intros α Hα c d β Heq. unfold strict_bcompl.
+ f_equiv. rewrite ofe_truncated_dist.
+ apply bcompl_ne. intros γ Hγ. cbn.
+ f_equiv. eapply dist_mono'. apply Heq. apply index_min_le_l.
+ Qed.
+
+ Instance Truncatable_StronglyUnique : @BcomplStronglyUnique _ A strict_cofe.
+ Proof using Hun.
+ intros α Hα c d H1. unfold strict_cofe, bcompl. unfold strict_bcompl.
+ apply ne_proper. apply _. rewrite ofe_truncated_equiv.
+ apply Hun. intros γ Hγ. cbn. f_equiv. apply H1.
+ Qed.
+End strict_lim.
+
+(** We show that ProtoTruncatable implies Truncatable *)
+(* For defining the truncated types, we wrap the OFE A in an inductive in order to not confuse typeclass inference when defining a different equivalence on it. *)
+Inductive trunc_truncation {SI : indexT} (A : ofeT SI) (β : SI) := trunc_truncationC (a : A).
+Section proto_truncatable.
+ Context {SI : indexT} (A : ofeT SI) (Htrunc : ProtoTruncatable A).
+
+ Section trunc_def.
+ Context (α : SI).
+ Local Definition truncembed (a : trunc_truncation A α): A := match a with trunc_truncationC _ _ a => a end.
+
+ Instance trunc_truncation_equiv : Equiv (trunc_truncation A α) := λ a b, proto_trunc α (truncembed a) ≡ proto_trunc α (truncembed b).
+ Lemma trunc_truncation_equiv_unfold a b : a ≡ b ↔ proto_trunc α (truncembed a) ≡ proto_trunc α (truncembed b).
+ Proof. tauto. Qed.
+
+ Instance trunc_truncation_dist : Dist SI (trunc_truncation A α) :=
+ λ n a b, proto_trunc α (truncembed a) ≡{n}≡ proto_trunc α (truncembed b).
+
+ Lemma trunc_truncation_dist_unfold a b n : a ≡{n}≡ b ↔ proto_trunc α (truncembed a) ≡{n}≡ proto_trunc α (truncembed b).
+ Proof. tauto. Qed.
+
+ Definition trunc_truncation_ofe_mixin : OfeMixin SI (trunc_truncation A α).
+ Proof.
+ split.
+ - setoid_rewrite trunc_truncation_dist_unfold. setoid_rewrite trunc_truncation_equiv_unfold.
+ intros x y. split; intros H.
+ + intros β. by apply equiv_dist.
+ + apply equiv_dist. intros γ. apply (H γ).
+ - intros α'. unfold dist, trunc_truncation_dist. split; auto.
+ intros a b c -> ->. auto.
+ - setoid_rewrite trunc_truncation_dist_unfold. intros α' β x y Heq Hlt. eauto using dist_mono.
+ Qed.
+ Canonical Structure tcar_truncO : ofeT SI := OfeT (trunc_truncation A α) trunc_truncation_ofe_mixin.
+
+ Program Definition tcar_trunc : A -n> tcar_truncO := λne a, trunc_truncationC A α a.
+ Next Obligation.
+ intros β x y. rewrite trunc_truncation_dist_unfold; cbn. intros Heq.
+ by apply ofe_mor_ne.
+ Qed.
+
+ Program Definition tcar_embed : tcar_truncO -n> A := λne a, proto_trunc α (truncembed a).
+ Next Obligation.
+ intros β [x] [y]. rewrite trunc_truncation_dist_unfold; cbn. auto.
+ Qed.
+
+ Lemma tcar_trunc_embed_inv : boundedInverse tcar_trunc tcar_embed α.
+ Proof.
+ split.
+ - intros x. rewrite trunc_truncation_dist_unfold. cbn. destruct x. cbn.
+ apply equiv_dist. apply proto_trunc_idempotent.
+ - intros x. cbn. apply proto_ne.
+ Qed.
+ End trunc_def.
+
+ Global Program Instance ProtoTruncatable_is_Truncatable : Truncatable A :=
+ {
+ ofe_trunc_car α := tcar_truncO α;
+ ofe_trunc_expand α := tcar_embed α;
+ ofe_trunc_truncate α := tcar_trunc α;
+ }.
+ Next Obligation.
+ intros α x y β Hle. split.
+ - rewrite !trunc_truncation_dist_unfold. destruct x, y. cbn. intros H. apply equiv_dist. apply proto_compat.
+ rewrite <- proto_ne. setoid_rewrite <- proto_ne at 3. apply H.
+ - intros H. eapply dist_mono'. apply H. apply Hle.
+ Qed.
+ Next Obligation.
+ intros α. apply tcar_trunc_embed_inv.
+ Qed.
+ Global Opaque ProtoTruncatable_is_Truncatable.
+End proto_truncatable.
+
+(** We can show that every OFE is truncatable and every COFE can be equipped with strongly unique limits, using classical logic with choice. *)
+Require Coq.Logic.Epsilon.
+Require Coq.Logic.Classical.
+Require Coq.Logic.FunctionalExtensionality.
+Require Coq.Logic.PropExtensionality.
+Section classical_truncation.
+ Context {SI : indexT}.
+ Context (A : ofeT SI).
+
+ (** First we show that we can get a "truncation" operation for arbitrary decidable equivalence relations.
+ We later instantiate this with dist and dist_later *)
+ Section fix_alpha.
+ Context (P : A → A → Prop).
+ Import Epsilon.
+ Lemma binary_choice (X : Prop) : (X ∨ ~X) → {X} + {~ X}.
+ Proof.
+ intros H.
+ assert (H0: exists (b : bool), if b then X else ¬ X).
+ { destruct H as [H | H]. by exists true. by exists false. }
+ apply constructive_indefinite_description in H0 as [[] H0]; auto.
+ Qed.
+
+ Context (Pdec : ∀ a b, {P a b} + {¬ P a b}).
+ Context {P_equiv : Equivalence P}.
+ Existing Instance P_equiv.
+
+ Definition choice_fun (a : A) := λ (b : A), if Pdec a b then true else false.
+
+ Import FunctionalExtensionality.
+ Lemma choice_fun_ext (a b : A) : P a b → choice_fun a = choice_fun b.
+ Proof using P_equiv.
+ intros H. apply functional_extensionality.
+ intros x. unfold choice_fun.
+ destruct (Pdec a x) as [H1 | H1], (Pdec b x) as [H2 | H2]; try reflexivity; exfalso.
+ - apply H2. etransitivity. symmetry; exact H. exact H1.
+ - apply H1. etransitivity; eauto.
+ Qed.
+
+ Lemma choice_fun_exists (a : A) : ∃ b, choice_fun a b = true.
+ Proof using P_equiv.
+ exists a. unfold choice_fun. destruct Pdec as [ | H1]; [reflexivity | exfalso; apply H1; reflexivity].
+ Qed.
+
+ Definition choose_witness (a : A) := proj1_sig (constructive_indefinite_description _ (choice_fun_exists a)).
+ Lemma witness_P (a : A) : P a (choose_witness a).
+ Proof.
+ assert (choice_fun a (choose_witness a) = true).
+ { apply (proj2_sig (constructive_indefinite_description _ (choice_fun_exists a))). }
+ unfold choice_fun in H.
+ destruct Pdec as [H1 | H1]. assumption. congruence.
+ Qed.
+
+ Import PropExtensionality.
+ Lemma witness_unique (R Q : A → Prop) (H0 : ∃ a, R a) (H1 : ∃ b, Q b) :
+ (∀ a, R a ↔ Q a)
+ → proj1_sig (constructive_indefinite_description R H0) = proj1_sig (constructive_indefinite_description Q H1).
+ Proof.
+ intros H.
+ assert (H2 : R = Q).
+ { apply functional_extensionality. intros x. apply propositional_extensionality, H. }
+ subst.
+ rewrite (proof_irrelevance _ H0 H1). reflexivity.
+ Qed.
+
+ Lemma choose_witness_choice (a b : A) : P a b → choose_witness a = choose_witness b.
+ Proof.
+ intros H. unfold choose_witness.
+ apply witness_unique. intros x.
+ apply choice_fun_ext in H. by rewrite H.
+ Qed.
+ End fix_alpha.
+
+ Import Classical.
+ Lemma dec_dist α (x y : A) : { x ≡{α}≡ y} + {~ x ≡{α}≡ y}.
+ Proof. apply binary_choice. apply classic. Qed.
+
+ Program Definition trunc (α : SI) := λne a, choose_witness (dist α) (dec_dist α) a.
+ Next Obligation.
+ intros α β a b Heq.
+ destruct (index_le_lt_dec α β) as [H1 | H1].
+ - unshelve erewrite (choose_witness_choice _ _ a b _). { eapply dist_mono'; eassumption. }
+ reflexivity.
+ - rewrite <- (dist_mono _ _ _ _ (witness_P _ _ a)). 2 : assumption.
+ rewrite <- (dist_mono _ _ _ _ (witness_P _ _ b)). 2: assumption.
+ apply Heq.
+ Qed.
+
+ (* classical ProtoTruncatable instance for arbitrary OFEs *)
+ Instance classical_proto_trunc : ProtoTruncatable A.
+ Proof.
+ exists trunc.
+ - intros. unfold trunc. cbn. by rewrite (choose_witness_choice _ _ x y H).
+ - intros. symmetry. unfold trunc. cbn. apply witness_P.
+ Qed.
+
+ (* Now we can use a similar technique to show that any COFE is StronglyUnique *)
+ Lemma dec_dist_later α (x y : A) : { dist_later α x y} + {¬ dist_later α x y}.
+ Proof. apply binary_choice. apply classic. Qed.
+
+ Program Definition trunc_dist_later (α : SI) := λne a, choose_witness (dist_later α) (dec_dist_later α) a.
+ Next Obligation.
+ intros α β a b Heq.
+ destruct (index_le_lt_dec α β) as [H1 | H1].
+ - unshelve erewrite (choose_witness_choice _ _ a b _).
+ { intros γ H. eapply dist_mono. apply Heq. eapply index_lt_le_trans; eauto. }
+ reflexivity.
+ - rewrite <- (@witness_P (dist_later α) _ _ a β H1).
+ rewrite <- (@witness_P (dist_later α) _ _ b β H1).
+ assumption.
+ Qed.
+
+ Lemma trunc_dist_later_eq α a: dist_later α a (trunc_dist_later α a).
+ Proof. unfold trunc_dist_later. cbn. apply witness_P. Qed.
+ Lemma trunc_dist_later_pre α a b : dist_later α a b → trunc_dist_later α a ≡ trunc_dist_later α b.
+ Proof. intros H. unfold trunc_dist_later. cbn. by rewrite (choose_witness_choice _ _ a b H). Qed.
+
+ Context {Hcofe : Cofe A}.
+
+ (* we can prove, under these classical assumptions, that we can always make limits unique *)
+ Program Definition classical_strict_bcompl α (Hα : zero ≺ α) (c : bchain A α) :=
+ trunc_dist_later α (bcompl Hα c).
+
+ Program Instance classical_strict_cofe : Cofe A :=
+ { compl := @compl SI A _;
+ bcompl := classical_strict_bcompl;
+ }.
+ Next Obligation. apply conv_compl. Qed.
+ Next Obligation.
+ intros α Hα c β Hβ. unfold classical_strict_bcompl.
+ rewrite ofe_mor_ne.
+ 2: { rewrite conv_bcompl. cbn. reflexivity. }
+ rewrite <- (trunc_dist_later_eq α (c _ _) β). reflexivity. apply Hβ.
+ Qed.
+ Next Obligation.
+ intros. unfold classical_strict_bcompl.
+ destruct (index_le_lt_dec α β) as [H1 | H1].
+ - apply ofe_mor_ne. apply bcompl_ne, H.
+ - rewrite <- (trunc_dist_later_eq α _ β H1).
+ rewrite <- (trunc_dist_later_eq α _ β H1).
+ apply bcompl_ne, H.
+ Qed.
+
+ Instance classical_StronglyUnique : @BcomplStronglyUnique _ A classical_strict_cofe.
+ Proof.
+ intros α Hα c d H1. unfold classical_strict_cofe, bcompl. unfold classical_strict_bcompl.
+ apply trunc_dist_later_pre. intros β Hβ.
+ rewrite !conv_bcompl. apply H1. Unshelve. apply Hβ.
+ Qed.
+End classical_truncation.
diff --git a/theories/algebra/ordinals/arithmetic.v b/theories/algebra/ordinals/arithmetic.v
new file mode 100644
index 0000000000000000000000000000000000000000..d115c756fa55c975304c7a31095c0a74310f91e1
--- /dev/null
+++ b/theories/algebra/ordinals/arithmetic.v
@@ -0,0 +1,837 @@
+
+From iris.algebra Require Export base stepindex.
+From iris.algebra.ordinals Require Import set_ordinals set_model ord_stepindex.
+Set Universe Polymorphism.
+
+
+(* Natural Addition, also called Hessenberg Addition *)
+Polymorphic Class NaturalAddition (A : Type) := nadd : A → A → A.
+Hint Mode NaturalAddition ! : typeclass_instances.
+Infix "⊕" := nadd (at level 60) : stdpp_scope.
+Notation "(⊕)" := nadd (only parsing) : stdpp_scope.
+Instance: Params (@nadd) 1 := {}.
+
+
+(* Ordinal Subtraction *)
+Polymorphic Class NaturalSubtraction (A : Type) := nsub : A → A → A.
+Hint Mode NaturalSubtraction ! : typeclass_instances.
+Infix "⊖" := nsub (at level 60) : stdpp_scope.
+Notation "(⊖)" := nsub (only parsing) : stdpp_scope.
+Instance: Params (@nsub) 1 := {}.
+
+(* Ordinal Multiplication *)
+Polymorphic Class NaturalMultiplication (A : Type) := nmul : A → A → A.
+Hint Mode NaturalMultiplication ! : typeclass_instances.
+Infix "⊗" := nmul (at level 59) : stdpp_scope.
+Notation "(⊗)" := nmul (only parsing) : stdpp_scope.
+Instance: Params (@nmul) 1 := {}.
+
+Section ordinals.
+ Polymorphic Universe i.
+ Implicit Types α β γ δ : Ord@{i}.
+
+
+ (* general step-index lemmas *)
+ Lemma ord_linear α β: (α ≺ β) ∨ α = β ∨ (β ≺ α).
+ Proof.
+ destruct (ordinal_linear α β) as [|[Heq % ord_extensional|]]; eauto.
+ Qed.
+
+ Lemma ord_leq_eq α β: α ⪯ β ∧ β ⪯ α → α = β.
+ Proof.
+ intros [H1 % ord_leq_unfold H2 % ord_leq_unfold].
+ by apply ord_extensional, zf_extensionality.
+ Qed.
+
+ (* better names*)
+ Lemma ord_lt_leq α β γ: α ≺ β → β ⪯ γ → α ≺ γ.
+ Proof.
+ intros ? [->|?]; eauto; etransitivity; eauto.
+ Qed.
+
+ Lemma ord_leq_lt α β γ: α ⪯ β → β ≺ γ → α ≺ γ.
+ Proof.
+ intros [->|?] ?; eauto; etransitivity; eauto.
+ Qed.
+
+ Lemma succ_greater α: α ≺ succ α.
+ Proof.
+ eapply in_succ_set_iff. by left.
+ Qed.
+
+ Lemma succ_least_greater α β: α ≺ β → succ α ⪯ β.
+ Proof.
+ intros H; by apply index_succ_iff, index_lt_succ_mono.
+ Qed.
+
+ Lemma succ_mono_leq α β: α ⪯ β → succ α ⪯ succ β.
+ Proof.
+ intros H; by eapply succ_least_greater, index_succ_iff.
+ Qed.
+
+ Lemma succ_mono_lt α β: α ≺ β → succ α ≺ succ β.
+ Proof.
+ intros Hα. eapply ord_leq_lt; last eapply succ_greater.
+ by eapply succ_least_greater.
+ Qed.
+
+ Lemma succ_inj α β: succ α = succ β → α = β.
+ Proof.
+ intros Hα. destruct (ord_linear α β) as [H % succ_mono_lt|[|H%succ_mono_lt]]; auto.
+ all: rewrite Hα in H; exfalso; eapply index_lt_irrefl; eapply H.
+ Qed.
+
+ Lemma succ_inj_lt α β: succ α ≺ succ β → α ≺ β.
+ Proof.
+ intros Hα. eapply in_succ_set_iff in Hα as [Heq % ord_extensional|Hα].
+ - rewrite -Heq. apply succ_greater.
+ - eapply ord_lt_leq; first apply succ_greater; auto.
+ Qed.
+
+ Lemma succ_inj_leq α β: succ α ⪯ succ β → α ⪯ β.
+ Proof.
+ intros [H % succ_inj|H % succ_inj_lt]; eauto.
+ Qed.
+
+ Lemma zero_succ α: zero ≺ succ α.
+ Proof.
+ eapply ord_lt_leq; first apply succ_greater.
+ eapply succ_mono_leq, index_zero_minimum.
+ Qed.
+
+
+ (* set ordinal specific *)
+ Lemma zero_no_elements : typeof zero → False.
+ Proof.
+ intros x. eapply zero_least, (ordinals_lt _ x).
+ Qed.
+
+ Lemma one_elements_are_zero x: ordinals (succ zero) x = zero.
+ Proof.
+ apply ord_leq_eq; split; last apply index_zero_minimum.
+ apply succ_inj_leq, succ_least_greater, ordinals_lt.
+ Qed.
+
+ (* Ordinals and Well-Founded Relations *)
+ Section well_founded.
+ Context {X: Type} {R: X → X → Prop}.
+
+ Record successors (x: X) := successors_of {
+ next:> X;
+ is_successor: R next x
+ }.
+ Arguments next {_} _.
+ Arguments successors_of {_} _.
+ Arguments is_successor {_} _.
+
+ Fixpoint acc_ord {x} (a: Acc R x) : Ord :=
+ match a with
+ | Acc_intro _ f => limit (λ (y: successors x), succ (acc_ord (f y (is_successor y))))
+ end.
+
+ Lemma acc_ord_unfold {x} (a: Acc R x):
+ acc_ord a = limit (λ (y: successors x), succ (@acc_ord y (Acc_inv a (is_successor y)))) .
+ Proof.
+ eapply Acc_inv_dep with (a := a); simpl; clear a x. auto.
+ Qed.
+
+
+ Lemma acc_ord_pi {x} (a b: Acc R x): acc_ord a = acc_ord b.
+ Proof.
+ revert b. eapply Acc_inv_dep with (a := a); simpl; clear a x.
+ intros x f IH; intros [g]; simpl.
+ apply limit_ext.
+ intros []; f_equal; apply IH.
+ Qed.
+
+
+ Lemma acc_ord_lt {x y} (a: Acc R x) (b: Acc R y):
+ R y x → acc_ord b ≺ acc_ord a.
+ Proof.
+ intros Hr; apply ord_lt_unfold. destruct a; simpl.
+ apply zf_union. exists (succ (acc_ord b)). split.
+ - apply in_succ_set_iff. by left.
+ - eapply (in_intro _ (successors_of y Hr)); simpl.
+ by rewrite (acc_ord_pi b (a y Hr)).
+ Qed.
+
+
+ Corollary acc_ord_lt' {x y} (a: Acc R x) (H: R y x):
+ acc_ord (Acc_inv a H) ≺ acc_ord a.
+ Proof.
+ apply (acc_ord_lt _ _ H).
+ Qed.
+
+ (* A single ordinal for an entire well-founded relation *)
+ Definition wf_ord (wf: wf R) := limit (λ x, succ (acc_ord (wf x))).
+
+ Lemma wf_ord_is_larger (wf: well_founded R) x:
+ acc_ord (wf x) ≺ wf_ord wf.
+ Proof.
+ eapply zf_union. exists (succ (acc_ord (wf x))); split.
+ - eapply succ_greater.
+ - by eapply in_intro.
+ Qed.
+
+ End well_founded.
+ Arguments next {_ _ _} _.
+ Arguments successors_of {_ _ _} _.
+ Arguments is_successor {_ _ _} _.
+
+ Section well_founded_embedding.
+ Variable (X Y: Type) (R: X → X → Prop) (S: Y → Y → Prop) (sim: X → Y → Prop).
+ Hypothesis (embed: ∀ x x' y, R x' x → sim x y → ∃ y', S y' y ∧ sim x' y').
+
+ Lemma embed_acc {y} (b: Acc S y): ∀ x, sim x y → Acc R x.
+ Proof using R S X Y embed sim.
+ induction b as [y _ IH]. intros x Hsim. constructor.
+ intros x' Hr. edestruct embed as [y' [HS Hsim']]; eauto.
+ Qed.
+
+ Lemma acc_ord_embed' y (b: Acc S y):
+ ∀ x (H: sim x y), acc_ord (embed_acc b _ H) ⪯ acc_ord b.
+ Proof.
+ eapply Acc_inv_dep with (a := b); simpl; clear y b.
+ intros y a IH x Hsim. rewrite acc_ord_unfold. eapply limit_mono_strong.
+ intros [x' Hstep]. edestruct embed as [y' [HS Hsim']]; first apply Hstep; first apply Hsim.
+ exists (successors_of y' HS). apply succ_mono_leq; simpl.
+ transitivity (acc_ord (embed_acc (a y' HS) x' Hsim')).
+ - left. apply acc_ord_pi.
+ - apply IH.
+ Qed.
+
+ Lemma acc_ord_embed x y (b: Acc S y) (a: Acc R x): sim x y → acc_ord a ⪯ acc_ord b.
+ Proof using R S X Y embed sim.
+ intros Hsim. etransitivity; last eapply (acc_ord_embed' _ _ x Hsim).
+ left. apply acc_ord_pi.
+ Qed.
+
+ Lemma acc_ord_strict y y' (b: Acc S y') x (a: Acc R x):
+ S y y' → sim x y → acc_ord a ≺ acc_ord b.
+ Proof using R S X Y embed sim.
+ intros H Hsim. eapply ord_leq_lt with (β := acc_ord (Acc_inv b H)).
+ - by eapply acc_ord_embed.
+ - eapply acc_ord_lt; auto.
+ Qed.
+
+ Lemma wf_ord_embed (wfS: wf S) (wfR: wf R): (∀ x, ∃ y, sim x y) → wf_ord wfR ⪯ wf_ord wfS.
+ Proof using R S X Y embed sim.
+ intros Hsim. eapply limit_mono_strong. intros x. destruct (Hsim x) as [y Hsim']. exists y.
+ by eapply succ_mono_leq, acc_ord_embed.
+ Qed.
+
+ (* With functions it is trivial to construct the simulation relation *)
+ Definition im_rel (f: X → Y) x y := y = f x.
+
+ Lemma im_rel_ex f: ∀ x, ∃ y, im_rel f x y.
+ Proof. intros x. by exists (f x). Qed.
+
+ Lemma im_rel_embed f:
+ (∀ x x', R x x' → S (f x) (f x')) →
+ (∀ x x' y, R x' x → im_rel f x y → ∃ y', S y' y ∧ im_rel f x' y').
+ Proof.
+ intros Hrel x x' y Hr ->. exists (f x'). split; by eauto.
+ Qed.
+
+ End well_founded_embedding.
+
+
+ (* A special well-founded relation, the element relation: *)
+ Section element_order.
+ Definition element_order s: typeof s → typeof s → Prop :=
+ λ a b, elements s a ∈ elements s b.
+
+ Lemma element_order_wf s: wf (element_order s).
+ Proof.
+ intros x. specialize (IN_wf (elements s x)).
+ remember (elements s x) as t. intros wf. revert x Heqt.
+ induction wf as [x' _ IH].
+ intros x ->. constructor. intros y Hel.
+ eapply IH; last reflexivity.
+ apply Hel.
+ Qed.
+
+ Lemma acc_ord_upper_bound α x: ordinals α x ⪯ acc_ord (element_order_wf α x).
+ Proof.
+ apply ord_leq_unfold. remember (ordinals α x: set) as s. revert x Heqs.
+ induction s as [s IH] using eps_ind.
+ intros x ->. intros s Hs. specialize (IH s Hs).
+ assert (s ∈ (α: set)) as Hin.
+ { eapply ordinal_trans; eauto using elements_in, ordinal_el; apply ordinals_lt. }
+ eapply in_inv_elements in Hin as [y ->].
+ feed pose proof (IH y) as H; eauto.
+ replace (elements α y) with (ordinals α y: set) by reflexivity.
+ apply ->ord_lt_unfold. eapply ord_leq_lt.
+ - apply ord_leq_unfold, H.
+ - apply acc_ord_lt, Hs.
+ Qed.
+
+ Lemma acc_ord_lower_bound α x: acc_ord (element_order_wf α x) ⪯ ordinals α x.
+ Proof.
+ apply ord_leq_unfold. eapply Acc_inv_dep with (a := element_order_wf α x); clear; simpl.
+ intros x a IH. intros s [t [Hst Hin]] % zf_union. apply in_inv in Hin as [y ->].
+ apply in_succ_set_iff in Hst as [->|Hst].
+ - destruct y as [y Hin]; simpl. specialize (IH y Hin).
+ replace (elements α x) with (ordinals α x: set) by reflexivity.
+ apply ->ord_lt_unfold. eapply ord_leq_lt with (β := ordinals α y).
+ + apply ord_leq_unfold, IH.
+ + apply ord_lt_unfold, Hin.
+ - specialize (IH _ _ _ Hst). clear Hst. destruct y as [y Hin].
+ eapply ordinal_trans; last apply Hin.
+ all: eauto using elements_in, ordinal_el.
+ Qed.
+
+
+ Lemma acc_ord_id α x: acc_ord (element_order_wf α x) = ordinals α x.
+ Proof.
+ apply ord_leq_eq; eauto using acc_ord_lower_bound, acc_ord_upper_bound.
+ Qed.
+
+ Lemma element_order_id α : wf_ord (element_order_wf α) = α.
+ Proof.
+ apply ord_leq_eq; split.
+ - apply ord_leq_unfold. intros s [t [Hst Hin]] % zf_union.
+ apply in_inv in Hin as [x ->].
+ rewrite acc_ord_id in Hst.
+ apply in_succ_set_iff in Hst as [->|Hst]; first apply ordinals_lt.
+ eapply ordinal_trans; eauto using elements_in, ordinal_el; apply ordinals_lt.
+ - etransitivity; last unshelve (eapply limit_mono with (F := λ x, succ (ordinals α x))); last first.
+ { intros ?; by rewrite acc_ord_id. }
+ apply ord_leq_unfold.
+ intros s Hs. apply in_inv_elements in Hs as [x ->].
+ apply zf_union. exists (succ (ordinals α x)); split; eauto using in_intro.
+ eapply in_succ_set_iff; by left.
+ Qed.
+ End element_order.
+
+
+
+ Section simultaneous_induction.
+ Inductive interleave {X Y} (R: X → X → Prop) (S: Y → Y → Prop): (X * Y) → (X * Y) → Prop :=
+ | interleave_L (x x': X) (y: Y): R x x' → interleave R S (x, y) (x', y)
+ | interleave_R x y y': S y y' → interleave R S (x, y) (x, y').
+
+ Lemma interleave_wf {X Y} (R: X → X → Prop) (S: Y → Y → Prop): wf R → wf S → wf (interleave R S).
+ Proof.
+ intros wfR wfS. intros [x y].
+ revert y; induction (wfR x) as [x _ IHx]; intros y.
+ induction (wfS y) as [y _ IHy].
+ constructor. intros p H. inversion H; subst; eauto.
+ Qed.
+
+
+ Definition ord_rect2 := Fix (interleave_wf _ _ wf_ord_lt wf_ord_lt).
+
+ (* TODO: add to stdpp *)
+ Lemma rtc_acc {X} (R: X → X → Prop) x y: rtc R y x → Acc R x → Acc R y.
+ Proof.
+ induction 1; auto.
+ intros Hacc. apply IHrtc; auto.
+ Qed.
+
+ Lemma tc_inv_rtc {X} (R: X → X → Prop) x y: tc R x y → ∃ z, rtc R x z ∧ R z y.
+ Proof.
+ induction 1.
+ - exists x; split; by auto.
+ - destruct IHtc as [z' [Hr Hrtc]].
+ exists z'; split; auto. by econstructor 2.
+ Qed.
+
+ Lemma rtc_embed_tc {X} (R: X → X → Prop) x y: rtc R x y → rtc (tc R) x y.
+ Proof.
+ induction 1; first reflexivity.
+ econstructor 2; eauto using tc_once.
+ Qed.
+
+ Lemma tc_wf {X} (R: X → X → Prop): wf R → wf (tc R).
+ Proof.
+ intros H x. specialize (H x). induction H as [x H IH].
+ constructor. intros y [z [Hrtc Hr]] % tc_inv_rtc.
+ eapply rtc_acc; last apply IH; eauto. by eapply rtc_embed_tc.
+ Qed.
+
+ Lemma interleave_tc_wf {X Y} (R: X → X → Prop) (S: Y → Y → Prop): wf R → wf S → wf (tc (interleave R S)).
+ Proof.
+ intros wfR wfS. by apply tc_wf, interleave_wf.
+ Qed.
+
+ Definition ord_rect2_strong := Fix (interleave_tc_wf _ _ wf_ord_lt wf_ord_lt).
+
+ End simultaneous_induction.
+
+
+ Section natural_addition.
+
+ Definition natural_addition α β: Ord@{i} :=
+ ord_rect2 (λ _, Ord) (λ '(α, β) add,
+ limit (λ (s: typeof α + typeof β),
+ match s with
+ | inl a => succ (add (ordinals α a, β) (interleave_L _ _ _ _ _ (ordinals_lt α a)))
+ | inr b => succ (add (α, ordinals β b) (interleave_R _ _ _ _ _ (ordinals_lt β b)))
+ end))
+ (* max (limitO a (λ γ Hγ, succ (IH (γ, b) (interleave_L _ _ _ _ _ Hγ)))) (limitO b (λ γ Hγ, succ (IH (a, γ) (interleave_R _ _ _ _ _ Hγ))))) *)
+ (α, β).
+
+
+
+ Global Instance natural_addition_operator: NaturalAddition Ord := natural_addition.
+
+ Lemma natural_addition_nadd α β: α ⊕ β = natural_addition α β.
+ Proof. reflexivity. Qed.
+
+ Lemma natural_addition_unfold α β:
+ α ⊕ β = limit (λ (s: typeof α + typeof β),
+ match s with
+ | inl a => succ (ordinals α a ⊕ β)
+ | inr b => succ (α ⊕ ordinals β b)
+ end).
+ Proof.
+ rewrite natural_addition_nadd /natural_addition /ord_rect2 Fix_eq; first reflexivity.
+ intros [x y] f g H. eapply limit_ext.
+ all: intros []; f_equal; eauto.
+ Qed.
+
+
+
+ Lemma natural_addition_zero_left_id α: zero ⊕ α = α.
+ Proof.
+ induction α as [α IH] using ord_ind.
+ rewrite natural_addition_unfold; apply ord_leq_eq; split.
+ - apply limit_least_upper_bound; intros [t| a]; first destruct (zero_no_elements t).
+ rewrite IH; last apply ordinals_lt.
+ apply succ_least_greater, ordinals_lt.
+ - apply limit_upper_bound_strong. intros β [x Hβ] % in_inv_elements.
+ exists (inr x). rewrite IH; last apply ordinals_lt.
+ rewrite ord_lt_unfold Hβ. apply succ_greater.
+ Qed.
+
+ Lemma natural_addition_comm α β: α ⊕ β = β ⊕ α.
+ Proof.
+ revert β; induction α as [α IHα] using ord_ind; intros β.
+ induction β as [β IHβ] using ord_ind.
+ rewrite !natural_addition_unfold; eapply ord_leq_eq.
+ split; eapply limit_mono_strong.
+ - intros [a|b]; first exists (inr a); last exists (inl b).
+ + rewrite IHα; eauto; apply ordinals_lt.
+ + rewrite IHβ; eauto; apply ordinals_lt.
+ - intros [b|a]; first exists (inr b); last exists (inl a).
+ + rewrite IHβ; eauto; apply ordinals_lt.
+ + rewrite (IHα (ordinals α a)); eauto; apply ordinals_lt.
+ Qed.
+
+ Lemma natural_addition_zero_right_id α: α ⊕ zero = α.
+ Proof.
+ by rewrite natural_addition_comm natural_addition_zero_left_id.
+ Qed.
+
+ Lemma natural_addition_strict_compat α β γ: α ≺ β → α ⊕ γ ≺ β ⊕ γ.
+ Proof.
+ intros Hle. rewrite [β ⊕ γ]natural_addition_unfold.
+ eapply zf_union. exists (succ (α ⊕ γ)); split.
+ { apply in_succ_set_iff. by left. }
+ apply ord_lt_inv_ordinals in Hle as [b ->].
+ by eapply (in_intro _ (inl b)).
+ Qed.
+
+ Lemma natural_addition_strict_compat' α β γ: α ≺ β → γ ⊕ α ≺ γ ⊕ β.
+ Proof.
+ intros H. rewrite [γ ⊕ α]natural_addition_comm [γ ⊕ β]natural_addition_comm.
+ by eapply natural_addition_strict_compat.
+ Qed.
+
+ Global Instance natural_addition_lt_proper: Proper (index_lt ordI ==> index_lt ordI ==> index_lt ordI) nadd.
+ Proof.
+ intros α β Hαβ γ δ Hγδ; etransitivity; first apply natural_addition_strict_compat; eauto using natural_addition_strict_compat'.
+ Qed.
+
+ Lemma natural_addition_compat α β γ: α ⪯ β → α ⊕ γ ⪯ β ⊕ γ.
+ Proof.
+ intros [->|]; eauto using natural_addition_strict_compat.
+ Qed.
+
+ Lemma natural_addition_compat' α β γ: α ⪯ β → γ ⊕ α ⪯ γ ⊕ β.
+ Proof.
+ intros [->|]; eauto using natural_addition_strict_compat'.
+ Qed.
+
+ Global Instance natural_addition_leq_proper: Proper ((@index_le ordI) ==> (@index_le ordI) ==> (@index_le ordI)) nadd.
+ Proof.
+ intros α β Hαβ γ δ Hγδ; etransitivity; first apply natural_addition_compat; eauto using natural_addition_compat'.
+ Qed.
+
+ Lemma natural_addition_increase α β: α ⪯ α ⊕ β.
+ Proof.
+ Set Printing All.
+ replace α with (zero ⊕ α) at 1 by apply natural_addition_zero_left_id.
+ rewrite [α ⊕ β]natural_addition_comm.
+ apply natural_addition_compat, index_zero_minimum.
+ Qed.
+
+ Lemma natural_addition_cancel α β γ: α ⊕ γ = β ⊕ γ → α = β.
+ Proof.
+ intros Heq. destruct (ord_linear α β) as [H|[|H]]; auto; exfalso.
+ all: eapply (natural_addition_strict_compat _ _ γ) in H; rewrite Heq in H; eapply index_lt_irrefl; eauto.
+ Qed.
+
+ Lemma natural_addition_cancel_lt α β γ: α ⊕ γ ≺ β ⊕ γ → α ≺ β.
+ Proof.
+ intros Heq. destruct (ord_linear α β) as [H|[|H]]; auto; exfalso.
+ - subst α. by eapply index_lt_irrefl.
+ - eapply (natural_addition_strict_compat _ _ γ) in H.
+ eapply index_lt_irrefl. etransitivity; eauto.
+ Qed.
+
+ Lemma natural_addition_cancel_leq α β γ: α ⊕ γ ⪯ β ⊕ γ → α ⪯ β.
+ Proof.
+ intros [?%natural_addition_cancel |? % natural_addition_cancel_lt]; eauto.
+ Qed.
+
+
+ Lemma natural_addition_limit (X: Type@{i}) (f: X → Ord@{i}) (α : Ord@{i}):
+ limit (λ x, f x ⊕ α) ⪯ limit f ⊕ α .
+ Proof.
+ eapply limit_least_upper_bound. intros x.
+ eapply natural_addition_compat, limit_upper_bound.
+ Qed.
+
+
+ Lemma nat_add_inv α β γ: γ ≺ α ⊕ β → ∃ δ, (δ ≺ α ∧ γ ≺ succ (δ ⊕ β)) ∨ (δ ≺ β ∧ γ ≺ succ (α ⊕ δ)).
+ Proof.
+ intros H. rewrite natural_addition_unfold in H.
+ eapply zf_union in H as [s [Hs Hin]].
+ eapply in_inv in Hin as [[a|b] ->].
+ - exists (ordinals α a). left; split; auto using ordinals_lt.
+ - exists (ordinals β b); right; split; auto using ordinals_lt.
+ Qed.
+
+
+ Lemma natural_addition_succ_1 α β: succ α ⊕ β ⪯ succ (α ⊕ β).
+ Proof.
+ induction β as [β IHβ] using ord_ind.
+ apply ord_leq_unfold, ord_subset. intros γ Hγ.
+ apply nat_add_inv in Hγ as [δ [[Hδα Hlt]|[Hδβ Hlt]]].
+ + eapply ord_lt_leq; first apply Hlt.
+ eapply succ_least_greater in Hδα.
+ eapply succ_mono_leq. eapply succ_inj_leq in Hδα.
+ by eapply natural_addition_compat.
+ + eapply ord_lt_leq; eauto.
+ eapply succ_mono_leq. etransitivity. eapply IHβ; auto.
+ by eapply succ_least_greater, natural_addition_strict_compat'.
+ Qed.
+
+ Lemma natural_addition_succ_2 α β: succ (α ⊕ β) ⪯ succ α ⊕ β.
+ Proof.
+ eapply succ_least_greater, natural_addition_strict_compat, succ_greater.
+ Qed.
+
+ Lemma natural_addition_succ α β: succ α ⊕ β = succ (α ⊕ β).
+ Proof.
+ eapply ord_leq_eq; split; eauto using natural_addition_succ_1, natural_addition_succ_2.
+ Qed.
+
+
+ Lemma natural_addition_assoc_1 α β γ: (α ⊕ β) ⊕ γ ⪯ α ⊕ (β ⊕ γ).
+ Proof.
+ revert β γ; induction α as [α IHα] using ord_ind; intros β.
+ induction β as [β IHβ] using ord_ind; intros γ.
+ induction γ as [γ IHγ] using ord_ind.
+ rewrite natural_addition_unfold.
+ eapply limit_least_upper_bound. intros [ab|c].
+ - destruct (nat_add_inv _ _ _ (ordinals_lt _ ab)) as [δ [[Hδα Hlt]|[Hδβ Hlt]]].
+ + specialize (IHα _ Hδα). apply succ_least_greater.
+ eapply ord_lt_leq; first apply natural_addition_strict_compat, Hlt.
+ rewrite natural_addition_succ. apply succ_least_greater.
+ eapply ord_leq_lt; first eapply IHα.
+ by eapply natural_addition_strict_compat.
+ + specialize (IHβ _ Hδβ). apply succ_least_greater.
+ eapply ord_lt_leq; first apply natural_addition_strict_compat, Hlt.
+ rewrite natural_addition_succ. apply succ_least_greater.
+ eapply ord_leq_lt; first eapply IHβ.
+ eapply natural_addition_strict_compat'.
+ by eapply natural_addition_strict_compat.
+ - etransitivity. eapply succ_mono_leq, IHγ; auto; first apply ordinals_lt.
+ apply succ_least_greater.
+ do 2 eapply natural_addition_strict_compat'; auto using ordinals_lt.
+ Qed.
+
+ Lemma natural_addition_assoc_2 α β γ: α ⊕ (β ⊕ γ) ⪯ (α ⊕ β) ⊕ γ.
+ Proof.
+ rewrite natural_addition_comm [β ⊕ γ]natural_addition_comm.
+ rewrite [α ⊕ β]natural_addition_comm [_ ⊕ γ]natural_addition_comm.
+ eapply natural_addition_assoc_1.
+ Qed.
+
+ Lemma natural_addition_assoc α β γ: (α ⊕ β) ⊕ γ = α ⊕ (β ⊕ γ).
+ Proof.
+ eapply ord_leq_eq; split; eauto using natural_addition_assoc_1, natural_addition_assoc_2.
+ Qed.
+
+ End natural_addition.
+
+ Section natural_sub.
+
+ Definition limitP {X: Type} (P: X → Prop) (f: X → Ord) :=
+ limit (λ s : { x: X | P x}, f (`s)).
+
+ Definition natural_sub α β :=
+ limitP (λ a: typeof α, ordinals α a ⊕ β ≺ α) (λ a, succ (ordinals α a)).
+
+ Global Instance natural_sub_operator: NaturalSubtraction Ord := natural_sub.
+
+ Lemma natural_sub_unfold α β:
+ α ⊖ β = limitP (λ a: typeof α, ordinals α a ⊕ β ≺ α) (λ a, succ (ordinals α a)).
+ Proof.
+ reflexivity.
+ Qed.
+
+ Lemma natural_sub_decreases α β: α ⊖ β ⪯ α.
+ Proof.
+ rewrite natural_sub_unfold. eapply limit_least_upper_bound.
+ intros [? H]; simpl.
+ eapply succ_least_greater, ordinals_lt.
+ Qed.
+
+ Lemma natural_sub_eq α β γ: α = β ⊕ γ → α ⊖ β = γ.
+ Proof.
+ intros ->. rewrite natural_addition_comm natural_sub_unfold. eapply ord_leq_eq; split.
+ - eapply limit_least_upper_bound. intros [x H]; simpl.
+ eapply natural_addition_cancel_lt in H.
+ by apply succ_least_greater.
+ - eapply limit_upper_bound_strong. intros δ Hδ.
+ assert (δ ≺ γ ⊕ β) as H.
+ { eapply ord_lt_leq; eauto.
+ eapply natural_addition_increase. }
+ eapply ord_lt_inv_ordinals in H as [x ->].
+ assert (ordinals (γ ⊕ β) x ⊕ β ≺ γ ⊕ β) as Hγβ.
+ { eapply natural_addition_strict_compat, Hδ. }
+ exists (exist _ x Hγβ); simpl. apply succ_greater.
+ Qed.
+
+ Lemma natural_sub_zero_right α: α ⊖ zero = α.
+ Proof.
+ eapply natural_sub_eq; by rewrite natural_addition_zero_left_id.
+ Qed.
+
+ Lemma natural_sub_zero_left α: zero ⊖ α = zero.
+ Proof.
+ eapply ord_leq_eq; split; last apply index_zero_minimum.
+ apply natural_sub_decreases.
+ Qed.
+
+ Lemma natural_sub_self α: α ⊖ α = zero.
+ Proof.
+ eapply natural_sub_eq. by rewrite natural_addition_zero_right_id.
+ Qed.
+
+ Lemma natural_sub_inv α β: (α ⊕ β) ⊖ β = α.
+ Proof.
+ eapply natural_sub_eq, natural_addition_comm.
+ Qed.
+
+ Lemma natural_sub_leq α β γ: γ ⪯ α ⊕ β → γ ⊖ β ⪯ α.
+ Proof.
+ intros H; rewrite natural_sub_unfold. eapply limit_least_upper_bound.
+ intros [x Hx]. apply succ_least_greater; cbn -[index_lt].
+ eapply natural_addition_cancel_lt with (γ := β).
+ eapply ord_lt_leq; eauto.
+ Qed.
+
+ Lemma natural_sub_mono α β γ: α ⪯ β → α ⊖ γ ⪯ β ⊖ γ.
+ Proof.
+ intros H. rewrite !natural_sub_unfold; eapply limit_mono_strong.
+ intros [a Ha]. eapply ord_leq_unfold in H.
+ pose proof (ordinals_lt _ a) as Hin. apply H in Hin.
+ eapply ord_lt_inv_ordinals in Hin as [b Heq].
+ assert (ordinals β b ⊕ γ ≺ β) as Hb.
+ { rewrite -Heq. eapply ord_lt_leq; eauto; by eapply ord_leq_unfold. }
+ exists (exist _ b Hb); simpl; by rewrite Heq.
+ Qed.
+
+ End natural_sub.
+
+
+
+ Section natural_mutliplication.
+
+ Arguments tc_once {_ _ _ _} _.
+ Arguments tc_l {_ _ _ _ _} _.
+ Arguments interleave_L {_ _ _ _ _ _ _} _.
+ Arguments interleave_R {_ _ _ _ _ _ _} _.
+
+
+ (* limitS simply fills the holes in {{ f x | x : X }} *)
+ Definition limitS {X} (f: X → Ord) := limit (λ x, succ (f x)).
+
+ Definition natural_multiplication α β: Ord :=
+ ord_rect2_strong (λ _, Ord) (λ '(α, β) mul,
+ limitS (λ '(a, b), (mul (ordinals α a, β) (tc_once (interleave_L (ordinals_lt α a)))
+ ⊕ mul (α, ordinals β b) (tc_once (interleave_R (ordinals_lt β b)))
+ ⊖ mul (ordinals α a, ordinals β b)
+ (tc_l (interleave_L (ordinals_lt α a)) (tc_once (interleave_R (ordinals_lt β b)))))))
+ (α, β).
+
+ Global Instance natural_multiplication_operator: NaturalMultiplication Ord := natural_multiplication.
+
+ Lemma natural_multiplication_nmul α β: α ⊗ β = natural_multiplication α β.
+ Proof. reflexivity. Qed.
+
+ Lemma natural_multiplication_unfold α β:
+ α ⊗ β = limitS (λ '(a, b), ((ordinals α a ⊗ β) ⊕ (α ⊗ ordinals β b)) ⊖ (ordinals α a ⊗ ordinals β b)).
+ Proof.
+ rewrite natural_multiplication_nmul /natural_multiplication /ord_rect2_strong Fix_eq; first reflexivity.
+ intros [x y] f g H. eapply limit_ext.
+ intros [a b]; do 2 f_equal; eauto; f_equal; auto.
+ Qed.
+
+ Lemma natural_multiplication_zero α: zero ⊗ α = zero.
+ Proof.
+ apply ord_leq_eq; split; last apply index_zero_minimum.
+ rewrite natural_multiplication_unfold. apply limit_least_upper_bound.
+ intros [a b]. exfalso. by eapply zero_no_elements.
+ Qed.
+
+ Lemma natural_multiplication_comm α β: α ⊗ β = β ⊗ α.
+ Proof.
+ revert β; induction α as [α IHα] using ord_ind; intros β.
+ induction β as [β IHβ] using ord_ind.
+ rewrite !natural_multiplication_unfold; eapply ord_leq_eq; split.
+ - eapply limit_mono_strong. intros [a b]. exists (b, a).
+ rewrite natural_addition_comm.
+ rewrite IHβ; last apply ordinals_lt.
+ rewrite [ordinals α a ⊗ β]IHα; last apply ordinals_lt.
+ by rewrite [ordinals α a ⊗ ordinals β b]IHα; last apply ordinals_lt.
+ - eapply limit_mono_strong. intros [b a]. exists (a, b).
+ rewrite natural_addition_comm.
+ rewrite IHβ; last apply ordinals_lt.
+ rewrite [ordinals α a ⊗ β]IHα; last apply ordinals_lt.
+ by rewrite [ordinals α a ⊗ ordinals β b]IHα; last apply ordinals_lt.
+ Qed.
+
+ Lemma natural_multiplication_strict_compat α β γ:
+ zero ≺ γ → α ≺ β → α ⊗ γ ≺ β ⊗ γ.
+ Proof.
+ intros Hzero Hprec. rewrite [β ⊗ γ]natural_multiplication_unfold.
+ apply zf_union. exists (succ (α ⊗ γ)); split; first by apply succ_greater.
+ apply ord_lt_inv_ordinals in Hzero as [c Hc].
+ apply ord_lt_inv_ordinals in Hprec as [b Hb].
+ eapply in_intro with (y := (b, c)).
+ rewrite -Hc -Hb [β ⊗ zero]natural_multiplication_comm natural_multiplication_zero.
+ rewrite [α ⊗ zero]natural_multiplication_comm natural_multiplication_zero.
+ by rewrite natural_addition_zero_right_id natural_sub_zero_right.
+ Qed.
+
+ Lemma natural_multiplication_strict_compat' α β γ:
+ zero ≺ γ → α ≺ β → γ ⊗ α ≺ γ ⊗ β.
+ Proof.
+ intros H1 H2; rewrite [γ ⊗ α]natural_multiplication_comm [γ ⊗ β]natural_multiplication_comm.
+ by eapply natural_multiplication_strict_compat.
+ Qed.
+
+ Lemma natural_multiplication_compat α β γ: α ⪯ β → α ⊗ γ ⪯ β ⊗ γ.
+ Proof.
+ revert α β; induction γ as [γ IHγ] using ord_ind; intros α β.
+ intros H; rewrite !natural_multiplication_unfold; eapply limit_mono_strong.
+ eapply ord_leq_unfold in H. intros [a c].
+ pose proof (ordinals_lt _ a) as Hin. apply H in Hin.
+ eapply ord_lt_inv_ordinals in Hin as [b Heq].
+ exists (b, c). rewrite Heq. eapply succ_mono_leq, natural_sub_mono.
+ eapply natural_addition_compat'. eapply IHγ; first by apply ordinals_lt.
+ by apply ord_leq_unfold.
+ Qed.
+
+
+ Lemma natural_multiplication_compat' α β γ: α ⪯ β → γ ⊗ α ⪯ γ ⊗ β.
+ Proof.
+ intros Hαβ. rewrite [γ ⊗ α]natural_multiplication_comm [γ ⊗ β]natural_multiplication_comm.
+ by apply natural_multiplication_compat.
+ Qed.
+
+ Lemma natural_multiplication_leq_proper: Proper (index_le ordI ==> index_le ordI ==> index_le ordI) nmul.
+ Proof.
+ intros α β Hαβ γ δ Hγδ; etransitivity; first apply natural_multiplication_compat; eauto using natural_multiplication_compat'.
+ Qed.
+
+ Lemma natural_multiplication_one α: succ zero ⊗ α = α.
+ Proof.
+ induction α as [α IHα] using ord_ind.
+ rewrite natural_multiplication_unfold.
+ apply ord_leq_eq; split.
+ - apply limit_least_upper_bound. intros [x a].
+ rewrite !one_elements_are_zero !natural_multiplication_zero.
+ rewrite natural_addition_zero_left_id natural_sub_zero_right.
+ rewrite IHα; last apply ordinals_lt.
+ apply succ_least_greater, ordinals_lt.
+ - apply limit_upper_bound_strong.
+ intros β Hβ. assert (zero ≺ succ zero) as Hlt by apply succ_greater.
+ apply ord_lt_inv_ordinals in Hlt as [x Hx].
+ apply ord_lt_inv_ordinals in Hβ as [a Ha].
+ exists (x, a); rewrite -Hx -Ha.
+ rewrite !natural_multiplication_zero natural_addition_zero_left_id natural_sub_zero_right.
+ rewrite IHα; last (rewrite Ha; apply ordinals_lt).
+ apply succ_greater.
+ Qed.
+
+ Lemma natural_multiplication_cancel α β γ:
+ zero ≺ γ → γ ⊗ α = γ ⊗ β → α = β.
+ Proof.
+ intros H1 H2. destruct (ord_linear α β) as [H|[H|H]]; auto.
+ - exfalso. eapply natural_multiplication_strict_compat' with (γ := γ) in H; auto.
+ rewrite H2 in H. by eapply index_lt_irrefl.
+ - exfalso. eapply natural_multiplication_strict_compat' with (γ := γ) in H; auto.
+ rewrite H2 in H. by eapply index_lt_irrefl.
+ Qed.
+
+ Lemma natural_multiplication_cancel' α β γ:
+ zero ≺ γ → α ⊗ γ = β ⊗ γ → α = β.
+ Proof.
+ intros; eapply natural_multiplication_cancel; eauto.
+ by rewrite [γ ⊗ α]natural_multiplication_comm [γ ⊗ β]natural_multiplication_comm.
+ Qed.
+
+ Lemma limit_strong_ext {X Y} (F: X → Ord) (G: Y → Ord):
+ (∀ x, ∃ y, F x ⪯ G y) →
+ (∀ y, ∃ x, G y ⪯ F x) →
+ limit F = limit G.
+ Proof.
+ intros H1 H2; eapply ord_leq_eq; split; by eapply limit_mono_strong.
+ Qed.
+
+ Lemma multiplication_typeof {α β} (x: typeof α) (y: typeof β):
+ ∃ z: typeof (α ⊗ β), (ordinals _ x ⊗ β) ⊕ (α ⊗ ordinals _ y) ⊖ (ordinals _ x ⊗ ordinals _ y) = ordinals _ z.
+ Proof.
+ eapply ord_lt_inv_ordinals. rewrite [α ⊗ β]natural_multiplication_unfold.
+ eapply zf_union. exists (succ ((ordinals α x ⊗ β ⊕ α ⊗ ordinals β y) ⊖ ordinals α x ⊗ ordinals β y)).
+ split; first by eapply succ_greater.
+ by eapply (in_intro _ (x, y)).
+ Qed.
+End natural_mutliplication.
+
+Section ordinal_multiplication.
+ (* multiplication by some natural number *)
+ Fixpoint natmul (n: nat) α :=
+ match n with
+ | 0%nat => ord_stepindex.zero
+ | S n => α ⊕ natmul n α
+ end.
+
+ Definition omul α := ord_stepindex.limit (λ n: nat, natmul n α).
+ Lemma natmul_omul n α: natmul n α ⪯ omul α.
+ Proof.
+ apply (limit_upper_bound (λ n, natmul n α)).
+ Qed.
+
+ Lemma natmul_zero n: natmul n zero = zero.
+ Proof.
+ induction n as [|n IH]; simpl; auto.
+ rewrite IH natural_addition_zero_left_id //=.
+ Qed.
+
+ Lemma omul_zero: zero = omul zero.
+ Proof.
+ apply ord_leq_eq; split; auto.
+ apply limit_least_upper_bound; intros n.
+ by rewrite natmul_zero.
+ Qed.
+End ordinal_multiplication.
+
+End ordinals.
diff --git a/theories/algebra/ordinals/ord_stepindex.v b/theories/algebra/ordinals/ord_stepindex.v
new file mode 100644
index 0000000000000000000000000000000000000000..63df2f0055d8e8acbb6e184e5fc2e33177246ed5
--- /dev/null
+++ b/theories/algebra/ordinals/ord_stepindex.v
@@ -0,0 +1,322 @@
+(** * Set-theoretic ordinals as a step-index type using several axioms *)
+(** In total, this development relies on:
+ - PE
+ - FE
+ - Hilbert's ϵ
+ - XM
+ - PI (but this is already implied by PE)
+ *)
+
+Require Import Coq.Logic.Epsilon.
+Require Import Coq.Logic.ProofIrrelevance.
+Require Import Coq.Logic.Classical_Prop.
+From iris.algebra Require Export stepindex.
+From iris.algebra Require Import set_model set_sets set_ordinals.
+
+Set Universe Polymorphism.
+
+
+(* classical preliminaries *)
+(*make an or into a sum using ϵ *)
+Lemma or_to_sum (P1 P2 : Prop) : P1 ∨ P2 → P1 + P2.
+Proof.
+ intros H. assert (exists (b : bool), if b then P1 else P2) as H1.
+ { destruct H.
+ - now exists true.
+ - now exists false.
+ }
+ apply constructive_indefinite_description in H1. destruct H1 as (b & H1).
+ destruct b; eauto.
+Qed.
+
+Lemma classic_dn (X : Prop) : X ↔ ¬ (¬ X).
+Proof.
+ split; intros H.
+ - tauto.
+ - destruct (classic X) as [H1 | H1]; [easy | tauto].
+Qed.
+
+Lemma classic_forall_exists_dn (X : Type) (P : X → Prop): (∀ x, P x) ↔ ¬ (∃ x, ¬ (P x)).
+Proof.
+ split.
+ - intros H (x & H1). eauto.
+ - intros H x. destruct (classic (P x)) as [ | H0]; [easy | ]. exfalso; apply H; eauto.
+Qed.
+
+Lemma classic_forall_exists (X : Type) (P : X → Prop): ¬ (∀ x, P x) ↔ (∃ x, ¬ (P x)).
+Proof.
+ by rewrite classic_forall_exists_dn -classic_dn.
+Qed.
+
+Lemma classic_exists_forall (X : Type) (P : X → Prop): ¬ (∃ x, (P x)) ↔ (∀ x, ¬ P x).
+Proof.
+ rewrite classic_forall_exists_dn; split; intros H [x ?]; eauto using classic_dn.
+Qed.
+
+
+
+
+Section ord_definition.
+ Local Open Scope zf_scope.
+ Implicit Types s t u: set.
+
+ (* definition of the ordinal type *)
+ Record Ord@{i}:= ord {
+ ord_set :> set@{i};
+ ord_set_is_ordinal : ordinal ord_set
+ }.
+ Hint Extern 0 (ordinal _) => by apply ord_set_is_ordinal : core.
+ Implicit Types α β γ δ : Ord.
+
+ (* NOTE: This proof uses proof_irrelevance. *)
+ Lemma ord_extensional α β: ord_set α = ord_set β → α = β.
+ Proof.
+ intros Heq. destruct α as [s Hs], β as [t Ht]; simpl in *.
+ subst s. f_equal. apply proof_irrelevance.
+ Qed.
+
+ Program Definition ordinals (α: Ord) (x: typeof α): Ord :=
+ {| ord_set := elements α x |}.
+ Next Obligation.
+ intros α x. eapply ordinal_el; eauto using elements_in.
+ Qed.
+
+ Definition zero : Ord := {| ord_set := empty; ord_set_is_ordinal := empty_ordinal |}.
+ Definition succ α : Ord := {| ord_set := succ_set α; ord_set_is_ordinal := succ_set_ordinal α (ord_set_is_ordinal α) |}.
+ Program Definition limit {X} (f: X → Ord) := {| ord_set := ⋃ {{ f x | x : X}} |}.
+ Next Obligation.
+ intros X f. apply ordinal_union. by intros a [x ->] % in_inv.
+ Qed.
+
+ Definition ord_lt (α β : Ord) := (α: set) ∈ (β: set).
+ Infix "≺" := ord_lt (at level 80).
+ Infix "⪯" := (rc ord_lt) (at level 80).
+ Hint Constructors rc.
+
+ Lemma ord_leq_unfold α β: α ⪯ β ↔ (α: set) ⊆ (β: set).
+ Proof.
+ split.
+ - intros [->|H]; first by intros ?.
+ apply el_succ_set_subs in H; auto.
+ eapply subs_trans; last apply H.
+ eauto using bunion_subs1, subseq.
+ - destruct (ordinal_linear α β) as [H|[H % ord_extensional|Hβα]]; auto.
+ intros Hαβ. exfalso. eapply one_cycles, Hαβ, Hβα.
+ Qed.
+
+ (** Step-Index Instance *)
+ (* Transitivity *)
+ Instance ord_lt_trans : Transitive ord_lt.
+ Proof.
+ intros ???; simpl. destruct z as [z [Ht ?]].
+ intros ??. eapply Ht; eauto.
+ Qed.
+
+ (* ordinal induction and well-foundedness *)
+ Lemma ord_ind (P: Ord → Prop): (∀ α, (∀ β, β ≺ α → P β) → P α) → ∀ α, P α.
+ Proof.
+ specialize (eps_ind) as Htrans.
+ specialize (ordinal_el) as Hordel.
+ intros H [a Ha].
+ pose (P' := fun a => forall (Ha : ordinal a), P (ord a Ha)).
+ enough (P' a) as H'.
+ { subst P'. simpl in H'. now apply H'. }
+ apply (Htrans P'); auto. clear a Ha.
+ intros a IH. intros Ha'. apply H.
+ intros [b Hb] Hlt. now apply (IH b Hlt).
+ Qed.
+
+ Lemma wf_ord_lt: wf ord_lt.
+ Proof.
+ intros α. induction α using ord_ind.
+ by constructor.
+ Qed.
+
+ (* strong linearity *)
+ Lemma ord_linear_strong α β: (α ≺ β) + (α = β) + (β ≺ α).
+ Proof.
+ destruct (or_to_sum _ _ (ordinal_linear α β (ord_set_is_ordinal α) (ord_set_is_ordinal β))) as [|H]; auto.
+ destruct (or_to_sum _ _ H); auto using ord_extensional.
+ Qed.
+
+ (* zero *)
+ Lemma zero_least α: α ≺ zero → False.
+ Proof.
+ apply zf_existence.
+ Qed.
+
+ Corollary no_smaller_than_zero: ¬ (∃ α, α ≺ zero).
+ Proof. by intros [α H % zero_least]. Qed.
+
+ (* successor *)
+ Lemma succ_greater α: α ≺ succ α.
+ Proof.
+ eapply in_succ_set_iff. by left.
+ Qed.
+
+ Lemma succ_least_greater α β: α ≺ β → succ α ⪯ β.
+ Proof.
+ intros H. apply ord_leq_unfold.
+ intros s Hs. eapply in_succ_set_iff in Hs as [->|Hs]; auto.
+ eapply ordinal_trans with (y := (α: set)); eauto using ordinal_el.
+ Qed.
+
+ Lemma succ_or_limit α: {β : Ord | α = succ β} + (∀ β : Ord, β ≺ α → succ β ≺ α).
+ Proof.
+ destruct (or_to_sum _ _ (ord_types α (ord_set_is_ordinal α))) as [H|[H|H] % or_to_sum].
+ - right. replace α with zero by (apply ord_extensional, symmetry, H).
+ intros ? [] % zero_least.
+ - left. apply constructive_indefinite_description in H as [s [Ho Heq]].
+ exists (ord s Ho); by apply ord_extensional.
+ - right. intros β Hβα. by apply limit_ord_el_succ_set in Hβα.
+ Qed.
+
+ Lemma ord_index_mixin : IndexMixin Ord ord_lt zero succ.
+ Proof.
+ constructor.
+ - apply _.
+ - apply wf_ord_lt.
+ - apply ord_linear_strong.
+ - apply no_smaller_than_zero.
+ - apply succ_greater.
+ - apply succ_least_greater.
+ - apply succ_or_limit.
+ Qed.
+
+ Canonical Structure ordI@{i j} : indexT@{j} := IndexT (Ord@{i}) ord_lt zero succ ord_index_mixin.
+
+ (** we define the jump operation to the next limit ordinal by taking the union over all ordinals reachable via succ *)
+ Definition jump_limit α := limit (λ n: nat, Nat.iter n succ α).
+
+ Global Instance: TransfiniteIndex ordI.
+ Proof.
+ exists jump_limit. intros n α.
+ apply zf_union. exists (Nat.iter (S n) succ α); split.
+ - apply succ_greater.
+ - by eapply in_intro.
+ Qed.
+
+End ord_definition.
+Hint Extern 0 (ordinal _) => by apply ord_set_is_ordinal : core.
+
+
+Section set_ordinal_lemmas.
+ Implicit Types α β γ δ : Ord.
+
+ Lemma ord_lt_unfold α β: α ≺ β ↔ (α: set) ∈ (β: set).
+ Proof. reflexivity. Qed.
+
+ Lemma ordinals_lt α x: ordinals α x ≺ α.
+ Proof.
+ apply ord_lt_unfold, elements_in.
+ Qed.
+ Hint Immediate ordinals_lt : core.
+
+ Lemma ord_subset α β: (∀ γ, γ ≺ α → γ ≺ β) → (α: set) ⊆ (β: set).
+ Proof.
+ intros Ha s [x ->] % in_inv_elements.
+ apply (Ha _ (ordinals_lt α x)).
+ Qed.
+
+ Lemma ord_lt_inv_ordinals β α: β ≺ α → ∃ x: typeof α, β = ordinals α x.
+ Proof.
+ intros [x Hx] % in_inv_elements. exists x. apply ord_extensional, Hx.
+ Qed.
+
+ (* limit operation *)
+ Lemma limit_upper_bound_strong (X : Type) (f : X → Ord) (α: Ord):
+ (∀ β, β ≺ α → ∃ x, β ≺ f x) → α ⪯ limit f.
+ Proof.
+ intros H. apply ord_leq_unfold, ord_subset. intros s [a ->] % ord_lt_inv_ordinals.
+ destruct (H (ordinals α a) (ordinals_lt α a)) as [x Hleq].
+ apply zf_union. exists (f x); eauto using in_intro.
+ Qed.
+
+ Lemma limit_upper_bound {X} (f: X → Ord) x: f x ⪯ limit f.
+ Proof.
+ eapply limit_upper_bound_strong; eauto.
+ Qed.
+
+ Lemma limit_least_upper_bound {X} (f: X → Ord) y: (∀ x, f x ⪯ y) → limit f ⪯ y.
+ Proof.
+ intros Hle. apply ord_leq_unfold.
+ intros s [t [Hst Hf]] % zf_union. apply in_inv in Hf as [x ->].
+ eapply ord_leq_unfold; [ | apply Hst]. destruct (index_le_eq_or_lt _ _ (Hle x)); eauto.
+ Qed.
+
+ Lemma limit_ext {Y} (f g: Y → Ord):
+ (∀ x, f x = g x) → limit f = limit g.
+ Proof.
+ intros Heq. apply ord_extensional; simpl.
+ f_equal. apply setof_ext. intros x. by destruct (Heq x).
+ Qed.
+
+ Lemma limit_mono_strong {A B} (F: A → Ord) (G: B → Ord): (∀ a, ∃ b, F a ⪯ G b) → limit F ⪯ limit G.
+ Proof.
+ intros H.
+ apply limit_least_upper_bound. intros x. destruct (H x) as [b Hle].
+ transitivity (G b); eauto using limit_upper_bound.
+ Qed.
+
+ Lemma limit_mono {A} (F: A → Ord) (G: A → Ord): (∀ a, F a ⪯ G a) → limit F ⪯ limit G.
+ Proof.
+ intros H; eapply limit_mono_strong; intros a; by exists a.
+ Qed.
+
+ (* derived limit constructor for limits of ordinals *)
+ Definition limitO α (f: ∀ β, β ≺ α → Ord) := limit (λ x : typeof α, f (ordinals α x) (ordinals_lt α x)).
+
+ Lemma limitO_ext α (f g: ∀ β, β ≺ α → Ord): (∀ β Hβ, f β Hβ = g β Hβ) → limitO α f = limitO α g.
+ Proof.
+ intros H; apply limit_ext; auto.
+ Qed.
+End set_ordinal_lemmas.
+
+
+Section existential_property.
+
+ (** proof that once can "pull out" existentials when using ordinals as the stepindex type *)
+ Lemma constructive_upper_bound_ordinal A (φ: A → Ord → Prop):
+ (∀ a α β, α ⪯ β → φ a α → φ a β) →
+ (∀ a : A, { α : Ord | φ a α }) →
+ ({ α: Ord | ∀ a: A, φ a α}).
+ Proof.
+ intros Hge X. exists (limit (λ a : A, proj1_sig (X a))).
+ intros a. destruct (X a) as [α Hφ] eqn: H.
+ eapply Hge, Hφ. transitivity (proj1_sig (X a)); last apply (limit_upper_bound (λ a : A, proj1_sig (X a))).
+ by rewrite H.
+ Qed.
+
+ Lemma upper_bound_ordinal (A: Type) (φ: A → Ord → Prop):
+ (∀ a α β, α ⪯ β → φ a α → φ a β) →
+ (∀ a : A, ∃ α : Ord, φ a α) →
+ (∃ α: Ord, ∀ a: A, φ a α).
+ Proof.
+ intros Hge Ha. edestruct (constructive_upper_bound_ordinal _ _ Hge) as [α Hα].
+ - intros a. by apply constructive_indefinite_description.
+ - by exists α.
+ Qed.
+
+ (* classical proof of the existential property *)
+ Lemma commute_exists (J : Type) (P : J → Ord → Prop) :
+ (∀ j α β, α ≺ β → P j β → P j α)
+ → (∀ α, ∃ j, P j α)
+ → ∃ j, ∀ α, P j α.
+ Proof.
+ intros Hdown H. destruct (classic (∃ j : J, ∀ α : Ord, P j α)) as [|H1]; auto.
+ destruct (upper_bound_ordinal _ (λ j α, ¬ P j α)) as [α Hbound].
+ - intros a α β Hle Hα Hβ. apply Hα. destruct Hle; subst; eauto.
+ - intros a. revert H1. rewrite classic_exists_forall -classic_forall_exists; eauto.
+ - exfalso. destruct (H α); by eapply Hbound.
+ Qed.
+End existential_property.
+
+Section large_index_class.
+ Polymorphic Universes i j.
+ Polymorphic Constraint i < j.
+
+ Global Instance set_model_large_index: LargeIndex (ordI@{i j}).
+ Proof.
+ intros X P H He. eapply commute_exists; eauto.
+ Qed.
+End large_index_class.
diff --git a/theories/algebra/ordinals/set_functions.v b/theories/algebra/ordinals/set_functions.v
new file mode 100644
index 0000000000000000000000000000000000000000..e98ad97b6dbfa023c11bfa5957e972698f98f2bd
--- /dev/null
+++ b/theories/algebra/ordinals/set_functions.v
@@ -0,0 +1,1021 @@
+(** This file has been adapted from Dominik Kirst's Bachelor Thesis
+ "Formalised Set Theory: Well-Orderings and the Axiom of Choice",
+ see https://www.ps.uni-saarland.de/~kirst/bachelor.php
+*)
+
+(** initial import of the development **)
+From iris.algebra.ordinals Require Import set_model set_sets.
+
+Set Universe Polymorphism.
+Set Universe Minimization ToSet.
+
+Section set_functions.
+Local Open Scope zf_scope.
+
+Implicit Types (a b c A B C R S T f: set).
+
+(** ** Relations *)
+
+Definition relation R A B := R ⊆ product A B.
+
+Definition dom R := replacement_set R (λ p, pi1 p).
+Definition ran R := replacement_set R (λ p, pi2 p).
+Definition field R := bunion_set (dom R) (ran R).
+
+Definition symmetric R := ∀ a b, (a,b) ∈ R → (b,a) ∈ R.
+Definition asymmetric R := ∀ a b, (a,b) ∈ R → (b,a) ∉ R.
+Definition antisymmetric R := ∀ a b, (a,b) ∈ R → (b,a) ∈ R → a = b.
+Definition transitive R := ∀ a b c, (a,b) ∈ R → (b,c) ∈ R → (a,c) ∈ R.
+Definition reflexive R A := ∀ a, a ∈ A → (a,a) ∈ R.
+Definition irreflexive R := ∀ a, (a,a) ∉ R.
+Definition linear R A := ∀ a b, a ∈ A → b ∈ A → (a,b) ∈ R ∨ (b,a) ∈ R ∨ a = b.
+
+Definition equivalence R A :=
+ relation R A A ∧ symmetric R ∧ reflexive R A ∧ transitive R.
+
+Definition lordering R A :=
+ relation R A A ∧ asymmetric R ∧ transitive R ∧ linear R A.
+
+Definition least R A x := x ∈ A ∧ ∀ y, y ∈ A → (x,y) ∈ R ∨ y = x.
+Definition wfounded R A := ∀ M, M ⊆ A → M <> empty → ∃ x, least R M x.
+Definition wordering R A := lordering R A ∧ wfounded R A.
+Definition WO A := ∃ R, wordering R A.
+
+
+Lemma rel_pair R A B p a b: relation R A B → p ∈ R → a = pi1 p → b = pi2 p → p = (a,b).
+Proof.
+intros I J. specialize (I p J). now apply (opair_pi A B).
+Qed.
+
+Lemma rel_pi f A B p: relation f A B → p ∈ f → (pi1 p, pi2 p) ∈ f.
+Proof.
+intros I J. now rewrite <- (@rel_pair f A B p (pi1 p) (pi2 p) I J) at 1.
+Qed.
+
+Lemma rel_pair1 R A B a b: relation R A B → (a,b) ∈ R → a ∈ A.
+Proof.
+intros I J. specialize (I (a,b) J). now apply product_opair in I.
+Qed.
+
+Lemma rel_pair2 R A B a b: relation R A B → (a,b) ∈ R → b ∈ B.
+Proof.
+intros I J. specialize (I (a,b) J). now apply product_opair in I.
+Qed.
+
+Lemma rel_pi1 R A B p: relation R A B → p ∈ R → pi1 p ∈ A.
+Proof.
+intros I J. specialize (I p J). now apply product_pi1 in I.
+Qed.
+
+Lemma rel_pi2 R A B p: relation R A B → p ∈ R → pi2 p ∈ B.
+Proof.
+intros I J. specialize (I p J). now apply product_pi2 in I.
+Qed.
+
+Lemma asym_irref R: asymmetric R → antisymmetric R ∧ irreflexive R.
+Proof.
+intros I. split.
+- intros a b I1 I2. exfalso. now apply (I a b).
+- intros a J. now apply (I a a).
+Qed.
+
+Lemma irref_asym R: antisymmetric R ∧ irreflexive R → asymmetric R.
+Proof.
+intros [I1 I2] a b J1 J2.
+specialize (I1 a b J1 J2).
+subst b. now apply (I2 a).
+Qed.
+
+Lemma trans_asym R: transitive R ∧ irreflexive R → asymmetric R.
+Proof.
+intros [I1 I2] a b J1 J2.
+specialize (I1 a b a J1 J2).
+now apply (I2 a).
+Qed.
+
+Lemma wo_irr R A: wordering R A → irreflexive R.
+Proof.
+intros I. apply asym_irref. apply I.
+Qed.
+
+Lemma wordering_empty: wordering empty empty.
+Proof.
+repeat split.
+- intros p I. contradiction (zf_existence p I).
+- intros x y I. contradiction (zf_existence (x,y) I).
+- intros x y z I. contradiction (zf_existence (x,y) I).
+- intros x y I. contradiction (zf_existence x I).
+- intros M I J. exfalso. apply J. apply zf_extensionality; eauto using empty_subs.
+Qed.
+
+
+
+(** ** Functions *)
+
+Definition total f A B := ∀ x, x ∈ A → ∃ y, y ∈ B ∧ (x,y) ∈ f.
+Definition functional f := ∀ a b b', (a,b) ∈ f → (a,b') ∈ f → b' = b.
+
+Definition surjective f A B := ∀ y, y ∈ B → ∃ x, x ∈ A ∧ (x,y) ∈ f.
+Definition injective f := ∀ a a' b, (a,b) ∈ f → (a',b) ∈ f → a = a'.
+Definition bijective f A B := surjective f A B ∧ injective f.
+
+Definition function f A B := relation f A B ∧ total f A B ∧ functional f.
+
+Definition surjection f A B := function f A B ∧ surjective f A B.
+Definition injection f A B := function f A B ∧ injective f.
+Definition bijection f A B := function f A B ∧ surjective f A B ∧ injective f.
+Definition equi A B := ∃ f, bijection f A B.
+
+
+Lemma fun_pi f A B p: function f A B → p ∈ f → (pi1 p, pi2 p) ∈ f.
+Proof.
+intros [I I'] J. eauto using rel_pi.
+Qed.
+
+Lemma fun_pair f A B p: function f A B → p ∈ f → p = (pi1 p, pi2 p).
+Proof.
+intros [I I'] J. specialize (I p J). now apply (opair_pi A B (pi1 p) (pi2 p)) in I.
+Qed.
+
+Lemma fun_product f A B p: function f A B → p ∈ f → p ∈ product A B.
+Proof.
+intros [I _] J. auto.
+Qed.
+
+Lemma fun_pi1 f A B p: function f A B → p ∈ f → pi1 p ∈ A.
+Proof.
+intros I J. apply (product_pi1 A B). apply (@fun_product f); assumption.
+Qed.
+
+Lemma fun_pi2 f A B p: function f A B → p ∈ f → pi2 p ∈ B.
+Proof.
+intros I J. apply (product_pi2 A B). apply (fun_product f); assumption.
+Qed.
+
+Lemma fun_pair1 f A B a b: function f A B → (a,b) ∈ f → a ∈ A.
+Proof.
+intros FF PE. apply (rel_pair1 f A B a b); trivial. apply FF.
+Qed.
+
+Lemma fun_pair2 f A B a b: function f A B → (a,b) ∈ f → b ∈ B.
+Proof.
+intros FF PE. apply (rel_pair2 f A B a b); trivial. apply FF.
+Qed.
+
+Lemma fun_el1 f A B a b: function f A B → (a,b) ∈ f → a ∈ A.
+Proof.
+intros [I _] J. specialize (I (a,b) J). apply product_opair in I as [I _]. assumption.
+Qed.
+
+Lemma fun_el2 f A B a b: function f A B → (a,b) ∈ f → b ∈ B.
+Proof.
+intros [I _] J. specialize (I (a,b) J). apply product_opair in I as [_ I]. assumption.
+Qed.
+
+Lemma fun_el_dom f a b: (a,b) ∈ f → a ∈ dom f.
+Proof.
+intros I. apply zf_replacement.
+exists (a,b). rewrite pi1_cor. split; trivial.
+Qed.
+
+Lemma fun_el_ran f a b: (a,b) ∈ f → b ∈ ran f.
+Proof.
+intros I. apply zf_replacement.
+exists (a,b). rewrite pi2_cor. split; trivial.
+Qed.
+
+Lemma sur_ran1 f A B: relation f A B → surjective f A B → ran f = B.
+Proof.
+intros H I. apply zf_extensionality; split; intros y Y.
+- apply zf_replacement in Y as [p [P1 P2]].
+ subst y. now apply (rel_pi2 f A B).
+- apply zf_replacement. destruct (I y Y) as [x [X1 X2]].
+ exists (x,y). rewrite pi2_cor. split; trivial.
+Qed.
+
+Lemma sur_ran2 f A B: relation f A B → ran f = B → surjective f A B.
+Proof.
+intros H I y Y. apply extenE in I as [_ I]. specialize (I y Y).
+apply zf_replacement in I as [p [P1 P2]]. subst y.
+exists (pi1 p). split; eauto using rel_pi1.
+eauto using rel_pi.
+Qed.
+
+Lemma sur_ran f A B: relation f A B → (surjective f A B ↔ ran f = B).
+Proof.
+intros H. split; intros I.
+- now apply (sur_ran1 f A B).
+- now apply (sur_ran2 f A B).
+Qed.
+
+Lemma fun_ran_subs f A B: function f A B → ran f ⊆ B.
+Proof.
+intros I y Y. apply zf_replacement in Y as [p [P1 P2]].
+subst y. now apply (fun_pi2 f A B).
+Qed.
+
+Lemma tot_dom1 f A B: relation f A B → total f A B → dom f = A.
+Proof.
+intros H I. apply zf_extensionality; split; intros x X.
+- apply zf_replacement in X as [p [P1 P2]].
+ subst x. now apply (rel_pi1 f A B).
+- apply zf_replacement. destruct (I x X) as [y [Y1 Y2]].
+ exists (x,y). rewrite pi1_cor. split; trivial.
+Qed.
+
+Lemma tot_dom2 f A B: relation f A B → dom f = A → total f A B.
+intros H I x X. apply extenE in I as [_ I]. specialize (I x X).
+apply zf_replacement in I as [p [P1 P2]]. subst x.
+exists (pi2 p). split; eauto using rel_pi2.
+eauto using rel_pi.
+Qed.
+
+Lemma tot_dom f A B: relation f A B → (total f A B ↔ dom f = A).
+Proof.
+intros H. split; intros I.
+- now apply (tot_dom1 f A B).
+- now apply (tot_dom2 f A B).
+Qed.
+
+Lemma bijec_empty f A: bijection f A empty → A = empty.
+Proof.
+intros [[R[T F]][S I]]. apply zf_extensionality; split; eauto using empty_subs.
+intros x J. specialize (T x J). destruct T as [y [T _]].
+contradiction (zf_existence y T).
+Qed.
+
+Lemma fun_step_rel f A B x y: function f A B → x ∉ A → y ∈ B →
+ relation (bunion_set f (singleton (x,y))) (bunion_set A (singleton x)) B.
+Proof.
+intros [FR[FT FF]] XA YB p P. apply bunionE in P as [P|P].
+- apply (product_subs1 (bunion_set A (singleton x)) A).
++ apply bunion_subs1. apply subseq.
++ now apply FR.
+- apply single_el in P. subst p.
+ apply product_opair. split; trivial.
+ apply bunionI2. now apply single_el.
+Qed.
+
+Lemma fun_step_tot f A B x y: function f A B → x ∉ A → y ∈ B →
+ total (bunion_set f (singleton (x,y))) (bunion_set A (singleton x)) B.
+Proof.
+intros [FR[FT FF]] XA YB a AE. apply bunionE in AE as [AE|AE].
+- destruct (FT a AE) as [b [BE1 BE2]].
+ exists b. split; trivial.
+ now apply bunionI1.
+- apply single_el in AE. subst a.
+ exists y. split; trivial.
+ apply bunionI2. now apply single_el.
+Qed.
+
+Lemma fun_step_fun f A B x y: function f A B → x ∉ A → y ∈ B →
+ functional (bunion_set f (singleton (x,y))).
+Proof.
+intros [FR[FT FF]] XA YB a b b' I1 I2.
+apply bunionE in I1 as [I1|I1]; apply bunionE in I2 as [I2|I2].
+- now apply (FF a b b').
+- apply single_el in I2. apply opair_eq in I2 as [I2 I3]. subst.
+ exfalso. apply XA. apply (fun_pair1 f A B x b); trivial. repeat split; assumption.
+- apply single_el in I1. apply opair_eq in I1 as [I1 I3]. subst.
+ exfalso. apply XA. apply (fun_pair1 f A B x b'); trivial. repeat split; assumption.
+- apply single_el in I1. apply single_el in I2.
+ apply opair_eq in I1 as [_ I1].
+ apply opair_eq in I2 as [_ I2].
+ congruence.
+Qed.
+
+Lemma fun_step f A B x y: function f A B → x ∉ A → y ∈ B →
+ function (bunion_set f (singleton (x,y))) (bunion_set A (singleton x)) B.
+Proof.
+intros FF XA YB. repeat split.
+- now apply fun_step_rel.
+- now apply fun_step_tot.
+- eapply fun_step_fun; try apply FF; assumption.
+Qed.
+
+Lemma fun_expand f A B B': function f A B → B ⊆ B' → function f A B'.
+Proof.
+intros [I1[I2 I3]] J. repeat split.
+- intros p P. specialize (I1 p P). now apply (product_subs2 A B B').
+- intros x X. destruct (I2 x X) as [y[Y1 Y2]].
+ exists y. split; auto.
+- assumption.
+Qed.
+
+
+
+(** ** Application *)
+
+Definition xgraph f x := specification_set f (λ p, pi1 p = x).
+Definition ximages f x := replacement_set (xgraph f x) (λ p, pi2 p).
+Definition app f x := union_set (ximages f x).
+Notation "f '[' x ']'" := (app f x) (at level 10).
+
+
+Lemma xgraph_cor f x y: (x,y) ∈ f → (x,y) ∈ xgraph f x.
+Proof.
+intros I. apply zf_specification. split; eauto using pi1_cor.
+Qed.
+
+Lemma im_cor f x y A B: function f A B → (x,y) ∈ f → ximages f x = singleton y.
+Proof.
+intros [I [I' I'']] J. apply zf_extensionality; split; intros y' H.
+- apply single_el. apply (I'' x y y').
++ assumption.
++ apply zf_replacement in H as [p [H H']]. apply zf_specification in H as [H H''].
+ assert (P: p = (x,y')) by eauto using (rel_pair f A B). now rewrite <- P.
+- apply single_el in H. rewrite H. apply zf_replacement. exists (x,y). split.
++ now apply xgraph_cor.
++ now rewrite pi2_cor.
+Qed.
+
+Lemma app_cor f x A B: function f A B → x ∈ A → (x,f[x]) ∈ f ∧ f[x] ∈ B.
+Proof.
+intros [I [I' I'']] J.
+assert (F: function f A B) by (repeat split; assumption).
+destruct (I' x J) as [y [J'' J']]. cut (y = f[x]).
+- intros H. subst y. now split.
+- unfold app. rewrite (im_cor f x y A B F J'). now rewrite single_union_set.
+Qed.
+
+Lemma app_cor1 f x A B: function f A B → x ∈ A → (x,f[x]) ∈ f.
+Proof.
+intros I J. specialize (app_cor f x A B I J). now intros [H H'].
+Qed.
+
+Lemma app_cor2 f x A B: function f A B → x ∈ A → f[x] ∈ B.
+Proof.
+intros I J. specialize (app_cor f x A B I J). now intros [H H'].
+Qed.
+
+Lemma app_eq f x y A B: function f A B → (x,y) ∈ f → y = f[x].
+Proof.
+intros I J. specialize (im_cor f x y A B I J). intros H.
+unfold app. rewrite H. now rewrite single_union_set.
+Qed.
+
+Lemma app_sur f A B y: surjection f A B → y ∈ B → ∃ x, x ∈ A ∧ y = f[x].
+Proof.
+intros [I I'] Y. destruct (I' y Y) as [x [J I'']].
+exists x. split; try assumption. now apply (app_eq f x y A B).
+Qed.
+
+Lemma app_inj f A B x x': injection f A B → x ∈ A → x' ∈ A → f[x] = f[x'] → x = x'.
+Proof.
+intros [I I'] X X' J. specialize (I' x x' (f[x])). apply I'.
+- eauto using app_cor1.
+- rewrite J. eauto using app_cor1.
+Qed.
+
+Lemma fun_app f A B p: function f A B → p ∈ f → pi2 p = f[pi1 p].
+Proof.
+intros I J. apply (app_eq f (pi1 p) (pi2 p) A B); auto. now apply (fun_pi f A B).
+Qed.
+
+Lemma fun_appel f A B p: function f A B → p ∈ f → p = (pi1 p, f[pi1 p]).
+Proof.
+intros I J. rewrite <- (fun_app f A B); trivial.
+now apply (fun_pair f A B).
+Qed.
+
+Lemma bij_app f A B p: bijection f A B → p ∈ f → pi2 p = f[pi1 p].
+Proof.
+intros [I] J. now apply (fun_app f A B).
+Qed.
+
+Lemma fun_shrink A B B' f: function f A B → (∀ x, x ∈ A → f[x] ∈ B') → function f A B'.
+Proof.
+intros FF BB. repeat split.
+intros p P.
+- specialize (fun_appel f A B p FF P).
+ intros PP. rewrite PP. rewrite PP in P. apply product_opair.
+ assert (P1: pi1 p ∈ A) by eauto using fun_pair1.
+ split; trivial. now apply BB.
+- assert (FT: total f A B) by apply FF.
+ intros x X. destruct (FT x X) as [y [Y1 Y2]].
+ exists y. split; trivial. rewrite (app_eq f x y A B); trivial.
+ now apply BB.
+- apply FF.
+Qed.
+
+
+
+(** ** Restriction *)
+
+Definition restriction f A := specification_set f (λ p, pi1 p ∈ A).
+Notation "f '|*' A" := (restriction f A) (at level 8).
+
+Definition rel_restriction R A := specification_set R (λ p, p ∈ product A A).
+Notation "R '|>' A" := (rel_restriction R A) (at level 9).
+
+
+Lemma res_functional f A: functional f → functional f|*A.
+Proof.
+intros I x y y'. intros P1 P2.
+apply spec_subs in P1. apply spec_subs in P2.
+now apply (I x y y').
+Qed.
+
+Lemma res_injective f A: injective f → injective f|*A.
+Proof.
+intros I x x' y. intros P1 P2.
+apply spec_subs in P1. apply spec_subs in P2.
+now apply (I x x' y).
+Qed.
+
+Lemma res_fun f A B A': function f A B → A' ⊆ A → function (f|*A') A' B.
+Proof.
+intros [I [I' I'']]. repeat split.
+- intros p J. apply zf_specification in J as [J J']. apply product_el.
+ exists (pi1 p), (pi2 p). repeat split; eauto using opair_pi, product_pi2.
+- intros x J. specialize (I' x (H x J)). destruct I' as [y [X Y]].
+ exists y. split; eauto. apply zf_specification. split; eauto. now rewrite pi1_cor.
+- now apply res_functional.
+Qed.
+
+Lemma res_el f A B A' x y: function f A B → A' ⊆ A → (x,y) ∈ f |* A' → x ∈ A'.
+Proof.
+intros I H. specialize (res_fun f A B A' I H). intros J J'.
+now apply (fun_el1 (f|*A') A' B x y).
+Qed.
+
+Lemma res_eq f A B A' x: function f A B → A' ⊆ A → x ∈ A' → f [x] = f|*A' [x].
+Proof.
+intros I I' I''. specialize (res_fun f A B A' I I'). intros J.
+specialize (app_cor1 f x A B I (I' x I'')). intros J'.
+specialize (app_cor1 f|*A' x A' B J I''). intros J''.
+apply spec_subs in J''. destruct I as [I [H H']]. symmetry. now apply (H' x (f[x]) (f |* A' [x])).
+Qed.
+
+Lemma res_opair f A B A' a b: function f A B → A' ⊆ A → (a,b) ∈ f → a ∈ A' → (a,b) ∈ f |* A'.
+Proof.
+intros I1 I2 I3 I4. apply zf_specification. split; eauto. now rewrite pi1_cor.
+Qed.
+
+Lemma res_res f A B: A ⊆ B → (f|*B)|*A = f|* A.
+Proof.
+intros I. apply zf_extensionality; split; intros p P;
+apply zf_specification in P as [P1 P2]; apply zf_specification.
+- apply zf_specification in P1 as [P1 _]. split; assumption.
+- split; trivial. apply zf_specification. split; auto.
+Qed.
+
+Lemma relres_rel R A': relation (R|>A') A' A'.
+Proof.
+intros p P. apply zf_specification in P as [_ P]. assumption.
+Qed.
+
+Lemma relres_asym R A': asymmetric R → asymmetric (R|>A').
+Proof.
+intros I a b J1 J2.
+apply zf_specification in J1 as [J1 _].
+apply zf_specification in J2 as [J2 _].
+now apply (I a b).
+Qed.
+
+Lemma relres_trans R A': transitive R → transitive (R|>A').
+Proof.
+intros I a b c J1 J2.
+apply zf_specification in J1 as [J1 J1'].
+apply zf_specification in J2 as [J2 J2'].
+apply zf_specification. split.
++ now apply (I a b c).
++ apply product_opair in J1' as [J1' _].
+ apply product_opair in J2' as [_ J2'].
+ apply product_opair. split; assumption.
+Qed.
+
+Lemma relres_linear R A A': linear R A → A' ⊆ A → linear (R|>A') A'.
+Proof.
+intros I J a b J1 J2. destruct (I a b) as [H|[H|H]]; auto.
+- left. apply zf_specification. split; trivial.
+ apply product_opair. split; assumption.
+- right. left. apply zf_specification. split; trivial.
+ apply product_opair. split; assumption.
+Qed.
+
+Lemma relres_wf R A A': wfounded R A → A' ⊆ A → wfounded (R|>A') A'.
+Proof.
+intros I J B B1 B2. destruct (I B) as [x [H1 H2]].
+- now apply (subs_trans) with (B:=A').
+- assumption.
+- exists x. split; trivial.
+ intros y Y. destruct (H2 y Y) as [H|H].
++ left. apply zf_specification. split; trivial.
+ apply product_opair. split; auto.
++ right. assumption.
+Qed.
+
+Lemma worder_subs R A A': wordering R A → A' ⊆ A → wordering (R|>A') A'.
+Proof.
+intros WOR S. repeat split.
+- apply relres_rel.
+- apply relres_asym. apply WOR.
+- apply relres_trans. apply WOR.
+- apply (relres_linear R A); trivial. apply WOR.
+- apply (relres_wf R A); trivial. apply WOR.
+Qed.
+
+Lemma equi_empty A B: equi A B → A <> empty → B <> empty.
+Proof.
+intros [f [I H]] I'. apply empty_el in I' as [x I']. apply empty_el.
+exists (f[x]). eauto using app_cor2.
+Qed.
+
+
+
+(** ** Image *)
+
+Definition image f A := replacement_set f|* A (λ p, pi2 p).
+Notation "f '[(' A ')]'" := (image f A) (at level 10).
+
+
+Lemma image_subs f A B A': function f A B → image f A' ⊆ B.
+Proof.
+intros I y H. apply zf_replacement in H as [p [H H']]. rewrite H'.
+apply zf_specification in H as [H _]. now apply (fun_pi2 f A).
+Qed.
+
+Lemma image_empty f A B A': function f A B → A' ⊆ A → A' <> empty → image f A' <> empty.
+Proof.
+intros I I' I''. apply empty_el in I'' as [x I'']. apply empty_el.
+exists (f[x]). apply zf_replacement. exists (x,f[x]). split.
+- rewrite (res_eq f A B A'); eauto using app_cor1, res_fun.
+- now rewrite pi2_cor.
+Qed.
+
+Lemma im_el f A B A' x y: injection f A B → A' ⊆ A → (x,y) ∈ f → y ∈ image f A' → x ∈ A'.
+Proof.
+intros [I I'] I'' J J'. apply zf_replacement in J' as [p [J' J'']]. subst y.
+specialize (I' x (pi1 p) (pi2 p) J). rewrite I'.
+- destruct (res_fun f A B A' I I'') as [H H']. specialize (H p J'). eauto using product_pi1.
+- apply spec_subs in J'. eauto using fun_pi.
+Qed.
+
+Lemma image_el f A B A' x: function f A B → A' ⊆ A → x ∈ A' → f[x] ∈ image f A'.
+Proof.
+intros I I' I''. apply zf_replacement. exists (x,f[x]). split.
+- specialize (res_fun f A B A' I I'). intros H. rewrite (res_eq f A B A'); eauto using app_cor1.
+- now rewrite pi2_cor.
+Qed.
+
+Lemma image_res f A B A': function f A B → A' ⊆ A → f|*A'[(A')] = f[(A')].
+Proof.
+intros I J. apply zf_extensionality; split; intros y Y;
+apply zf_replacement; apply zf_replacement in Y as [p [P1 P2]];
+exists p; split; auto.
++ now apply zf_specification in P1 as [].
++ apply zf_specification. split; auto. now apply zf_specification in P1 as [].
+Qed.
+
+Lemma image_rel f A B A': bijection f A B → A' ⊆ A → relation (f|*A') A' (f[(A')]).
+Proof.
+intros [[re [to fu]] [I2 I3]] J.
+assert (F: function f A B) by (repeat split; eauto).
+intros p I. apply zf_specification in I as [J1 J2]. apply product_el. exists (pi1 p), (f[pi1 p]).
+assert (H: (pi1 p, pi2 p) ∈ f) by eauto using fun_pi. repeat split; eauto.
+- apply zf_replacement. exists p. split. apply zf_specification. split; eauto.
+ symmetry. apply (app_eq f (pi1 p) (pi2 p) A B); eauto.
+- specialize (re p J1). apply (opair_pi A B (pi1 p) (f[pi1 p])) in re; eauto.
+ apply (fu (pi1 p) (pi2 p) (f[pi1 p])); eauto. apply (app_cor1 f (pi1 p) A B); eauto.
+Qed.
+
+Lemma image_tot f A B A': bijection f A B → A' ⊆ A → total (f|*A') A' (f[(A')]).
+Proof.
+intros [[re [to fu]] [I2 I3]] J.
+assert (F: function f A B) by (repeat split; eauto).
+intros x I. specialize (to x (J x I)). destruct to as [y [H1 H2]]. exists y. split.
+- apply zf_replacement. exists (x,y). split. eauto using res_opair. now rewrite pi2_cor.
+- eauto using res_opair.
+Qed.
+
+Lemma image_sur f A B A': bijection f A B → A' ⊆ A → surjective (f|*A') A' (f[(A')]).
+Proof.
+intros [F [I2 I3]] J.
+intros y H. apply zf_replacement in H as [p [H1 H2]]. exists (pi1 p). split.
++ apply zf_specification in H1 as [_ H]. assumption.
++ subst y. eauto using fun_pi, res_fun.
+Qed.
+
+Lemma image_bijection f A B A': bijection f A B → A' ⊆ A → bijection (f|*A') A' (f[(A')]).
+Proof.
+intros I1 I2. repeat split.
+- now apply (image_rel f A B).
+- now apply (image_tot f A B).
+- apply res_functional. apply I1.
+- now apply (image_sur f A B).
+- apply res_injective. apply I1.
+Qed.
+
+Lemma image_bij f A B A': bijection f A B → A' ⊆ A → bijection (f|*A') A' (f|*A'[(A')]).
+Proof.
+intros I1 I2. cut (f|*A'[(A')] = f[(A')]).
+- intros I. rewrite I. apply (image_bijection f A B); assumption.
+- apply (image_res f A B); trivial; apply I1.
+Qed.
+
+Lemma fun_ran f A B: function f A B → function f A (ran f).
+Proof.
+intros [I [I' I'']]. repeat split.
+- intros p J. specialize (I p J). apply product_el in I as [a [b [H [H' H'']]]]. subst p.
+ apply product_el. exists a, b. repeat split; eauto. apply zf_replacement.
+ exists (a,b). rewrite pi2_cor. now split.
+- intros x J. destruct (I' x J) as [y [H H']]. exists y. split; eauto.
+ apply zf_replacement. exists (x,y). rewrite pi2_cor. now split.
+- assumption.
+Qed.
+
+Lemma image_ran f A B A': A' ⊆ A → function f A B → image f A' = ran (f|*A').
+Proof.
+intros I [I' I'']. assert (F: function f A B). split; eauto. apply zf_extensionality; split; intros y J.
+- apply zf_replacement. apply zf_replacement in J as [p [J J']]. exists p. now split.
+- apply zf_replacement. apply zf_replacement in J as [p [J' J'']]. exists p. now split.
+Qed.
+
+Lemma equi_subs A B A': equi A B → A' ⊆ A → ∃ B', B' ⊆ B ∧ equi A' B'.
+Proof.
+intros [f FF] J. exists (image f A'). split.
+- apply (image_subs f A); trivial. apply FF.
+- exists (f|*A'). now apply (image_bijection f A B).
+Qed.
+
+
+
+(** ** Inverse *)
+
+Definition inverse f := replacement_set f (λ p, (pi2 p, pi1 p)).
+Notation "f ^" := (inverse f) (at level 5).
+
+
+Lemma inv_el1 f x y: (x,y) ∈ f → (y,x) ∈ f^.
+Proof.
+intros I. apply zf_replacement. exists (x,y). split; eauto. now rewrite pi1_cor pi2_cor.
+Qed.
+
+Lemma inv_el2 f x y A B: relation f A B → (y,x) ∈ f^ → (x,y) ∈ f.
+Proof.
+intros Rel I. apply zf_replacement in I as [p [I I']]. apply opair_eq in I' as [H H'].
+assert (J: p = (x,y)) by eauto using opair_pi. now rewrite <- J at 1.
+Qed.
+
+Lemma inv_bij f A B: bijection f A B → bijection f^ B A.
+Proof.
+intros [[I [J H]] [I' I'']]. repeat split.
+- intros p H'. apply zf_replacement in H' as [p' [H' H'']]. apply product_el.
+ exists (pi2 p'), (pi1 p'). repeat split; [eapply product_pi2; eauto | eapply product_pi1; eauto | eauto].
+- intros x H'. specialize (I' x H'). destruct I' as [y [I' H'']].
+ exists y. split; eauto. now apply inv_el1.
+- intros x y y'. intros H' H''. symmetry. apply (I'' y y' x); eauto using inv_el2.
+- intros x H'. specialize (J x H'). destruct J as [y [J J']]. eauto using inv_el1.
+- intros x x' y J' J''. symmetry. apply (H y x x'); eauto using inv_el2.
+Qed.
+
+Lemma inv_el f A B y: bijection f A B → y ∈ B → f^[y] ∈ A.
+Proof.
+intros I J. apply (app_cor2 f^ y B); eauto.
+apply inv_bij in I as [I _]. assumption.
+Qed.
+
+Lemma inv_element f A B y: bijection f A B → y ∈ B → (f^[y], y) ∈ f.
+Proof.
+intros I J. apply (inv_el2 f (f^[y]) y A B).
+- apply I.
+- apply (app_cor1 f^ y B A); auto.
+ apply inv_bij in I. apply I.
+Qed.
+
+Lemma inv_idem f A B: bijection f A B → f = f^^.
+Proof.
+intros [fct[sur inj]]. apply zf_extensionality; split; intros p I.
+- apply zf_replacement. exists (pi2 p, pi1 p). rewrite pi1_cor pi2_cor.
+ setoid_rewrite (fun_pair f A B p) at 3; eauto. split; eauto.
+ apply zf_replacement. exists p. split; eauto.
+- apply zf_replacement in I as [q[I J1]].
+ apply zf_replacement in I as [r[I J2]].
+ rewrite J2 in J1. rewrite pi1_cor pi2_cor in J1.
+ rewrite J1. apply (fun_pair f A B r) in fct; eauto.
+ now rewrite <- fct.
+Qed.
+
+Lemma inv1 f A B x: bijection f A B → x ∈ A → x = f^[f[x]].
+Proof.
+intros I1 I2. apply (app_eq f^ (f[x]) x B A).
+- destruct (inv_bij f A B) as [J _]; eauto.
+- apply inv_el1. apply (app_cor1 f x A B).
++ now destruct I1.
++ assumption.
+Qed.
+
+Lemma inv2 f A B y: bijection f A B → y ∈ B → y = f[f^[y]].
+Proof.
+intros I1 I2. setoid_rewrite (inv_idem f A B) at 1.
+- apply (inv1 f^ B A y).
++ apply inv_bij. assumption.
++ assumption.
+- assumption.
+Qed.
+
+Lemma equi_com A B: equi A B → equi B A.
+Proof.
+intros [f I]. exists (f^). now apply inv_bij.
+Qed.
+
+
+
+(** ** Composition *)
+
+Definition comp f g :=
+ specification_set (product (dom g) (ran f)) (λ p, ∃ b, (pi1 p, b) ∈ g ∧ (b, pi2 p) ∈ f).
+
+
+Lemma comp_rel f g A B C: function f B C → function g A B → relation (comp f g) A C.
+Proof.
+intros [FR[FT FF]] [GR[GT GF]].
+apply subs_trans with (B:=product (dom g) (ran f)); eauto using spec_subs.
+destruct (tot_dom g A B GR) as [H _]. rewrite (H GT).
+apply product_subs2. apply fun_ran_subs with (A:=B). repeat split; assumption.
+Qed.
+
+Lemma comp_tot f g A B C: function f B C → function g A B → total (comp f g) A C.
+Proof.
+intros [FR[FT FF]] [GR[GT GF]] a I1.
+destruct (GT a I1) as [b [I2 I3]]. destruct (FT b I2) as [c [I4 I5]].
+exists c. split; auto. apply zf_specification. split.
+- apply product_opair. split; eauto using fun_el_dom, fun_el_ran.
+- rewrite pi1_cor pi2_cor. exists b. split; assumption.
+Qed.
+
+Lemma comp_fct f g A B C: function f B C → function g A B → functional (comp f g).
+Proof.
+intros [FR[FT FF]] [GR[GT GF]] a c c' I1 I2.
+apply zf_specification in I1 as [I1[b [GB FB]]].
+apply zf_specification in I2 as [I2[b' [GB' FB']]].
+rewrite pi1_cor in GB; rewrite pi1_cor in GB'.
+rewrite pi2_cor in FB; rewrite pi2_cor in FB'.
+specialize (GF a b b' GB GB'). subst b'.
+specialize (FF b c c' FB FB'). assumption.
+Qed.
+
+Lemma comp_fun f g A B C: function f B C → function g A B → function (comp f g) A C.
+Proof.
+intros FF FG. repeat split; eauto using comp_rel, comp_tot, comp_fct.
+Qed.
+
+Lemma comp_app A B C f g x: bijection f B C → bijection g A B → x ∈ A → (comp f g)[x] = f[g[x]].
+Proof.
+intros [I1 _] [I2 _] I3.
+cut ((x, (comp f g) [x]) ∈ (comp f g));
+eauto using (app_cor1 (comp f g) x A C), (comp_fun f g A B C).
+intros J. apply zf_specification in J as [J1[y[J2 J3]]].
+rewrite pi1_cor in J2. rewrite pi2_cor in J3.
+assert (GY: y = g[x]) by eauto using app_eq. subst y.
+eauto using app_eq.
+Qed.
+
+Lemma comp_sur f g A B C: bijection f B C → bijection g A B → surjective (comp f g) A C.
+Proof.
+intros [F1[F2 F3]] [G1[G2 G3]] c I1.
+destruct (F2 c I1) as [b [I2 I3]].
+destruct (G2 b I2) as [a [I4 I5]].
+exists a. split; auto. apply zf_specification. split.
+- apply product_opair. split; eauto using fun_el_dom, fun_el_ran.
+- exists b. rewrite pi1_cor pi2_cor. split; assumption.
+Qed.
+
+Lemma comp_inj f g A B C: bijection f B C → bijection g A B → injective (comp f g).
+Proof.
+intros [F1[F2 F3]] [G1[G2 G3]] a a' c I1 I2.
+apply zf_specification in I1 as [I1[b [GB FB]]].
+apply zf_specification in I2 as [I2[b' [GB' FB']]].
+rewrite pi1_cor in GB. rewrite pi1_cor in GB'.
+rewrite pi2_cor in FB. rewrite pi2_cor in FB'.
+specialize (F3 b b' c FB FB'). subst b'.
+specialize (G3 a a' b GB GB'). assumption.
+Qed.
+
+Lemma comp_bij f g A B C: bijection f B C → bijection g A B → bijection (comp f g) A C.
+Proof.
+intros BF BG. assert (FF: function f B C) by apply BF. assert (FG: function g A B) by apply BG.
+split; eauto using comp_fun. split; eauto using comp_sur, comp_inj.
+Qed.
+
+Lemma equi_trans A B C: equi A B → equi B C → equi A C.
+Proof.
+intros [g I] [f J]. exists (comp f g). now apply comp_bij with (B:=B).
+Qed.
+
+
+
+(** ** The Identity Function *)
+
+Definition id A := specification_set (product A A) (λ p, pi1 p = pi2 p).
+
+Lemma id_bijection A: bijection (id A) A A.
+Proof.
+repeat split.
+- apply spec_subs.
+- intros x X. exists x. split; trivial. apply zf_specification.
+ rewrite pi1_cor pi2_cor. split; trivial. apply product_opair. split; assumption.
+- intros x y y' I J. apply zf_specification in I as [_ I]. apply zf_specification in J as [_ J].
+ rewrite pi1_cor pi2_cor in I. rewrite pi1_cor pi2_cor in J. congruence.
+- intros y Y. exists y. split; trivial. apply zf_specification.
+ rewrite pi1_cor pi2_cor. split; trivial. apply product_opair. split; assumption.
+- intros x x' y I J. apply zf_specification in I as [_ I]. apply zf_specification in J as [_ J].
+ rewrite pi1_cor pi2_cor in I. rewrite pi1_cor pi2_cor in J. congruence.
+Qed.
+
+Lemma id_app A a: a ∈ A → (id A)[a] = a.
+Proof.
+intros I. symmetry. apply (app_eq (id A) a a A A).
+- apply id_bijection.
+- apply zf_specification. rewrite pi1_cor pi2_cor. split; trivial. apply product_opair. now split.
+Qed.
+
+Lemma id_equal A B: bijection (id A) A B → A = B.
+Proof.
+intros ID. assert (ID': bijection (id A)^ B A) by eauto using inv_bij.
+assert (IDF: function (id A) A B) by now destruct ID.
+assert (IDF': function (id A)^ B A) by now destruct ID'.
+apply zf_extensionality; split; intros x X.
+- specialize (app_cor1 (id A) x A B IDF X). intros I.
+ apply zf_specification in I as [_ I].
+ rewrite pi1_cor pi2_cor in I. rewrite I.
+ apply (app_cor2 (id A) x A); assumption.
+- specialize (app_cor1 (id A)^ x B A IDF' X). intros I.
+ apply (inv_el2 (id A) ((id A)^[x]) x A B) in I; try now destruct IDF.
+ apply zf_specification in I as [_ I].
+ rewrite pi1_cor pi2_cor in I. rewrite <- I.
+ apply (inv_el (id A) A B); assumption.
+Qed.
+
+Lemma id_rel f A B: function f A B → (∀ x, x ∈ A → (x,x) ∈ f) → relation f A A.
+Proof.
+intros FF I p P. specialize (fun_pair f A B p FF P).
+intros J. rewrite J. apply product_opair.
+assert (H: pi1 p ∈ A) by now apply (fun_pi1 f A B). split; trivial.
+specialize (I (pi1 p) H). cut (pi2 p = pi1 p).
+- intros PP. now rewrite PP.
+- destruct FF as [_ [_ FF]]. rewrite J in P.
+ now apply (FF (pi1 p) (pi1 p) (pi2 p)).
+Qed.
+
+
+Lemma id_fun f A B: function f A B → (∀ x, x ∈ A → (x,x) ∈ f) → id A = f.
+Proof.
+intros FF I. apply zf_extensionality; split; intros p P.
+- apply zf_specification in P as [P1 P2].
+ assert (PI1: pi1 p ∈ A) by eauto using product_pi1.
+ specialize (I (pi1 p) PI1).
+ rewrite (product_p A A p); auto.
+ rewrite <- P2. assumption.
+- apply zf_specification. split.
+ {
+ eapply (id_rel f A B FF I p), P.
+ (* curiously, the following eauto does not work, although it produces the same proof term (only different universes) *)
+ (*eauto using (id_rel f A B FF I p).*)
+ }
+ assert (fct: functional f) by now destruct FF as [_[]].
+ apply (fct (pi1 p)); [eapply fun_pi; eauto | eapply I; eapply fun_pi1; eauto].
+ Qed.
+
+(** ** Functions are Extensional *)
+
+Lemma fun_subs1 A B f g: function f A B → function g A B →
+ (∀ b, b ∈ A → f[b] = g[b]) → f ⊆ g.
+Proof.
+intros FF GF E. intros p P.
+assert (PA: pi1 p ∈ A) by eauto using fun_pi1.
+apply (fun_appel f A B) in P; trivial.
+rewrite P. rewrite E; trivial.
+eauto using app_cor1.
+Qed.
+
+Lemma fun_subs2 A B f g: function f A B → function g A B →
+ (∀ b, b ∈ A → f[b] = g[b]) → g ⊆ f.
+Proof.
+intros FF GF E. apply (fun_subs1 A B); trivial.
+intros b I. now rewrite (E b I).
+Qed.
+
+Lemma fun_eq A B f g: function f A B → function g A B →
+ (∀ b, b ∈ A → f[b] = g[b]) → f = g.
+Proof.
+intros FF GF E. apply zf_extensionality; eauto using fun_subs1, fun_subs2.
+Qed.
+
+Lemma fun_eq_gen A B B' f g: function f A B → function g A B' →
+ (∀ x, x ∈ A → f[x] = g[x]) → f = g.
+Proof.
+intros FF GF E. apply (fun_eq A B); trivial.
+apply fun_shrink with (B:=B'); trivial.
+intros x X. rewrite <- (E x X). eauto using app_cor2.
+Qed.
+
+Lemma fun_res_eq A B B' f g A': function f A B → function g A B' → A' ⊆ A →
+ (∀ b, b ∈ A' → f[b] = g[b]) → f|*A' = g|*A'.
+Proof.
+intros FF GF S E. apply (fun_eq_gen A' B B'); eauto using res_fun.
+intros b BE.
+rewrite <- (res_eq _ A B); trivial.
+rewrite <- (res_eq _ A B'); trivial.
+now apply E.
+Qed.
+
+Lemma fun_subs f g A B A' x: function f A B → function g A' B → x ∈ A'
+ → g ⊆ f → g [x] = f [x].
+Proof.
+intros FF FG X S.
+apply (app_eq f x (g[x]) A B); trivial.
+apply S. apply (app_cor1 g x A' B); assumption.
+Qed.
+
+Lemma fun_subs_res f g A B A' C: function f A B → function g A' B
+ → g ⊆ f → C ⊆ A' → A' ⊆ A → f|*C = g|*C.
+Proof.
+intros FF FG S1 S2 S3. apply (fun_eq C B).
+- apply res_fun with (A:=A); trivial.
+ now apply subs_trans with (B:=A').
+- now apply res_fun with (A:=A').
+- intros b BE.
+ rewrite <- (res_eq f A B C); eauto using (subs_trans C A').
+ rewrite <- (res_eq g A' B C); trivial.
+ symmetry. apply (fun_subs f g A B A'); auto.
+Qed.
+
+
+
+(** ** Meta-Functions and Object-Functions *)
+
+Definition lam (F: set → set) A := replacement_set A (λ a, (a,F a)).
+Definition sur (F: set → set) A B := ∀ y, y ∈ B → ∃ x, x ∈ A ∧ F x = y.
+Definition inj (F: set → set) A:= ∀ x x' (y:set), x ∈ A → x' ∈ A → F x = y → F x' = y → x = x'.
+
+Lemma lam_el F A x y: (x,y) ∈ (lam F A) → F x = y ∧ x ∈ A.
+Proof.
+intros I. apply zf_replacement in I as [a [AA I]].
+apply opair_eq in I. destruct I as [I1 I2].
+split; congruence.
+Qed.
+
+Lemma lam_fun F A B: (∀ x, x ∈ A → F x ∈ B) → function (lam F A) A B.
+Proof.
+intros I. repeat split.
+- intros p P. apply zf_replacement in P as [x [P1 P2]].
+ rewrite P2. apply product_opair. split; auto.
+- intros x X. exists (F x). split; auto.
+ apply zf_replacement. exists x. split; eauto using opair_eq.
+- intros x y y' I1 I2.
+ apply zf_replacement in I1 as [x1 [_ I1]].
+ apply zf_replacement in I2 as [x2 [_ I2]].
+ apply opair_eq in I1 as [I1 I1'].
+ apply opair_eq in I2 as [I2 I2'].
+ congruence.
+Qed.
+
+Lemma lam_app F A B x: (∀ x, x ∈ A → F x ∈ B) → x ∈ A → F x = (lam F A) [x].
+Proof.
+intros I X. apply app_eq with (A:=A) (B:=B).
+- now apply lam_fun.
+- apply zf_replacement. exists x. split; auto.
+Qed.
+
+Lemma lam_app2 F A B x: function (lam F A) A B → x ∈ A → F x = (lam F A) [x].
+Proof.
+intros I X. apply app_eq with (A:=A) (B:=B).
+- assumption.
+- apply zf_replacement. exists x. split; auto.
+Qed.
+
+Lemma lam_subs F A A': A' ⊆ A → (lam F A) |* A' = lam F A'.
+Proof.
+intros I. apply zf_extensionality; split; intros p P.
+- apply zf_specification in P as [P1 P2].
+ apply zf_replacement in P1 as [x[X1 X2]]. subst p.
+ apply zf_replacement. rewrite pi1_cor in P2.
+ exists x. split; trivial.
+- apply zf_replacement in P as [x[X1 X2]]. subst p.
+ apply zf_specification. rewrite pi1_cor. split; trivial.
+ apply zf_replacement. exists x. split; auto.
+Qed.
+
+Lemma lam_sur F A B: sur F A B → surjective (lam F A) A B.
+Proof.
+intros I y Y. destruct (I y Y) as [x [I1 I2]].
+exists x. split; auto. rewrite <- I2.
+apply zf_replacement. exists x. split; auto.
+Qed.
+
+Lemma lam_inj F A: inj F A → injective (lam F A).
+Proof.
+intros I x x' y I1 I2.
+apply lam_el in I1 as [I1 I1'].
+apply lam_el in I2 as [I2 I2'].
+apply I with (y:=y); assumption.
+Qed.
+
+End set_functions.
+Notation "f '[(' A ')]'" := (image f A) (at level 10) : zf_scope.
+Notation "f '[' x ']'" := (app f x) (at level 10) : zf_scope.
+Notation "f ^" := (inverse f) (at level 5) : zf_scope.
+Notation "f '|*' A" := (restriction f A) (at level 8) : zf_scope.
+Notation "R '|>' A" := (rel_restriction R A) (at level 9) : zf_scope.
diff --git a/theories/algebra/ordinals/set_model.v b/theories/algebra/ordinals/set_model.v
new file mode 100644
index 0000000000000000000000000000000000000000..a5aeef899856ead41777ba22bc5783f00876b9a2
--- /dev/null
+++ b/theories/algebra/ordinals/set_model.v
@@ -0,0 +1,718 @@
+(** This file has been adapted from the Coq development of the paper
+
+"Large Model Constructions for Second-Order ZF in Dependent Type Theory"
+by Dominik Kirst and Gert Smolka, CPP 2018
+
+See https://www.ps.uni-saarland.de/Publications/details/KirstSmolka:2017:Large-Model.html.
+*)
+
+(** Aczel's Intensional Model Construction + Extensionalisation using a choice operator*)
+
+From iris.algebra Require Export base.
+Unset Universe Minimization ToSet.
+
+
+(** Well-Founded Trees *)
+(* Following Aczel 78 and Werner 97 we construct an intensional type of sets *)
+Section aczel_trees.
+Set Universe Polymorphism.
+Polymorphic Inductive Acz@{i} : Type :=
+| Asup : ∀ A : Type@{i}, (A → Acz) → Acz.
+
+Definition Atypeof '(Asup A f) := A.
+Definition Aelements s : (Atypeof s) → Acz :=
+ match s with
+ Asup A f => f
+ end.
+
+Fixpoint Aeq@{i} (s t: Acz@{i}) :=
+ match s, t with
+ | Asup A f, Asup B g =>
+ (∀ a, ∃ b, Aeq (f a) (g b)) ∧ (∀ b, ∃ a, Aeq (f a) (g b))
+ end.
+
+Lemma Aeq_ref s :
+ Aeq s s.
+Proof.
+ induction s as [A f IH]. simpl. split.
+ - intros a. exists a. by apply IH.
+ - intros a. exists a. by apply IH.
+Qed.
+
+
+Lemma Aeq_sym s t :
+ Aeq s t → Aeq t s.
+Proof.
+revert t. induction s as [A f IH].
+intros [B g]. simpl. intros [H1 H2]. split.
+- intros b. destruct (H2 b) as [a H3]. exists a. by apply IH.
+- intros a. destruct (H1 a) as [b H3]. exists b. by apply IH.
+Qed.
+
+Lemma Aeq_tra s t u :
+ Aeq s t → Aeq t u → Aeq s u.
+Proof.
+ revert t u. induction s as [A f IH].
+ intros [B g] [C h]. simpl. intros [H1 H2] [H3 H4]. split.
+ - intros a. destruct (H1 a) as [b H5]. destruct (H3 b) as [c H6].
+ exists c. by apply IH with (t := (g b)).
+ - intros c. destruct (H4 c) as [b H5]. destruct (H2 b) as [a H6].
+ exists a. by apply IH with (t := (g b)).
+Qed.
+
+Hint Resolve Aeq_ref Aeq_sym Aeq_tra : core.
+
+Global Instance aeq_equiv :
+ Equivalence Aeq.
+Proof.
+ constructor; eauto.
+Qed.
+
+Definition Ain s '(Asup A f) := ∃ a, Aeq s (f a).
+Definition ASubq s t := ∀ u, Ain u s → Ain u t.
+
+Lemma Ain_Asup A f a : Ain (f a) (Asup A f).
+Proof.
+ simpl. exists a. by apply Aeq_ref.
+Qed.
+
+Lemma Ain_Alements s t : Ain s t → ∃ a : (Atypeof t), Aeq s (Aelements t a).
+Proof.
+ destruct t as [A f]. intros [a H]. by exists a.
+Qed.
+
+Lemma Aelements_Ain (s : Acz) (a : Atypeof s) : Ain (Aelements s a) s.
+Proof.
+ destruct s as [A f]; simpl in *. by exists a.
+Qed.
+
+Lemma Ain_mor s s' t t' :
+ Aeq s s' → Aeq t t' → Ain s t → Ain s' t'.
+Proof.
+ intros H1 H2 H3.
+ destruct t as [B1 g1]. simpl in H3. destruct H3 as [b1 H3].
+ destruct t' as [B2 g2]. simpl. simpl in H2. destruct H2 as [H2 _].
+ destruct (H2 b1) as [b2 H4]. exists b2.
+ rewrite <- H4. by rewrite <- H1.
+Qed.
+
+Global Instance Ain_proper :
+ Proper (Aeq ==> Aeq ==> iff) Ain.
+Proof.
+ intros s s' H1 t t' H2. split; intros H.
+ - by eapply Ain_mor.
+ - apply Aeq_sym in H1. apply Aeq_sym in H2.
+ by eapply Ain_mor.
+Qed.
+
+Global Instance ASubq_proper :
+Proper (Aeq ==> Aeq ==> iff) ASubq.
+Proof.
+intros s s' H1 t t' H2. split; intros H.
+- intros u. rewrite <- H1, <- H2. apply H.
+- intros u. rewrite H1 H2. apply H.
+Qed.
+
+
+
+(** Definition of Set Operations *)
+Definition AEmpty :=
+ Asup False (λ a, match a with end).
+
+Definition Aupair X Y :=
+ Asup bool (λ a, if a then X else Y).
+
+Definition Aunion '(Asup A f) :=
+ Asup (sigT (λ (a : A), (Atypeof (f a)))) (λ p, let (a, b) := p in Aelements (f a) b).
+
+Definition Apower '(Asup A f) :=
+ Asup (A → Prop) (λ P, Asup (sig P) (λ p, let (a, _) := p in f a)).
+
+Definition Asep '(Asup A f) (P : Acz → Prop) :=
+ Asup (sig (λ a, P (f a))) (λ p, let (a, _) := p in f a).
+
+Definition Arepl (F : Acz → Acz) '(Asup A f) :=
+ Asup A (λ a, F (f a)).
+
+
+(* Extensionality *)
+Lemma Aeq_ext s t :
+ ASubq s t → ASubq t s → Aeq s t.
+Proof.
+ destruct s as [A f], t as [B g].
+ intros H1 H2. simpl. split.
+ - intros a. destruct (H1 (f a) (Ain_Asup _ f a)) as [b H3]. by exists b.
+ - intros b. destruct (H2 (g b) (Ain_Asup _ g b)) as [a H3]. by exists a.
+Qed.
+
+Lemma Aeq_ASubq s t :
+ Aeq s t → ASubq s t.
+Proof.
+ destruct s as [A f], t as [B g]. intros [H _] z [a Z].
+ destruct (H a) as [b I]. exists b. eauto.
+Qed.
+
+(** Proof of Intensional Axioms *)
+
+(* Foundation *)
+Lemma Aeq_acc_mor s t:
+ Aeq s t → Acc Ain s → Acc Ain t.
+Proof.
+ revert t. induction s as [A f IH].
+ intros [B g] H1 H2. constructor.
+ intros u [b H3]. destruct H1 as [_ H1].
+ destruct (H1 b) as [a H4]. apply (IH a).
+ - by rewrite H4.
+ - apply H2. apply Ain_Asup.
+Qed.
+
+Lemma Ain_wf: wf Ain.
+Proof.
+ intros s; induction s as [A f IH].
+ constructor. intros t [a H].
+ symmetry in H. by eapply Aeq_acc_mor, IH.
+Qed.
+
+(* Empty *)
+Lemma AEmptyAx s : ¬ Ain s AEmpty.
+Proof.
+ by intros [t H].
+Qed.
+
+(* Unordered Pairs *)
+Lemma AupairAx s t u:
+ Ain u (Aupair s t) ↔ Aeq u s \/ Aeq u t.
+Proof.
+ split; intros H.
+ - destruct H as [[] H]; auto.
+ - destruct H as [H|H]; [by exists true | by exists false].
+Qed.
+
+Lemma Aupair_mor s s' t t' u :
+ Aeq s s' → Aeq t t' → Ain u (Aupair s t) → Ain u (Aupair s' t').
+Proof.
+ intros H1 H2 H. apply AupairAx.
+ rewrite <- H1, <- H2. by apply AupairAx in H.
+Qed.
+
+Global Instance Aupair_proper :
+ Proper (Aeq ==> Aeq ==> Aeq) Aupair.
+Proof.
+ intros s s' H1 t t' H2. apply Aeq_ext; intros z H.
+ - by eapply Aupair_mor.
+ - symmetry in H1, H2. by eapply Aupair_mor.
+Qed.
+
+(* Union *)
+Lemma AunionAx s u :
+ Ain u (Aunion s) ↔ ∃ t, Ain t s /\ Ain u t.
+Proof.
+ split; intros H; destruct s as [A f].
+ - destruct H as [[a b] H]. exists (f a). split.
+ + by exists a.
+ + destruct (f a) as [C h]; simpl in *. by exists b.
+ - destruct H as [[B g][[a Z1][b Z2]]].
+ apply Aeq_ASubq in Z1.
+ specialize (Z1 (g b) (Ain_Asup _ g b)).
+ apply Ain_Alements in Z1 as [c H].
+ exists (existT a c). by etransitivity.
+Qed.
+
+Lemma Aunion_mor s s' u :
+ Aeq s s' → Ain u (Aunion s) → Ain u (Aunion s').
+Proof.
+ intros H1 H2. apply AunionAx in H2 as [t H2].
+ move: H2; rewrite H1 =>H2. apply AunionAx. by exists t.
+Qed.
+
+Global Instance Aunion_proper :
+ Proper (Aeq ==> Aeq) Aunion.
+Proof.
+ intros s s' H1. apply Aeq_ext; intros z H.
+ - by eapply Aunion_mor.
+ - symmetry in H1. by eapply Aunion_mor.
+Qed.
+
+(* Power *)
+Lemma ApowerAx s t :
+ Ain t (Apower s) ↔ ASubq t s.
+Proof.
+ split; intros H; destruct s as [A f].
+ - destruct H as [P H].
+ intros u Z. apply Aeq_ASubq in H.
+ destruct (H u Z) as [[a PA] I]. by exists a.
+ - exists (λ a, Ain (f a) t). apply Aeq_ext; intros z Z.
+ + destruct t as [B g], Z as [b H1].
+ destruct (H (g b) (Ain_Asup _ g b)) as [a J].
+ assert (H2: Ain (f a) (Asup B g)) by (exists b; auto).
+ exists (exist _ a H2). eauto.
+ + destruct Z as [[a YA] H1 % Aeq_sym].
+ by eapply Ain_mor.
+Qed.
+
+Lemma Apower_mor s s' t :
+ Aeq s s' → Ain t (Apower s) → Ain t (Apower s').
+Proof.
+ intros H1 H2. apply ApowerAx.
+ rewrite <- H1. by apply ApowerAx.
+Qed.
+
+Global Instance Apower_proper :
+ Proper (Aeq ==> Aeq) Apower.
+Proof.
+ intros s s' H1. apply Aeq_ext; intros z H.
+ - by eapply Apower_mor.
+ - symmetry in H1. by eapply Apower_mor.
+Qed.
+
+(* Separation *)
+Definition cres {X} (equiv : X → X → Prop) (P : X → Prop) :=
+ ∀ x x', equiv x x' → P x → P x'.
+
+Lemma AsepAx (P : Acz → Prop) s t :
+ cres Aeq P → Ain t (Asep s P) ↔ Ain t s /\ P t.
+Proof.
+ intros HP. split; intros H; destruct s as [A f].
+ - destruct H as [[a PA]H].
+ split; eauto. by exists a.
+ - destruct H as [[a H]PY].
+ assert (PA : P (f a)) by by apply (HP t).
+ by exists (exist _ a PA).
+Qed.
+
+Lemma Asep_mor (P P' : Acz → Prop) s s' t :
+ cres Aeq P → cres Aeq P' → (∀ s, P s ↔ P' s)
+ → Aeq s s' → Ain t (Asep s P) → Ain t (Asep s' P').
+Proof.
+ intros H1 H2 H3 H4 H5. apply AsepAx; trivial.
+ rewrite <- H3, <- H4. apply AsepAx; trivial.
+Qed.
+
+Lemma Asep_proper' (P P' : Acz → Prop) s s' :
+ cres Aeq P → cres Aeq P' → (∀ s, P s ↔ P' s)
+ → Aeq s s' → Aeq (Asep s P) (Asep s' P').
+Proof.
+ intros H1 H2 H3 H4. apply Aeq_ext; intros z Z.
+ - apply (Asep_mor _ _ _ _ _ H1 H2 H3 H4); assumption.
+ - apply (@Asep_mor P' P s' s); naive_solver.
+Qed.
+
+Lemma Asep_proper (P : Acz → Prop) s s' :
+ cres Aeq P → Aeq s s' → Aeq (Asep s P) (Asep s' P).
+Proof.
+ intros H1 H2. apply (@Asep_proper' P P); naive_solver.
+Qed.
+
+(* Functional Replacement *)
+Definition fres {X} (equiv : X → X → Prop) (F : X → X) :=
+ ∀ x x', equiv x x' → equiv (F x) (F x').
+
+Lemma AreplAx F s u :
+ fres Aeq F → Ain u (Arepl F s) ↔ ∃ t, Ain t s /\ Aeq u (F t).
+Proof.
+ intros HF. split; intros H; destruct s as [A f].
+ - destruct H as [a H]. exists (f a).
+ split; trivial. apply Ain_Asup.
+ - destruct H as [z[[a H] Z]].
+ exists a. apply HF in H; try by exists a.
+ by rewrite Z H.
+Qed.
+
+Lemma Arepl_mor (F F' : Acz → Acz) s s' u :
+ fres Aeq F → fres Aeq F' → (∀ s, Aeq (F s) (F' s))
+ → Aeq s s' → Ain u (Arepl F s) → Ain u (Arepl F' s').
+Proof.
+ intros H1 H2 H3 H4 H5. apply AreplAx; trivial.
+ apply AreplAx in H5 as [y H]; trivial.
+ exists y. by rewrite <- H3, <- H4.
+Qed.
+
+Lemma Arepl_proper' (F F' : Acz → Acz) s s' :
+ fres Aeq F → fres Aeq F' → (∀ s, Aeq (F s) (F' s))
+ → Aeq s s' → Aeq (Arepl F s) (Arepl F' s').
+Proof.
+ intros H1 H2 H3 H4. apply Aeq_ext; intros z Z.
+ - apply (Arepl_mor _ _ _ _ _ H1 H2 H3 H4); assumption.
+ - apply (@Arepl_mor F' F s' s); auto.
+Qed.
+
+Lemma Arepl_proper (F : Acz → Acz) s s' :
+ fres Aeq F → Aeq s s' → Aeq (Arepl F s) (Arepl F s').
+Proof.
+ intros H1 H2. by apply Arepl_proper'.
+Qed.
+
+(** Infinity *)
+Fixpoint Aenc_inf n :=
+ match n with
+ | O => AEmpty
+ | S n' => Aunion (Aupair (Aenc_inf n') (Aupair (Aenc_inf n') (Aenc_inf n')))
+ end.
+
+Definition Aom := Asup nat Aenc_inf.
+
+Lemma Aom_spec : ∀ x, (∃ n, Aeq x (Aenc_inf n)) ↔ Ain x Aom.
+Proof.
+ intros s. split; intros [n H].
+ - by exists n.
+ - exists n. by apply H.
+Qed.
+
+End aczel_trees.
+Hint Resolve Aeq_ref Aeq_sym Aeq_tra : core.
+
+
+(** * extensional model using ϵ, PE and FE *)
+(** in the original development, the weaker tree description axiom below is used, but as we need ϵ to make ordinals a stepindex type anyway, we just directly use ϵ + PE + FE *)
+Require Import Coq.Logic.Epsilon.
+Require Import Coq.Logic.PropExtensionality.
+Require Import Coq.Logic.FunctionalExtensionality.
+
+Definition tdelta : (Acz → Prop) → Acz := epsilon (inhabits AEmpty).
+
+Lemma TDesc1 : ∀ P, (∃ s, ∀ t, P t ↔ Aeq t s) → P (tdelta P).
+Proof.
+intros P H. unfold tdelta. apply epsilon_spec.
+destruct H as (s & H). exists s. by apply H.
+Qed.
+
+Lemma TDesc2 : ∀ P P', (∀ s, P s ↔ P' s) → tdelta P = tdelta P'.
+Proof.
+intros P P' H. f_equal. apply functional_extensionality.
+intros x. by apply propositional_extensionality.
+Qed.
+
+(* Define a normaliser yielding the quotient model *)
+Definition N s := tdelta (Aeq s).
+
+Lemma PI_N: ∀ s (H H' : N s = s), H = H'.
+Proof.
+ intros s. apply proof_irrelevance.
+Qed.
+
+Fact N_Aeq: ∀ s, Aeq s (N s).
+Proof.
+ intros s. pattern (N s). apply TDesc1. by exists s.
+Qed.
+
+Lemma N_Aeq_mor: ∀ s t, Aeq s t → N s = N t.
+Proof.
+ intros s t H. apply TDesc2.
+ intros u. rewrite H. tauto.
+Qed.
+
+Lemma N_idem s: N (N s) = N s.
+Proof.
+ apply N_Aeq_mor. symmetry. apply N_Aeq.
+Qed.
+
+Lemma N_eq_Aeq s t: N s = N t → Aeq s t.
+Proof.
+ intros H. rewrite (N_Aeq s) (N_Aeq t). by rewrite H.
+Qed.
+
+Instance N_proper : Proper (Aeq ==> Aeq) N.
+Proof.
+ intros s t H. by rewrite -(N_Aeq s) -(N_Aeq t).
+Qed.
+
+
+(* sigma type for sets based on aczel trees *)
+Polymorphic Record set@{i} := mkset {
+ set_tree :> Acz@{i};
+ set_tree_is_normal: N set_tree = set_tree
+}.
+
+Definition NS s : set := mkset (N s) (N_idem s).
+Definition IN (X Y : set) := Ain X Y.
+Instance in_elem_of: ElemOf set set := IN.
+Lemma IN_unfold (X Y: set): X ∈ Y = Ain X Y.
+Proof. reflexivity. Qed.
+
+
+Definition Subq (X Y : set) := ∀ Z, Z ∈ X → Z ∈ Y.
+Instance Subq_subseteq: SubsetEq set := Subq.
+Lemma Subq_unfold (X Y: set): X ⊆ Y = Subq X Y.
+Proof. reflexivity. Qed.
+
+(* lemmas for interfacing with the normalizer *)
+Section set_lemmas.
+ Implicit Types s t u : Acz.
+ Implicit Types X Y Z: set.
+
+
+ (* equality *)
+ Lemma mkset_pi s t (H1 : N s = s) (H2 : N t = t) :
+ s = t → mkset s H1 = mkset t H2.
+ Proof.
+ intros XY. subst t. f_equal. apply PI_N.
+ Qed.
+
+ Lemma NS_id X : NS X = X.
+ Proof.
+ destruct X. simpl. by apply mkset_pi.
+ Qed.
+
+ Lemma Aeq_NS s: Aeq (NS s) s.
+ Proof. symmetry. exact (N_Aeq s). Qed.
+
+
+ Lemma Aeq_eq_NS s t :
+ Aeq s t → NS s = NS t.
+ Proof.
+ intros H % N_Aeq_mor. by apply mkset_pi.
+ Qed.
+
+ Lemma Aeq_eq X Y:
+ Aeq X Y → X = Y.
+ Proof.
+ intros H % Aeq_eq_NS; move: H; by rewrite !NS_id.
+ Qed.
+
+
+ (* elements *)
+ Lemma Ain_IN X Y : Ain X Y ↔ X ∈ Y.
+ Proof. by rewrite IN_unfold. Qed.
+
+ Lemma Ain_IN_NS s t : Ain s t ↔ NS s ∈ NS t.
+ Proof.
+ by rewrite -Ain_IN !Aeq_NS.
+ Qed.
+
+ Lemma ASubq_Subq X Y :
+ ASubq X Y ↔ Subq X Y.
+ Proof.
+ split; intros H s H1.
+ - by apply Ain_IN, H.
+ - rewrite Ain_IN_NS NS_id. eapply H.
+ by rewrite IN_unfold Aeq_NS.
+ Qed.
+
+End set_lemmas.
+
+
+(* shorthands hiding the normalizer and the aczel trees *)
+Definition setof {X: Type} (f: X → set): set := NS (Asup X (λ x, set_tree (f x))).
+Notation "{{ f | x : X }}" := (@setof X (λ x, f)) (x pattern, at level 60).
+
+Definition typeof (s: set) : Type := Atypeof s.
+Definition elements (s: set): typeof s → set := λ x, NS (Aelements s x).
+
+Lemma in_inv {Y} x (f: Y → set): x ∈ setof f → ∃ y, x = f y.
+Proof.
+ rewrite IN_unfold Aeq_NS; intros [y Heq] % Ain_Alements; simpl in *.
+ exists y; by apply Aeq_eq.
+Qed.
+
+Lemma in_intro {Y} x y (f: Y → set): x = f y → x ∈ setof f.
+Proof.
+ intros ->. rewrite IN_unfold Aeq_NS; simpl.
+ by exists y.
+Qed.
+
+Lemma setof_ext {Y} (f g: Y → set): (∀ y, f y = g y) → setof f = setof g.
+Proof.
+ intros Heq. unfold setof. eapply Aeq_eq_NS; simpl; split.
+ all: intros a; exists a; rewrite Heq; reflexivity.
+Qed.
+
+Lemma setof_eta (s: set): {{ elements s x | x: typeof s }} = s.
+Proof.
+ apply Aeq_eq; rewrite Aeq_NS; destruct s as [[X f]]; simpl.
+ split; intros a; exists a; symmetry; by rewrite -N_Aeq.
+Qed.
+
+Lemma elements_in s x: elements s x ∈ s.
+Proof.
+ replace s with ({{ elements s x | x: typeof s }}) at 2 by apply setof_eta.
+ by eapply in_intro.
+Qed.
+
+Lemma in_inv_elements s t: s ∈ t → ∃ x: typeof t, s = elements t x.
+Proof.
+ replace t with ({{ elements t x | x: typeof t }}) at 1 by apply setof_eta.
+ intros [x ->] % in_inv. by exists x.
+Qed.
+
+
+(* ZF constructions *)
+Declare Scope zf_scope.
+Delimit Scope zf_scope with zf.
+
+Definition empty_set := NS AEmpty.
+Instance empty_set_notation: Empty set := empty_set.
+Lemma empty_set_unfold: ∅ = empty_set.
+Proof. reflexivity. Qed.
+
+Definition upair_set (X Y : set) := NS (Aupair X Y).
+Definition union_set (X : set) := NS (Aunion X).
+Notation "⋃ S" := (union_set S) (at level 20) : zf_scope.
+
+Definition singleton_set A := upair_set A A.
+Instance singleton_Singleton: Singleton set set := singleton_set.
+
+Definition bunion_set A B := union_set (upair_set A B).
+Instance bunion_Union : Union set := bunion_set.
+
+
+Definition power_set (X : set) := NS (Apower X).
+
+Definition empred (P : set → Prop) := λ s, P (NS s).
+Definition specification_set (X : set) (P : set → Prop) := NS (Asep X (empred P)).
+
+Definition inter_set S := specification_set (⋃ S)%zf (λ x, ∀ A, A ∈ S → x ∈ A).
+Notation "â‹‚ S" := (inter_set S) (at level 50) : zf_scope.
+Definition binter_set A B := inter_set (upair_set A B).
+Instance binter_notation : Intersection set := binter_set.
+
+Definition comp_set (A B: set) := specification_set A (λ a, ¬ a ∈ B).
+Infix "\" := comp_set (at level 55) : zf_scope.
+
+Definition emfun (F : set → set) := λ s, F (NS s): Acz.
+
+(* We have functional replacement, which is weaker than the usual relational replacement.*)
+(* (this difference in power between relational replacement and functional replacement is only present when formalising set theory in Coq, as functions need to be computable while relations don't) *)
+Definition replacement_set (X : set) (F : set → set) := NS (Arepl (emfun F) X).
+Notation "R @ A" := (replacement_set A R) (at level 56) : zf_scope.
+
+
+(* We prove the extensional axioms of ZF for the quotient type *)
+Section zf_axioms.
+Implicit Types X Y Z: set.
+(* Extensionality *)
+Lemma zf_extensionality X Y : X ⊆ Y ∧ Y ⊆ X ↔ X = Y.
+Proof.
+ rewrite !Subq_unfold; split; intros H.
+ - destruct H as [H1 H2]. apply Aeq_eq, Aeq_ext; by apply ASubq_Subq.
+ - by rewrite H /Subq.
+Qed.
+
+(* Foundation *)
+Lemma IN_wf : wf IN.
+Proof.
+ intros X. destruct X as [s NX].
+ induction (Ain_wf s) as [s _ IH].
+ constructor. intros [t NY] YX.
+ by apply IH.
+Qed.
+
+(* Existence *)
+Lemma zf_existence X : ¬ X ∈ (∅: set).
+Proof.
+ rewrite empty_set_unfold.
+ intros H % Ain_IN. move: H; rewrite Aeq_NS. by apply AEmptyAx.
+Qed.
+
+(* Unordered Pairs *)
+Lemma zf_pair X Y Z : Z ∈ (upair_set X Y) ↔ Z = X ∨ Z = Y.
+Proof.
+ split; rewrite -Ain_IN Aeq_NS AupairAx.
+ - intros [H|H].
+ + left. by apply Aeq_eq.
+ + right. by apply Aeq_eq.
+ - intros [-> | ->]; auto.
+Qed.
+
+(* Union *)
+Lemma zf_union X Z : Z ∈ (union_set X) ↔ ∃ Y, Z ∈ Y ∧ Y ∈ X.
+Proof.
+split; rewrite -Ain_IN Aeq_NS AunionAx.
+- intros [y[Y1 Y2]].
+ exists (NS y). by rewrite -!Ain_IN Aeq_NS.
+- intros [Y[Y1 Y2]].
+ exists Y. move: Y1 Y2; by rewrite -!Ain_IN.
+Qed.
+
+(* Power *)
+Lemma zf_power X Y : Y ∈ (power_set X) ↔ Y ⊆ X.
+Proof.
+ split; by rewrite -Ain_IN Aeq_NS ApowerAx Subq_unfold ASubq_Subq.
+Qed.
+
+(* Specification *)
+Lemma empred_Aeq P : cres Aeq (empred P).
+Proof.
+ intros s s' H % Aeq_eq_NS. unfold empred. by rewrite H.
+Qed.
+
+Lemma zf_specification X P Y : Y ∈ (specification_set X P) ↔ Y ∈ X ∧ P Y.
+Proof.
+ split; rewrite -!Ain_IN Aeq_NS AsepAx; auto using empred_Aeq.
+ all: intros [H1 H2]; split; auto.
+ - by rewrite -[Y]NS_id.
+ - by rewrite /empred NS_id.
+Qed.
+
+(* Functional Replacement *)
+Lemma emfun_Aeq F: fres Aeq (emfun F).
+Proof.
+ intros s s' H % Aeq_eq_NS. by rewrite /emfun H.
+Qed.
+
+Lemma zf_replacement F X Y :
+ Y ∈ (replacement_set X F) ↔ ∃ Z, Z ∈ X ∧ Y = F Z.
+Proof.
+ split; rewrite -!Ain_IN Aeq_NS AreplAx; auto using emfun_Aeq.
+ - intros [z[Z1 Z2]]; exists (NS z); rewrite -Ain_IN Aeq_NS; split; auto.
+ by apply Aeq_eq.
+ - intros [Z [Z1 ->]]. exists Z.
+ by rewrite Ain_IN /emfun NS_id.
+Qed.
+
+
+Fixpoint inf_set_at n : set :=
+ match n with
+ | O => ∅
+ | S n' => (inf_set_at n') ∪ (singleton (inf_set_at n'))
+ end.
+
+Lemma NS_enc_inf n : Aeq (inf_set_at n) (Aenc_inf n).
+Proof.
+ induction n; cbn [inf_set_at Aenc_inf].
+ - cbn. by rewrite -N_Aeq.
+ - cbn -[Aunion]. by rewrite IHn -!N_Aeq.
+Qed.
+
+Fact SETZS_Inf :
+ ∀ x, (∃ n, x = inf_set_at n) ↔ x ∈ (NS Aom).
+Proof.
+ intros x. rewrite -Ain_IN Aeq_NS -Aom_spec; split.
+ - intros [n ->]. exists n. apply NS_enc_inf.
+ - intros [n Heq]. exists n. revert Heq; rewrite -NS_enc_inf; apply Aeq_eq.
+Qed.
+
+Definition infinite_set := NS Aom.
+Lemma Infinity : (∅: set) ∈ infinite_set ∧ (∀ x: set, x ∈ infinite_set → x ∪ (singleton x) ∈ infinite_set).
+Proof.
+split.
+- rewrite -SETZS_Inf. by exists 0.
+- intros x. rewrite -!SETZS_Inf. intros [n ->]; by exists (S n).
+Qed.
+
+
+(* As we only require functional replacement, we use the following description axiom to make up for the lack of relational replacement *)
+(* The quotient model inherits the description operator *)
+Definition desc_set (P : set → Prop) := NS (tdelta (λ s, empred P s)).
+
+Lemma zf_desc : ∀ P, (exists! x, P x) → P (desc_set P).
+Proof.
+ intros P [X [H1 H2]].
+ enough (empred P (tdelta (empred P))) by assumption.
+ apply TDesc1. exists X.
+ intros t. split; intros H.
+ - by rewrite (H2 _ H) Aeq_NS.
+ - symmetry in H. apply (empred_Aeq _ _ _ H).
+ by rewrite /empred NS_id.
+Qed.
+
+(* epsilon induction is equivalent to regularity in ZF*)
+(*Axiom Regularity : ∀ A, A <> empty → exists B, B ∈ A /\ (∀ x, x ∈ B → x ∉ A). *)
+Lemma eps_ind : ∀ (P:set → Prop), (∀ X, (∀ x, x ∈ X → P x) → P X) → ∀ X, P X.
+Proof.
+ intros P H X. specialize (IN_wf X). induction 1; auto.
+Qed.
+End zf_axioms.
+
+(* universe polymorphism test -- we can create a set of sets (not really, since the sets contained in the set live in a different universe, so a better description might be that this is the class of sets?) *)
+Definition set_of_sets: set := {{ (∅: set) | s : set (* <- set in a smaller universe *) }}.
+(* Definition set_of_all_sets: set := {{ s | s : set <- set in a smaller universe }}. *)
\ No newline at end of file
diff --git a/theories/algebra/ordinals/set_ordinals.v b/theories/algebra/ordinals/set_ordinals.v
new file mode 100644
index 0000000000000000000000000000000000000000..421def68677e73ac2fe735e63dd96fbc89f49abd
--- /dev/null
+++ b/theories/algebra/ordinals/set_ordinals.v
@@ -0,0 +1,509 @@
+(** This file has been adapted from Dominik Kirst's Bachelor Thesis
+ "Formalised Set Theory: Well-Orderings and the Axiom of Choice",
+ see https://www.ps.uni-saarland.de/~kirst/bachelor.php
+*)
+
+Require Import Coq.Logic.Classical_Prop.
+From iris.algebra.ordinals Require Export set_model.
+From iris.algebra.ordinals Require Import set_sets set_functions.
+
+
+Set Universe Polymorphism.
+Set Universe Minimization ToSet.
+
+
+(** * Set-theoretic ordinals as a step-index type using several axioms *)
+(** In total, this development relies on:
+ - PE
+ - FE
+ - Hilbert's ϵ
+ - XM
+ - PI (but this is already implied by PE)
+*)
+Require Import Coq.Logic.Epsilon.
+
+
+(** ** Definition and General Statements *)
+Section set_ordinals.
+Local Open Scope zf_scope.
+Polymorphic Universe i.
+Implicit Types (a b c A B C: set@{i}).
+
+Definition succ_set a : set := a ∪ singleton a.
+Definition zero_set : set := ∅.
+Definition one_set : set := succ_set zero_set.
+
+(* we can construct omega by taking infinity and removing all elements which are not constructed by zero_set or succ_set *)
+Definition omega_set := specification_set infinite_set (λ x, ∃ n, x = Nat.iter n succ_set zero_set).
+Lemma omega_spec : ∀ x, x ∈ omega_set ↔ ∃ n, x = Nat.iter n succ_set zero_set.
+Proof.
+ intros x. split.
+ - intros Hel. apply zf_specification in Hel. apply Hel.
+ - intros (n & ->). apply zf_specification. split; [ | eauto].
+ induction n; cbn.
+ + apply Infinity.
+ + apply Infinity, IHn.
+Qed.
+Definition stransitive (A: set@{i}) := ∀ (x: set@{i}), x ∈ A → x ⊆ A.
+Definition elorder A := specification_set (product A A) (λ p, pi1 p ∈ pi2 p).
+Definition ordinal (a: set@{i}) := stransitive a ∧ wordering (elorder a) a.
+
+Lemma empty_ordinal: ordinal empty.
+Proof.
+split.
+- intros x I. exfalso. contradiction (zf_existence x).
+- cut (elorder ∅ = ∅).
++ intros J. rewrite J. apply wordering_empty.
++ apply zf_extensionality; split; eauto using empty_subs.
+ intros p H. apply spec_subs in H.
+ apply product_pi in H as [H _]. contradiction (zf_existence (pi1 p)).
+Qed.
+
+Lemma elorder_el a b A: a ∈ b → a ∈ A → b ∈ A → (a,b) ∈ elorder A.
+Proof.
+intros I J J'. apply zf_specification. split.
+- apply product_opair. split; eauto.
+- now rewrite pi1_cor pi2_cor.
+Qed.
+
+Lemma elorder_el' a b A: (a,b) ∈ elorder A → a ∈ A ∧ b ∈ A ∧ a ∈ b.
+Proof.
+intros I.
+apply zf_specification in I as [I J].
+apply product_opair in I as [I1 I2].
+rewrite pi1_cor pi2_cor in J.
+now repeat split.
+Qed.
+
+Lemma elorder_element A a b: (a,b) ∈ elorder A → a ∈ b.
+Proof.
+ apply elorder_el'.
+Qed.
+
+
+Lemma elorder_res a b: a ⊆ b → (elorder b)|> a = elorder a.
+Proof.
+intros I. apply zf_extensionality; split; intros p J.
+- apply zf_specification in J as [J1 J2].
+ apply zf_specification in J1 as [J1 J1'].
+ apply zf_specification. now split.
+- apply zf_specification in J as [J1 J2].
+ apply zf_specification. split; auto.
+ apply zf_specification. split; eauto.
+ now apply (product_subs b a I p).
+Qed.
+
+Lemma succ_set_subs A B: A ⊆ B → A ⊆ succ_set B.
+Proof.
+intros I x J. apply bunionI1. exact (I x J).
+Qed.
+
+Lemma succ_set_el A: A ∈ succ_set A.
+Proof.
+apply bunionI2. now apply single_el.
+Qed.
+
+Lemma succ_set_subset A: A ⊆ succ_set A.
+Proof.
+intros x I. now apply bunionI1.
+Qed.
+
+Lemma el_succ_set b a: ordinal a → b ∈ a → succ_set b ⊆ succ_set a.
+Proof.
+intros AO I. intros x X.
+apply bunionE in X as [X|X].
+- apply bunionI1. apply AO with (x:=b); assumption.
+- apply single_el in X. subst x.
+ apply bunionI1. assumption.
+Qed.
+
+Lemma el_succ_set_subs b a: ordinal a → b ∈ a → succ_set b ⊆ a.
+Proof.
+intros AO I. intros x X.
+apply bunionE in X as [X|X].
+- apply AO with (x:=b); assumption.
+- apply single_el in X. now subst x.
+Qed.
+
+Lemma zero_set_succ_set_disjoint a : zero_set <> succ_set a.
+Proof.
+ intros H. enough (a ∈ zero_set) as H0 by now apply zf_existence in H0.
+ rewrite H. apply succ_set_el.
+Qed.
+
+Lemma in_succ_set_iff a : ∀ x, x ∈ succ_set a ↔ x = a ∨ x ∈ a.
+Proof.
+ intros x. unfold succ_set. split; intros Hel.
+ - apply bunionE in Hel as [Hel | Hel]; [eauto | ]. apply single_el in Hel. eauto.
+ - destruct Hel as [-> | Hel].
+ + apply bunionI2, single_el; easy.
+ + now apply bunionI1.
+Qed.
+
+Lemma succ_set_injective a b : succ_set a = succ_set b → a = b.
+Proof.
+ revert a b.
+ enough (∀ a b, succ_set a = succ_set b → a ⊆ b).
+ { intros a b H1. apply zf_extensionality. split; now apply H. }
+ intros a b Heq.
+ intros x Hel.
+ enough (x ∈ succ_set b).
+ { apply in_succ_set_iff in H as [-> | H]; [ | easy].
+ apply zf_extensionality in Heq as [H1 H2].
+ enough (a ∈ succ_set b).
+ { apply in_succ_set_iff in H as [-> | H]; [now apply one_cycles in Hel | exfalso; eapply two_cycles; eauto]. }
+ eapply H1. apply in_succ_set_iff. now left.
+ }
+ rewrite <- Heq. apply in_succ_set_iff. now right.
+Qed.
+
+Lemma succ_set_fun f A B: function f A (succ_set B) → B ∉ ran f → function f A B.
+Proof.
+intros I I'. specialize (fun_ran_subs f A (succ_set B) I). intros J.
+apply fun_ran in I. apply fun_expand with (B:=ran f); trivial.
+intros y Y. specialize (J y Y). apply bunionE in J as [J|J]; trivial.
+exfalso. apply single_el in J. subst y. now apply I'.
+Qed.
+
+Lemma succ_set_trans A x: x ∈ A → x ∈ succ_set A.
+Proof.
+apply succ_set_subset.
+Qed.
+
+Lemma elorder_subs A A' a b: A' ⊆ A → (a,b) ∈ elorder A' → (a,b) ∈ elorder A.
+Proof.
+intros I I'. apply zf_specification in I' as [I' I'']. apply zf_specification. split; eauto.
+apply (product_subs1 A A' A') in I'; eauto. apply (product_subs2 A A' A) in I'; eauto.
+Qed.
+
+Lemma elorder_succ_set A a b: (a,b) ∈ elorder A → (a,b) ∈ elorder (succ_set A).
+Proof.
+intros I. apply (elorder_subs (succ_set A) A); eauto using succ_set_subset.
+Qed.
+
+Lemma el_su A A' a b: (a,b) ∈ elorder A → a ∈ A' → b ∈ A' → (a,b) ∈ elorder A'.
+Proof.
+intros I J J'. apply elorder_el; eauto. apply zf_specification in I as [I I'].
+now rewrite pi1_cor pi2_cor in I'.
+Qed.
+
+Lemma elorder_trans a x y z: transitive (elorder a) → x ∈ a → y ∈ a → z ∈ a →
+ x ∈ y → y ∈ z → x ∈ z.
+Proof.
+intros I X Y Z J1 J2. specialize (I x y z).
+apply zf_specification in I as [_ I]; eauto using elorder_el.
+now rewrite pi1_cor pi2_cor in I.
+Qed.
+
+Lemma elorder_worder M M': M' ⊆ M → wordering (elorder M) M → wordering (elorder M') M'.
+Proof.
+intros I J. generalize (elorder_res M' M I). intros H.
+rewrite <- H. now apply worder_subs with (A:=M).
+Qed.
+
+Lemma ordinal_el a a': ordinal a → a' ∈ a → ordinal a'.
+Proof.
+intros [str [[reo [ass [tra lin]]] ex]]. intros I. split.
+- intros v V u U. assert (J: v ∈ a) by eauto using (str a' I v).
+ assert (H: u ∈ a) by eauto using (str v J u). eauto using elorder_trans.
+- apply (elorder_worder a); eauto. repeat split; eauto.
+Qed.
+
+Lemma ordinal_eltrans a x: ordinal a → x ∈ a → stransitive x.
+Proof.
+intros I J. now apply (ordinal_el a x I) in J as [J _].
+Qed.
+
+Lemma ordinal_subs x y: ordinal x → ordinal y → x <> y → x ⊆ y → x ∈ y.
+Proof.
+intros I1 I2 J1 J2. assert (YWF: wfounded (elorder y) y) by now destruct I2 as [_[_ wf]].
+destruct (YWF (y\x)) as [l [H1 H2]]; eauto using spec_subs.
+- now apply (comp_nempty x y).
+- cut (x = l); try (intros I; rewrite I; now apply spec_subs in H1).
+ apply zf_specification in H1 as [H1 H1'].
+ assert (LO: ordinal l) by eauto using ordinal_el. apply zf_extensionality; split.
++ intros d I. destruct (classic (d ∈ l)); eauto. exfalso.
+ destruct I1 as [I1 _]. destruct I2 as [_[[_[_[_ lin]]]_]].
+ destruct (lin d l) as [J|[J|J]]; eauto.
+* apply elorder_element in J. now apply H.
+* apply elorder_element in J. apply H1'. eauto using (I1 d I).
+* subst d. now apply H.
++ destruct (classic (l ⊆ x)); eauto. exfalso. apply subs_comp in H as [d H].
+ destruct I2 as [str [[_ [ass _]] _]].
+ assert (irr: irreflexive (elorder y)) by now apply asym_irref.
+ apply zf_specification in H as [H H']. destruct (H2 d) as [I|I].
+* apply zf_specification. split; eauto. now apply (str l H1).
+* apply (ass l d I). apply elorder_el; eauto. now apply (str l H1).
+* subst d. apply (irr l). apply elorder_el; eauto.
+Qed.
+
+
+
+(** ** Ordering Properties *)
+
+Lemma ordinal_nel a: ordinal a → a ∉ a.
+Proof.
+intros [str [[reo [ass [tra lin]]] wf]]. intros I.
+assert (IRR: irreflexive (elorder a)) by now apply asym_irref.
+apply (IRR a). now apply elorder_el.
+Qed.
+
+Lemma ordinal_trans x y z: ordinal x → ordinal y → ordinal z → x ∈ y → y ∈ z → x ∈ z.
+Proof.
+intros I1 I2 I3 J1 J2. destruct I3 as [T _]. exact (T y J2 x J1).
+Qed.
+
+Lemma ordinal_anti x y: ordinal x → ordinal y → x ∈ y → y ∉ x.
+Proof.
+intros I1 I2 J1 J2. assert (T: stransitive x).
+- now destruct I1.
+- specialize (T y J2 x J1). now apply (ordinal_nel x).
+Qed.
+
+Lemma ordinal_inter x y: ordinal x → ordinal y → ordinal (x ∩ y).
+Proof.
+intros I1 I2. split.
+- intros a I. apply binterE in I as [J1 J2]. destruct I1 as [I1 _]. destruct I2 as [I2 _].
+ specialize (I1 a J1). specialize (I2 a J2). intros x' I. apply binterI; eauto.
+- apply (elorder_worder x).
++ apply binter_subs1.
++ destruct I1 as [_ I1]. assumption.
+Qed.
+
+Lemma ordinal_linear x y: ordinal x → ordinal y → x ∈ y ∨ x = y ∨ y ∈ x.
+Proof.
+intros I1 I2. pose (int := binter_set x y).
+assert (J1: int ⊆ x) by eauto using binter_subs1.
+assert (J2: int ⊆ y) by eauto using binter_subs2.
+assert (IO: ordinal int) by eauto using ordinal_inter.
+destruct (classic (int = x)) as [I|I], (classic (int = y)) as [J|J].
+- right. left. rewrite <- I. rewrite J. reflexivity.
+- apply binter_eq1 in I. destruct (classic (x=y)); eauto. left.
+ apply ordinal_subs; eauto.
+- apply binter_eq2 in J. destruct (classic (x=y)); eauto. right. right.
+ apply ordinal_subs; eauto.
+- exfalso. apply (ordinal_nel int); eauto.
+ assert (H1: int ∈ x) by eauto using ordinal_subs.
+ assert (H2: int ∈ y) by eauto using ordinal_subs.
+ now apply binterI.
+Qed.
+
+Lemma elorder_linear M: (∀ a, a ∈ M → ordinal a) → linear (elorder M) M.
+Proof.
+intros I x y X Y. destruct (ordinal_linear x y) as [J|[J|J]]; eauto.
+- left. now apply elorder_el.
+- right. left. now apply elorder_el.
+Qed.
+
+Lemma ordinal_wfounded (M: set): (∀ a, a ∈ M → ordinal a) → M ≠∅ →
+ ∃ a, a ∈ M ∧ ∀ b, b ∈ M → a ∈ b ∨ a = b.
+Proof.
+intros I J. apply empty_el in J as [a A].
+destruct (classic (binter_set a M = empty)).
+- exists a. split; trivial. intros b B.
+ destruct (ordinal_linear a b (I a A) (I b B)) as [J|[J|J]].
++ now left.
++ now right.
++ exfalso. apply (empty_el (binter_set a M)); eauto. exists b. now apply binterI.
+- assert (OA: ordinal a) by eauto.
+ assert (J: wfounded (elorder a) a). now destruct OA as [_[]].
+ specialize (J (binter_set a M) (binter_subs1 a M) H). destruct J as [x [H1 H2]].
+ exists x. split. now apply binterE in H1 as []. apply binterE in H1 as [H1 H1'].
+ intros b B. destruct (elorder_linear M I x b H1' B) as [J|[J|J]].
++ apply elorder_element in J. now left.
++ apply zf_specification in J as [J J']. rewrite pi1_cor pi2_cor in J'.
+ destruct OA as [TA _]. specialize (TA x H1 b J'). destruct (H2 b); eauto using binterI.
+ left. apply zf_specification in H0 as [_ H0]. now rewrite pi1_cor pi2_cor in H0.
++ now right.
+Qed.
+
+
+
+(** ** Sets of Ordinals are Wellordered *)
+
+Lemma ordinal_set_asym M: (∀ a, a ∈ M → ordinal a) → asymmetric (elorder M).
+Proof.
+intros I x y. intros J H.
+apply elorder_el' in J as [J1[J2 J3]].
+apply elorder_el' in H as [H1[H2 H3]].
+apply (ordinal_anti x y); eauto.
+Qed.
+
+Lemma ordinal_set_trans M: (∀ a, a ∈ M → ordinal a) → transitive (elorder M).
+Proof.
+intros I x y z J H.
+apply elorder_el' in J as [J1[J2 J3]].
+apply elorder_el' in H as [H1[H2 H3]].
+apply elorder_el; eauto.
+apply (ordinal_trans x y); eauto.
+Qed.
+
+Lemma ordinal_set_wf M: (∀ a, a ∈ M → ordinal a) → wfounded (elorder M) M.
+Proof.
+intros I N J1 J2. destruct (ordinal_wfounded N) as [min [N1 N2]]; trivial.
+- intros a A. apply I. now apply J1.
+- exists min. split; trivial. intros a A. destruct (N2 a A) as [H|H].
++ left. apply elorder_el; auto.
++ now right.
+Qed.
+
+Theorem ordinal_set M: (∀ a, a ∈ M → ordinal a) → wordering (elorder M) M.
+Proof.
+intros I. repeat split.
+- apply spec_subs.
+- now apply ordinal_set_asym.
+- now apply ordinal_set_trans.
+- now apply elorder_linear.
+- now apply ordinal_set_wf.
+Qed.
+
+Corollary succ_set_ordinal a: ordinal a → ordinal (succ_set a).
+Proof.
+intros I. split.
+- destruct I as [str _]. intros x I. apply bunionE in I as [I|I].
++ eauto using succ_set_subs.
++ apply single_el in I. subst x. apply succ_set_subset.
+- apply ordinal_set. intros x J. apply bunionE in J as [J|J].
++ apply (ordinal_el a); eauto.
++ apply single_el in J. now subst x.
+Qed.
+
+Lemma el_succ_set_eq_el b a : ordinal a → b ∈ a → succ_set b = a ∨ succ_set b ∈ a.
+Proof.
+ intros Hord Hel. specialize (ordinal_el _ _ Hord Hel) as Hordb.
+ specialize (succ_set_ordinal _ Hordb) as Hordb'.
+ destruct (ordinal_linear _ _ Hord Hordb') as [H1 | [H1 | H1]];[ | eauto | eauto].
+ exfalso. apply bunionE in H1. destruct H1 as [H1 | H1].
+ - eapply two_cycles; eauto.
+ - apply single_el in H1. rewrite H1 in Hel. now apply one_cycles in Hel.
+Qed.
+
+Corollary ordinal_union (M: set): (∀ a, a ∈ M → ordinal a) → ordinal (union_set M).
+Proof.
+intros I. split.
+- intros a A c C. apply zf_union in A as [b [B1 B2]].
+ specialize (I b B2). apply zf_union. exists b. split; trivial.
+ assert (AB: a ⊆ b) by now apply I. now apply AB.
+- apply ordinal_set. intros a A. apply zf_union in A as [b [B1 B2]].
+ specialize (I b B2). now apply ordinal_el with (a:=b).
+Qed.
+
+(*we can obtain an ordinal bounding every ordinal of a set S *)
+Lemma ordinal_union_el_succ_set S : (∀ a, a ∈ S → ordinal a) → ∀ a, a ∈ S → a ∈ succ_set (union_set S).
+Proof.
+ intros H a Hel.
+ (* either a is the largest ordinal of S or there exists a larger ordinal *)
+ destruct (classic (∃ b, b ∈ S ∧ a ∈ b)) as [Hlarger | Hmax].
+ - apply bunionI1. apply zf_union. destruct Hlarger as (b & H1 & H2); eauto.
+ - apply bunionI2. apply single_el.
+ apply zf_extensionality. split.
+ + intros x H1. apply zf_union. exists a. eauto.
+ + intros x H1. apply zf_union in H1 as (c & H2 & H3).
+ specialize (H c H3) as Hordc.
+ specialize (H a Hel) as Horda.
+ destruct (ordinal_linear a c Horda Hordc) as [H0 | [H0 | H0]].
+ * exfalso; apply Hmax. eauto.
+ * rewrite H0. apply H2.
+ * eapply ordinal_trans; [ | apply Hordc | apply Horda | apply H2 | apply H0].
+ eapply ordinal_el; [apply Hordc | apply H2].
+Qed.
+
+Corollary ordinal_bunion a b: ordinal a → ordinal b → ordinal (a ∪ b).
+Proof.
+intros AO BO. apply ordinal_union. intros x X.
+apply zf_pair in X as [X|X]; now subst x.
+Qed.
+
+Corollary ordinal_noset: ¬ ∃ O: set, ∀ a, (ordinal a → a ∈ O) ∧ (a ∈ O → ordinal a).
+Proof.
+intros [O I].
+assert (OO: ordinal O).
+- split.
++ intros a A b B. apply I. apply ordinal_el with (a:=a); trivial. now apply I.
++ apply ordinal_set. intros a A. now apply I.
+- apply (ordinal_nel O); trivial. now apply I.
+Qed.
+
+Corollary ordinals_nosubset: ¬ ∃ O: set, ∀ a, ordinal a → a ∈ O.
+Proof.
+intros [S I]. pose (O:=specification_set S (λ a, ordinal a)).
+apply ordinal_noset. exists O. intros a. split; intros J.
+- apply zf_specification. split; trivial. now apply I.
+- apply zf_specification in J as [_ J]. assumption.
+Qed.
+
+Definition is_limit_ordinal a := a = ⋃ a ∧ ∀ a', a' ∈ a → ordinal a'.
+Definition is_succ_set_ordinal a := ∃ b, ordinal b ∧ a = succ_set b.
+
+Hint Unfold is_limit_ordinal is_succ_set_ordinal : core.
+
+Lemma succ_set_not_el a : not (succ_set a ∈ a).
+Proof.
+ intros H. eapply two_cycles. split. apply H. apply succ_set_el.
+Qed.
+
+Lemma ord_types a : ordinal a → a = ∅ ∨ is_succ_set_ordinal a ∨ is_limit_ordinal a.
+Proof.
+ intros Hord.
+ destruct (classic (a = ∅)) as [H1 | Hne]; [now left | right ].
+ destruct (classic (is_succ_set_ordinal a)) as [H1 | Hns]; [now left | right].
+ split. 2: { intros a' Hel. eapply ordinal_el; eauto. }
+ pose (b := ⋃ a). assert (ordinal b ∧ (a = b ∨ b ∈ a)) as [H1 H2].
+ - assert (ordinal b) as Hordb.
+ { eapply ordinal_union. intros a' Hel. eapply ordinal_el; eauto. }
+ split; [easy | ].
+ destruct (ordinal_linear _ _ Hord Hordb) as [H | [H | H]]; [ | eauto | eauto ].
+ exfalso. subst b. apply zf_union in H. destruct H as (A & H1 & H2).
+ eapply two_cycles; eauto.
+ - destruct H2 as [H | H]; [easy | ].
+ specialize (el_succ_set_eq_el _ _ Hord H) as [H2 | H2].
+ + exfalso; apply Hns. eauto.
+ + (* b is the largest ordinal < a *)
+ assert (∀ c, c ∈ a → c = b ∨ c ∈ b) as Hgreatest.
+ {
+ intros c Hel. assert (Hordc : ordinal c). { eapply ordinal_el. apply Hord. eauto. }
+ apply el_union_subs in Hel.
+ destruct (classic (c = b)) as [Heq | Hneq]; [now left | ].
+ right. apply ordinal_subs; eauto.
+ }
+ apply Hgreatest in H2 as [H2 | H2].
+ { unfold succ_set in H2. enough (b ∈ b) by (exfalso; eapply one_cycles; eauto).
+ rewrite <- H2 at 2. apply bunionI2, single_el. reflexivity.
+ }
+ now apply succ_set_not_el in H2.
+Qed.
+
+Lemma succ_set_smallest a b: b ∈ a → a ∈ succ_set b → False.
+Proof.
+ intros H H1. apply bunionE in H1 as [H1 | H1].
+ - eapply two_cycles; eauto.
+ - apply single_el in H1. rewrite H1 in H. now apply one_cycles in H.
+Qed.
+
+Lemma limit_not_succ_set a : is_limit_ordinal a → not (is_succ_set_ordinal a).
+Proof.
+ intros [Heq H] [b [H1 H2]].
+ rewrite H2 in Heq. clear H2. enough (b ∈ succ_set b ∧ not (b ∈ ⋃ (succ_set b))) as H0.
+ { rewrite {1}Heq in H0. destruct H0. by apply H2. }
+ split.
+ - apply succ_set_el.
+ - intros H2. unfold succ_set in H2. apply zf_union in H2 as (B & H2 & H3).
+ apply bunionE in H3 as [H3 | H3].
+ + eapply two_cycles; eauto.
+ + apply single_el in H3. rewrite H3 in H2. now apply one_cycles in H2.
+Qed.
+
+Lemma limit_ord_el_succ_set a : is_limit_ordinal a → ∀ b, b ∈ a → succ_set b ∈ a.
+Proof.
+ intros [Heq H] b Hel.
+ destruct (ordinal_linear (succ_set b) a) as [Hl | [Hl | Hl]].
+ - apply succ_set_ordinal. apply H, Hel.
+ - rewrite Heq. apply ordinal_union, H.
+ - easy.
+ - exfalso. eapply limit_not_succ_set.
+ + eauto.
+ + exists b. split; [ | eauto]. apply H, Hel.
+ - exfalso. eapply succ_set_smallest. now apply Hel. now apply Hl.
+Qed.
+
+End set_ordinals.
\ No newline at end of file
diff --git a/theories/algebra/ordinals/set_sets.v b/theories/algebra/ordinals/set_sets.v
new file mode 100644
index 0000000000000000000000000000000000000000..0437553a49d9da6b44b0e1600f70c065ca4d568c
--- /dev/null
+++ b/theories/algebra/ordinals/set_sets.v
@@ -0,0 +1,516 @@
+(** * Formalisation of basic ZF *)
+(** This file has been adapted from Dominik Kirst's Bachelor Thesis
+ "Formalised Set Theory: Well-Orderings and the Axiom of Choice",
+ see https://www.ps.uni-saarland.de/~kirst/bachelor.php
+*)
+
+
+(** This formalisation is part of Dominik Kirst's Bachelor Thesis, submitted Sep 2014.
+ It was implemented at the Programming Systems Lab in Saarbrücken, headed by Prof. Gert Smolka.
+ We present the development of a ZF set theory, introduce the notions of orderings,
+ functions and ordinals and conclude the equivalence of Well-Ordering Theorem and Axiom of Choice.
+ We do not provide excessive commentary in the source files
+ and refer to the explanations given in the thesis. **)
+
+(** import of necessary libraries **)
+
+Require Import Coq.Logic.Classical_Prop.
+Require Export iris.algebra.ordinals.set_model.
+
+Set Universe Polymorphism.
+Unset Universe Minimization ToSet.
+
+
+(** ** Basic Framework with Element- and Subset-Relation *)
+Section set_theory.
+ Implicit Types (A B C: set).
+
+(* we do not want the definitions to unfold / be reduced automatically in proof scripts *)
+Local Open Scope zf_scope.
+Arguments union_set : simpl never.
+Arguments replacement_set : simpl never.
+Arguments desc_set: simpl never.
+Arguments upair_set : simpl never.
+Arguments specification_set : simpl never.
+Arguments power_set : simpl never.
+
+Lemma desc_set_unique P A: (exists! x, P x) → P A → A = desc_set P.
+Proof.
+intros I1 I2. specialize (zf_desc _ I1). intros J. destruct I1 as [x [_ I1]].
+rewrite <- (I1 A I2). rewrite <- (I1 (desc_set P) J). reflexivity.
+Qed.
+
+Lemma desc_set_P P x: (exists! x, P x) → x = desc_set P → P x.
+Proof.
+intros I1 I2. apply zf_desc in I1.
+by rewrite I2.
+Qed.
+
+(** following
+ Chad Brown, "Three Forms of Replacement" at https://www.ps.uni-saarland.de/settheory.html
+ we can derive a relational form of replacement_set which allows us to define non-computable things more comfortably *)
+Definition total_replacement_set (X : set) (P : set → set → Prop) := (λ x, desc_set (P x)) @ X.
+Lemma TotalReplacement X (P : set → set → Prop) : (∀ x, x ∈ X → exists! y, P x y) → ∀ y, y ∈ total_replacement_set X P ↔ (∃ x, x ∈ X ∧ P x y).
+Proof.
+ intros Htotal y. unfold total_replacement_set.
+ destruct (zf_replacement (λ x, desc_set (P x)) X y) as [H1 H2]. split.
+ - intros H%H1. destruct H as (x & H0 & H). exists x. split; [easy | ].
+ apply desc_set_P; eauto.
+ - intros (x & H3 & H4).
+ apply H2. exists x. split; [easy | ].
+ apply desc_set_unique; eauto.
+Qed.
+
+(** ** Some General Statements *)
+
+Lemma subseq A: A ⊆ A.
+Proof.
+intros x I. assumption.
+Qed.
+
+Lemma subs_trans A B C: A ⊆ B → B ⊆ C → A ⊆ C.
+Proof.
+intros I I' x J. eauto.
+Qed.
+
+Lemma empty_subs A: ∅ ⊆ A.
+Proof.
+intros x I. apply zf_existence in I. contradiction I.
+Qed.
+
+Lemma empty_el A: A ≠∅ ↔ ∃ x, x ∈ A.
+Proof.
+split; intros I.
+- destruct (classic (∃ x, x∈ A)); trivial. exfalso. apply I, zf_extensionality. split.
+ + intros a Hel. exfalso; apply H; eauto.
+ + intros x Hel. by apply zf_existence in Hel.
+- intros H. subst A. destruct I. apply zf_existence in H. assumption.
+Qed.
+
+Lemma subs_el A B: A ⊈ B ↔ ∃ x, x ∈ A ∧ x ∉ B.
+Proof.
+split; intros I.
+- destruct (classic (∃ x, x ∈ A ∧ x ∉ B)); eauto.
+ exfalso. apply I. intros x J. destruct (classic (x ∈ B)); eauto.
+ exfalso. apply H. exists x. eauto.
+- destruct I as [x[I1 I2]]. intros J. apply I2. by apply J.
+Qed.
+
+Lemma extenE A B: A = B → A ⊆ B ∧ B ⊆ A.
+Proof.
+intros I. rewrite I. split; apply subseq.
+Qed.
+
+Lemma upair1 A B: A ∈ upair_set A B.
+Proof.
+apply zf_pair. left. reflexivity.
+Qed.
+
+Lemma upair2 A B: B ∈ upair_set A B.
+Proof.
+apply zf_pair. right. reflexivity.
+Qed.
+
+Lemma spec_subs A P: specification_set A P ⊆ A.
+Proof.
+intros x. intros I. apply zf_specification in I as [I J]. assumption.
+Qed.
+
+Lemma spec_equal A P: specification_set A P = A ↔ (∀ x, x ∈ A → P x).
+Proof.
+split; intros I.
+- rewrite <- I. intros x H. by apply zf_specification in H as [].
+- apply zf_extensionality; split. eauto using spec_subs. intros x J. apply zf_specification. eauto.
+Qed.
+
+Lemma spec_empty P: specification_set ∅ P = ∅.
+Proof.
+apply zf_extensionality; split; eauto using empty_subs. intros x I.
+apply zf_specification in I as [I _]. assumption.
+Qed.
+
+Lemma el_union_subs A B : A ∈ B → A ⊆ ⋃ B.
+Proof.
+ intros H c Hel. apply zf_union. eauto.
+Qed.
+
+Lemma power_set_trans A B C: A ⊆ B → B ∈ power_set C → A ∈ power_set C.
+Proof.
+intros I J. apply zf_power.
+apply (@subs_trans A B C); auto.
+by apply zf_power in J.
+Qed.
+
+Lemma one_cycles A: A ∉ A.
+Proof.
+ revert A. apply eps_ind.
+ intros X H H1. by apply (H X).
+Qed.
+
+Lemma all_set: ¬ ∃ A, ∀ B, B ∈ A.
+Proof.
+intros [A I]. by apply (@one_cycles A).
+Qed.
+
+Lemma russell: ¬ ∃ A, ∀ B, B ∈ A ↔ B ∉ B.
+Proof.
+ intros [A I]. specialize (I A). tauto.
+Qed.
+
+Lemma two_cycles A B : not (A ∈ B ∧ B ∈ A).
+Proof.
+ revert B. enough (∀ B, B ∈ A → not (A ∈ B)).
+ { intros B [H1 H2]. eapply H; eauto. }
+ apply eps_ind with (X := A); clear A.
+ intros A IH B Hel1 Hel2.
+ specialize (IH B Hel1 A Hel2). tauto.
+Qed.
+
+(** ** Binary Union, Intersection and Complement Sets *)
+
+
+Lemma bunionI1 A B x: x ∈ A → x ∈ A ∪ B.
+Proof.
+intros I. apply zf_union. exists A. split.
+- assumption.
+- apply zf_pair. left. reflexivity.
+Qed.
+
+Lemma bunionI2 A B x: x ∈ B → x ∈ A ∪ B.
+Proof.
+intros I. apply zf_union. exists B. split.
+- assumption.
+- apply zf_pair. right. reflexivity.
+Qed.
+
+Lemma bunionE A B x: x ∈ A ∪ B → x ∈ A ∨ x ∈ B.
+Proof.
+intros I. apply zf_union in I as [C I]. destruct I as [I J]. apply zf_pair in J as [J|J].
+- left. subst C. assumption.
+- right. subst C. assumption.
+Qed.
+
+Lemma interI S x: (∀ A, A ∈ S → x ∈ A) → S ≠∅ → x ∈ (⋂ S).
+Proof.
+intros I J. apply zf_specification. split.
+- apply zf_union. apply empty_el in J as [A H]. exists A. split. exact (I A H). assumption.
+- assumption.
+Qed.
+
+Lemma interE S x: x ∈ (⋂ S) → (∀ A, A ∈ S → x ∈ A) ∧ S ≠∅.
+Proof.
+intros I. apply zf_specification in I as [I J]. split.
+- assumption.
+- apply zf_union in I as [A [I1 I2]]. intros H. subst S. apply zf_existence in I2. assumption.
+Qed.
+
+Lemma binterI A B x: x ∈ A → x ∈ B → x ∈ (A ∩ B).
+Proof.
+intros I J. apply interI.
+- intros C H. apply zf_pair in H as [H|H]; subst C; assumption.
+- apply empty_el. exists A. apply zf_pair. left. reflexivity.
+Qed.
+
+Lemma binterE A B x: x ∈ (A ∩ B) → x ∈ A ∧ x ∈ B.
+Proof.
+intros I. apply interE in I as [I J]. split; apply I; apply zf_pair.
+- left. reflexivity.
+- right. reflexivity.
+Qed.
+
+Lemma union_set_empty: ⋃ ∅ = ∅.
+Proof.
+apply zf_extensionality; split; intros x I.
+- apply zf_union in I as [A [I I']]. destruct (zf_existence A I').
+- destruct (zf_existence x I).
+Qed.
+
+Lemma inter_empty: ⋂ ∅ = ∅.
+Proof.
+apply zf_extensionality; split; intros x I.
+- apply interE in I as [I I']. exfalso. by apply I'.
+- destruct (zf_existence x I).
+Qed.
+
+Lemma repl_empty R: R @ ∅ = ∅.
+Proof.
+apply zf_extensionality; split; intros x I.
+- apply zf_replacement in I as [A [I I']]. destruct (zf_existence A I).
+- destruct (zf_existence x I).
+Qed.
+
+Lemma binter_subs1 A B: A ∩ B ⊆ A.
+Proof.
+intros x I. by apply binterE in I as [I _].
+Qed.
+
+Lemma binter_subs2 A B: A ∩ B ⊆ B.
+Proof.
+intros x I. by apply binterE in I as [_ I].
+Qed.
+
+Lemma binter_eq1 A B: A ∩ B = A → A ⊆ B.
+Proof.
+intros I. rewrite <- I. apply binter_subs2.
+Qed.
+
+Lemma binter_eq2 A B: A ∩ B = B → B ⊆ A.
+Proof.
+intros I. rewrite <- I. apply binter_subs1.
+Qed.
+
+Lemma comp_empty A B: A\B = ∅ ↔ A ⊆ B.
+Proof.
+split.
+- intros I. intros x J. destruct (classic (x ∈ B)); eauto.
+ exfalso. apply (zf_existence x). rewrite <- I. apply zf_specification. split; eauto.
+- intros I. apply zf_extensionality; split; eauto using empty_subs.
+ intros x J. apply zf_specification in J as [J J'].
+ exfalso. apply J'. by apply (I x).
+Qed.
+
+Lemma comp_nempty A B: A ≠B → A ⊆ B → B\A ≠∅.
+Proof.
+intros J1 J2. destruct (classic (B\A = ∅)); eauto.
+exfalso. apply J1. apply zf_extensionality; split; eauto.
+intros a I. destruct (classic (a ∈ A)); eauto. exfalso. apply (zf_existence a).
+rewrite <- H. apply zf_specification; eauto.
+Qed.
+
+Lemma subs_comp A B: A ⊈ B → ∃ x, x ∈ A \ B.
+Proof.
+intros I. destruct (classic (∃ x, x ∈ A\B)); eauto. exfalso.
+apply I. intros x. intros J. destruct (classic (x ∈ B)); eauto. exfalso.
+apply H. exists x. apply zf_specification. split; eauto.
+Qed.
+
+Lemma bunion_subs1 A B C: C ⊆ A → C ⊆ A ∪ B.
+Proof.
+intros I x J. apply bunionI1. eauto.
+Qed.
+
+Lemma bunion_subs2 A B C: C ⊆ B → C ⊆ A ∪ B.
+Proof.
+intros I x J. apply bunionI2. eauto.
+Qed.
+
+
+
+(** ** Singletons and Ordered Pairs, Projection and Cartesian Product *)
+
+Definition opair A B := upair_set (singleton A) (upair_set A B).
+Notation "( x , y )" := (opair x y) (at level 0) : zf_scope.
+
+Definition pi1 p := ⋃ (⋂ p).
+Definition pi2 p := ⋃ (specification_set (⋃ p) (λ x, x ∈ ⋂ p → ⋃ p = ⋂ p)).
+Definition product A B := ⋃ ((λ a, (λ b, (a, b)) @ B) @ A).
+Notation "A × B" := (product A B) (at level 53) : zf_scope.
+
+
+Lemma single_el A B: A = B ↔ A ∈ (singleton B: set).
+Proof.
+split; intros I.
+- rewrite I. apply zf_pair. left. reflexivity.
+- apply zf_pair in I as [I|I]; apply I.
+Qed.
+
+Lemma single_union_set A: ⋃ (singleton A) = A.
+Proof.
+apply zf_extensionality; split; intros x I.
+- apply zf_union in I as [a [I J]]. apply single_el in J. rewrite <- J. apply I.
+- apply zf_union. exists A. split. apply I. apply single_el. reflexivity.
+Qed.
+
+Lemma single_inter A: â‹‚ (singleton A) = A.
+Proof.
+apply zf_extensionality; split; intros x I.
+- apply interE in I as [I I']. apply (I A). by apply single_el.
+- apply zf_specification. split. apply zf_union. exists A. split. apply I. apply single_el. eauto.
+ intros a J. apply single_el in J. rewrite J. assumption.
+Qed.
+
+Lemma opair_single A: (A,A) = singleton(singleton A).
+Proof.
+reflexivity.
+Qed.
+
+Lemma single_opair A B: singleton A ∈ (A,B).
+Proof.
+apply upair1.
+Qed.
+
+Lemma opair_intuni A B: ⋃ (A,B) = ⋂ (A,B) ↔ A = B.
+Proof.
+split; intros I.
+- apply extenE in I as [I I']. symmetry. apply single_el. cut (B ∈ union_set (A,B)).
++ intros J. specialize (I B J). apply interE in I as [I H].
+ specialize (I (singleton A)). apply I. apply upair1.
++ apply zf_union. exists (upair_set A B). split; apply upair2.
+- rewrite I. rewrite opair_single. by rewrite single_union_set single_inter.
+Qed.
+
+Lemma opair_nempty A B: (A,B) ≠∅.
+Proof.
+apply empty_el. exists (singleton A). apply upair1.
+Qed.
+
+Lemma pi1_subs1 A B: pi1 (A,B) ⊆ A.
+Proof.
+intros x I. apply zf_union in I as [a [I J]]. apply interE in J as [J J'].
+specialize (J (singleton A) (single_opair A B)). apply single_el in J. by rewrite <- J.
+Qed.
+
+Lemma pi1_subs2 A B: A ⊆ pi1 (A,B).
+Proof.
+intros x I. apply zf_union.
+exists A. split. apply I. apply interI.
+- intros a J. apply zf_pair in J as [J|J].
++ rewrite J. by apply single_el.
++ rewrite J. apply upair1.
+- apply empty_el. exists (singleton A). apply upair1.
+Qed.
+
+Lemma pi1_cor A B: pi1 (A,B) = A.
+Proof.
+apply zf_extensionality. split.
+- apply pi1_subs1.
+- apply pi1_subs2.
+Qed.
+
+Lemma pi2_subs1 A B: pi2 (A,B) ⊆ B.
+Proof.
+intros x I.
+apply zf_union in I as [a [I J]]. apply zf_specification in J as [J J'].
+apply zf_union in J as [b [J H]]. apply zf_pair in H as [H|H].
+- subst b. apply single_el in J. subst a. cut (A=B). intros H. subst A. assumption.
+ apply opair_intuni. apply J'. apply interI.
++ intros a H. apply zf_pair in H as [H|H]; subst a. by apply single_el. apply zf_pair. eauto.
++ apply empty_el. exists (singleton A). apply upair1.
+- subst b. apply zf_pair in J as [J|J].
++ subst a. cut (A=B); try congruence.
+ apply opair_intuni. apply J'. apply interI; eauto using opair_nempty.
+ intros a H. apply zf_pair in H as [H|H]; subst a; try by apply single_el. apply upair1.
++ subst a. assumption.
+Qed.
+
+Lemma pi2_subs2 A B: B ⊆ pi2 (A,B).
+Proof.
+intros x I. apply zf_union. exists B. split; trivial. apply zf_specification. split.
+- apply zf_union. exists (upair_set A B). split; apply upair2.
+- intros J. cut (A=B).
++ intros H. apply opair_intuni. assumption.
++ apply interE in J as [J J']. specialize (J (singleton A) (single_opair A B)).
+ apply single_el in J. by rewrite J.
+Qed.
+
+Lemma pi2_cor A B: pi2 (A,B) = B.
+Proof.
+apply zf_extensionality. split.
+- apply pi2_subs1.
+- apply pi2_subs2.
+Qed.
+
+Lemma opair_eq A A' B B': (A,B) = (A',B') ↔ A = A' ∧ B = B'.
+Proof.
+split; intros I.
+- split. rewrite <- (pi1_cor A B), <- (pi1_cor A' B'). by rewrite I.
+ rewrite <- (pi2_cor A B), <- (pi2_cor A' B'). by rewrite I.
+- destruct I as [I J]. by rewrite I J.
+Qed.
+
+Lemma product_empty1 B: ∅ × B = ∅.
+Proof.
+unfold product. rewrite repl_empty. by rewrite union_set_empty.
+Qed.
+
+Lemma product_empty2 A: A × ∅ = ∅.
+Proof.
+destruct (classic (A = ∅)). rewrite H. apply product_empty1. apply empty_el in H as [a H].
+cut (replacement_set A (λ A : set, replacement_set ∅ (λ B : set, (A,B))) = singleton ∅).
+- intros I. unfold product. rewrite I. apply single_union_set.
+- apply zf_extensionality; split; intros x I.
++ apply single_el. apply zf_replacement in I as [y [I I']]. rewrite I'. apply repl_empty.
++ apply single_el in I. apply zf_replacement. exists a. split. assumption. by rewrite -> repl_empty.
+Qed.
+
+Lemma product_el A B p: p ∈ A × B ↔ ∃ a b, a ∈ A ∧ b ∈ B ∧ p = (a,b).
+Proof.
+split; intros I.
+- apply zf_union in I as [C [I I']]. apply zf_replacement in I' as [a [a' J]]. subst C.
+ apply zf_replacement in I as [b [B' I]]. exists a, b. eauto.
+- destruct I as [a [b [A' [B' P]]]]. apply zf_union.
+ exists (replacement_set B (λ c : set, (a,c))). split.
++ apply zf_replacement. exists b. split. apply B'. assumption.
++ apply zf_replacement. exists a. split. apply A'. reflexivity.
+Qed.
+
+Lemma opair_pi A B a b p: p ∈ A × B → a = pi1 p → b = pi2 p → p = (a,b).
+Proof.
+intros I PI1 PI2. apply product_el in I as [a' [b' [H [H' J]]]].
+subst p. apply opair_eq. split.
+- rewrite PI1. by rewrite pi1_cor.
+- rewrite PI2. by rewrite pi2_cor.
+Qed.
+
+Lemma product_opair x y A B: x ∈ A ∧ y ∈ B ↔ (x,y) ∈ A × B.
+Proof.
+split; intros I.
+- apply product_el. exists x, y. destruct I as [I I']. eauto.
+- apply product_el in I as [a [b [I [I' J]]]]. apply opair_eq in J as [J J']. subst x y. eauto.
+Qed.
+
+Lemma product_pi1 A B p: p ∈ A × B → pi1 p ∈ A.
+Proof.
+intros I. apply product_el in I as [a [b [I [I' J]]]].
+rewrite J. rewrite pi1_cor. assumption.
+Qed.
+
+Lemma product_pi2 A B p: p ∈ A × B → pi2 p ∈ B.
+Proof.
+intros I. apply product_el in I as [a [b [I [I' J]]]].
+rewrite J. rewrite pi2_cor. assumption.
+Qed.
+
+Lemma product_pi A B p: p ∈ A × B → pi1 p ∈ A ∧ pi2 p ∈ B.
+Proof.
+intros I. split. eauto using product_pi1. eauto using product_pi2.
+Qed.
+
+Lemma product_p A B p: p ∈ A × B → p = (pi1 p, pi2 p).
+Proof.
+intros I. by apply (opair_pi A B).
+Qed.
+
+Lemma product_subs1 A A' B: A' ⊆ A → A' × B ⊆ A × B.
+Proof.
+intros I p H.
+specialize (product_el A' B p). intros [J _]. specialize (J H). destruct J as [a [b [X [Y Z]]]].
+apply product_el. exists a, b. repeat split; eauto.
+Qed.
+
+Lemma product_subs2 A B B': B ⊆ B' → A ×B ⊆ A × B'.
+Proof.
+intros I p H.
+specialize (product_el A B p). intros [J _]. specialize (J H). destruct J as [a [b [X [Y Z]]]].
+apply product_el. exists a, b. repeat split; eauto.
+Qed.
+
+Lemma product_subs A A': A' ⊆ A → A' × A' ⊆ A × A.
+Proof.
+intros I. specialize (product_subs1 A A' A I).
+intros J. specialize (product_subs2 A' A' A I).
+intros H. by apply (subs_trans (product A' A') (product A' A)).
+Qed.
+
+Lemma product_monotone A B C D: A ⊆ C → B ⊆ D → A × B ⊆ C × D.
+Proof.
+intros I1 I2 p P.
+generalize (product_pi A B p P). intros [P1 P2].
+generalize (product_p A B p P). intros P3.
+apply product_el. exists (pi1 p), (pi2 p).
+repeat split; auto.
+Qed.
+
+End set_theory.
+Notation "( x , y )" := (opair x y) (at level 0) : zf_scope.
+Notation "A × B" := (product A B) (at level 53) : zf_scope.
diff --git a/theories/algebra/proofmode_classes.v b/theories/algebra/proofmode_classes.v
index 7ccebbe786a091147778f9ca798f9ab62a8b84a0..3eca688a290f6ae116cd73e49a7c5b7d71f7215e 100644
--- a/theories/algebra/proofmode_classes.v
+++ b/theories/algebra/proofmode_classes.v
@@ -15,40 +15,40 @@ From iris.algebra Require Export cmra.
[own γ (q1 + q2)] where [q1] and [q2] are fractions, we actually get
[own γ q1] and [own γ q2] instead of [own γ ((q1 + q2)/2)] twice.
*)
-Class IsOp {A : cmraT} (a b1 b2 : A) := is_op : a ≡ b1 ⋅ b2.
-Arguments is_op {_} _ _ _ {_}.
-Hint Mode IsOp + - - - : typeclass_instances.
+Class IsOp {SI} {A : cmraT SI} (a b1 b2 : A) := is_op : a ≡ b1 ⋅ b2.
+Arguments is_op {_ _} _ _ _ {_}.
+Hint Mode IsOp - + - - - : typeclass_instances.
-Instance is_op_op {A : cmraT} (a b : A) : IsOp (a â‹… b) a b | 100.
+Instance is_op_op {SI} {A : cmraT SI} (a b : A) : IsOp (a â‹… b) a b | 100.
Proof. by rewrite /IsOp. Qed.
-Class IsOp' {A : cmraT} (a b1 b2 : A) := is_op' :> IsOp a b1 b2.
-Hint Mode IsOp' + ! - - : typeclass_instances.
-Hint Mode IsOp' + - ! ! : typeclass_instances.
+Class IsOp' {SI} {A : cmraT SI} (a b1 b2 : A) := is_op' :> IsOp a b1 b2.
+Hint Mode IsOp' - + ! - - : typeclass_instances.
+Hint Mode IsOp' - + - ! ! : typeclass_instances.
-Class IsOp'LR {A : cmraT} (a b1 b2 : A) := is_op_lr : IsOp a b1 b2.
+Class IsOp'LR {SI} {A : cmraT SI} (a b1 b2 : A) := is_op_lr : IsOp a b1 b2.
Existing Instance is_op_lr | 0.
-Hint Mode IsOp'LR + ! - - : typeclass_instances.
-Instance is_op_lr_op {A : cmraT} (a b : A) : IsOp'LR (a â‹… b) a b | 0.
+Hint Mode IsOp'LR - + ! - - : typeclass_instances.
+Instance is_op_lr_op {SI} {A : cmraT SI} (a b : A) : IsOp'LR (a â‹… b) a b | 0.
Proof. by rewrite /IsOp'LR /IsOp. Qed.
(* FromOp *)
(* TODO: Worst case there could be a lot of backtracking on these instances,
try to refactor. *)
-Global Instance is_op_pair {A B : cmraT} (a b1 b2 : A) (a' b1' b2' : B) :
+Global Instance is_op_pair {SI} {A B : cmraT SI} (a b1 b2 : A) (a' b1' b2' : B) :
IsOp a b1 b2 → IsOp a' b1' b2' → IsOp' (a,a') (b1,b1') (b2,b2').
Proof. by constructor. Qed.
-Global Instance is_op_pair_core_id_l {A B : cmraT} (a : A) (a' b1' b2' : B) :
+Global Instance is_op_pair_core_id_l {SI} {A B : cmraT SI} (a : A) (a' b1' b2' : B) :
CoreId a → IsOp a' b1' b2' → IsOp' (a,a') (a,b1') (a,b2').
Proof. constructor=> //=. by rewrite -core_id_dup. Qed.
-Global Instance is_op_pair_core_id_r {A B : cmraT} (a b1 b2 : A) (a' : B) :
+Global Instance is_op_pair_core_id_r {SI} {A B : cmraT SI} (a b1 b2 : A) (a' : B) :
CoreId a' → IsOp a b1 b2 → IsOp' (a,a') (b1,a') (b2,a').
Proof. constructor=> //=. by rewrite -core_id_dup. Qed.
-Global Instance is_op_Some {A : cmraT} (a : A) b1 b2 :
+Global Instance is_op_Some {SI} {A : cmraT SI} (a : A) b1 b2 :
IsOp a b1 b2 → IsOp' (Some a) (Some b1) (Some b2).
Proof. by constructor. Qed.
(* This one has a higher precendence than [is_op_op] so we get a [+] instead of
an [â‹…]. *)
-Global Instance is_op_plus (n1 n2 : nat) : IsOp (n1 + n2) n1 n2.
-Proof. done. Qed.
\ No newline at end of file
+Global Instance is_op_plus (I: indexT) (n1 n2 : nat) : @IsOp I _ (n1 + n2) n1 n2.
+Proof. done. Qed.
diff --git a/theories/algebra/stepindex.v b/theories/algebra/stepindex.v
new file mode 100644
index 0000000000000000000000000000000000000000..90322037f8b650e2cfb24fcb30f5e7668d67bc65
--- /dev/null
+++ b/theories/algebra/stepindex.v
@@ -0,0 +1,832 @@
+From iris.algebra Require Import base.
+
+
+(* TODO: move into stdpp *)
+Inductive rc {A} (R: A → A → Prop) (x: A) (y: A): Prop :=
+| rc_refl: x = y → rc R x y
+| rc_subrel: R x y → rc R x y.
+Hint Constructors rc : core.
+
+Instance rc_reflexive {A} (R : A → A → Prop) : Reflexive (rc R).
+Proof. intros ?; by apply rc_refl. Qed.
+Instance rc_subrelation {A} (R : A → A → Prop): subrelation R (rc R).
+Proof. intros ? ? ?; by apply rc_subrel. Qed.
+
+Polymorphic Structure IndexMixin {A} {R: A → A → Prop} {zero: A} {succ: A → A} :=
+ {
+ index_mixin_lt_trans: Transitive R;
+ index_mixin_lt_wf: wf R;
+ index_mixin_lt_strict_total α β: (R α β) + (α = β) + (R β α);
+ index_mixin_zero_least: nf (flip R) zero;
+ index_mixin_succ_greater α: R α (succ α);
+ index_mixin_succ_least α β: R α β → rc R (succ α) β;
+ index_mixin_dec_limit α: {β | α = succ β} +
+ (∀ β, R β α → R (succ β) α);
+ }.
+Arguments IndexMixin : clear implicits.
+
+Polymorphic Structure indexT@{i} :=
+ IndexT {
+ index_car :> Type@{i};
+ index_lt : relation index_car;
+ index_zero : index_car;
+ index_succ : index_car → index_car;
+ index_mixin :> IndexMixin index_car index_lt index_zero index_succ;
+ }.
+
+Notation "(≺)" := (index_lt _).
+Notation "(≻)" := (flip (index_lt _)).
+
+Notation zero := (index_zero _).
+Notation succ α := (index_succ _ α).
+Notation "α ≺ β" := (index_lt _ α β) (at level 80).
+
+Polymorphic Definition index_le (SI : indexT) : relation SI := rc (index_lt SI).
+Notation "(⪯)" := (index_le _).
+Notation "α ⪯ β" := (index_le _ α β) (at level 80).
+
+Instance index_le_refl {SI : indexT} : Reflexive (@index_le SI) := _.
+Instance index_lt_le_subrel {SI : indexT}: subrelation (@index_lt SI) (@index_le SI) := _.
+Lemma index_le_refl_auto {SI : indexT} (α β : SI) (H : α = β): α ⪯ β.
+Proof. rewrite H. apply index_le_refl. Qed.
+Hint Extern 1 (?a ⪯ ?a) => apply index_le_refl : core.
+Hint Extern 2 (?a ⪯ ?b) => apply index_le_refl_auto : core.
+Hint Extern 1 (?a ⪯ ?b) => apply index_lt_le_subrel : core.
+
+Lemma index_le_eq_or_lt {SI : indexT} (α β : SI) : α ⪯ β → α = β ∨ α ≺ β.
+Proof. intros [H | H]; auto. Qed.
+
+Section index_laws.
+ Context {SI : indexT}.
+ Global Instance index_lt_trans : Transitive (index_lt SI).
+ Proof. eapply index_mixin_lt_trans, SI. Qed.
+ Lemma index_lt_wf : wf (index_lt SI).
+ Proof. eapply index_mixin_lt_wf, SI. Qed.
+ Lemma index_lt_eq_lt_dec (α β : SI) : (α ≺ β) + (α = β) + (β ≺ α).
+ Proof. eapply index_mixin_lt_strict_total, SI. Qed.
+ Lemma index_zero_least : nf (flip (index_lt SI)) zero.
+ Proof. eapply index_mixin_zero_least, SI. Qed.
+ Lemma index_succ_greater (α : SI) : α ≺ succ α.
+ Proof. eapply index_mixin_succ_greater, SI. Qed.
+ Lemma index_succ_least (α β : SI) : α ≺ β → succ α ⪯ β.
+ Proof. eapply index_mixin_succ_least, SI. Qed.
+ Lemma index_dec_limit (α: SI) : { β | α = succ β } + (∀ β, β ≺ α → succ β ≺ α).
+ Proof. eapply index_mixin_dec_limit, SI. Qed.
+End index_laws.
+Arguments index_zero_least : clear implicits.
+Arguments index_lt_wf : clear implicits.
+
+Definition index_is_limit {SI : indexT} (α : SI) := ∀ β, β ≺ α → succ β ≺ α.
+(* proper limit indices that are not zero*)
+Record limit_idx {SI: indexT} := mklimitidx {
+ limit_index :> SI;
+ limit_index_is_limit : index_is_limit limit_index;
+ limit_index_not_zero : zero ≺ limit_index;
+}.
+Arguments limit_idx : clear implicits.
+Arguments mklimitidx {_}.
+
+Section StepIndexProperties.
+ Context {I: indexT}.
+ Implicit Type (α β γ : I).
+
+ Global Instance: Inhabited I.
+ Proof. constructor. exact zero. Qed.
+
+ Global Instance: PreOrder (@index_le SI).
+ Proof.
+ split; [by constructor|].
+ intros ??? [] []; subst; eauto.
+ right; transitivity y; auto.
+ Qed.
+
+ Lemma index_le_total α β: {α ⪯ β} + {β ⪯ α}.
+ Proof.
+ destruct (index_lt_eq_lt_dec α β) as [[|]|]; eauto.
+ Qed.
+
+ Lemma index_le_lt_dec α β : {α ⪯ β} + {β ≺ α}.
+ Proof.
+ edestruct (index_lt_eq_lt_dec α β) as [[H | H] | H]; eauto.
+ Defined.
+
+ Lemma index_zero_minimum α: zero ⪯ α.
+ Proof.
+ destruct (index_le_total zero α) as [|[]]; eauto.
+ exfalso; eapply (index_zero_least); eauto.
+ Qed.
+
+ Lemma index_lt_zero_is_normal α: ¬ (α ≺ zero).
+ Proof.
+ specialize (index_zero_least I) as H.
+ intros R; apply H; unfold red, flip; eauto.
+ Qed.
+
+ Lemma index_zero_is_unique α: (∀ β, ¬ (β ≺ α)) → α = zero.
+ Proof.
+ intros H; destruct (index_le_total α zero) as [[]|[]]; eauto; exfalso.
+ by eapply index_lt_zero_is_normal. by eapply H.
+ Qed.
+
+ Lemma index_is_zero α: {α = zero} + {zero ≺ α}.
+ Proof.
+ destruct (index_lt_eq_lt_dec α zero) as [[]|]; eauto.
+ exfalso; by eapply index_lt_zero_is_normal.
+ Qed.
+
+ Lemma index_lt_dec_minimum α: (∀ β, ¬ (β ≺ α)) + { β | β ≺ α}.
+ Proof.
+ destruct (index_lt_eq_lt_dec α zero) as [[]|].
+ - exfalso; by eapply index_lt_zero_is_normal.
+ - subst; left; exact index_lt_zero_is_normal.
+ - right; by eexists.
+ Qed.
+
+ Lemma index_lt_irrefl α: ¬ (α ≺ α).
+ Proof.
+ induction α using (well_founded_ind (index_lt_wf I)).
+ intros H1; apply H in H1 as H2; eauto.
+ Qed.
+
+ Lemma index_lt_le_trans α β γ: α ≺ β → β ⪯ γ → α ≺ γ.
+ Proof. intros ? []; subst; eauto. by transitivity β. Qed.
+
+ Lemma index_le_lt_trans α β γ: α ⪯ β → β ≺ γ → α ≺ γ.
+ Proof. intros [] ?; subst; eauto. by transitivity β. Qed.
+
+ Lemma index_le_lt_contradict α α' : α ⪯ α' → α' ≺ α → False.
+ Proof.
+ intros H1 H2. enough (α ≺ α) by (by eapply index_lt_irrefl).
+ by eapply index_le_lt_trans.
+ Qed.
+
+ Lemma index_lt_le_contradict α α' : α ≺ α' → α' ⪯ α → False.
+ Proof.
+ intros H1 H2. enough (α ≺ α) by (by eapply index_lt_irrefl).
+ by eapply index_lt_le_trans.
+ Qed.
+
+ Lemma index_le_ge_eq α α' : α ⪯ α' → α' ⪯ α → α = α'.
+ Proof.
+ intros [-> | H1] [H2 | H2]; try by eauto.
+ exfalso; eapply index_lt_irrefl. by eapply index_lt_trans.
+ Qed.
+
+ Lemma index_succ_iff α β: α ⪯ β ↔ α ≺ succ β.
+ Proof.
+ split; intros H.
+ - destruct H; subst. 2: transitivity β.
+ all: eauto; eapply index_succ_greater.
+ - destruct (index_le_total α β) as [|[|H1]]; eauto.
+ apply index_succ_least in H1.
+ eapply index_lt_le_trans in H1; eauto.
+ exfalso; eapply index_lt_irrefl; eauto.
+ Qed.
+
+ Lemma index_le_lt_eq_dec α β : α ⪯ β → {α ≺ β} + {α = β}.
+ Proof.
+ intros Hle. destruct (index_lt_eq_lt_dec α β) as [[H | H] | H].
+ - by left.
+ - by right.
+ - exfalso. eapply index_lt_irrefl with (α := α). by eapply index_le_lt_trans.
+ Qed.
+
+ Lemma index_lt_succ_mono α β: α ≺ β → succ α ≺ succ β.
+ Proof.
+ intros. by eapply index_succ_iff, index_succ_least.
+ Qed.
+
+ Lemma index_le_succ_mono α β: α ⪯ β → succ α ⪯ succ β.
+ Proof.
+ intros [->|H % index_lt_succ_mono]; eauto.
+ Qed.
+
+ Lemma index_succ_greater' α β: α = succ β → β ≺ α.
+ Proof. intros ->; by apply index_succ_greater. Qed.
+
+ Lemma index_succ_neq α : α ≠succ α.
+ Proof.
+ intros H%index_succ_greater'. by eapply index_lt_irrefl.
+ Qed.
+
+ Lemma index_lt_succ_inj α β: succ α ≺ succ β → α ≺ β.
+ Proof.
+ destruct (index_le_total α β) as [[]|H].
+ - subst; intros [] % index_lt_irrefl.
+ - auto.
+ - intros H'. apply index_le_succ_mono in H.
+ specialize (index_le_lt_trans _ _ _ H H') as [] % index_lt_irrefl.
+ Qed.
+
+ Lemma index_succ_inj α β: succ α = succ β → α = β.
+ Proof.
+ intros H. destruct (index_lt_eq_lt_dec α β) as [[H'|]|H']; eauto; exfalso.
+ all: eapply index_lt_succ_mono in H'; rewrite H in H'; by eapply index_lt_irrefl.
+ Qed.
+
+ Lemma index_le_succ_inj α β : succ α ⪯ succ β → α ⪯ β.
+ Proof.
+ intros [Heq | Hlt].
+ - apply index_succ_inj in Heq. by left.
+ - apply index_lt_succ_inj in Hlt. by right.
+ Qed.
+
+ Lemma index_eq_dec α β: {α = β} + {α ≠β}.
+ Proof.
+ destruct (index_lt_eq_lt_dec α β) as [[H|H]|H]; subst.
+ - right; intros ->; by eapply index_lt_irrefl.
+ - by left.
+ - right; intros ->; by eapply index_lt_irrefl.
+ Qed.
+
+ Lemma index_succ_le_lt α β : succ α ⪯ β ↔ α ≺ β.
+ Proof.
+ split.
+ - intros [<- | H1]; [eapply index_succ_greater | ].
+ eapply index_lt_trans; [ eapply index_succ_greater | eauto ].
+ - intros H. destruct (index_lt_eq_lt_dec (succ α) β) as [[Hlt | Heq] | Hgt].
+ + by right.
+ + by left.
+ + exfalso. eapply index_succ_least in Hgt.
+ apply index_le_succ_inj in Hgt.
+ eapply index_lt_irrefl. by eapply index_lt_le_trans.
+ Qed.
+
+ Lemma index_succ_le α β : succ α ⪯ β → α ⪯ β.
+ Proof.
+ right. by apply index_succ_le_lt.
+ Qed.
+
+ Lemma index_lt_succ_tight α β : α ≺ β → β ≺ succ α → False.
+ Proof.
+ intros H1%index_succ_le_lt H2. eapply index_lt_irrefl, index_le_lt_trans; eauto.
+ Qed.
+
+ Lemma index_succ_not_zero α: succ α ≠zero.
+ Proof.
+ intros H. eapply index_lt_zero_is_normal, index_succ_greater'. by symmetry.
+ Qed.
+
+ Lemma index_succ_not_limit β: ¬ (∀ α, α ≺ succ β → succ α ≺ succ β).
+ Proof.
+ intros H. eapply index_lt_irrefl, H. apply index_succ_greater.
+ Qed.
+
+ Lemma index_limit_not_succ (β : I) : index_is_limit β → ∀ α, β ≠succ α.
+ Proof.
+ intros H α Hα. specialize (H α). rewrite Hα in H. eapply index_lt_irrefl. apply H, index_succ_greater.
+ Qed.
+
+ Definition index_min α β := if index_le_total α β then α else β.
+ Lemma index_min_eq α β: index_min α β = α ∨ index_min α β = β.
+ Proof.
+ unfold index_min; destruct index_le_total; eauto.
+ Qed.
+
+ Lemma index_min_le_l α β : index_min α β ⪯ α.
+ Proof.
+ unfold index_min. destruct index_le_total; eauto.
+ Qed.
+ Lemma index_min_le_r α β : index_min α β ⪯ β.
+ Proof.
+ unfold index_min. destruct index_le_total; eauto.
+ Qed.
+
+ Lemma index_min_l α β : α ⪯ β → index_min α β = α.
+ Proof.
+ intros H. unfold index_min. destruct (index_le_total α β) as [_ | Hle]; [easy | ].
+ by apply index_le_ge_eq.
+ Qed.
+
+ Lemma index_min_r α β : α ⪯ β → index_min β α = α.
+ Proof.
+ intros H. unfold index_min. destruct (index_le_total β α) as [Hle | ]; [| easy].
+ by apply index_le_ge_eq.
+ Qed.
+
+ Lemma index_min_comm α β : index_min β α = index_min α β.
+ Proof.
+ unfold index_min.
+ destruct (index_le_total β α) as [H1 | H1], (index_le_total α β) as [H2 | H2].
+ - by apply index_le_ge_eq.
+ - reflexivity.
+ - reflexivity.
+ - by apply index_le_ge_eq.
+ Qed.
+
+ Lemma index_min_mono_r γ β α: γ ⪯ β → index_min α γ ⪯ index_min α β.
+ Proof.
+ intros H. unfold index_min. destruct (index_le_total α γ) as [H1 | H1];
+ destruct (index_le_total α β) as [H2 | H2]; try by auto.
+ left. eapply index_le_ge_eq; auto. etransitivity; eauto.
+ Qed.
+End StepIndexProperties.
+
+Hint Immediate index_zero_minimum : core.
+Hint Resolve index_succ_greater : core.
+Hint Resolve <- index_succ_iff : core.
+
+Section ordinal_match.
+ Context {SI : indexT}.
+ Definition ord_match (P : SI → Type) : P zero → (∀ α, P (succ α)) → (∀ α : limit_idx SI, P α) → ∀ α, P α :=
+ λ s f lim α,
+ match index_is_zero α with
+ | left EQ => eq_rect_r P s EQ
+ | right NT =>
+ match index_dec_limit α with
+ | inl (exist _ β EQ) => eq_rect_r P (f β) EQ
+ | inr Hlim => lim (mklimitidx α Hlim NT)
+ end
+ end.
+End ordinal_match.
+
+Section ordinal_recursor.
+ Context {SI: indexT}.
+
+ Definition index_rec (P: SI → Type): P zero → (∀ α, P α → P (succ α)) → (∀ α: limit_idx SI, (∀ β, β ≺ α → P β) → P α) → ∀ α, P α :=
+ λ s f lim, Fix (index_lt_wf SI) _ (λ α IH,
+ match index_is_zero α with
+ | left EQ => eq_rect_r P s EQ
+ | right NZ =>
+ match index_dec_limit α with
+ | inl (exist _ β EQ) => eq_rect_r P (f β (IH β (index_succ_greater' α β EQ))) EQ
+ | inr Hlim => lim (mklimitidx α Hlim NZ) IH
+ end
+ end
+ ).
+
+ Lemma index_type_dec (α : SI) :
+ (α = zero) + { α' | α = succ α'} + ( index_is_limit α).
+ Proof.
+ revert α. apply index_rec.
+ - by left; left.
+ - intros α _; left; right. by exists α.
+ - intros α _. right. apply limit_index_is_limit.
+ Defined.
+
+ Class index_rec_lim_ext {P: SI → Type} (lim: ∀ α: limit_idx SI, (∀ β, β ≺ α → P β) → P α) := {
+ index_rec_lim_ext_proofs α H1 H2 f: lim α f = lim (mklimitidx α H2 H1) f;
+ index_rec_lim_ext_function α f g: (∀ β Hβ, f β Hβ = g β Hβ) → lim α f = lim α g
+ }.
+
+ Lemma index_rec_unfold P s f lim `{index_rec_lim_ext P lim} α:
+ index_rec P s f lim α =
+ match index_is_zero α with
+ | left EQ => eq_rect_r P s EQ
+ | right NZ =>
+ match index_dec_limit α with
+ | inl (exist _ β EQ) => eq_rect_r P (f β (index_rec P s f lim β)) EQ
+ | inr Hlim => lim (mklimitidx α Hlim NZ) (λ β _, index_rec P s f lim β)
+ end
+ end.
+ Proof.
+ unfold index_rec at 1. rewrite Fix_eq.
+ - reflexivity.
+ - intros β g h EQ. destruct index_is_zero; eauto.
+ destruct index_dec_limit as [[γ EQ']|].
+ + by rewrite EQ.
+ + erewrite index_rec_lim_ext_function; eauto.
+ Qed.
+
+ Lemma index_rec_zero P s f lim `{index_rec_lim_ext P lim}: index_rec P s f lim zero = s.
+ Proof.
+ rewrite index_rec_unfold; eauto.
+ destruct index_is_zero as [EQ|NT].
+ - symmetry. apply Eqdep_dec.eq_rect_eq_dec, index_eq_dec.
+ - exfalso; by eapply index_lt_irrefl.
+ Qed.
+
+ Lemma index_rec_succ P s f lim `{index_rec_lim_ext P lim} α: index_rec P s f lim (succ α) = f α (index_rec P s f lim α).
+ Proof.
+ rewrite index_rec_unfold; eauto.
+ destruct index_is_zero as [EQ|NT];[|destruct index_dec_limit as [[β EQ]|Hlim]].
+ - exfalso. by eapply index_succ_not_zero.
+ - eapply index_succ_inj in EQ as EQ'. subst α.
+ symmetry. apply Eqdep_dec.eq_rect_eq_dec, index_eq_dec.
+ - exfalso. eapply index_lt_irrefl, Hlim, index_succ_greater.
+ Qed.
+
+ Lemma index_rec_lim P s f lim `{index_rec_lim_ext P lim} (α: limit_idx SI):
+ index_rec P s f lim α = lim α (λ β _, index_rec P s f lim β).
+ Proof.
+ rewrite index_rec_unfold; eauto.
+ destruct index_is_zero as [EQ|NT];[|destruct index_dec_limit as [[β EQ]|Hlim]].
+ - exfalso. specialize (limit_index_not_zero α). rewrite EQ. by apply index_lt_irrefl.
+ - exfalso. specialize (limit_index_is_limit α β (index_succ_greater' _ _ EQ)).
+ rewrite EQ. by apply index_lt_irrefl.
+ - simpl. symmetry. apply index_rec_lim_ext_proofs.
+ Qed.
+End ordinal_recursor.
+
+Section ordinal_cumulative_recursor.
+
+ Context {SI: indexT}.
+ Variable (P: SI → Type) (Q: ∀ α, (∀ β, β ≺ α → P β) → Type).
+
+ Let R α := {f: ∀ β, β ≺ α → P β & Q α f}.
+
+ Lemma index_cumulative_rec (F: ∀ α, R α → P α):
+ (∀ α G, Q α (λ β Hβ, F β (G β Hβ))) → (∀ α, R α).
+ Proof.
+ intros IH. apply (Fix (index_lt_wf SI)).
+ intros α G. unfold R. unshelve econstructor.
+ - intros β Hβ. by eapply F, G.
+ - by apply IH.
+ Defined.
+
+ Lemma index_cumulative_rec_dep (F: ∀ α, R α → P α):
+ (∀ α G, Q α (λ β Hβ, F β (G β Hβ))) → (∀ α (H : Acc (≺) α), R α).
+ Proof.
+ intros IH. apply (Fix_F).
+ intros α G. unfold R. unshelve econstructor.
+ - intros β Hβ. by eapply F, G.
+ - by apply IH.
+ Defined.
+
+ Lemma index_cumulative_rec_dep_step F step β succs:
+ index_cumulative_rec_dep F step β (Acc_intro β succs) =
+ existT (λ γ Hγ, F γ (index_cumulative_rec_dep F step γ (succs γ Hγ)))
+ (step β (λ γ Hγ, index_cumulative_rec_dep F step γ (succs γ Hγ))).
+ Proof. reflexivity. Qed.
+
+ Lemma index_cumulative_rec_unfold F step (M : ∀ α, R α → Prop) :
+ (∀ β succs, (∀ γ (Hγ: γ ≺ β), M γ (index_cumulative_rec_dep F step γ (succs γ Hγ))) → M β (index_cumulative_rec_dep F step β (Acc_intro β succs)))
+ → ∀ β, M β (index_cumulative_rec F step β).
+ Proof.
+ intros H β. unfold index_cumulative_rec, Fix.
+ pattern β, (index_lt_wf SI β). eapply Acc_inv_dep. clear β.
+ intros β succs Hβ.
+ unfold index_cumulative_rec_dep in H.
+ eapply H. apply Hβ.
+ Qed.
+ Global Opaque index_cumulative_rec_dep.
+ Global Opaque index_cumulative_rec.
+End ordinal_cumulative_recursor.
+
+Polymorphic Class FiniteIndex (I: indexT) :=
+ finite_index: ∀ α, (∀ β, ¬ (β ≺ α)) + {β | β ≺ α ∧ ∀ (γ: I), γ ≺ α → γ ⪯ β}.
+
+Polymorphic Class TransfiniteIndex (SI: indexT) :=
+ { upper_limit: SI → SI;
+ upper_limit_is_limit n m: Nat.iter n (index_succ SI) m ≺ upper_limit m
+ }.
+
+Section large_index_class.
+
+ Polymorphic Universes i j.
+ Polymorphic Constraint i < j.
+
+ Polymorphic Class LargeIndex (SI: indexT@{j}) : Type :=
+ can_commute_exists (X : Type@{i}) (P : X → SI → Prop) :
+ (∀ x a b, a ≺ b → P x b → P x a)
+ → (∀ a, ∃ x, P x a)
+ → ∃ x, ∀ a, P x a.
+
+End large_index_class.
+
+
+Section finite_existential_property.
+ Set Universe Polymorphism.
+
+ (* For the finite existential property classical logic suffices *)
+ Polymorphic Class FiniteExistential (SI: indexT) :=
+ can_split_or (P Q: SI → Prop):
+ (∀ a b, a ≺ b → P b → P a) →
+ (∀ a b, a ≺ b → Q b → Q a) →
+ (∀ a, P a ∨ Q a) → (∀ a, P a) ∨ (∀ a, Q a).
+
+ (* Natural numbers satisfy a bounded version *)
+ Polymorphic Class FiniteBoundedExistential (SI: indexT) :=
+ can_split_bounded_or (P Q: SI → Prop) c:
+ (∀ a b, a ≺ b → P b → P a) →
+ (∀ a b, a ≺ b → Q b → Q a) →
+ (∀ a, a ≺ c → P a ∨ Q a) → (∀ a, a ≺ c → P a) ∨ (∀ a, a ≺ c → Q a).
+
+ (* assuming this type class or instantiaing it with classical axioms makes FiniteExistential available *)
+ Polymorphic Class Classical : Prop :=
+ excluded_middle : ∀ P: Prop, P ∨ ¬ P.
+
+ Lemma classical_can_commute_or {SI: indexT} (P Q: SI → Prop):
+ (∀ P: Prop, P ∨ ¬ P) →
+ (∀ a b, a ≺ b → P b → P a) →
+ (∀ a b, a ≺ b → Q b → Q a) →
+ (∀ a, P a ∨ Q a) → (∀ a, P a) ∨ (∀ a, Q a).
+ Proof.
+ intros xm HdownP HdownQ Hsome. destruct (xm (∃ a, ¬ P a)) as [[a HP]|HP]; last first.
+ - left. intros a. destruct (xm (P a)); auto. exfalso. apply HP. by exists a.
+ - assert (Q a) by (destruct (Hsome a); naive_solver).
+ right. intros b. destruct (index_lt_eq_lt_dec a b) as [[|<-]|]; eauto.
+ destruct (Hsome b); auto. exfalso. apply HP; eauto.
+ Qed.
+
+ Global Instance classical_finite_existential SI `{Classical}: FiniteExistential SI.
+ Proof.
+ intros P Q ???. eapply classical_can_commute_or; eauto.
+ Qed.
+
+ Lemma classical_can_commute_bounded_or {SI: indexT} (P Q: SI → Prop) c:
+ (∀ P: Prop, P ∨ ¬ P) →
+ (∀ a b, a ≺ b → P b → P a) →
+ (∀ a b, a ≺ b → Q b → Q a) →
+ (∀ a, a ≺ c → P a ∨ Q a) → (∀ a, a ≺ c → P a) ∨ (∀ a, a ≺ c → Q a).
+ Proof.
+ intros xm HdownP HdownQ Hsome. destruct (xm (∃ a, ¬ P a ∧ a ≺ c)) as [[a [HP Ha]]|HP]; last first.
+ - left. intros a Ha. destruct (xm (P a)); auto. exfalso. apply HP. by exists a.
+ - assert (Q a) by (destruct (Hsome a); naive_solver).
+ right. intros b Hb. destruct (index_lt_eq_lt_dec a b) as [[|<-]|]; eauto.
+ destruct (Hsome b); auto. exfalso. apply HP; eauto.
+ Qed.
+
+ Global Instance classical_finite_bounded_existential SI `{Classical}: FiniteBoundedExistential SI.
+ Proof.
+ intros P Q ???. eapply classical_can_commute_bounded_or; eauto.
+ Qed.
+
+ Lemma can_commute_finite_exists {SI: indexT} `{FiniteExistential SI} (X : Type) (P : X → SI → Prop) (Q: X → Prop) :
+ (∀ x a b, a ≺ b → P x b → P x a)
+ → (∀ a, ∃ x, Q x ∧ P x a)
+ → pred_finite Q
+ → ∃ x, ∀ a, P x a.
+ Proof.
+ intros Hdown Hsome [A Hfin].
+ assert (∀ a, ∃ x, x ∈ A ∧ P x a) as Hsome'.
+ { intros a. destruct (Hsome a) as [x [? ?]]. exists x. split; eauto. }
+ clear Hfin Hsome. induction A as [|x A IH].
+ - specialize (Hsome' zero) as [x [? ?]]. exfalso. by eapply not_elem_of_nil.
+ - assert ((∀ a, P x a) ∨ (∀ a : SI, ∃ x : X, x ∈ A ∧ P x a)) as [|]; eauto.
+ eapply can_split_or; eauto.
+ + intros a b Hab [y [HA HP]]. exists y; split; eauto.
+ + intros a; destruct (Hsome' a) as [y [HA HP]].
+ apply elem_of_cons in HA as [<-|?]; eauto.
+ Qed.
+
+ Lemma can_commute_finite_bounded_exists {SI: indexT} `{FiniteBoundedExistential SI} (X : Type) (P : X → SI → Prop) (Q: X → Prop) c:
+ zero ≺ c
+ → (∀ x a b, a ≺ b → P x b → P x a)
+ → (∀ a, a ≺ c → ∃ x, Q x ∧ P x a)
+ → pred_finite Q
+ → ∃ x, ∀ a, a ≺ c → P x a.
+ Proof.
+ intros Hterm Hdown Hsome [A Hfin].
+ assert (∀ a, a ≺ c → ∃ x, x ∈ A ∧ P x a) as Hsome'.
+ { intros a Ha. destruct (Hsome a Ha) as [x [? ?]]. exists x. split; eauto. }
+ clear Hfin Hsome. induction A as [|x A IH].
+ - specialize (Hsome' zero Hterm) as [x [? ?]]. exfalso. by eapply not_elem_of_nil.
+ - assert ((∀ a, a ≺ c → P x a) ∨ (∀ a : SI, a ≺ c → ∃ x : X, x ∈ A ∧ P x a)) as [|]; eauto.
+ eapply can_split_bounded_or; eauto.
+ + intros a b Hab [y [HA HP]]. exists y; split; eauto.
+ + intros a Ha; destruct (Hsome' a Ha) as [y [HA HP]].
+ apply elem_of_cons in HA as [<-|?]; eauto.
+ Qed.
+
+ Global Instance large_index_finite_existential@{i j} (SI: indexT@{j}) (LI: LargeIndex@{i j} SI): FiniteExistential@{j} SI.
+ Proof.
+ intros P Q H1 H2 Hor.
+ enough (∃ b: bool, ∀ a, if b then P a else Q a) as [[] ?]; eauto.
+ eapply can_commute_exists.
+ - intros []; eauto.
+ - intros a; destruct (Hor a) as [|]; [exists true|exists false]; eauto.
+ Qed.
+
+ Global Instance finite_bounded_from_finite `{FiniteIndex SI}: FiniteBoundedExistential SI.
+ Proof.
+ intros P Q α Pdown Qdown Hor. destruct (finite_index α) as [|[β [Hβα Hleast]]].
+ - left; simpl; intros. naive_solver.
+ - destruct (Hor β Hβα).
+ + left. intros γ Hγ. destruct (Hleast γ Hγ) as [->|]; eauto.
+ + right. intros γ Hγ. destruct (Hleast γ Hγ) as [->|]; eauto.
+ Qed.
+End finite_existential_property.
+
+
+(* Canonical instances: natural numbers, pairs *)
+Section nat_index.
+ Lemma le_rc_lt x y: le x y ↔ rc lt x y.
+ Proof.
+ split.
+ - intros [| ->] % le_lt_or_eq; [ by right| by left].
+ - intros []; lia.
+ Qed.
+
+ Lemma nat_index_mixin: IndexMixin nat lt 0 S.
+ Proof.
+ constructor.
+ - typeclasses eauto.
+ - exact lt_wf.
+ - intros m n. destruct (lt_eq_lt_dec m n) as [[]|]; eauto.
+ - unfold flip; intros [n]; lia.
+ - intros; lia.
+ - intros; eapply le_rc_lt; auto.
+ - intros [|n].
+ + right; intros; lia.
+ + left; by (exists n).
+ Qed.
+
+ Canonical Structure natI : indexT := IndexT nat lt 0 S nat_index_mixin.
+
+ Global Instance: FiniteIndex natI.
+ Proof.
+ intros [|n]; [left; by intros ? ? % PeanoNat.Nat.nlt_0_r|].
+ right; exists n; simpl; split; [lia|]; intros. eapply le_rc_lt; lia.
+ Qed.
+End nat_index.
+
+
+Section pair_index.
+ Variable (I J: indexT).
+
+ Definition pair_zero : I * J := (zero, zero).
+
+ Definition pair_succ : (I * J) → I * J := λ '(n, m), (n, succ m).
+
+ Definition pair_lt : I * J → I * J → Prop :=
+ λ '(n1, m1) '(n2, m2), n1 ≺ n2 ∨ (n1 = n2 ∧ m1 ≺ m2).
+
+ Instance pair_lt_trans: Transitive pair_lt.
+ Proof.
+ intros [] [] []; simpl; intros [|[]] [|[]]; subst; firstorder.
+ - left; etransitivity; eauto.
+ - right; split; eauto; by etransitivity.
+ Qed.
+
+ Lemma pair_lt_wf: wf pair_lt.
+ Proof.
+ intros [m n]. revert n; induction m using (well_founded_ind (index_lt_wf I)).
+ intros n; induction n using (well_founded_ind (index_lt_wf J)).
+ constructor. intros [m' n'] [|[->]]; eauto.
+ Qed.
+
+ Lemma pair_index_mixin: IndexMixin (I * J) pair_lt pair_zero pair_succ.
+ Proof.
+ constructor.
+ - typeclasses eauto.
+ - apply pair_lt_wf.
+ - intros [m1 n1] [m2 n2]; simpl.
+ destruct (index_lt_eq_lt_dec m1 m2) as [[]|];
+ destruct (index_lt_eq_lt_dec n1 n2) as [[]|].
+ all: subst; firstorder.
+ - intros [[m n] [H1 | [_ H1]]]; eapply index_zero_least; eauto.
+ - intros [m n]; simpl. right; split; eauto.
+ - intros [m1 n1] [m2 n2]; simpl; intros [|[]]; subst.
+ + right. by left.
+ + destruct (index_succ_least n1 n2); eauto; subst.
+ * by left.
+ * right. right. by split.
+ - intros [m n]. destruct (index_dec_limit n) as [[n' ->]|].
+ + left. by (exists (m, n')).
+ + right; intros [m' n']; simpl; intros []; firstorder.
+ Qed.
+
+ Canonical Structure pairI : indexT := IndexT (I * J) pair_lt pair_zero pair_succ pair_index_mixin.
+
+ Lemma pair_rc_right n m m': (n, m) ⪯ (n, m') ↔ m ⪯ m'.
+ Proof.
+ split; intros [Heq | Heq].
+ - injection Heq. auto.
+ - destruct Heq as [[]%index_lt_irrefl | H]. right; apply H.
+ - subst; auto.
+ - right. right; auto.
+ Qed.
+
+
+ Global Instance: TransfiniteIndex pairI.
+ Proof.
+ exists (λ '(m, n), (succ m, n)). intros k [m n]; simpl.
+ replace (Nat.iter k pair_succ (m, n)) with (m, Nat.iter k (index_succ J) n).
+ - simpl; left; eapply index_succ_greater.
+ - symmetry; induction k; simpl; by rewrite ?IHk.
+ Qed.
+End pair_index.
+
+
+(** ** Some Classical Reasoning *)
+Lemma classical_dn `{Classical} (X : Prop) : X ↔ ¬ (¬ X).
+Proof.
+ split; intros ?.
+ - tauto.
+ - destruct (excluded_middle X) as [H1 | H1]; [easy | tauto].
+Qed.
+
+Lemma classical_forall_exists_dn `{Classical} (X : Type) (P : X → Prop): (∀ x, P x) ↔ ¬ (∃ x, ¬ (P x)).
+Proof.
+ split.
+ - intros ? (x & H1). eauto.
+ - intros Hx x. destruct (excluded_middle (P x)) as [ | ?]; [easy | ]. exfalso; apply Hx; eauto.
+Qed.
+
+Lemma classical_forall_exists `{Classical} (X : Type) (P : X → Prop): ¬ (∀ x, P x) ↔ (∃ x, ¬ (P x)).
+Proof.
+ by rewrite classical_forall_exists_dn -classical_dn.
+Qed.
+
+Lemma classical_exists_forall `{Classical} (X : Type) (P : X → Prop): ¬ (∃ x, (P x)) ↔ (∀ x, ¬ P x).
+Proof.
+ rewrite classical_forall_exists_dn; split; intros ? [x ?]; eauto using classical_dn.
+Qed.
+
+Lemma classical_impl `{Classical} (P Q : Prop): ¬ (P → Q) ↔ (P ∧ ¬ Q).
+Proof.
+ destruct (excluded_middle Q), (excluded_middle P); tauto.
+Qed.
+
+Lemma find_least `{Classical} {SI: indexT} (P: SI → Prop) α:
+ (∀ α β, α ⪯ β → P β → P α) →
+ P α →
+ ∃ β, P β ∧ ∀ γ, γ ≺ β → ¬ P γ.
+Proof.
+ intros HP. induction (index_lt_wf SI α) as [α _ IH].
+ intros Hα. destruct (excluded_middle (∀ γ, γ ≺ α → ¬ P γ)) as [|Hn]; eauto.
+ apply ->classical_forall_exists in Hn. destruct Hn as [β Hβ].
+ apply ->classical_impl in Hβ. destruct Hβ as [Hαβ Hβ].
+ apply classical_dn in Hβ.
+ apply (IH _ Hαβ Hβ).
+Qed.
+
+
+(** ** Automation *)
+
+Create HintDb index.
+Hint Extern 1 False => eapply index_lt_irrefl : index.
+Hint Resolve -> index_succ_iff : index.
+Hint Constructors rc : index.
+(* TODO: maybe remove the transitivity stuff *)
+Hint Extern 2 (_ ≺ _) => etransitivity : index.
+Hint Resolve index_le_lt_trans : index.
+Hint Resolve index_lt_le_trans : index.
+Hint Resolve index_succ_greater : index.
+Hint Resolve index_le_succ_inj : index.
+Hint Resolve index_lt_succ_mono : index.
+Hint Immediate index_zero_minimum : index.
+
+(** subst fails in some settings with dependent typing, when that happens, we have to do stuff manually *)
+Ltac subst_with H :=
+ match type of H with
+ | ?a = ?b =>
+ tryif (match b with context[?c] => constr_eq a c end) then fail else
+ (match goal with
+ | H0 : _ ≺ _ |- _ => assert_fails (constr_eq H H0); rewrite H in H0
+ | H0 : _ ⪯ _ |- _ => assert_fails (constr_eq H H0); rewrite H in H0
+ | H0 : _ = _ |- _ => assert_fails (constr_eq H H0); progress (try rewrite H in H0)
+ end;
+ repeat match goal with
+ | H0 : _ ≺ _ |- _ => assert_fails (constr_eq H H0); rewrite H in H0
+ | H0 : _ ⪯ _ |- _ => assert_fails (constr_eq H H0); rewrite H in H0
+ | H0 : _ = _ |- _ => assert_fails (constr_eq H H0); progress (try rewrite H in H0)
+ end)
+ end.
+Ltac subst_assmpt :=
+subst +
+(repeat match goal with
+| H : ?a = ?b |- _ => is_var a; subst_with H; clear H
+| H : ?a = ?b |- _ => is_var b; let H' := fresh H in specialize (symmetry H) as H'; try clear H; subst_with H'; clear H'
+end).
+
+Ltac hypot_exists H :=
+ match type of H with ?t =>
+ match goal with
+ | H0 : t |- _ => assert_fails (constr_eq H0 H)
+ end
+ end.
+
+(* index_contra_solve: solve directly contadictory goals using assumptions on index order*)
+
+Ltac normalise_hypot H :=
+ try match type of H with
+ | succ ?a ≺ succ ?b => apply index_lt_succ_inj in H
+ | succ ?a = succ ?b => apply index_succ_inj in H; repeat subst_assmpt
+ end.
+Ltac index_contra_solve_core cont :=
+ subst_assmpt;
+ match goal with
+ | [H : ?a ≺ ?a |- _] => specialize (index_lt_irrefl _ H) as []
+ | [H : ?a ≺ zero |- _] => by apply index_lt_zero_is_normal in H
+ | [H : ?a = succ ?a |- _] => apply index_succ_neq in H as []
+ | [H : succ ?a = ?a |- _] => symmetry in H; cont
+ | [H : ?a ⪯ zero, H1 : ?b ≺ ?a |- _] => eapply index_lt_zero_is_normal, index_lt_le_trans; [apply H1 | apply H]
+ | [H1 : ?a ≺ ?b, H2 : ?b ≺ succ ?a |- _] => specialize (index_lt_succ_tight _ _ H1 H2) as []
+ | [H1 : ?a ⪯ ?b, H2 : ?b ≺ ?a |- _] => eapply index_lt_irrefl, index_le_lt_trans; [apply H1 | apply H2]
+ | [H : succ ?a = zero |- _] => destruct (index_succ_not_zero _ H) as []
+ | [H : zero = succ ?a |- _] => symmetry in H; destruct (index_succ_not_zero _ H) as []
+ | [H : succ ?a ≺ ?a |- _] =>
+ let H1 := fresh "H" in
+ specialize (index_lt_trans _ _ _ H (index_succ_greater a)) as H1;
+ apply index_lt_irrefl in H1 as []
+ | [H : succ ?a ≺ succ ?b |- _ ] => normalise_hypot H; cont
+ | [H : succ ?a = succ ?b |- _ ] => normalise_hypot H; cont
+ | [H : succ ?a ⪯ ?b |- _] => destruct H; cont
+ end.
+(* infer by transitivity -- might be very expensive when many inferences can be done or even diverge *)
+Ltac index_contra_solve_infer cont :=
+ match goal with
+ | [H1 : ?a ≺ ?b, H2 : ?b ≺ ?c |- _] =>
+ let H := fresh "H" in
+ specialize (index_lt_trans _ _ _ H1 H2) as H; normalise_hypot H;
+ tryif (hypot_exists H) then fail else cont
+ end.
+Ltac index_contra_solve :=
+ exfalso;
+ index_contra_solve_core index_contra_solve + index_contra_solve_infer index_contra_solve.
+
+(* Do not do any transitivity inferences. A smarter strategy would be to give it a budget for transitivity inferences, but that would be more complicated *)
+Ltac index_contra_solve_fast :=
+ exfalso; index_contra_solve_core index_contra_solve_core.
diff --git a/theories/algebra/sts.v b/theories/algebra/sts.v
deleted file mode 100644
index c5d07b8579261248035aa23d6daff46d0e58cf8a..0000000000000000000000000000000000000000
--- a/theories/algebra/sts.v
+++ /dev/null
@@ -1,501 +0,0 @@
-From stdpp Require Export propset.
-From iris.algebra Require Export cmra.
-From iris.algebra Require Import dra.
-Set Default Proof Using "Type".
-Local Arguments valid _ _ !_ /.
-Local Arguments op _ _ !_ !_ /.
-Local Arguments core _ _ !_ /.
-
-(** * Definition of STSs *)
-Module sts.
-Structure stsT := Sts {
- state : Type;
- token : Type;
- prim_step : relation state;
- tok : state → propset token;
-}.
-Arguments Sts {_ _} _ _.
-Arguments prim_step {_} _ _.
-Arguments tok {_} _.
-Notation states sts := (propset (state sts)).
-Notation tokens sts := (propset (token sts)).
-
-(** * Theory and definitions *)
-Section sts.
-Context {sts : stsT}.
-
-(** ** Step relations *)
-Inductive step : relation (state sts * tokens sts) :=
- | Step s1 s2 T1 T2 :
- prim_step s1 s2 → tok s1 ## T1 → tok s2 ## T2 →
- tok s1 ∪ T1 ≡ tok s2 ∪ T2 → step (s1,T1) (s2,T2).
-Notation steps := (rtc step).
-Inductive frame_step (T : tokens sts) (s1 s2 : state sts) : Prop :=
- (* Possible alternative definition: (tok s2) ## T) ∧ s \rightarrow s'.
- This is not equivalent, but it might be good enough? *)
- | Frame_step T1 T2 :
- T1 ## tok s1 ∪ T → step (s1,T1) (s2,T2) → frame_step T s1 s2.
-Notation frame_steps T := (rtc (frame_step T)).
-
-(** ** Closure under frame steps *)
-Record closed (S : states sts) (T : tokens sts) : Prop := Closed {
- closed_disjoint s : s ∈ S → tok s ## T;
- closed_step s1 s2 : s1 ∈ S → frame_step T s1 s2 → s2 ∈ S
-}.
-Definition up (s : state sts) (T : tokens sts) : states sts :=
- {[ s' | frame_steps T s s' ]}.
-Definition up_set (S : states sts) (T : tokens sts) : states sts :=
- S ≫= λ s, up s T.
-
-(** Tactic setup *)
-Hint Resolve Step : core.
-Hint Extern 50 (equiv (A:=propset _) _ _) => set_solver : sts.
-Hint Extern 50 (¬equiv (A:=propset _) _ _) => set_solver : sts.
-Hint Extern 50 (_ ∈ _) => set_solver : sts.
-Hint Extern 50 (_ ⊆ _) => set_solver : sts.
-Hint Extern 50 (_ ## _) => set_solver : sts.
-
-(** ** Setoids *)
-Instance frame_step_mono : Proper (flip (⊆) ==> (=) ==> (=) ==> impl) frame_step.
-Proof.
- intros ?? HT ?? <- ?? <-; destruct 1; econstructor;
- eauto with sts; set_solver.
-Qed.
-Global Instance frame_step_proper : Proper ((≡) ==> (=) ==> (=) ==> iff) frame_step.
-Proof. move=> ?? /set_equiv_spec [??]; split; by apply frame_step_mono. Qed.
-Instance closed_proper' : Proper ((≡) ==> (≡) ==> impl) closed.
-Proof. destruct 3; constructor; intros; setoid_subst; eauto. Qed.
-Global Instance closed_proper : Proper ((≡) ==> (≡) ==> iff) closed.
-Proof. by split; apply closed_proper'. Qed.
-Global Instance up_preserving : Proper ((=) ==> flip (⊆) ==> (⊆)) up.
-Proof.
- intros s ? <- T T' HT ; apply elem_of_subseteq.
- induction 1 as [|s1 s2 s3 [T1 T2]]; [constructor|].
- eapply elem_of_PropSet, rtc_l; [eapply Frame_step with T1 T2|]; eauto with sts.
-Qed.
-Global Instance up_proper : Proper ((=) ==> (≡) ==> (≡)) up.
-Proof.
- by move=> ??? ?? /set_equiv_spec [??]; split; apply up_preserving.
-Qed.
-Global Instance up_set_preserving : Proper ((⊆) ==> flip (⊆) ==> (⊆)) up_set.
-Proof.
- intros S1 S2 HS T1 T2 HT. rewrite /up_set.
- f_equiv=> // s1 s2. by apply up_preserving.
-Qed.
-Global Instance up_set_proper : Proper ((≡) ==> (≡) ==> (≡)) up_set.
-Proof.
- move=> S1 S2 /set_equiv_spec [??] T1 T2 /set_equiv_spec [??];
- split; by apply up_set_preserving.
-Qed.
-
-(** ** Properties of closure under frame steps *)
-Lemma closed_steps S T s1 s2 :
- closed S T → s1 ∈ S → frame_steps T s1 s2 → s2 ∈ S.
-Proof. induction 3; eauto using closed_step. Qed.
-Lemma closed_op T1 T2 S1 S2 :
- closed S1 T1 → closed S2 T2 → closed (S1 ∩ S2) (T1 ∪ T2).
-Proof.
- intros [? Hstep1] [? Hstep2]; split; [set_solver|].
- 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.
-Lemma step_closed s1 s2 T1 T2 S Tf :
- step (s1,T1) (s2,T2) → closed S Tf → s1 ∈ S → T1 ## Tf →
- s2 ∈ S ∧ T2 ## Tf ∧ tok s2 ## T2.
-Proof.
- inversion_clear 1 as [???? HR Hs1 Hs2]; intros [? Hstep]??; split_and?; auto.
- - eapply Hstep with s1, Frame_step with T1 T2; auto with sts.
- - set_solver -Hstep Hs1 Hs2.
-Qed.
-Lemma steps_closed s1 s2 T1 T2 S Tf :
- steps (s1,T1) (s2,T2) → closed S Tf → s1 ∈ S → T1 ## Tf →
- tok s1 ## T1 → s2 ∈ S ∧ T2 ## Tf ∧ tok s2 ## T2.
-Proof.
- remember (s1,T1) as sT1 eqn:HsT1; remember (s2,T2) as sT2 eqn:HsT2.
- intros Hsteps; revert s1 T1 HsT1 s2 T2 HsT2.
- induction Hsteps as [?|? [s2 T2] ? Hstep Hsteps IH];
- intros s1 T1 HsT1 s2' T2' ?????; simplify_eq; first done.
- destruct (step_closed s1 s2 T1 T2 S Tf) as (?&?&?); eauto.
-Qed.
-
-(** ** Properties of the closure operators *)
-Lemma elem_of_up s T : s ∈ up s T.
-Proof. constructor. Qed.
-Lemma subseteq_up_set S T : S ⊆ up_set S T.
-Proof. intros s ?; apply elem_of_bind; eauto using elem_of_up. Qed.
-Lemma elem_of_up_set S T s : s ∈ S → s ∈ up_set S T.
-Proof. apply subseteq_up_set. Qed.
-Lemma up_up_set s T : up s T ≡ up_set {[ s ]} T.
-Proof. by rewrite /up_set set_bind_singleton. Qed.
-Lemma closed_up_set S T : (∀ s, s ∈ S → tok s ## T) → closed (up_set S T) T.
-Proof.
- intros HS; unfold up_set; split.
- - intros s; rewrite !elem_of_bind; intros (s'&Hstep&Hs').
- specialize (HS s' Hs'); clear Hs' S.
- induction Hstep as [s|s1 s2 s3 [T1 T2 ? Hstep] ? IH]; first done.
- inversion_clear Hstep; apply IH; clear IH; auto with sts.
- - intros s1 s2; rewrite /up; set_unfold; intros (s&?&?) ?; exists s.
- split; [eapply rtc_r|]; eauto.
-Qed.
-Lemma closed_up s T : tok s ## T → closed (up s T) T.
-Proof.
- intros; rewrite -(set_bind_singleton (λ s, up s T) s).
- apply closed_up_set; set_solver.
-Qed.
-Lemma closed_up_set_empty S : closed (up_set S ∅) ∅.
-Proof. eauto using closed_up_set with sts. Qed.
-Lemma closed_up_empty s : closed (up s ∅) ∅.
-Proof. eauto using closed_up with sts. Qed.
-Lemma up_closed S T : closed S T → up_set S T ≡ S.
-Proof.
- intros ?; apply set_equiv_spec; 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.
-Lemma up_subseteq s T S : closed S T → s ∈ S → sts.up s T ⊆ S.
-Proof. move=> ?? s' ?. eauto using closed_steps. Qed.
-Lemma up_set_subseteq S1 T S2 : closed S2 T → S1 ⊆ S2 → sts.up_set S1 T ⊆ S2.
-Proof. move=> ?? s [s' [? ?]]. eauto using closed_steps. Qed.
-Lemma up_op s T1 T2 : up s (T1 ∪ T2) ⊆ up s T1 ∩ up s T2.
-Proof. (* Notice that the other direction does not hold. *)
- intros x Hx. split; eapply elem_of_PropSet, rtc_subrel; try exact Hx.
- - intros; eapply frame_step_mono; last first; try done. set_solver+.
- - intros; eapply frame_step_mono; last first; try done. set_solver+.
-Qed.
-End sts.
-
-Notation steps := (rtc step).
-Notation frame_steps T := (rtc (frame_step T)).
-
-(* The type of bounds we can give to the state of an STS. This is the type
- that we equip with an RA structure. *)
-Inductive car (sts : stsT) :=
- | auth : state sts → propset (token sts) → car sts
- | frag : propset (state sts) → propset (token sts) → car sts.
-Arguments auth {_} _ _.
-Arguments frag {_} _ _.
-End sts.
-
-Notation stsT := sts.stsT.
-Notation Sts := sts.Sts.
-
-(** * STSs form a disjoint RA *)
-Section sts_dra.
-Context (sts : stsT).
-Import sts.
-Implicit Types S : states sts.
-Implicit Types T : tokens sts.
-
-Inductive sts_equiv : Equiv (car sts) :=
- | 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.
-Existing Instance sts_equiv.
-Instance sts_valid : Valid (car sts) := λ x,
- match x with
- | auth s T => tok s ## T
- | frag S' T => closed S' T ∧ ∃ s, s ∈ S'
- end.
-Instance sts_core : Core (car sts) := λ x,
- match x with
- | frag S' _ => frag (up_set S' ∅ ) ∅
- | auth s _ => frag (up s ∅) ∅
- end.
-Inductive sts_disjoint : Disjoint (car sts) :=
- | frag_frag_disjoint S1 S2 T1 T2 :
- (∃ s, s ∈ 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.
-Existing Instance sts_disjoint.
-Instance sts_op : Op (car sts) := λ 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.
-
-Hint Extern 50 (equiv (A:=propset _) _ _) => set_solver : sts.
-Hint Extern 50 (∃ s : state sts, _) => set_solver : sts.
-Hint Extern 50 (_ ∈ _) => set_solver : sts.
-Hint Extern 50 (_ ⊆ _) => set_solver : sts.
-Hint Extern 50 (_ ## _) => set_solver : sts.
-
-Global Instance auth_proper s : Proper ((≡) ==> (≡)) (@auth sts s).
-Proof. by constructor. Qed.
-Global Instance frag_proper : Proper ((≡) ==> (≡) ==> (≡)) (@frag sts).
-Proof. by constructor. Qed.
-
-Instance sts_equivalence: Equivalence ((≡) : relation (car sts)).
-Proof.
- split.
- - by intros []; constructor.
- - by destruct 1; constructor.
- - destruct 1; inversion_clear 1; constructor; etrans; eauto.
-Qed.
-Lemma sts_dra_mixin : DraMixin (car sts).
-Proof.
- split.
- - apply _.
- - by do 2 destruct 1; constructor; setoid_subst.
- - by destruct 1; constructor; setoid_subst.
- - by destruct 1; simpl; intros ?; setoid_subst.
- - by intros ? [|]; destruct 1; inversion_clear 1; econstructor; setoid_subst.
- - destruct 3; simpl in *; destruct_and?; eauto using closed_op;
- match goal with H : closed _ _ |- _ => destruct H end; set_solver.
- - intros []; naive_solver eauto using closed_up, closed_up_set,
- elem_of_up, elem_of_up_set with sts.
- - intros [] [] [] _ _ _ _ _; constructor; rewrite ?assoc; 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 []; constructor; eauto with sts.
- - intros []; constructor; auto 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 with sts.
- - intros x y. exists (core (x â‹… y))=> ?? Hxy; split_and?.
- + destruct Hxy; constructor; unfold up_set; set_solver.
- + destruct Hxy; simpl;
- eauto using closed_up_set_empty, closed_up_empty with sts.
- + destruct Hxy; econstructor;
- repeat match goal with
- | |- context [ up_set ?S ?T ] =>
- unless (S ⊆ up_set S T) by done; pose proof (subseteq_up_set S T)
- | |- context [ up ?s ?T ] =>
- unless (s ∈ up s T) by done; pose proof (elem_of_up s T)
- end; auto with sts.
-Qed.
-Canonical Structure stsDR : draT := DraT (car sts) sts_dra_mixin.
-End sts_dra.
-
-(** * The STS Resource Algebra *)
-(** Finally, the general theory of STS that should be used by users *)
-Notation stsC sts := (validityO (stsDR sts)).
-Notation stsR sts := (validityR (stsDR sts)).
-
-Section sts_definitions.
- Context {sts : stsT}.
- Definition sts_auth (s : sts.state sts) (T : sts.tokens sts) : stsR sts :=
- to_validity (sts.auth s T).
- Definition sts_frag (S : sts.states sts) (T : sts.tokens sts) : stsR sts :=
- to_validity (sts.frag S T).
- Definition sts_frag_up (s : sts.state sts) (T : sts.tokens sts) : stsR sts :=
- sts_frag (sts.up s T) T.
-End sts_definitions.
-Instance: Params (@sts_auth) 2 := {}.
-Instance: Params (@sts_frag) 1 := {}.
-Instance: Params (@sts_frag_up) 2 := {}.
-
-Section stsRA.
-Import sts.
-Context {sts : stsT}.
-Implicit Types s : state sts.
-Implicit Types S : states sts.
-Implicit Types T : tokens sts.
-Arguments dra_valid _ !_/.
-
-(** Setoids *)
-Global Instance sts_auth_proper s : Proper ((≡) ==> (≡)) (sts_auth s).
-Proof. solve_proper. Qed.
-Global Instance sts_frag_proper : Proper ((≡) ==> (≡) ==> (≡)) (@sts_frag sts).
-Proof. solve_proper. Qed.
-Global Instance sts_frag_up_proper s : Proper ((≡) ==> (≡)) (sts_frag_up s).
-Proof. solve_proper. Qed.
-
-(** Validity *)
-Lemma sts_auth_valid s T : ✓ sts_auth s T ↔ tok s ## T.
-Proof. done. Qed.
-Lemma sts_frag_valid S T : ✓ sts_frag S T ↔ closed S T ∧ ∃ s, s ∈ S.
-Proof. done. Qed.
-Lemma sts_frag_up_valid s T : ✓ sts_frag_up s T ↔ tok s ## T.
-Proof.
- split.
- - move=>/sts_frag_valid [H _]. apply H, elem_of_up.
- - intros. apply sts_frag_valid; split. by apply closed_up. set_solver.
-Qed.
-
-Lemma sts_auth_frag_valid_inv s S T1 T2 :
- ✓ (sts_auth s T1 ⋅ sts_frag S T2) → s ∈ S.
-Proof. by intros (?&?&Hdisj); inversion Hdisj. Qed.
-
-(** Op *)
-Lemma sts_op_auth_frag s S T :
- s ∈ S → closed S T → sts_auth s ∅ ⋅ sts_frag S T ≡ sts_auth s T.
-Proof.
- intros; split; [split|constructor; set_solver]; simpl.
- - intros (?&?&?); by apply closed_disjoint with S.
- - intros; split_and?; last constructor; set_solver.
-Qed.
-Lemma sts_op_auth_frag_up s T :
- sts_auth s ∅ ⋅ sts_frag_up s T ≡ sts_auth s T.
-Proof.
- intros; split; [split|constructor; set_solver]; simpl.
- - intros (?&[??]&?). by apply closed_disjoint with (up s T), elem_of_up.
- - intros; split_and?.
- + set_solver+.
- + by apply closed_up.
- + exists s. set_solver.
- + constructor; last set_solver. apply elem_of_up.
-Qed.
-
-Lemma sts_op_frag S1 S2 T1 T2 :
- T1 ## T2 → sts.closed S1 T1 → sts.closed S2 T2 →
- sts_frag (S1 ∩ S2) (T1 ∪ T2) ≡ sts_frag S1 T1 ⋅ sts_frag S2 T2.
-Proof.
- intros HT HS1 HS2. rewrite /sts_frag -to_validity_op //.
- move=>/=[?[? ?]]. split_and!; [set_solver..|constructor; set_solver].
-Qed.
-
-(* Notice that the following does *not* hold -- the composition of the
- two closures is weaker than the closure with the itnersected token
- set. Also see up_op.
-Lemma sts_op_frag_up s T1 T2 :
- T1 ## T2 → sts_frag_up s (T1 ∪ T2) ≡ sts_frag_up s T1 ⋅ sts_frag_up s T2.
-*)
-
-(** Frame preserving updates *)
-Lemma sts_update_auth s1 s2 T1 T2 :
- steps (s1,T1) (s2,T2) → sts_auth s1 T1 ~~> sts_auth s2 T2.
-Proof.
- intros ?; apply validity_update.
- inversion 3 as [|? S ? Tf|]; simplify_eq/=; destruct_and?.
- destruct (steps_closed s1 s2 T1 T2 S Tf) as (?&?&?); auto; [].
- repeat (done || constructor).
-Qed.
-
-Lemma sts_update_frag S1 S2 T1 T2 :
- (closed S1 T1 → closed S2 T2 ∧ S1 ⊆ S2 ∧ T2 ⊆ T1) → sts_frag S1 T1 ~~> sts_frag S2 T2.
-Proof.
- rewrite /sts_frag=> HC HS HT. apply validity_update.
- inversion 3 as [|? S ? Tf|]; simplify_eq/=;
- (destruct HC as (? & ? & ?); first by destruct_and?).
- - split_and!. done. set_solver. constructor; set_solver.
- - split_and!. done. set_solver. constructor; set_solver.
-Qed.
-
-Lemma sts_update_frag_up s1 S2 T1 T2 :
- (tok s1 ## T1 → closed S2 T2) → s1 ∈ S2 → T2 ⊆ T1 → sts_frag_up s1 T1 ~~> sts_frag S2 T2.
-Proof.
- intros HC ? HT; apply sts_update_frag. intros HC1; split; last split; eauto using closed_steps.
- - eapply HC, HC1, elem_of_up.
- - rewrite <-HT. eapply up_subseteq; last done. apply HC, HC1, elem_of_up.
-Qed.
-
-Lemma sts_up_set_intersection S1 Sf Tf :
- closed Sf Tf → S1 ∩ Sf ≡ S1 ∩ up_set (S1 ∩ Sf) Tf.
-Proof.
- intros Hclf. apply (anti_symm (⊆)).
- - move=>s [HS1 HSf]. split. by apply HS1. by apply subseteq_up_set.
- - move=>s [HS1 [s' [/elem_of_PropSet Hsup Hs']]]. split; first done.
- eapply closed_steps, Hsup; first done. set_solver +Hs'.
-Qed.
-
-Global Instance sts_frag_core_id S : CoreId (sts_frag S ∅).
-Proof.
- constructor; split=> //= [[??]]. by rewrite /dra.dra_core /= sts.up_closed.
-Qed.
-
-(** Inclusion *)
-(* This is surprisingly different from to_validity_included. I am not sure
- whether this is because to_validity_included is non-canonical, or this
- one here is non-canonical - but I suspect both. *)
-(* TODO: These have to be proven again. *)
-(*
-Lemma sts_frag_included S1 S2 T1 T2 :
- closed S2 T2 → S2 ≢ ∅ →
- (sts_frag S1 T1 ≼ sts_frag S2 T2) ↔
- (closed S1 T1 ∧ S1 ≢ ∅ ∧ ∃ Tf, T2 ≡ T1 ∪ Tf ∧ T1 ## Tf ∧
- S2 ≡ S1 ∩ up_set S2 Tf).
-Proof.
- intros ??; split.
- - intros [[???] ?].
- destruct (to_validity_included (sts_dra.car sts) (sts_dra.frag S1 T1) (sts_dra.frag S2 T2)) as [Hfincl Htoincl].
- intros Hcl2 HS2ne. split.
- - intros Hincl. destruct Hfincl as ((Hcl1 & ?) & (z & EQ & Hval & Hdisj)).
- { split; last done. split; done. }
- clear Htoincl. split_and!; try done; [].
- destruct z as [sf Tf|Sf Tf].
- { exfalso. inversion_clear EQ. }
- exists Tf. inversion_clear EQ as [|? ? ? ? HT2 HS2].
- inversion_clear Hdisj as [? ? ? ? _ HTdisj | |]. split_and!; [done..|].
- rewrite HS2. apply up_set_intersection. apply Hval.
- - intros (Hcl & Hne & (Tf & HT & HTdisj & HS)). destruct Htoincl as ((Hcl' & ?) & (z & EQ)); last first.
- { exists z. exact EQ. } clear Hfincl.
- split; first (split; done). exists (sts_dra.frag (up_set S2 Tf) Tf). split_and!.
- + constructor; done.
- + simpl. split.
- * apply closed_up_set. move=>s Hs2. move:(closed_disjoint _ _ Hcl2 _ Hs2).
- set_solver +HT.
- * by apply up_set_non_empty.
- + constructor; last done. by rewrite -HS.
-Qed.
-
-Lemma sts_frag_included' S1 S2 T :
- closed S2 T → closed S1 T → S2 ≢ ∅ → S1 ≢ ∅ → S2 ≡ S1 ∩ up_set S2 ∅ →
- sts_frag S1 T ≼ sts_frag S2 T.
-Proof.
- intros. apply sts_frag_included; split_and?; auto.
- exists ∅; split_and?; done || set_solver+.
-Qed. *)
-End stsRA.
-
-(** STSs without tokens: Some stuff is simpler *)
-Module sts_notok.
-Structure stsT := Sts {
- state : Type;
- prim_step : relation state;
-}.
-Arguments Sts {_} _.
-Arguments prim_step {_} _ _.
-Notation states sts := (propset (state sts)).
-
-Definition stsT_token := Empty_set.
-Definition stsT_tok {sts : stsT} (_ : state sts) : propset stsT_token := ∅.
-
-Canonical Structure sts_notok (sts : stsT) : sts.stsT :=
- sts.Sts (@prim_step sts) stsT_tok.
-Coercion sts_notok.sts_notok : sts_notok.stsT >-> sts.stsT.
-
-Section sts.
- Context {sts : stsT}.
- Implicit Types s : state sts.
- Implicit Types S : states sts.
-
- Notation prim_steps := (rtc prim_step).
-
- Lemma sts_step s1 s2 : prim_step s1 s2 → sts.step (s1, ∅) (s2, ∅).
- Proof. intros. split; set_solver. Qed.
-
- Lemma sts_steps s1 s2 : prim_steps s1 s2 → sts.steps (s1, ∅) (s2, ∅).
- Proof. induction 1; eauto using sts_step, rtc_refl, rtc_l. Qed.
-
- Lemma frame_prim_step T s1 s2 : sts.frame_step T s1 s2 → prim_step s1 s2.
- Proof. inversion 1 as [??? Hstep]. by inversion_clear Hstep. Qed.
-
- Lemma prim_frame_step T s1 s2 : prim_step s1 s2 → sts.frame_step T s1 s2.
- Proof.
- intros Hstep. apply sts.Frame_step with ∅ ∅; first set_solver.
- by apply sts_step.
- Qed.
-
- Lemma mk_closed S :
- (∀ s1 s2, s1 ∈ S → prim_step s1 s2 → s2 ∈ S) → sts.closed S ∅.
- Proof. intros ?. constructor; [by set_solver|eauto using frame_prim_step]. Qed.
-End sts.
-End sts_notok.
-
-Notation sts_notokT := sts_notok.stsT.
-Notation Sts_NoTok := sts_notok.Sts.
-
-Section sts_notokRA.
- Context {sts : sts_notokT}.
- Import sts_notok.
- Implicit Types s : state sts.
- Implicit Types S : states sts.
-
- Lemma sts_notok_update_auth s1 s2 :
- rtc prim_step s1 s2 → sts_auth s1 ∅ ~~> sts_auth s2 ∅.
- Proof. intros. by apply sts_update_auth, sts_steps. Qed.
-End sts_notokRA.
diff --git a/theories/algebra/ufrac.v b/theories/algebra/ufrac.v
index 42d9645d7bf3d47fee58e245c3692957ba9c3797..a465f14845472e929c66734d429b65619fe3bd65 100644
--- a/theories/algebra/ufrac.v
+++ b/theories/algebra/ufrac.v
@@ -11,7 +11,8 @@ infers the [frac] camera by default when using the [Qp] type. *)
Definition ufrac := Qp.
Section ufrac.
-Canonical Structure ufracO := leibnizO ufrac.
+Context {SI : indexT}.
+Canonical Structure ufracO := leibnizO SI ufrac.
Instance ufrac_valid : Valid ufrac := λ x, True.
Instance ufrac_pcore : PCore ufrac := λ _, None.
@@ -25,23 +26,26 @@ Proof. intros ?%ufrac_included. auto using Qclt_le_weak. Qed.
Definition ufrac_ra_mixin : RAMixin ufrac.
Proof. split; try apply _; try done. Qed.
-Canonical Structure ufracR := discreteR ufrac ufrac_ra_mixin.
+Canonical Structure ufracR := discreteR SI ufrac ufrac_ra_mixin.
Global Instance ufrac_cmra_discrete : CmraDiscrete ufracR.
Proof. apply discrete_cmra_discrete. Qed.
End ufrac.
-Global Instance ufrac_cancelable (q : ufrac) : Cancelable q.
-Proof. intros ?????. by apply Qp_eq, (inj (Qcplus q)), (Qp_eq (q+y) (q+z))%Qp. Qed.
+Section fix_index.
+ Context {SI : indexT}.
+ Global Instance ufrac_cancelable (q : ufrac) : Cancelable (I := SI) q.
+ Proof. intros ?????. by apply Qp_eq, (inj (Qcplus q)), (Qp_eq (q+y) (q+z))%Qp. Qed.
-Global Instance ufrac_id_free (q : ufrac) : IdFree q.
-Proof.
- intros [q0 Hq0] ? EQ%Qp_eq. rewrite -{1}(Qcplus_0_r q) in EQ.
- eapply Qclt_not_eq; first done. by apply (inj (Qcplus q)).
-Qed.
+ Global Instance ufrac_id_free (q : ufrac) : IdFree (I := SI) q.
+ Proof.
+ intros [q0 Hq0] ? EQ%Qp_eq. rewrite -{1}(Qcplus_0_r q) in EQ.
+ eapply Qclt_not_eq; first done. by apply (inj (Qcplus q)).
+ Qed.
-Lemma ufrac_op' (q p : ufrac) : (p â‹… q) = (p + q)%Qp.
-Proof. done. Qed.
+ Lemma ufrac_op' (q p : ufrac) : cmra_op (I := SI) _ p q = (p + q)%Qp.
+ Proof. done. Qed.
-Global Instance is_op_ufrac (q : ufrac) : IsOp' q (q/2)%Qp (q/2)%Qp.
-Proof. by rewrite /IsOp' /IsOp ufrac_op' Qp_div_2. Qed.
+ Global Instance is_op_ufrac (q : ufrac) : IsOp' (SI := SI) q (q/2)%Qp (q/2)%Qp.
+ Proof. by rewrite /IsOp' /IsOp /op ufrac_op' Qp_div_2. Qed.
+End fix_index.
diff --git a/theories/algebra/ufrac_auth.v b/theories/algebra/ufrac_auth.v
index d7c1e89ea1dd0df7d3d293983010aa7c0900a796..70554b3a35f04a1768b6ae221b7721a7c1b77c36 100644
--- a/theories/algebra/ufrac_auth.v
+++ b/theories/algebra/ufrac_auth.v
@@ -22,9 +22,9 @@ From iris.algebra Require Export updates local_updates.
From iris.algebra Require Import proofmode_classes.
From Coq Require Import QArith Qcanon.
-Definition ufrac_authR (A : cmraT) : cmraT :=
+Definition ufrac_authR {SI : indexT} (A : cmraT SI) : cmraT SI :=
authR (optionUR (prodR ufracR A)).
-Definition ufrac_authUR (A : cmraT) : ucmraT :=
+Definition ufrac_authUR {SI : indexT} (A : cmraT SI) : ucmraT SI :=
authUR (optionUR (prodR ufracR A)).
(** Note in the signature of [ufrac_auth_auth] and [ufrac_auth_frag] we use
@@ -34,30 +34,30 @@ instances with carrier [Qp], namely [fracR] and [ufracR]. When writing things
like [ufrac_auth_auth q a ∧ ✓{q}] we want Coq to infer the type of [q] as [Qp]
such that the [✓] of the default [fracR] camera is used, and not the [✓] of
the [ufracR] camera. *)
-Definition ufrac_auth_auth {A : cmraT} (q : Qp) (x : A) : ufrac_authR A :=
+Definition ufrac_auth_auth {SI : indexT} {A : cmraT SI} (q : Qp) (x : A) : ufrac_authR A :=
â— (Some (q : ufracR,x)).
-Definition ufrac_auth_frag {A : cmraT} (q : Qp) (x : A) : ufrac_authR A :=
+Definition ufrac_auth_frag {SI : indexT} {A : cmraT SI} (q : Qp) (x : A) : ufrac_authR A :=
â—¯ (Some (q : ufracR,x)).
Typeclasses Opaque ufrac_auth_auth ufrac_auth_frag.
-Instance: Params (@ufrac_auth_auth) 2 := {}.
-Instance: Params (@ufrac_auth_frag) 2 := {}.
+Instance: Params (@ufrac_auth_auth) 3 := {}.
+Instance: Params (@ufrac_auth_frag) 3 := {}.
Notation "â—U{ q } a" := (ufrac_auth_auth q a) (at level 10, format "â—U{ q } a").
Notation "â—¯U{ q } a" := (ufrac_auth_frag q a) (at level 10, format "â—¯U{ q } a").
Section ufrac_auth.
- Context {A : cmraT}.
+ Context {SI : indexT} {A : cmraT SI}.
Implicit Types a b : A.
- Global Instance ufrac_auth_auth_ne q : NonExpansive (@ufrac_auth_auth A q).
+ Global Instance ufrac_auth_auth_ne q : NonExpansive (@ufrac_auth_auth _ A q).
Proof. solve_proper. Qed.
- Global Instance ufrac_auth_auth_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_auth A q).
+ Global Instance ufrac_auth_auth_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_auth _ A q).
Proof. solve_proper. Qed.
- Global Instance ufrac_auth_frag_ne q : NonExpansive (@ufrac_auth_frag A q).
+ Global Instance ufrac_auth_frag_ne q : NonExpansive (@ufrac_auth_frag _ A q).
Proof. solve_proper. Qed.
- Global Instance ufrac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_frag A q).
+ Global Instance ufrac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_frag _ A q).
Proof. solve_proper. Qed.
Global Instance ufrac_auth_auth_discrete q a : Discrete a → Discrete (â—U{q} a).
@@ -74,7 +74,7 @@ Section ufrac_auth.
Proof.
rewrite auth_both_validN=> -[Hincl Hvalid].
move: Hincl=> /Some_includedN=> -[[_ ? //]|[[[p' ?] ?] [/=]]].
- rewrite -discrete_iff leibniz_equiv_iff. rewrite ufrac_op'=> [/Qp_eq/=].
+ rewrite -discrete_iff leibniz_equiv_iff. rewrite /op ufrac_op'=> [/Qp_eq/=].
rewrite -{1}(Qcplus_0_r p)=> /(inj (Qcplus p))=> ?; by subst.
Qed.
Lemma ufrac_auth_agree p a b : ✓ (â—U{p} a â‹… â—¯U{p} b) → a ≡ b.
@@ -86,13 +86,13 @@ Section ufrac_auth.
Lemma ufrac_auth_includedN n p q a b : ✓{n} (â—U{p} a â‹… â—¯U{q} b) → Some b ≼{n} Some a.
Proof. by rewrite auth_both_validN=> -[/Some_pair_includedN [_ ?] _]. Qed.
- Lemma ufrac_auth_included `{CmraDiscrete A} q p a b :
+ Lemma ufrac_auth_included `{CmraDiscrete SI A} q p a b :
✓ (â—U{p} a â‹… â—¯U{q} b) → Some b ≼ Some a.
Proof. rewrite auth_both_valid=> -[/Some_pair_included [_ ?] _] //. Qed.
- Lemma ufrac_auth_includedN_total `{CmraTotal A} n q p a b :
+ Lemma ufrac_auth_includedN_total `{CmraTotal SI A} n q p a b :
✓{n} (â—U{p} a â‹… â—¯U{q} b) → b ≼{n} a.
Proof. intros. by eapply Some_includedN_total, ufrac_auth_includedN. Qed.
- Lemma ufrac_auth_included_total `{CmraDiscrete A, CmraTotal A} q p a b :
+ Lemma ufrac_auth_included_total `{CmraDiscrete SI A, CmraTotal SI A} q p a b :
✓ (â—U{p} a â‹… â—¯U{q} b) → b ≼ a.
Proof. intros. by eapply Some_included_total, ufrac_auth_included. Qed.
@@ -113,11 +113,11 @@ Section ufrac_auth.
Proof. done. Qed.
Global Instance is_op_ufrac_auth q q1 q2 a a1 a2 :
- IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯U{q} a) (◯U{q1} a1) (◯U{q2} a2).
+ IsOp (SI := SI)q q1 q2 → IsOp a a1 a2 → IsOp' (SI := SI) (◯U{q} a) (◯U{q1} a1) (◯U{q2} a2).
Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.
Global Instance is_op_ufrac_auth_core_id q q1 q2 a :
- CoreId a → IsOp q q1 q2 → IsOp' (◯U{q} a) (◯U{q1} a) (◯U{q2} a).
+ CoreId a → IsOp (SI := SI) q q1 q2 → IsOp' (◯U{q} a) (◯U{q1} a) (◯U{q2} a).
Proof.
rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
by rewrite -ufrac_auth_frag_op -core_id_dup.
diff --git a/theories/algebra/updates.v b/theories/algebra/updates.v
index 4e1f96c720619eb406872ade12a1e65bd92e397a..2afab0bd0deb1c83a453df0746e171ed3b2bbc88 100644
--- a/theories/algebra/updates.v
+++ b/theories/algebra/updates.v
@@ -6,33 +6,33 @@ Set Default Proof Using "Type".
make the following hold:
x ~~> P → Some c ~~> Some P
*)
-Definition cmra_updateP {A : cmraT} (x : A) (P : A → Prop) := ∀ n mz,
+Definition cmra_updateP {I: indexT} {A : cmraT I} (x : A) (P : A → Prop) := ∀ n mz,
✓{n} (x ⋅? mz) → ∃ y, P y ∧ ✓{n} (y ⋅? mz).
Instance: Params (@cmra_updateP) 1 := {}.
Infix "~~>:" := cmra_updateP (at level 70).
-Definition cmra_update {A : cmraT} (x y : A) := ∀ n mz,
+Definition cmra_update {I: indexT} {A : cmraT I} (x y : A) := ∀ n mz,
✓{n} (x ⋅? mz) → ✓{n} (y ⋅? mz).
Infix "~~>" := cmra_update (at level 70).
Instance: Params (@cmra_update) 1 := {}.
Section updates.
-Context {A : cmraT}.
+Context {I: indexT} {A : cmraT I}.
Implicit Types x y : A.
Global Instance cmra_updateP_proper :
- Proper ((≡) ==> pointwise_relation _ iff ==> iff) (@cmra_updateP A).
+ Proper ((≡) ==> pointwise_relation _ iff ==> iff) (@cmra_updateP I A).
Proof.
rewrite /pointwise_relation /cmra_updateP=> x x' Hx P P' HP;
split=> ? n mz; setoid_subst; naive_solver.
Qed.
Global Instance cmra_update_proper :
- Proper ((≡) ==> (≡) ==> iff) (@cmra_update A).
+ Proper ((≡) ==> (≡) ==> iff) (@cmra_update I A).
Proof.
rewrite /cmra_update=> x x' Hx y y' Hy; split=> ? n mz ?; setoid_subst; auto.
Qed.
-Lemma cmra_update_updateP x y : x ~~> y ↔ x ~~>: (y =).
+Lemma cmra_update_updateP x y : x ~~> y ↔ x ~~>: (eq y).
Proof. split=> Hup n z ?; eauto. destruct (Hup n z) as (?&<-&?); auto. Qed.
Lemma cmra_updateP_id (P : A → Prop) x : P x → x ~~>: P.
Proof. intros ? n mz ?; eauto. Qed.
@@ -42,7 +42,7 @@ Proof. intros Hx Hy n mz ?. destruct (Hx n mz) as (y&?&?); naive_solver. Qed.
Lemma cmra_updateP_compose_l (Q : A → Prop) x y : x ~~> y → y ~~>: Q → x ~~>: Q.
Proof.
rewrite cmra_update_updateP.
- intros; apply cmra_updateP_compose with (y =); naive_solver.
+ intros; apply cmra_updateP_compose with (eq y); naive_solver.
Qed.
Lemma cmra_updateP_weaken (P Q : A → Prop) x :
x ~~>: P → (∀ y, P y → Q y) → x ~~>: Q.
@@ -52,7 +52,7 @@ Lemma cmra_update_exclusive `{!Exclusive x} y:
Proof. move=>??[z|]=>[/exclusiveN_l[]|_]. by apply cmra_valid_validN. Qed.
(** Updates form a preorder. *)
-Global Instance cmra_update_preorder : PreOrder (@cmra_update A).
+Global Instance cmra_update_preorder : PreOrder (@cmra_update I A).
Proof.
split.
- intros x. by apply cmra_update_updateP, cmra_updateP_id.
@@ -85,17 +85,17 @@ Proof. intros n mz. rewrite comm cmra_op_opM_assoc. apply cmra_validN_op_r. Qed.
Lemma cmra_update_op_r x y : x â‹… y ~~> y.
Proof. rewrite comm. apply cmra_update_op_l. Qed.
-Lemma cmra_update_valid0 x y : (✓{0} x → x ~~> y) → x ~~> y.
+Lemma cmra_update_valid0 x y : (✓{zero} x → x ~~> y) → x ~~> y.
Proof.
intros H n mz Hmz. apply H, Hmz.
- apply (cmra_validN_le n); last lia.
+ apply (cmra_validN_le n); eauto using index_zero_minimum.
destruct mz. eapply cmra_validN_op_l, Hmz. apply Hmz.
Qed.
(** ** Frame preserving updates for total CMRAs *)
Section total_updates.
Local Set Default Proof Using "Type*".
- Context `{CmraTotal A}.
+ Context `{CmraTotal I A}.
Lemma cmra_total_updateP x (P : A → Prop) :
x ~~>: P ↔ ∀ n z, ✓{n} (x ⋅ z) → ∃ y, P y ∧ ✓{n} (y ⋅ z).
@@ -108,26 +108,26 @@ Section total_updates.
Lemma cmra_total_update x y : x ~~> y ↔ ∀ n z, ✓{n} (x ⋅ z) → ✓{n} (y ⋅ z).
Proof. rewrite cmra_update_updateP cmra_total_updateP. naive_solver. Qed.
- Context `{CmraDiscrete A}.
+ Context `{CmraDiscrete I A}.
Lemma cmra_discrete_updateP (x : A) (P : A → Prop) :
x ~~>: P ↔ ∀ z, ✓ (x ⋅ z) → ∃ y, P y ∧ ✓ (y ⋅ z).
Proof.
rewrite cmra_total_updateP; setoid_rewrite <-cmra_discrete_valid_iff.
- naive_solver eauto using 0.
+ naive_solver eauto using zero.
Qed.
Lemma cmra_discrete_update (x y : A) :
x ~~> y ↔ ∀ z, ✓ (x ⋅ z) → ✓ (y ⋅ z).
Proof.
rewrite cmra_total_update; setoid_rewrite <-cmra_discrete_valid_iff.
- naive_solver eauto using 0.
+ naive_solver eauto using zero.
Qed.
End total_updates.
End updates.
(** * Transport *)
Section cmra_transport.
- Context {A B : cmraT} (H : A = B).
+ Context {I: indexT} {A B : cmraT I} (H : A = B).
Notation T := (cmra_transport H).
Lemma cmra_transport_updateP (P : A → Prop) (Q : B → Prop) x :
x ~~>: P → (∀ y, P y → Q (T y)) → T x ~~>: Q.
@@ -139,7 +139,7 @@ End cmra_transport.
(** * Product *)
Section prod.
- Context {A B : cmraT}.
+ Context {I: indexT} {A B : cmraT I}.
Implicit Types x : A * B.
Lemma prod_updateP P1 P2 (Q : A * B → Prop) x :
@@ -162,7 +162,7 @@ End prod.
(** * Option *)
Section option.
- Context {A : cmraT}.
+ Context {I: indexT} {A : cmraT I}.
Implicit Types x y : A.
Lemma option_updateP (P : A → Prop) (Q : option A → Prop) x :
diff --git a/theories/algebra/vector.v b/theories/algebra/vector.v
index a03666a98fd1a81da963d4f2ee7ab08129fce155..2b2b3fdbb8782f329f4c58527911f78eec5a92e2 100644
--- a/theories/algebra/vector.v
+++ b/theories/algebra/vector.v
@@ -4,21 +4,22 @@ From iris.algebra Require Import list.
Set Default Proof Using "Type".
Section ofe.
- Context {A : ofeT}.
+ Context {SI : indexT} {A : ofeT SI}.
Instance vec_equiv m : Equiv (vec A m) := equiv (A:=list A).
- Instance vec_dist m : Dist (vec A m) := dist (A:=list A).
+ Instance vec_dist m : Dist SI (vec A m) := dist (A:=list A).
- Definition vec_ofe_mixin m : OfeMixin (vec A m).
+ Definition vec_ofe_mixin m : OfeMixin SI (vec A m).
Proof. by apply (iso_ofe_mixin vec_to_list). Qed.
- Canonical Structure vecO m : ofeT := OfeT (vec A m) (vec_ofe_mixin m).
+ Canonical Structure vecO m : ofeT SI := OfeT (vec A m) (vec_ofe_mixin m).
- Global Instance list_cofe `{Cofe A} m : Cofe (vecO m).
+ Global Instance list_cofe `{Cofe SI A} m : Cofe (vecO m).
Proof.
apply: (iso_cofe_subtype (λ l : list A, length l = m)
(λ l, eq_rect _ (vec A) (list_to_vec l) m) vec_to_list)=> //.
- - intros v []. by rewrite /= vec_to_list_of_list.
- - intros c. by rewrite (conv_compl 0 (chain_map _ c)) /= vec_to_list_length.
+ - intros v []. by rewrite /= vec_to_list_to_vec.
+ - intros c. by rewrite (conv_compl zero (chain_map _ c)) /= vec_to_list_length.
+ - intros α Hα c. by rewrite (conv_bcompl α Hα (bchain_map _ c) zero Hα) /= vec_to_list_length.
Qed.
Global Instance vnil_discrete : Discrete (@vnil A).
@@ -34,10 +35,11 @@ Section ofe.
End ofe.
Arguments vecO : clear implicits.
+Arguments vecO {_}.
Typeclasses Opaque vec_dist.
Section proper.
- Context {A : ofeT}.
+ Context {SI : indexT} {A : ofeT SI}.
Global Instance vcons_ne n :
Proper (dist n ==> forall_relation (λ x, dist n ==> dist n)) (@vcons A).
@@ -66,48 +68,48 @@ Section proper.
End proper.
(** Functor *)
-Definition vec_map {A B : ofeT} m (f : A → B) : vecO A m → vecO B m :=
+Definition vec_map {SI : indexT} {A B : ofeT SI} m (f : A → B) : vecO A m → vecO B m :=
@vmap A B f m.
-Lemma vec_map_ext_ne {A B : ofeT} m (f g : A → B) (v : vec A m) n :
+Lemma vec_map_ext_ne {SI : indexT} {A B : ofeT SI} m (f g : A → B) (v : vec A m) n :
(∀ x, f x ≡{n}≡ g x) → vec_map m f v ≡{n}≡ vec_map m g v.
Proof.
intros Hf. eapply (list_fmap_ext_ne f g v) in Hf.
by rewrite -!vec_to_list_map in Hf.
Qed.
-Instance vec_map_ne {A B : ofeT} m f n :
+Instance vec_map_ne {SI : indexT} {A B : ofeT SI} m f n :
Proper (dist n ==> dist n) f →
- Proper (dist n ==> dist n) (@vec_map A B m f).
+ Proper (dist n ==> dist n) (@vec_map _ A B m f).
Proof.
intros ? v v' H. eapply list_fmap_ne in H; last done.
by rewrite -!vec_to_list_map in H.
Qed.
-Definition vecO_map {A B : ofeT} m (f : A -n> B) : vecO A m -n> vecO B m :=
+Definition vecO_map {SI : indexT} {A B : ofeT SI } m (f : A -n> B) : vecO A m -n> vecO B m :=
OfeMor (vec_map m f).
-Instance vecO_map_ne {A A'} m :
- NonExpansive (@vecO_map A A' m).
+Instance vecO_map_ne {SI : indexT} {A A'} m :
+ NonExpansive (@vecO_map SI A A' m).
Proof. intros n f g ? v. by apply vec_map_ext_ne. Qed.
-Program Definition vecOF (F : oFunctor) m : oFunctor := {|
- oFunctor_car A _ B _ := vecO (oFunctor_car F A B) m;
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := vecO_map m (oFunctor_map F fg)
+Program Definition vecOF {SI : indexT} (F : oFunctor SI) m : oFunctor SI := {|
+ oFunctor_car A B := vecO (oFunctor_car F A B) m;
+ oFunctor_map A1 A2 B1 B2 fg := vecO_map m (oFunctor_map F fg)
|}.
Next Obligation.
- intros F A1 ? A2 ? B1 ? B2 ? n m f g Hfg. by apply vecO_map_ne, oFunctor_ne.
+ intros SI F A1 A2 B1 B2 n m f g Hfg. by apply vecO_map_ne, oFunctor_ne.
Qed.
Next Obligation.
- intros F m A ? B ? l.
+ intros SI F m A B l.
change (vec_to_list (vec_map m (oFunctor_map F (cid, cid)) l) ≡ l).
rewrite vec_to_list_map. apply listOF.
Qed.
Next Obligation.
- intros F m A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' l.
+ intros SI F m A1 A2 A3 B1 B2 B3 f g f' g' l.
change (vec_to_list (vec_map m (oFunctor_map F (f â—Ž g, g' â—Ž f')) l)
≡ vec_map m (oFunctor_map F (g, g')) (vec_map m (oFunctor_map F (f, f')) l)).
rewrite !vec_to_list_map. by apply: (oFunctor_compose (listOF F) f g f' g').
Qed.
-Instance vecOF_contractive F m :
+Instance vecOF_contractive {SI : indexT} (F : oFunctor SI) m :
oFunctorContractive F → oFunctorContractive (vecOF F m).
Proof.
- by intros ?? A1 ? A2 ? B1 ? B2 ? n ???; apply vecO_map_ne; first apply oFunctor_contractive.
+ by intros ?? A1 A2 B1 B2 n ???; apply vecO_map_ne; first apply oFunctor_contractive.
Qed.
diff --git a/theories/algebra/wf_IR.v b/theories/algebra/wf_IR.v
new file mode 100644
index 0000000000000000000000000000000000000000..53da5f0ee4a7f954fcd969fd9637075d495d1afc
--- /dev/null
+++ b/theories/algebra/wf_IR.v
@@ -0,0 +1,231 @@
+From iris.algebra Require Export ofe.
+Set Default Proof Using "Type".
+Require Import Coq.Logic.Eqdep_dec.
+
+(** * Well-founded induction-recursion schemes *)
+
+Section IR.
+ (** In the most general setting we consider, we have a well-founded decidable partial order *)
+ Variable (X : Type). (* the type of indices *)
+ Variable (rel : X → X → Prop).
+ Notation "a ≺ b" := (rel a b).
+ Notation "a ⪯ b" := (rc rel a b).
+
+ Variable (rel_wf : wf rel).
+ Variable (rel_transitive : Transitive rel).
+ Variable (existT_X_inj2 : ∀ (p : X → Type) (x : X) (H1 H2 : p x), existT x H1 = existT x H2 → H1 = H2).
+ Variable (rel_rc_total : ∀ x1 x2, {x1 ⪯ x2} + {x2 ⪯ x1}).
+
+ Implicit Type (P : X → Prop).
+
+ (** A is our type of approximations -- we want to define a : A (λ _, True) using wf IR *)
+ Variable (A : ∀ (P : X → Prop), Type).
+ (** A_agree is an equivalence relation (in a suitable sense) on A, capturing that two approximations agree in some way *)
+ Variable (A_agree : ∀ {P1 P2}, A P1 → A P2 → Prop).
+ Variable (A_agree_transitive : ∀ (P0 P1 P2 : X → Prop) A0 A1 A2, (∀ γ, P0 γ → P2 γ → P1 γ)
+ → @A_agree P0 P1 A0 A1 → @A_agree P1 P2 A1 A2 → @A_agree P0 P2 A0 A2).
+ Variable (A_agree_symmetric : ∀ P0 P1 A0 A1, @A_agree P0 P1 A0 A1 → @A_agree P1 P0 A1 A0).
+
+ (** we can merge previous approximations coherently *)
+ Variable (step_merge : ∀ P (IH : ∀ x, P x → A (λ y, y ⪯ x)),
+ (∀ x0 x1 H0 H1, A_agree (IH x0 H0) (IH x1 H1))
+ → A P).
+ Variable (merge_agree : ∀ P Hlt, ∀ x Hx H, A_agree (Hlt x Hx) (step_merge P Hlt H)).
+ Variable (merge_preserve : ∀ P (Hlt1 : ∀ x, P x → A (λ y, y ⪯ x)) (Hlt2 : ∀ x, P x → A (λ y, y ⪯ x)),
+ ∀ (H1 : ∀ x1 x2 Hx1 Hx2, A_agree (Hlt1 x1 Hx1) (Hlt1 x2 Hx2))
+ (H2 : ∀ x1 x2 Hx1 Hx2, A_agree (Hlt2 x1 Hx1) (Hlt2 x2 Hx2)),
+ (∀ x Hx, A_agree (Hlt1 x Hx) (Hlt2 x Hx))
+ → A_agree (step_merge P Hlt1 H1) (step_merge P Hlt2 H2)).
+
+ (** the inductive step *)
+ Variable (step : ∀ x, A (λ y, y ≺ x) → A (λ y, y ⪯ x)).
+ Variable (step_agree : ∀ x IH, A_agree IH (step x IH) ).
+ Variable (step_preserve : ∀ x IH1 IH2, A_agree IH1 IH2 → A_agree (step x IH1) (step x IH2)).
+
+ (** an inductive predicate capturing exactly the structure of the induction: if IR_spec β approx holds,
+ then approx was obtained by inductively applying step and merging *)
+ Inductive IR_spec : ∀ (x : X), A (λ y, y ⪯ x) → Prop :=
+ | wf_step x (IH : ∀ y, y ≺ x → A (λ y', y' ⪯ y))
+ (IH_spec : ∀ y Hy, IR_spec y (IH y Hy))
+ (IH_agree : ∀ y1 y2 Hy1 Hy2, A_agree (IH y1 Hy1) (IH y2 Hy2))
+ : IR_spec x (step x (step_merge (λ y, y ≺ x) IH IH_agree)).
+
+ (** thus, we obtain as a consequence that two approximations satisfying this specification must agree
+ (as merging and step both preserve agreement) *)
+ Lemma IR_spec_unique x1 x2 A1 A2 : x1 ⪯ x2 → IR_spec x1 A1 → IR_spec x2 A2 → A_agree A1 A2.
+ Proof using step_preserve step_agree rel_wf rel_transitive merge_preserve merge_agree existT_X_inj2 A_agree_transitive.
+ revert x2 x1 A1 A2. refine (Fix rel_wf _ _). intros x2 IH x1 A1 A2 Hle H1 H2.
+ destruct Hle.
+ - subst. inversion H1. subst. apply existT_X_inj2 in H3. subst.
+ inversion H2. subst. apply existT_X_inj2 in H3. subst.
+ apply step_preserve. apply merge_preserve.
+ intros. apply IH; [ assumption| reflexivity| apply IH_spec| apply IH_spec0].
+ - subst. inversion H2. subst. apply existT_X_inj2 in H4. subst.
+ eapply A_agree_transitive.
+ 3: { eapply step_agree. }
+ 2: { eapply A_agree_transitive. 3: { apply merge_agree. }
+ 2: eapply IH. 2: apply H. all: cbn; eauto.
+ }
+ cbn. intros γ H0 _. destruct H0; subst; eauto.
+ Unshelve. cbn; eauto.
+ Qed.
+
+ Lemma IR_spec_unique' (P : X → Prop) (H : ∀ x, P x → A (λ y, y ⪯ x)):
+ (∀ (x : X) (Hx : P x), IR_spec x (H x Hx))
+ → ∀ x0 x1 Hx0 Hx1, A_agree (H x0 Hx0) (H x1 Hx1).
+ Proof using step_preserve step_agree rel_wf rel_transitive rel_rc_total merge_preserve merge_agree existT_X_inj2 A_agree_transitive A_agree_symmetric.
+ intros H1 x0 x1 Hx0 Hx1.
+ destruct (rel_rc_total x0 x1) as [H2 | H2].
+ - apply IR_spec_unique; eauto.
+ - apply A_agree_symmetric. apply IR_spec_unique; eauto.
+ Qed.
+
+ (** By well-founded induction we can obtain, for every x, an approximation which satisfies the spec *)
+ Lemma A_all x : { H : A (λ y, y ⪯ x) & IR_spec x H}.
+ Proof using step_preserve step_agree rel_wf rel_transitive rel_rc_total merge_preserve merge_agree existT_X_inj2 A_agree_transitive A_agree_symmetric.
+ revert x. refine (Fix rel_wf _ _). intros x IH.
+ set (IH1 := λ y Hy, projT1 (IH y Hy)).
+ assert (IH2 : ∀ x0 x1 (Hx0 : x0 ≺ x) (Hx1 : x1 ≺ x), A_agree (IH1 x0 Hx0) (IH1 x1 Hx1)).
+ { apply IR_spec_unique'. intros. exact (projT2 (IH x0 Hx)). }
+ exists (step x (step_merge _ IH1 IH2)).
+ constructor. intros. exact (projT2 (IH y Hy)).
+ Qed.
+
+ Definition A_all_d x := projT1 (A_all x).
+ Definition A_all_p x := projT2 (A_all x).
+
+ Corollary A_all_agree x0 x1 : A_agree (A_all_d x0) (A_all_d x1).
+ Proof.
+ destruct (rel_rc_total x0 x1) as [H0 | H0].
+ - apply IR_spec_unique; eauto using A_all_p.
+ - apply A_agree_symmetric. apply IR_spec_unique; eauto using A_all_p.
+ Qed.
+
+ (** finally, we can merge all of these approximations together *)
+ Definition full_A : A (λ _, True) := step_merge (λ _, True) (λ x _, A_all_d x) (λ x1 x2 _ _ , A_all_agree x1 x2).
+End IR.
+
+
+(** we now specialize this construction to stepindices *)
+Section IR_wf_index.
+ Variable (SI : indexT).
+ Variable (A : ∀ (P : SI → Prop), Type).
+ Variable (A_agree : ∀ {P1 P2}, A P1 → A P2 → Prop).
+ Variable (A_agree_transitive : ∀ (P0 P1 P2 : SI → Prop) A0 A1 A2, (∀ γ, P0 γ → P2 γ → P1 γ)
+ → @A_agree P0 P1 A0 A1 → @A_agree P1 P2 A1 A2 → @A_agree P0 P2 A0 A2).
+ Variable (A_agree_symmetric : ∀ P0 P1 A0 A1, @A_agree P0 P1 A0 A1 → @A_agree P1 P0 A1 A0).
+
+ Implicit Type (P : SI → Prop).
+
+ (* we can merge previous approximations coherently *)
+ Variable (step_merge : ∀ P (IH : ∀ x, P x → A (λ y, y ⪯ x)), (∀ x0 x1 H0 H1, A_agree (IH x0 H0) (IH x1 H1)) → A P).
+ Variable (merge_agree : ∀ P Hlt, ∀ x Hx H, A_agree (Hlt x Hx) (step_merge P Hlt H)).
+ Variable (merge_preserve : ∀ P (Hlt1 : ∀ x, P x → A (λ y, y ⪯ x)) (Hlt2 : ∀ x, P x → A (λ y, y ⪯ x)),
+ ∀ (H1 : ∀ x1 x2 Hx1 Hx2, A_agree (Hlt1 x1 Hx1) (Hlt1 x2 Hx2))
+ (H2 : ∀ x1 x2 Hx1 Hx2, A_agree (Hlt2 x1 Hx1) (Hlt2 x2 Hx2)),
+ (∀ x Hx, A_agree (Hlt1 x Hx) (Hlt2 x Hx))
+ → A_agree (step_merge P Hlt1 H1) (step_merge P Hlt2 H2)).
+
+ Variable (step : ∀ x, A (λ y, y ≺ x) → A (λ y, y ⪯ x)).
+ Variable (step_agree : ∀ x IH, A_agree IH (step x IH) ).
+ Variable (step_preserve : ∀ x IH1 IH2, A_agree IH1 IH2 → A_agree (step x IH1) (step x IH2)).
+
+ Lemma existT_index_inj2 (p : SI → Type) (x : SI) (H1 H2 : p x) : existT x H1 = existT x H2 → H1 = H2.
+ Proof.
+ apply inj_pair2_eq_dec. apply index_eq_dec.
+ Qed.
+ Definition full_A_SI : A (λ _, True).
+ Proof using step_preserve step_merge step_agree step merge_preserve merge_agree A_agree_transitive A_agree_symmetric A_agree.
+ unshelve eapply full_A.
+ by apply index_lt.
+ by exact (@A_agree).
+ by apply step_merge.
+ by exact step.
+ all: eauto.
+ - apply SI.
+ - apply SI.
+ - apply existT_index_inj2.
+ - intros x1 x2. destruct (index_le_lt_dec x1 x2) as [H1 | H1]. by left. eauto.
+ Qed.
+
+End IR_wf_index.
+
+(** Finally, we can derive a transfinite induction scheme which relies on an extension operation for the inductive step *)
+Section IR_transfinite_index_cons.
+ Variable (SI : indexT).
+
+ Variable (A : ∀ (P : SI → Prop), Type).
+ Variable (A_agree : ∀ {P1 P2}, A P1 → A P2 → Prop).
+ Variable (A_agree_trivial : ∀ P1 P2 (A1 : A P1) (A2 : A P2), (∀ γ, P1 γ → P2 γ → False) → A_agree A1 A2).
+ Variable (A_agree_transitive : ∀ (P0 P1 P2 : SI → Prop) A0 A1 A2, (∀ γ, P0 γ → P2 γ → P1 γ)
+ → @A_agree P0 P1 A0 A1 → @A_agree P1 P2 A1 A2 → @A_agree P0 P2 A0 A2).
+ Variable (A_agree_symmetric : ∀ P0 P1 A0 A1, @A_agree P0 P1 A0 A1 → @A_agree P1 P0 A1 A0).
+ Variable (A_agree_reflexive : ∀ P A, @A_agree P P A A).
+
+ (** extension operation -- it is always relative to a particular approximation *)
+ Variable (E : ∀ γ (approx : A (λ y, y ≺ γ)), Type).
+ (** agreement of extensions is dependent on the agreement of the approximations they are based on *)
+ Variable (E_agree : ∀ γ ap0 ap1, E γ ap0 → E γ ap1 → A_agree ap0 ap1 → Prop).
+
+ Variable (extend : ∀ γ ap (ext : E γ ap) (succ_or_limit : {γ' | γ = succ γ'} + {index_is_limit γ}), A (λ y, y ⪯ γ)).
+ Variable (extend_agree : ∀ γ ap ext succ_or_limit, A_agree ap (extend γ ap ext succ_or_limit)).
+ Variable (extend_coherent : ∀ γ ap0 ap1 ext0 ext1 succ_or_limit,
+ ∀ H: A_agree ap0 ap1,
+ E_agree γ ap0 ap1 ext0 ext1 H
+ → A_agree (extend γ ap0 ext0 succ_or_limit) (extend γ ap1 ext1 succ_or_limit)).
+
+ Implicit Type (P : SI → Prop).
+
+ (** we can merge previous approximations coherently *)
+ Variable (step_merge : ∀ P (IH : ∀ x, P x → A (λ y, y ⪯ x)), (∀ x0 x1 H0 H1, A_agree (IH x0 H0) (IH x1 H1)) → A P).
+ Variable (merge_agree : ∀ P Hlt , ∀ x Hx H, A_agree (Hlt x Hx) (step_merge P Hlt H)).
+ Variable (merge_coherent : ∀ P (Hlt1 : ∀ x, P x → A (λ y, y ⪯ x)) (Hlt2 : ∀ x, P x → A (λ y, y ⪯ x)),
+ ∀ (H1 : ∀ x1 x2 Hx1 Hx2, A_agree (Hlt1 x1 Hx1) (Hlt1 x2 Hx2))
+ (H2 : ∀ x1 x2 Hx1 Hx2, A_agree (Hlt2 x1 Hx1) (Hlt2 x2 Hx2)),
+ (∀ x Hx, A_agree (Hlt1 x Hx) (Hlt2 x Hx))
+ → A_agree (step_merge P Hlt1 H1) (step_merge P Hlt2 H2)).
+
+ (** base case*)
+ Variable (base : A (λ y, y ⪯ zero)).
+
+ (** successor case *)
+ Variable (succ_step : ∀ β (IH : A (λ y, y ≺ succ β)), E (succ β) IH).
+ Variable (succ_extension_coherent : ∀ β IH0 IH1 (H : A_agree IH0 IH1),
+ E_agree (succ β) IH0 IH1 (succ_step β IH0) (succ_step β IH1) H).
+
+ (** limit case *)
+ Variable (limit_step : ∀ (β : limit_idx SI) (IH : A (λ y, y ≺ β)), E β IH).
+ Variable (limit_extension_coherent : ∀ (β : limit_idx SI) IH0 IH1 (H : A_agree IH0 IH1),
+ E_agree β IH0 IH1 (limit_step β IH0) (limit_step β IH1) H).
+
+
+ Definition full_A_transfinite : A (λ _, True).
+ Proof using succ_step succ_extension_coherent step_merge merge_coherent merge_agree limit_step limit_extension_coherent extend_coherent extend_agree extend base E_agree E A_agree_trivial A_agree_transitive A_agree_symmetric A_agree_reflexive A_agree.
+ unshelve eapply full_A_SI.
+ - apply @A_agree.
+ - apply step_merge.
+ - refine (ord_match _ _ _ _).
+ + intros. apply base.
+ + intros β IH. unshelve eapply extend. exact IH. 2: left; by exists β. eapply succ_step.
+ + intros β IH. unshelve eapply extend. exact IH. 2: right; apply limit_index_is_limit.
+ apply limit_step.
+ - apply A_agree_transitive.
+ - apply A_agree_symmetric.
+ - apply merge_agree.
+ - apply merge_coherent.
+ - intros x IH. unfold ord_match. destruct index_is_zero as [-> | Hnt]; cbn.
+ { apply A_agree_trivial. intros. index_contra_solve. }
+ destruct index_dec_limit as [[β ->] | H2]; cbn.
+ { apply extend_agree. }
+ { apply extend_agree. }
+ - intros x IH1 IH2 H. unfold ord_match. destruct index_is_zero as [-> | Hnt]; cbn.
+ { intros. apply A_agree_reflexive. }
+ destruct index_dec_limit as [[β ->] | H2]; cbn.
+ { unshelve eapply extend_coherent. exact H. eapply succ_extension_coherent. }
+ { unshelve eapply extend_coherent. exact H.
+ set (xlim := mklimitidx _ _ _).
+ enough (E_agree xlim IH1 IH2 (limit_step xlim IH1) (limit_step xlim IH2) H) as H0 by exact H0.
+ eapply limit_extension_coherent.
+ }
+ Qed.
+End IR_transfinite_index_cons.
diff --git a/theories/base_logic/bi.v b/theories/base_logic/bi.v
index 1d3758f02a1bceae2473ca4906726732970aa97e..a4868ae940dd5894616653e73e3b8ea464e3a7b9 100644
--- a/theories/base_logic/bi.v
+++ b/theories/base_logic/bi.v
@@ -5,14 +5,14 @@ Import uPred_primitive.
(** BI instances for uPred, and re-stating the remaining primitive laws in terms
of the BI interface. This file does *not* unseal. *)
-Definition uPred_emp {M} : uPred M := uPred_pure True.
+Definition uPred_emp {SI: indexT} {M: ucmraT SI} : uPred M := uPred_pure True.
Local Existing Instance entails_po.
-Lemma uPred_bi_mixin (M : ucmraT) :
+Lemma uPred_bi_mixin {SI: indexT} (M : ucmraT SI) :
BiMixin
uPred_entails uPred_emp uPred_pure uPred_and uPred_or uPred_impl
- (@uPred_forall M) (@uPred_exist M) uPred_sep uPred_wand
+ (@uPred_forall SI M) (@uPred_exist SI M) uPred_sep uPred_wand
uPred_persistently.
Proof.
split.
@@ -43,7 +43,7 @@ Proof.
- exact: @exist_intro.
- exact: @exist_elim.
- exact: sep_mono.
- - exact: True_sep_1.
+ - exact: True_sep_1.
- exact: True_sep_2.
- exact: sep_comm'.
- exact: sep_assoc'.
@@ -66,10 +66,10 @@ Proof.
- exact: persistently_and_sep_l_1.
Qed.
-Lemma uPred_sbi_mixin (M : ucmraT) : SbiMixin
+Lemma uPred_sbi_mixin {SI: indexT} (M : ucmraT SI) : SbiMixin
uPred_entails uPred_pure uPred_or uPred_impl
- (@uPred_forall M) (@uPred_exist M) uPred_sep
- uPred_persistently (@uPred_internal_eq M) uPred_later.
+ (@uPred_forall SI M) (@uPred_exist SI M) uPred_sep
+ uPred_persistently (@uPred_internal_eq SI M) uPred_later.
Proof.
split.
- exact: later_contractive.
@@ -85,22 +85,23 @@ Proof.
- exact: later_intro.
- exact: @later_forall_2.
- exact: @later_exist_false.
- - exact: later_sep_1.
+ - exact: @later_finite_exist_false.
+ - intros; eapply later_sep_1.
- exact: later_sep_2.
- exact: later_persistently_1.
- exact: later_persistently_2.
- exact: later_false_em.
Qed.
-Canonical Structure uPredI (M : ucmraT) : bi :=
- {| bi_ofe_mixin := ofe_mixin_of (uPred M); bi_bi_mixin := uPred_bi_mixin M |}.
-Canonical Structure uPredSI (M : ucmraT) : sbi :=
- {| sbi_ofe_mixin := ofe_mixin_of (uPred M);
+Canonical Structure uPredI {SI: indexT} (M : ucmraT SI) : bi SI :=
+ {| bi_ofe_mixin := ofe_mixin_of SI (uPred M); bi_bi_mixin := uPred_bi_mixin M |}.
+Canonical Structure uPredSI {SI: indexT} (M : ucmraT SI) : sbi SI :=
+ {| sbi_ofe_mixin := ofe_mixin_of SI (uPred M);
sbi_bi_mixin := uPred_bi_mixin M; sbi_sbi_mixin := uPred_sbi_mixin M |}.
-Coercion uPred_valid {M} : uPred M → Prop := bi_emp_valid.
+Coercion uPred_valid {SI: indexT} {M: ucmraT SI} : uPred M → Prop := bi_emp_valid.
-Lemma uPred_plainly_mixin M : BiPlainlyMixin (uPredSI M) uPred_plainly.
+Lemma uPred_plainly_mixin {SI} (M: ucmraT SI) : BiPlainlyMixin (uPredSI M) uPred_plainly.
Proof.
split.
- exact: plainly_ne.
@@ -125,10 +126,10 @@ Proof.
- exact: later_plainly_1.
- exact: later_plainly_2.
Qed.
-Global Instance uPred_plainlyC M : BiPlainly (uPredSI M) :=
+Global Instance uPred_plainlyC {SI} (M: ucmraT SI) : BiPlainly (uPredSI M) :=
{| bi_plainly_mixin := uPred_plainly_mixin M |}.
-Lemma uPred_bupd_mixin M : BiBUpdMixin (uPredI M) uPred_bupd.
+Lemma uPred_bupd_mixin {SI} (M: ucmraT SI) : BiBUpdMixin (uPredI M) uPred_bupd.
Proof.
split.
- exact: bupd_ne.
@@ -137,20 +138,20 @@ Proof.
- exact: bupd_trans.
- exact: bupd_frame_r.
Qed.
-Global Instance uPred_bi_bupd M : BiBUpd (uPredI M) := {| bi_bupd_mixin := uPred_bupd_mixin M |}.
+Global Instance uPred_bi_bupd {SI} (M: ucmraT SI) : BiBUpd (uPredI M) := {| bi_bupd_mixin := uPred_bupd_mixin M |}.
-Global Instance uPred_bi_bupd_plainly M : BiBUpdPlainly (uPredSI M).
+Global Instance uPred_bi_bupd_plainly {SI} (M: ucmraT SI) : BiBUpdPlainly (uPredSI M).
Proof. exact: bupd_plainly. Qed.
(** extra BI instances *)
-Global Instance uPred_affine M : BiAffine (uPredI M) | 0.
+Global Instance uPred_affine {SI} (M: ucmraT SI) : BiAffine (uPredI M) | 0.
Proof. intros P. exact: pure_intro. Qed.
(* Also add this to the global hint database, otherwise [eauto] won't work for
many lemmas that have [BiAffine] as a premise. *)
Hint Immediate uPred_affine : core.
-Global Instance uPred_plainly_exist_1 M : BiPlainlyExist (uPredSI M).
+Global Instance uPred_plainly_exist_1 {SI} (M: ucmraT SI) : BiPlainlyExist (uPredSI M).
Proof. exact: @plainly_exist_1. Qed.
(** Re-state/export lemmas about Iris-specific primitive connectives (own, valid) *)
@@ -158,17 +159,18 @@ Proof. exact: @plainly_exist_1. Qed.
Module uPred.
Section restate.
-Context {M : ucmraT}.
+Context `{M : ucmraT SI}.
Implicit Types φ : Prop.
Implicit Types P Q : uPred M.
Implicit Types A : Type.
(* Force implicit argument M *)
+Notation "⊢ P" := (bi_emp_valid (PROP := uPredI M) P%I).
Notation "P ⊢ Q" := (bi_entails (PROP:=uPredI M) P%I Q%I).
Notation "P ⊣⊢ Q" := (equiv (A:=uPredI M) P%I Q%I).
-Global Instance ownM_ne : NonExpansive (@uPred_ownM M) := uPred_primitive.ownM_ne.
-Global Instance cmra_valid_ne {A : cmraT} : NonExpansive (@uPred_cmra_valid M A)
+Global Instance ownM_ne : NonExpansive (@uPred_ownM SI M) := uPred_primitive.ownM_ne.
+Global Instance cmra_valid_ne {A : cmraT SI} : NonExpansive (@uPred_cmra_valid SI M A)
:= uPred_primitive.cmra_valid_ne.
(** Re-exporting primitive Own and valid lemmas *)
@@ -179,42 +181,45 @@ Lemma persistently_ownM_core (a : M) : uPred_ownM a ⊢ <pers> uPred_ownM (core
Proof. exact: uPred_primitive.persistently_ownM_core. Qed.
Lemma ownM_unit P : P ⊢ (uPred_ownM ε).
Proof. exact: uPred_primitive.ownM_unit. Qed.
-Lemma later_ownM a : ▷ uPred_ownM a ⊢ ∃ b, uPred_ownM b ∧ ▷ (a ≡ b).
-Proof. exact: uPred_primitive.later_ownM. Qed.
+Lemma later_ownM `{FiniteIndex SI} a : ▷ uPred_ownM a ⊢ ∃ b, uPred_ownM b ∧ ▷ (a ≡ b).
+Proof. intros; eapply uPred_primitive.later_ownM. Qed.
Lemma bupd_ownM_updateP x (Φ : M → Prop) :
x ~~>: Φ → uPred_ownM x ⊢ |==> ∃ y, ⌜Φ y⌠∧ uPred_ownM y.
Proof. exact: uPred_primitive.bupd_ownM_updateP. Qed.
Lemma ownM_valid (a : M) : uPred_ownM a ⊢ ✓ a.
Proof. exact: uPred_primitive.ownM_valid. Qed.
-Lemma cmra_valid_intro {A : cmraT} P (a : A) : ✓ a → P ⊢ (✓ a).
+Lemma cmra_valid_intro {A : cmraT SI} P (a : A) : ✓ a → P ⊢ (✓ a).
Proof. exact: uPred_primitive.cmra_valid_intro. Qed.
-Lemma cmra_valid_elim {A : cmraT} (a : A) : ¬ ✓{0} a → ✓ a ⊢ False.
+Lemma cmra_valid_elim {A : cmraT SI} (a : A) : ¬ ✓{zero} a → ✓ a ⊢ False.
Proof. exact: uPred_primitive.cmra_valid_elim. Qed.
-Lemma plainly_cmra_valid_1 {A : cmraT} (a : A) : ✓ a ⊢ ■✓ a.
+Lemma plainly_cmra_valid_1 {A : cmraT SI} (a : A) : ✓ a ⊢ ■✓ a.
Proof. exact: uPred_primitive.plainly_cmra_valid_1. Qed.
-Lemma cmra_valid_weaken {A : cmraT} (a b : A) : ✓ (a ⋅ b) ⊢ ✓ a.
+Lemma cmra_valid_weaken {A : cmraT SI} (a b : A) : ✓ (a ⋅ b) ⊢ ✓ a.
Proof. exact: uPred_primitive.cmra_valid_weaken. Qed.
-Lemma prod_validI {A B : cmraT} (x : A * B) : ✓ x ⊣⊢ ✓ x.1 ∧ ✓ x.2.
+Lemma prod_validI {A B : cmraT SI} (x : A * B) : ✓ x ⊣⊢ ✓ x.1 ∧ ✓ x.2.
Proof. exact: uPred_primitive.prod_validI. Qed.
-Lemma option_validI {A : cmraT} (mx : option A) :
+Lemma option_validI {A : cmraT SI} (mx : option A) :
✓ mx ⊣⊢ match mx with Some x => ✓ x | None => True : uPred M end.
Proof. exact: uPred_primitive.option_validI. Qed.
-Lemma discrete_valid {A : cmraT} `{!CmraDiscrete A} (a : A) : ✓ a ⊣⊢ ⌜✓ aâŒ.
+Lemma discrete_valid {A : cmraT SI} `{!CmraDiscrete A} (a : A) : ✓ a ⊣⊢ ⌜✓ aâŒ.
Proof. exact: uPred_primitive.discrete_valid. Qed.
-Lemma discrete_fun_validI {A} {B : A → ucmraT} (g : discrete_fun B) : ✓ g ⊣⊢ ∀ i, ✓ g i.
+Lemma discrete_fun_validI {A} {B : A → ucmraT SI} (g : discrete_fun B) : ✓ g ⊣⊢ ∀ i, ✓ g i.
Proof. exact: uPred_primitive.discrete_fun_validI. Qed.
(** Consistency/soundness statement *)
-Lemma pure_soundness φ : bi_emp_valid (PROP:=uPredI M) ⌜ φ ⌠→ φ.
+Lemma pure_soundness φ : (⊢ ⌜ φ âŒ) → φ.
Proof. apply pure_soundness. Qed.
-Lemma later_soundness P : bi_emp_valid (▷ P) → bi_emp_valid P.
+Lemma later_soundness P : (⊢ ▷ P) → ⊢ P.
Proof. apply later_soundness. Qed.
(** See [derived.v] for a similar soundness result for basic updates. *)
+
+
End restate.
+
(** New unseal tactic that also unfolds the BI layer.
This is used by [base_logic.double_negation].
TODO: Can we get rid of this? *)
diff --git a/theories/base_logic/bupd_alt.v b/theories/base_logic/bupd_alt.v
deleted file mode 100644
index 9cc3208a990027a434ec535e9456bf2b827b894e..0000000000000000000000000000000000000000
--- a/theories/base_logic/bupd_alt.v
+++ /dev/null
@@ -1,101 +0,0 @@
-From iris.base_logic Require Export base_logic.
-From iris.proofmode Require Import tactics.
-
-(** This file contains an alternative version of basic updates, that is
-expression in terms of just the plain modality [â– ]. *)
-Definition bupd_alt `{BiPlainly PROP} (P : PROP) : PROP :=
- (∀ R, (P -∗ ■R) -∗ ■R)%I.
-
-(** This definition is stated for any BI with a plain modality. The above
-definition is akin to the continuation monad, where one should think of [â– R]
-being the final result that one wants to get out of the basic update in the end
-of the day (via [bupd_alt (■P) ⊢ ■P]).
-
-We show that:
-
-1. [bupd_alt] enjoys the usual rules of the basic update modality.
-2. [bupd_alt] entails any other modality that enjoys the laws of a basic update
- modality (see [bupd_bupd_alt]).
-3. The ordinary basic update modality [|==>] on [uPred] entails [bupd_alt]
- (see [bupd_alt_bupd]). This result is proven in the model of [uPred].
-
-The first two points are shown for any BI with a plain modality. *)
-
-Section bupd_alt.
- Context `{BiPlainly PROP}.
- Implicit Types P Q R : PROP.
- Notation bupd_alt := (@bupd_alt PROP _).
-
- Global Instance bupd_alt_ne : NonExpansive bupd_alt.
- Proof. solve_proper. Qed.
- Global Instance bupd_alt_proper : Proper ((≡) ==> (≡)) bupd_alt.
- Proof. solve_proper. Qed.
- Global Instance bupd_alt_mono' : Proper ((⊢) ==> (⊢)) bupd_alt.
- Proof. solve_proper. Qed.
- Global Instance bupd_alt_flip_mono' : Proper (flip (⊢) ==> flip (⊢)) bupd_alt.
- Proof. solve_proper. Qed.
-
- (** The laws of the basic update modality hold *)
- Lemma bupd_alt_intro P : P ⊢ bupd_alt P.
- Proof. iIntros "HP" (R) "H". by iApply "H". Qed.
- Lemma bupd_alt_mono P Q : (P ⊢ Q) → bupd_alt P ⊢ bupd_alt Q.
- Proof. by intros ->. Qed.
- Lemma bupd_alt_trans P : bupd_alt (bupd_alt P) ⊢ bupd_alt P.
- Proof. iIntros "HP" (R) "H". iApply "HP". iIntros "HP". by iApply "HP". Qed.
- Lemma bupd_alt_frame_r P Q : bupd_alt P ∗ Q ⊢ bupd_alt (P ∗ Q).
- Proof.
- iIntros "[HP HQ]" (R) "H". iApply "HP". iIntros "HP". iApply ("H" with "[$]").
- Qed.
- Lemma bupd_alt_plainly P : bupd_alt (■P) ⊢ ■P.
- Proof. iIntros "H". iApply ("H" $! P with "[]"); auto. Qed.
-
- (** Any modality conforming with [BiBUpdPlainly] entails the alternative
- definition *)
- Lemma bupd_bupd_alt `{!BiBUpd PROP, BiBUpdPlainly PROP} P : (|==> P) ⊢ bupd_alt P.
- Proof. iIntros "HP" (R) "H". by iMod ("H" with "HP") as "?". Qed.
-
- (** We get the usual rule for frame preserving updates if we have an [own]
- connective satisfying the following rule w.r.t. interaction with plainly. *)
- Context {M : ucmraT} (own : M → PROP).
- Context (own_updateP_plainly : ∀ x Φ R,
- x ~~>: Φ →
- own x ∗ (∀ y, ⌜Φ y⌠-∗ own y -∗ ■R) ⊢ ■R).
-
- Lemma own_updateP x (Φ : M → Prop) :
- x ~~>: Φ → own x ⊢ bupd_alt (∃ y, ⌜Φ y⌠∧ own y).
- Proof.
- iIntros (Hup) "Hx"; iIntros (R) "H".
- iApply (own_updateP_plainly with "[$Hx H]"); first done.
- iIntros (y ?) "Hy". iApply "H"; auto.
- Qed.
-End bupd_alt.
-
-(** The alternative definition entails the ordinary basic update *)
-Lemma bupd_alt_bupd {M} (P : uPred M) : bupd_alt P ⊢ |==> P.
-Proof.
- rewrite /bupd_alt. uPred.unseal; split=> n x Hx H k y ? Hxy.
- unshelve refine (H {| uPred_holds k _ :=
- ∃ x' : M, ✓{k} (x' ⋅ y) ∧ P k x' |} k y _ _ _).
- - intros n1 n2 x1 x2 (z&?&?) _ ?.
- eauto using cmra_validN_le, uPred_mono.
- - done.
- - done.
- - intros k' z ?? HP. exists z. by rewrite (comm op).
-Qed.
-
-Lemma bupd_alt_bupd_iff {M} (P : uPred M) : bupd_alt P ⊣⊢ |==> P.
-Proof. apply (anti_symm _). apply bupd_alt_bupd. apply bupd_bupd_alt. Qed.
-
-(** The law about the interaction between [uPred_ownM] and plainly holds. *)
-Lemma ownM_updateP {M : ucmraT} x (Φ : M → Prop) (R : uPred M) :
- x ~~>: Φ →
- uPred_ownM x ∗ (∀ y, ⌜Φ y⌠-∗ uPred_ownM y -∗ ■R) ⊢ ■R.
-Proof.
- uPred.unseal=> Hup; split; intros n z Hv (?&z2&?&[z1 ?]&HR); ofe_subst.
- destruct (Hup n (Some (z1 â‹… z2))) as (y&?&?); simpl in *.
- { by rewrite assoc. }
- refine (HR y n z1 _ _ _ n y _ _ _); auto.
- - rewrite comm. by eapply cmra_validN_op_r.
- - by rewrite (comm _ _ y) (comm _ z2).
- - apply (reflexivity (R:=includedN _)).
-Qed.
diff --git a/theories/base_logic/derived.v b/theories/base_logic/derived.v
index 0adcc1a5c714ad87056f98e924db35bacaec7877..f406062d7dbf915df30bc17eacbedc5eaa95a20f 100644
--- a/theories/base_logic/derived.v
+++ b/theories/base_logic/derived.v
@@ -2,13 +2,14 @@ From iris.base_logic Require Export bi.
From iris.bi Require Export bi.
Set Default Proof Using "Type".
Import bi base_logic.bi.uPred.
+Require iris.bi.big_op.
-(** Derived laws for Iris-specific primitive connectives (own, valid).
- This file does NOT unseal! *)
+
+(** Derived (and not-so-derived) laws for Iris-specific primitive connectives (own, valid). *)
Module uPred.
Section derived.
-Context {M : ucmraT}.
+Context `{M : ucmraT SI}.
Implicit Types φ : Prop.
Implicit Types P Q : uPred M.
Implicit Types A : Type.
@@ -17,21 +18,122 @@ Implicit Types A : Type.
Notation "P ⊢ Q" := (bi_entails (PROP:=uPredI M) P%I Q%I).
Notation "P ⊣⊢ Q" := (equiv (A:=uPredI M) P%I Q%I).
+(* TODO: The following lemmas are currently proved in the model. Remove these once this has been fixed in sbi. *)
+Section remove_once_fixed.
+Global Instance pure_timeless φ : Timeless (PROP := uPredSI M) ⌜φâŒ.
+ apply uPred_primitive.pure_timeless.
+Qed.
+
+Global Instance emp_timeless `{BiAffine SI PROP} : Timeless (PROP:= uPredSI M) emp.
+Proof. rewrite -bi.True_emp. apply _. Qed.
+
+Lemma later_or_timeless P Q: Timeless P → Timeless Q → ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
+Proof. apply uPred_primitive.later_or_timeless. Qed.
+Global Instance or_timeless P Q : Timeless P → Timeless Q → Timeless (P ∨ Q).
+Proof.
+ intros; rewrite /Timeless bi.except_0_or later_or_timeless.
+ apply or_elim; [apply bi.or_intro_l', H | apply bi.or_intro_r', H0].
+Qed.
+
+Lemma later_sep_timeless P Q: Timeless P → Timeless Q → ▷ (P ∗ Q) ⊣⊢ ▷ P ∗ ▷ Q.
+Proof. apply uPred_primitive.later_sep_timeless. Qed.
+Global Instance sep_timeless P Q: Timeless P → Timeless Q → Timeless (P ∗ Q).
+Proof.
+ intros; rewrite /Timeless bi.except_0_sep later_sep_timeless. auto using bi.sep_mono.
+Qed.
+
+Global Instance wand_timeless P Q : Timeless Q → Timeless (P -∗ Q).
+Proof.
+ rewrite /Timeless=> HQ. rewrite bi.later_false_em.
+ apply bi.or_mono, bi.wand_intro_l; first done.
+ rewrite -{2}(bi.löb Q); apply bi.impl_intro_l.
+ rewrite HQ /sbi_except_0 !bi.and_or_r. apply bi.or_elim.
+ - by rewrite (comm _ P) bi.persistent_and_sep_assoc bi.impl_elim_r bi.wand_elim_l.
+ - apply bi.and_elim_l.
+Qed.
+
+Lemma later_exist_timeless {A} (Ψ : A → uPredSI M) :
+ (∀ x, Timeless (Ψ x)) → ▷ (∃ x, Ψ x) ⊢ ▷ False ∨ ∃ x, ▷ Ψ x.
+Proof. apply uPred_primitive.later_exist_timeless. Qed.
+
+Global Instance exist_timeless {A} (Ψ : A → uPredSI M) :
+ (∀ x, Timeless (Ψ x)) → Timeless (∃ x, Ψ x).
+Proof.
+ intros H; apply later_exist_timeless in H as Ht; rewrite /Timeless Ht. apply bi.or_elim.
+ - rewrite /sbi_except_0; apply bi.or_intro_l.
+ - apply bi.exist_elim=> x. rewrite -(bi.exist_intro x); auto. by apply H.
+Qed.
+Global Instance persistently_timeless P : Timeless P → Timeless (<pers> P).
+Proof.
+ intros. rewrite /Timeless /sbi_except_0 bi.later_persistently_1.
+ by rewrite H /sbi_except_0 bi.persistently_or {1}bi.persistently_elim.
+Qed.
+
+Global Instance absorbingly_timeless P : Timeless P → Timeless (<absorb> P).
+Proof. rewrite /bi_absorbingly; apply _. Qed.
+
+Global Instance intuitionistically_timeless P :
+ Timeless (PROP:= uPredSI M) emp → Timeless P → Timeless (□ P).
+Proof. rewrite /bi_intuitionistically; apply _. Qed.
+
+Global Instance eq_timeless {A : ofeT SI} (a b : A) :
+ Discrete a → Timeless (PROP:= uPredSI M) (a ≡ b).
+Proof. intros. rewrite /Discrete !bi.discrete_eq. apply pure_timeless. Qed.
+
+Import iris.bi.big_op.
+
+Global Instance big_sepL_timeless {A} (Φ : nat → A → uPredSI M) (l :list A) :
+ (∀ k x, Timeless (Φ k x)) → Timeless ([∗ list] k↦x ∈ l, Φ k x).
+Proof. revert Φ. induction l as [|x l IH]=> Φ ? /=; apply _. Qed.
+Global Instance big_sepL_timeless_id (Ps : list (uPredSI M)) :
+ TCForall Timeless Ps → Timeless ([∗] Ps).
+Proof. induction 1; simpl; apply _. Qed.
+
+Global Instance big_sepL2_timeless {A B} (Φ : nat → A → B → uPredSI M) l1 l2 :
+ (∀ k x1 x2, Timeless (Φ k x1 x2)) →
+ Timeless ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2).
+Proof. rewrite big_sepL2_alt. apply _. Qed.
+
+Global Instance big_sepM_timeless `{Countable K} {A} (Φ : K → A → uPredSI M) (m : gmap K A) :
+ (∀ k x, Timeless (Φ k x)) → Timeless ([∗ map] k↦x ∈ m, Φ k x).
+Proof. intros. apply big_sepL_timeless=> _ [??]; apply _. Qed.
+
+
+Global Instance big_sepM2_empty_timeless `{Countable K} {A B} (Φ : K → A → B → uPredSI M) :
+ Timeless ([∗ map] k↦x1;x2 ∈ ∅;∅, Φ k x1 x2).
+Proof. rewrite /big_sepM2 map_zip_with_empty. apply _. Qed.
+Global Instance big_sepM2_timeless `{Countable K} {A B} (Φ : K → A → B → uPredSI M) m1 m2 :
+ (∀ k x1 x2, Timeless (Φ k x1 x2)) →
+ Timeless ([∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2).
+Proof. intros. rewrite /big_sepM2. apply _. Qed.
+
+Global Instance big_sepS_timeless `{Countable A} (Φ : A → uPredSI M) (X : gset A) :
+ (∀ x, Timeless (Φ x)) → Timeless ([∗ set] x ∈ X, Φ x).
+Proof. rewrite /big_opS. apply _. Qed.
+
+Global Instance big_sepMS_timeless `{Countable A} (Φ : A → uPredSI M) (X : gmultiset A) :
+ (∀ x, Timeless (Φ x)) → Timeless ([∗ mset] x ∈ X, Φ x).
+Proof. rewrite /big_opMS. apply _. Qed.
+
+End remove_once_fixed.
+
+
+
(** Propers *)
-Global Instance uPred_valid_proper : Proper ((⊣⊢) ==> iff) (@uPred_valid M).
+Global Instance uPred_valid_proper : Proper ((⊣⊢) ==> iff) (@uPred_valid SI M).
Proof. solve_proper. Qed.
-Global Instance uPred_valid_mono : Proper ((⊢) ==> impl) (@uPred_valid M).
+Global Instance uPred_valid_mono : Proper ((⊢) ==> impl) (@uPred_valid SI M).
Proof. solve_proper. Qed.
Global Instance uPred_valid_flip_mono :
- Proper (flip (⊢) ==> flip impl) (@uPred_valid M).
+ Proper (flip (⊢) ==> flip impl) (@uPred_valid SI M).
Proof. solve_proper. Qed.
-Global Instance ownM_proper: Proper ((≡) ==> (⊣⊢)) (@uPred_ownM M) := ne_proper _.
-Global Instance cmra_valid_proper {A : cmraT} :
- Proper ((≡) ==> (⊣⊢)) (@uPred_cmra_valid M A) := ne_proper _.
+Global Instance ownM_proper: Proper ((≡) ==> (⊣⊢)) (@uPred_ownM SI M) := ne_proper _.
+Global Instance cmra_valid_proper {A : cmraT SI} :
+ Proper ((≡) ==> (⊣⊢)) (@uPred_cmra_valid SI M A) := ne_proper _.
(** Own and valid derived *)
-Lemma persistently_cmra_valid_1 {A : cmraT} (a : A) : ✓ a ⊢ <pers> (✓ a : uPred M).
+Lemma persistently_cmra_valid_1 {A : cmraT SI} (a : A) : ✓ a ⊢ <pers> (✓ a : uPred M).
Proof. by rewrite {1}plainly_cmra_valid_1 plainly_elim_persistently. Qed.
Lemma intuitionistically_ownM (a : M) : CoreId a → □ uPred_ownM a ⊣⊢ uPred_ownM a.
Proof.
@@ -39,15 +141,15 @@ Proof.
[by rewrite persistently_elim|].
by rewrite {1}persistently_ownM_core core_id_core.
Qed.
-Lemma ownM_invalid (a : M) : ¬ ✓{0} a → uPred_ownM a ⊢ False.
+Lemma ownM_invalid (a : M) : ¬ ✓{zero} a → uPred_ownM a ⊢ False.
Proof. by intros; rewrite ownM_valid cmra_valid_elim. Qed.
-Global Instance ownM_mono : Proper (flip (≼) ==> (⊢)) (@uPred_ownM M).
+Global Instance ownM_mono : Proper (flip (≼) ==> (⊢)) (@uPred_ownM SI M).
Proof. intros a b [b' ->]. by rewrite ownM_op sep_elim_l. Qed.
Lemma ownM_unit' : uPred_ownM ε ⊣⊢ True.
Proof. apply (anti_symm _); first by apply pure_intro. apply ownM_unit. Qed.
-Lemma plainly_cmra_valid {A : cmraT} (a : A) : ■✓ a ⊣⊢ ✓ a.
+Lemma plainly_cmra_valid {A : cmraT SI} (a : A) : ■✓ a ⊣⊢ ✓ a.
Proof. apply (anti_symm _), plainly_cmra_valid_1. apply plainly_elim, _. Qed.
-Lemma intuitionistically_cmra_valid {A : cmraT} (a : A) : □ ✓ a ⊣⊢ ✓ a.
+Lemma intuitionistically_cmra_valid {A : cmraT SI} (a : A) : □ ✓ a ⊣⊢ ✓ a.
Proof.
rewrite /bi_intuitionistically affine_affinely. intros; apply (anti_symm _);
first by rewrite persistently_elim.
@@ -55,40 +157,41 @@ Proof.
Qed.
Lemma bupd_ownM_update x y : x ~~> y → uPred_ownM x ⊢ |==> uPred_ownM y.
Proof.
- intros; rewrite (bupd_ownM_updateP _ (y =)); last by apply cmra_update_updateP.
+ intros; rewrite (bupd_ownM_updateP _ (eq y)); last by apply cmra_update_updateP.
by apply bupd_mono, exist_elim=> y'; apply pure_elim_l=> ->.
Qed.
(** Timeless instances *)
-Global Instance valid_timeless {A : cmraT} `{!CmraDiscrete A} (a : A) :
+Global Instance valid_timeless {A : cmraT SI} `{!CmraDiscrete A} (a : A) :
Timeless (✓ a : uPred M)%I.
Proof. rewrite /Timeless !discrete_valid. apply (timeless _). Qed.
+Arguments uPred_holds {_ _} _%I _ _ : simpl nomatch.
Global Instance ownM_timeless (a : M) : Discrete a → Timeless (uPred_ownM a).
Proof.
- intros ?. rewrite /Timeless later_ownM. apply exist_elim=> b.
- rewrite (timeless (a≡b)) (except_0_intro (uPred_ownM b)) -except_0_and.
- apply except_0_mono. rewrite internal_eq_sym.
- apply (internal_eq_rewrite' b a (uPred_ownM) _);
- auto using and_elim_l, and_elim_r.
+ (* TODO: find proof which does not unseal *)
+ intros ?. rewrite /Timeless. unfold sbi_except_0. unseal. split=> n x Hv //=.
+ destruct (index_lt_dec_minimum n) as [|[m]]; eauto.
+ assert (zero ≺ n) as Hterm by eauto using index_le_lt_trans.
+ intros Hlt; right; eapply cmra_included_includedN, cmra_discrete_included_l; eauto using cmra_validN_le.
Qed.
(** Plainness *)
-Global Instance cmra_valid_plain {A : cmraT} (a : A) :
+Global Instance cmra_valid_plain {A : cmraT SI} (a : A) :
Plain (✓ a : uPred M)%I.
Proof. rewrite /Persistent. apply plainly_cmra_valid_1. Qed.
(** Persistence *)
-Global Instance cmra_valid_persistent {A : cmraT} (a : A) :
+Global Instance cmra_valid_persistent {A : cmraT SI} (a : A) :
Persistent (✓ a : uPred M)%I.
Proof. rewrite /Persistent. apply persistently_cmra_valid_1. Qed.
-Global Instance ownM_persistent a : CoreId a → Persistent (@uPred_ownM M a).
+Global Instance ownM_persistent a : CoreId a → Persistent (@uPred_ownM SI M a).
Proof.
intros. rewrite /Persistent -{2}(core_id_core a). apply persistently_ownM_core.
Qed.
(** For big ops *)
Global Instance uPred_ownM_sep_homomorphism :
- MonoidHomomorphism op uPred_sep (≡) (@uPred_ownM M).
+ MonoidHomomorphism op uPred_sep (≡) (@uPred_ownM SI M).
Proof. split; [split; try apply _|]. apply ownM_op. apply ownM_unit'. Qed.
(** Consistency/soundness statement *)
@@ -105,11 +208,18 @@ Proof.
- intros H. by apply IH, later_soundness.
Qed.
+(* TODO: go through the interface *)
+Lemma transfinite_soundness φ `{TransfiniteIndex SI}: ((⧠⌜φâŒ)%I : uPred M) → φ.
+Proof.
+ intros H'; eapply pure_soundness, uPred_primitive.big_later_soundness, H'.
+Qed.
+
Corollary consistency_modal n : ¬ (▷^n False : uPred M)%I.
Proof. exact (soundness False n). Qed.
Corollary consistency : ¬(False : uPred M)%I.
Proof. exact (consistency_modal 0). Qed.
+
End derived.
End uPred.
diff --git a/theories/base_logic/lib/auth.v b/theories/base_logic/lib/auth.v
deleted file mode 100644
index c5a8b494a3e540ae9e5ee66c339da83fc6571ad4..0000000000000000000000000000000000000000
--- a/theories/base_logic/lib/auth.v
+++ /dev/null
@@ -1,169 +0,0 @@
-From iris.base_logic.lib Require Export invariants.
-From iris.algebra Require Export auth.
-From iris.algebra Require Import gmap.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-Import uPred.
-
-(* The CMRA we need. *)
-Class authG Σ (A : ucmraT) := AuthG {
- auth_inG :> inG Σ (authR A);
- auth_cmra_discrete :> CmraDiscrete A;
-}.
-Definition authΣ (A : ucmraT) : gFunctors := #[ GFunctor (authR A) ].
-
-Instance subG_authΣ Σ A : subG (authΣ A) Σ → CmraDiscrete A → authG Σ A.
-Proof. solve_inG. Qed.
-
-Section definitions.
- Context `{!invG Σ, !authG Σ A} {T : Type} (γ : gname).
-
- Definition auth_own (a : A) : iProp Σ :=
- own γ (◯ a).
- Definition auth_inv (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
- (∃ t, own γ (◠f t) ∗ φ t)%I.
- Definition auth_ctx (N : namespace) (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
- inv N (auth_inv f φ).
-
- Global Instance auth_own_ne : NonExpansive auth_own.
- Proof. solve_proper. Qed.
- Global Instance auth_own_proper : Proper ((≡) ==> (⊣⊢)) auth_own.
- Proof. solve_proper. Qed.
- Global Instance auth_own_timeless a : Timeless (auth_own a).
- Proof. apply _. Qed.
- Global Instance auth_own_core_id a : CoreId a → Persistent (auth_own a).
- Proof. apply _. Qed.
-
- Global Instance auth_inv_ne n :
- Proper (pointwise_relation T (dist n) ==>
- pointwise_relation T (dist n) ==> dist n) auth_inv.
- Proof. solve_proper. Qed.
- Global Instance auth_inv_proper :
- Proper (pointwise_relation T (≡) ==>
- pointwise_relation T (⊣⊢) ==> (⊣⊢)) auth_inv.
- Proof. solve_proper. Qed.
- Global Instance auth_ctx_ne N n :
- Proper (pointwise_relation T (dist n) ==>
- pointwise_relation T (dist n) ==> dist n) (auth_ctx N).
- Proof. solve_proper. Qed.
- Global Instance auth_ctx_proper N :
- Proper (pointwise_relation T (≡) ==>
- pointwise_relation T (⊣⊢) ==> (⊣⊢)) (auth_ctx N).
- Proof. solve_proper. Qed.
- Global Instance auth_ctx_persistent N f φ : Persistent (auth_ctx N f φ).
- Proof. apply _. Qed.
-End definitions.
-
-Typeclasses Opaque auth_own auth_inv auth_ctx.
-Instance: Params (@auth_own) 4 := {}.
-Instance: Params (@auth_inv) 5 := {}.
-Instance: Params (@auth_ctx) 7 := {}.
-
-Section auth.
- Context `{!invG Σ, !authG Σ A}.
- Context {T : Type} `{!Inhabited T}.
- Context (f : T → A) (φ : T → iProp Σ).
- Implicit Types N : namespace.
- Implicit Types P Q R : iProp Σ.
- Implicit Types a b : A.
- Implicit Types t u : T.
- Implicit Types γ : gname.
-
- Lemma auth_own_op γ a b : auth_own γ (a ⋅ b) ⊣⊢ auth_own γ a ∗ auth_own γ b.
- Proof. by rewrite /auth_own -own_op auth_frag_op. Qed.
-
-(*
- Global Instance from_and_auth_own γ a b1 b2 :
- IsOp a b1 b2 →
- FromAnd false (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
- Proof. rewrite /IsOp /FromAnd=> ->. by rewrite auth_own_op. Qed.
- Global Instance from_and_auth_own_persistent γ a b1 b2 :
- IsOp a b1 b2 → Or (CoreId b1) (CoreId b2) →
- FromAnd true (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 91.
- Proof.
- intros ? Hper; apply mk_from_and_persistent; [destruct Hper; apply _|].
- by rewrite -auth_own_op -is_op.
- Qed.
-
- Global Instance into_and_auth_own p γ a b1 b2 :
- IsOp a b1 b2 →
- IntoAnd p (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
- Proof. intros. apply mk_into_and_sep. by rewrite (is_op a) auth_own_op. Qed.
-*)
-
- Lemma auth_own_mono γ a b : a ≼ b → auth_own γ b ⊢ auth_own γ a.
- Proof. intros [? ->]. by rewrite auth_own_op sep_elim_l. Qed.
- Lemma auth_own_valid γ a : auth_own γ a ⊢ ✓ a.
- Proof. by rewrite /auth_own own_valid auth_frag_validI. Qed.
- Global Instance auth_own_sep_homomorphism γ :
- WeakMonoidHomomorphism op uPred_sep (≡) (auth_own γ).
- Proof. split; try apply _. apply auth_own_op. Qed.
-
- Global Instance own_mono' γ : Proper (flip (≼) ==> (⊢)) (auth_own γ).
- Proof. intros a1 a2. apply auth_own_mono. Qed.
-
- Lemma auth_alloc_strong N E t (I : gname → Prop) :
- pred_infinite I →
- ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, ⌜I γ⌠∧ auth_ctx γ N f φ ∧ auth_own γ (f t).
- Proof.
- iIntros (??) "Hφ". rewrite /auth_own /auth_ctx.
- iMod (own_alloc_strong (◠f t ⋅ ◯ f t) I) as (γ) "[% [Hγ Hγ']]";
- [done|by apply auth_both_valid|].
- iMod (inv_alloc N _ (auth_inv γ f φ) with "[-Hγ']") as "#?".
- { iNext. rewrite /auth_inv. iExists t. by iFrame. }
- eauto.
- Qed.
-
- Lemma auth_alloc_cofinite N E t (G : gset gname) :
- ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, ⌜γ ∉ G⌠∧ auth_ctx γ N f φ ∧ auth_own γ (f t).
- Proof.
- intros ?. apply auth_alloc_strong=>//.
- apply (pred_infinite_set (C:=gset gname)) => E'.
- exists (fresh (G ∪ E')). apply not_elem_of_union, is_fresh.
- Qed.
-
- Lemma auth_alloc N E t :
- ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, auth_ctx γ N f φ ∧ auth_own γ (f t).
- Proof.
- iIntros (?) "Hφ".
- iMod (auth_alloc_cofinite N E t ∅ with "Hφ") as (γ) "[_ ?]"; eauto.
- Qed.
-
- Lemma auth_empty γ : (|==> auth_own γ ε)%I.
- Proof. by rewrite /auth_own -own_unit. Qed.
-
- Lemma auth_acc E γ a :
- ▷ auth_inv γ f φ ∗ auth_own γ a ={E}=∗ ∃ t,
- ⌜a ≼ f t⌠∗ ▷ φ t ∗ ∀ u b,
- ⌜(f t, a) ~l~> (f u, b)⌠∗ ▷ φ u ={E}=∗ ▷ auth_inv γ f φ ∗ auth_own γ b.
- Proof using Type*.
- iIntros "[Hinv Hγf]". rewrite /auth_inv /auth_own.
- iDestruct "Hinv" as (t) "[>Hγa Hφ]".
- iModIntro. iExists t.
- iDestruct (own_valid_2 with "Hγa Hγf") as % [? ?]%auth_both_valid.
- iSplit; first done. iFrame. iIntros (u b) "[% Hφ]".
- iMod (own_update_2 with "Hγa Hγf") as "[Hγa Hγf]".
- { eapply auth_update; eassumption. }
- iModIntro. iFrame. iExists u. iFrame.
- Qed.
-
- Lemma auth_open E N γ a :
- ↑N ⊆ E →
- auth_ctx γ N f φ ∗ auth_own γ a ={E,E∖↑N}=∗ ∃ t,
- ⌜a ≼ f t⌠∗ ▷ φ t ∗ ∀ u b,
- ⌜(f t, a) ~l~> (f u, b)⌠∗ ▷ φ u ={E∖↑N,E}=∗ auth_own γ b.
- Proof using Type*.
- iIntros (?) "[#? Hγf]". rewrite /auth_ctx. iInv N as "Hinv" "Hclose".
- (* The following is essentially a very trivial composition of the accessors
- [auth_acc] and [inv_open] -- but since we don't have any good support
- for that currently, this gets more tedious than it should, with us having
- to unpack and repack various proofs.
- TODO: Make this mostly automatic, by supporting "opening accessors
- around accessors". *)
- iMod (auth_acc with "[$Hinv $Hγf]") as (t) "(?&?&HclAuth)".
- iModIntro. iExists t. iFrame. iIntros (u b) "H".
- iMod ("HclAuth" $! u b with "H") as "(Hinv & ?)". by iMod ("Hclose" with "Hinv").
- Qed.
-End auth.
-
-Arguments auth_open {_ _ _} [_] {_} [_] _ _ _ _ _ _ _.
diff --git a/theories/base_logic/lib/boxes.v b/theories/base_logic/lib/boxes.v
deleted file mode 100644
index 9d71aab4d32667404baedee3bf0f20126cbbc41b..0000000000000000000000000000000000000000
--- a/theories/base_logic/lib/boxes.v
+++ /dev/null
@@ -1,311 +0,0 @@
-From iris.base_logic.lib Require Export invariants.
-From iris.algebra Require Import excl auth gmap agree.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-Import uPred.
-
-(** The CMRAs we need. *)
-Class boxG Σ :=
- boxG_inG :> inG Σ (prodR
- (authR (optionUR (exclR boolO)))
- (optionR (agreeR (laterO (iPreProp Σ))))).
-
-Definition boxΣ : gFunctors := #[ GFunctor (authR (optionUR (exclR boolO)) *
- optionRF (agreeRF (▶ ∙)) ) ].
-
-Instance subG_boxΣ Σ : subG boxΣ Σ → boxG Σ.
-Proof. solve_inG. Qed.
-
-Section box_defs.
- Context `{!invG Σ, !boxG Σ} (N : namespace).
-
- Definition slice_name := gname.
-
- Definition box_own_auth (γ : slice_name) (a : auth (option (excl bool))) : iProp Σ :=
- own γ (a, None).
-
- Definition box_own_prop (γ : slice_name) (P : iProp Σ) : iProp Σ :=
- own γ (ε, Some (to_agree (Next (iProp_unfold P)))).
-
- Definition slice_inv (γ : slice_name) (P : iProp Σ) : iProp Σ :=
- (∃ b, box_own_auth γ (◠Excl' b) ∗ if b then P else True)%I.
-
- Definition slice (γ : slice_name) (P : iProp Σ) : iProp Σ :=
- (box_own_prop γ P ∗ inv N (slice_inv γ P))%I.
-
- Definition box (f : gmap slice_name bool) (P : iProp Σ) : iProp Σ :=
- (∃ Φ : slice_name → iProp Σ,
- ▷ (P ≡ [∗ map] γ ↦ _ ∈ f, Φ γ) ∗
- [∗ map] γ ↦ b ∈ f, box_own_auth γ (◯ Excl' b) ∗ box_own_prop γ (Φ γ) ∗
- inv N (slice_inv γ (Φ γ)))%I.
-End box_defs.
-
-Instance: Params (@box_own_prop) 3 := {}.
-Instance: Params (@slice_inv) 3 := {}.
-Instance: Params (@slice) 5 := {}.
-Instance: Params (@box) 5 := {}.
-
-Section box.
-Context `{!invG Σ, !boxG Σ} (N : namespace).
-Implicit Types P Q : iProp Σ.
-
-Global Instance box_own_prop_ne γ : NonExpansive (box_own_prop γ).
-Proof. solve_proper. Qed.
-Global Instance box_own_prop_contractive γ : Contractive (box_own_prop γ).
-Proof. solve_contractive. Qed.
-
-Global Instance box_inv_ne γ : NonExpansive (slice_inv γ).
-Proof. solve_proper. Qed.
-
-Global Instance slice_ne γ : NonExpansive (slice N γ).
-Proof. solve_proper. Qed.
-Global Instance slice_contractive γ : Contractive (slice N γ).
-Proof. solve_contractive. Qed.
-Global Instance slice_proper γ : Proper ((≡) ==> (≡)) (slice N γ).
-Proof. apply ne_proper, _. Qed.
-
-Global Instance slice_persistent γ P : Persistent (slice N γ P).
-Proof. apply _. Qed.
-
-Global Instance box_contractive f : Contractive (box N f).
-Proof. solve_contractive. Qed.
-Global Instance box_ne f : NonExpansive (box N f).
-Proof. apply (contractive_ne _). Qed.
-Global Instance box_proper f : Proper ((≡) ==> (≡)) (box N f).
-Proof. apply ne_proper, _. Qed.
-
-Lemma box_own_auth_agree γ b1 b2 :
- box_own_auth γ (â— Excl' b1) ∗ box_own_auth γ (â—¯ Excl' b2) ⊢ ⌜b1 = b2âŒ.
-Proof.
- rewrite /box_own_prop -own_op own_valid prod_validI /= and_elim_l.
- by iDestruct 1 as % [[[] [=]%leibniz_equiv] ?]%auth_both_valid.
-Qed.
-
-Lemma box_own_auth_update γ b1 b2 b3 :
- box_own_auth γ (◠Excl' b1) ∗ box_own_auth γ (◯ Excl' b2)
- ==∗ box_own_auth γ (◠Excl' b3) ∗ box_own_auth γ (◯ Excl' b3).
-Proof.
- rewrite /box_own_auth -!own_op. apply own_update, prod_update; last done.
- by apply auth_update, option_local_update, exclusive_local_update.
-Qed.
-
-Lemma box_own_agree γ Q1 Q2 :
- box_own_prop γ Q1 ∗ box_own_prop γ Q2 ⊢ ▷ (Q1 ≡ Q2).
-Proof.
- rewrite /box_own_prop -own_op own_valid prod_validI /= and_elim_r.
- rewrite option_validI /= agree_validI agree_equivI later_equivI /=.
- iIntros "#HQ". iNext. rewrite -{2}(iProp_fold_unfold Q1).
- iRewrite "HQ". by rewrite iProp_fold_unfold.
-Qed.
-
-Lemma box_alloc : box N ∅ True%I.
-Proof.
- iIntros. iExists (λ _, True)%I. iSplit; by auto.
-Qed.
-
-Lemma slice_insert_empty E q f Q P :
- ▷?q box N f P ={E}=∗ ∃ γ, ⌜f !! γ = None⌠∗
- slice N γ Q ∗ ▷?q box N (<[γ:=false]> f) (Q ∗ P).
-Proof.
- iDestruct 1 as (Φ) "[#HeqP Hf]".
- iMod (own_alloc_cofinite (â— Excl' false â‹… â—¯ Excl' false,
- Some (to_agree (Next (iProp_unfold Q)))) (dom _ f))
- as (γ) "[Hdom Hγ]"; first by (split; [apply auth_both_valid|]).
- rewrite pair_split. iDestruct "Hγ" as "[[Hγ Hγ'] #HγQ]".
- iDestruct "Hdom" as % ?%not_elem_of_dom.
- iMod (inv_alloc N _ (slice_inv γ Q) with "[Hγ]") as "#Hinv".
- { iNext. iExists false; eauto. }
- iModIntro; iExists γ; repeat iSplit; auto.
- iNext. iExists (<[γ:=Q]> Φ); iSplit.
- - iNext. iRewrite "HeqP". by rewrite big_opM_fn_insert'.
- - rewrite (big_opM_fn_insert (λ _ _ P', _ ∗ _ _ P' ∗ _ _ (_ _ P')))%I //.
- iFrame; eauto.
-Qed.
-
-Lemma slice_delete_empty E q f P Q γ :
- ↑N ⊆ E →
- f !! γ = Some false →
- slice N γ Q -∗ ▷?q box N f P ={E}=∗ ∃ P',
- ▷?q (▷ (P ≡ (Q ∗ P')) ∗ box N (delete γ f) P').
-Proof.
- iIntros (??) "[#HγQ Hinv] H". iDestruct "H" as (Φ) "[#HeqP Hf]".
- iExists ([∗ map] γ'↦_ ∈ delete γ f, Φ γ')%I.
- iInv N as (b) "[>Hγ _]".
- iDestruct (big_opM_delete _ f _ false with "Hf")
- as "[[>Hγ' #[HγΦ ?]] ?]"; first done.
- iDestruct (box_own_auth_agree γ b false with "[-]") as %->; first by iFrame.
- iModIntro. iSplitL "Hγ"; first iExists false; eauto.
- iModIntro. iNext. iSplit.
- - iDestruct (box_own_agree γ Q (Φ γ) with "[#]") as "HeqQ"; first by eauto.
- iNext. iRewrite "HeqP". iRewrite "HeqQ". by rewrite -big_opM_delete.
- - iExists Φ; eauto.
-Qed.
-
-Lemma slice_fill E q f γ P Q :
- ↑N ⊆ E →
- f !! γ = Some false →
- slice N γ Q -∗ ▷ Q -∗ ▷?q box N f P ={E}=∗ ▷?q box N (<[γ:=true]> f) P.
-Proof.
- iIntros (??) "#[HγQ Hinv] HQ H"; iDestruct "H" as (Φ) "[#HeqP Hf]".
- iInv N as (b') "[>Hγ _]".
- iDestruct (big_opM_delete _ f _ false with "Hf")
- as "[[>Hγ' #[HγΦ Hinv']] ?]"; first done.
- iMod (box_own_auth_update γ b' false true with "[$Hγ $Hγ']") as "[Hγ Hγ']".
- iModIntro. iSplitL "Hγ HQ"; first (iNext; iExists true; by iFrame).
- iModIntro; iNext; iExists Φ; iSplit.
- - by rewrite big_opM_insert_override.
- - rewrite -insert_delete big_opM_insert ?lookup_delete //.
- iFrame; eauto.
-Qed.
-
-Lemma slice_empty E q f P Q γ :
- ↑N ⊆ E →
- f !! γ = Some true →
- slice N γ Q -∗ ▷?q box N f P ={E}=∗ ▷ Q ∗ ▷?q box N (<[γ:=false]> f) P.
-Proof.
- iIntros (??) "#[HγQ Hinv] H"; iDestruct "H" as (Φ) "[#HeqP Hf]".
- iInv N as (b) "[>Hγ HQ]".
- iDestruct (big_opM_delete _ f with "Hf")
- as "[[>Hγ' #[HγΦ Hinv']] ?]"; first done.
- iDestruct (box_own_auth_agree γ b true with "[-]") as %->; first by iFrame.
- iFrame "HQ".
- iMod (box_own_auth_update γ with "[$Hγ $Hγ']") as "[Hγ Hγ']".
- iModIntro. iSplitL "Hγ"; first (iNext; iExists false; by repeat iSplit).
- iModIntro; iNext; iExists Φ; iSplit.
- - by rewrite big_opM_insert_override.
- - rewrite -insert_delete big_opM_insert ?lookup_delete //.
- iFrame; eauto.
-Qed.
-
-Lemma slice_insert_full E q f P Q :
- ↑N ⊆ E →
- ▷ Q -∗ ▷?q box N f P ={E}=∗ ∃ γ, ⌜f !! γ = None⌠∗
- slice N γ Q ∗ ▷?q box N (<[γ:=true]> f) (Q ∗ P).
-Proof.
- iIntros (?) "HQ Hbox".
- iMod (slice_insert_empty with "Hbox") as (γ ?) "[#Hslice Hbox]".
- iExists γ. iFrame "%#". iMod (slice_fill with "Hslice HQ Hbox"); first done.
- by apply lookup_insert. by rewrite insert_insert.
-Qed.
-
-Lemma slice_delete_full E q f P Q γ :
- ↑N ⊆ E →
- f !! γ = Some true →
- slice N γ Q -∗ ▷?q box N f P ={E}=∗
- ∃ P', ▷ Q ∗ ▷?q ▷ (P ≡ (Q ∗ P')) ∗ ▷?q box N (delete γ f) P'.
-Proof.
- iIntros (??) "#Hslice Hbox".
- iMod (slice_empty with "Hslice Hbox") as "[$ Hbox]"; try done.
- iMod (slice_delete_empty with "Hslice Hbox") as (P') "[Heq Hbox]"; first done.
- { by apply lookup_insert. }
- iExists P'. iFrame. rewrite -insert_delete delete_insert ?lookup_delete //.
-Qed.
-
-Lemma box_fill E f P :
- ↑N ⊆ E →
- box N f P -∗ ▷ P ={E}=∗ box N (const true <$> f) P.
-Proof.
- iIntros (?) "H HP"; iDestruct "H" as (Φ) "[#HeqP Hf]".
- iExists Φ; iSplitR; first by rewrite big_opM_fmap.
- iEval (rewrite internal_eq_iff later_iff big_sepM_later) in "HeqP".
- iDestruct ("HeqP" with "HP") as "HP".
- iCombine "Hf" "HP" as "Hf".
- rewrite -big_sepM_sep big_opM_fmap; iApply (fupd_big_sepM _ _ f).
- iApply (@big_sepM_impl with "Hf").
- iIntros "!#" (γ b' ?) "[(Hγ' & #$ & #$) HΦ]".
- iInv N as (b) "[>Hγ _]".
- iMod (box_own_auth_update γ with "[Hγ Hγ']") as "[Hγ $]"; first by iFrame.
- iModIntro. iSplitL; last done. iNext; iExists true. iFrame.
-Qed.
-
-Lemma box_empty E f P :
- ↑N ⊆ E →
- map_Forall (λ _, (true =)) f →
- box N f P ={E}=∗ ▷ P ∗ box N (const false <$> f) P.
-Proof.
- iDestruct 1 as (Φ) "[#HeqP Hf]".
- iAssert (([∗ map] γ↦b ∈ f, ▷ Φ γ) ∗
- [∗ map] γ↦b ∈ f, box_own_auth γ (◯ Excl' false) ∗ box_own_prop γ (Φ γ) ∗
- inv N (slice_inv γ (Φ γ)))%I with "[> Hf]" as "[HΦ ?]".
- { rewrite -big_sepM_sep -fupd_big_sepM. iApply (@big_sepM_impl with "[$Hf]").
- iIntros "!#" (γ b ?) "(Hγ' & #HγΦ & #Hinv)".
- assert (true = b) as <- by eauto.
- iInv N as (b) "[>Hγ HΦ]".
- iDestruct (box_own_auth_agree γ b true with "[-]") as %->; first by iFrame.
- iMod (box_own_auth_update γ true true false with "[$Hγ $Hγ']") as "[Hγ $]".
- iModIntro. iSplitL "Hγ"; first (iNext; iExists false; iFrame; eauto).
- iFrame "HγΦ Hinv". by iApply "HΦ". }
- iModIntro; iSplitL "HΦ".
- - rewrite internal_eq_iff later_iff big_sepM_later. by iApply "HeqP".
- - iExists Φ; iSplit; by rewrite big_opM_fmap.
-Qed.
-
-Lemma slice_iff E q f P Q Q' γ b :
- ↑N ⊆ E → f !! γ = Some b →
- ▷ □ (Q ↔ Q') -∗ slice N γ Q -∗ ▷?q box N f P ={E}=∗ ∃ γ' P',
- ⌜delete γ f !! γ' = None⌠∗ ▷?q ▷ □ (P ↔ P') ∗
- slice N γ' Q' ∗ ▷?q box N (<[γ' := b]>(delete γ f)) P'.
-Proof.
- iIntros (??) "#HQQ' #Hs Hb". destruct b.
- - iMod (slice_delete_full with "Hs Hb") as (P') "(HQ & Heq & Hb)"; try done.
- iDestruct ("HQQ'" with "HQ") as "HQ'".
- iMod (slice_insert_full with "HQ' Hb") as (γ' ?) "[#Hs' Hb]"; try done.
- iExists γ', _. iIntros "{$∗ $# $%} !>". do 2 iNext. iRewrite "Heq".
- iAlways. by iSplit; iIntros "[? $]"; iApply "HQQ'".
- - iMod (slice_delete_empty with "Hs Hb") as (P') "(Heq & Hb)"; try done.
- iMod (slice_insert_empty with "Hb") as (γ' ?) "[#Hs' Hb]"; try done.
- iExists γ', (Q' ∗ P')%I. iIntros "{$∗ $# $%} !>". do 2 iNext. iRewrite "Heq".
- iAlways. by iSplit; iIntros "[? $]"; iApply "HQQ'".
-Qed.
-
-Lemma slice_split E q f P Q1 Q2 γ b :
- ↑N ⊆ E → f !! γ = Some b →
- slice N γ (Q1 ∗ Q2) -∗ ▷?q box N f P ={E}=∗ ∃ γ1 γ2,
- ⌜delete γ f !! γ1 = None⌠∗ ⌜delete γ f !! γ2 = None⌠∗ ⌜γ1 ≠γ2⌠∗
- slice N γ1 Q1 ∗ slice N γ2 Q2 ∗ ▷?q box N (<[γ2 := b]>(<[γ1 := b]>(delete γ f))) P.
-Proof.
- iIntros (??) "#Hslice Hbox". destruct b.
- - iMod (slice_delete_full with "Hslice Hbox") as (P') "([HQ1 HQ2] & Heq & Hbox)"; try done.
- iMod (slice_insert_full with "HQ1 Hbox") as (γ1 ?) "[#Hslice1 Hbox]"; first done.
- iMod (slice_insert_full with "HQ2 Hbox") as (γ2 ?) "[#Hslice2 Hbox]"; first done.
- iExists γ1, γ2. iIntros "{$% $#} !>". iSplit; last iSplit; try iPureIntro.
- { by eapply lookup_insert_None. }
- { by apply (lookup_insert_None (delete γ f) γ1 γ2 true). }
- iNext. iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq] Hbox").
- iNext. iRewrite "Heq". iPureIntro. by rewrite assoc (comm _ Q2).
- - iMod (slice_delete_empty with "Hslice Hbox") as (P') "[Heq Hbox]"; try done.
- iMod (slice_insert_empty with "Hbox") as (γ1 ?) "[#Hslice1 Hbox]".
- iMod (slice_insert_empty with "Hbox") as (γ2 ?) "[#Hslice2 Hbox]".
- iExists γ1, γ2. iIntros "{$% $#} !>". iSplit; last iSplit; try iPureIntro.
- { by eapply lookup_insert_None. }
- { by apply (lookup_insert_None (delete γ f) γ1 γ2 false). }
- iNext. iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq] Hbox").
- iNext. iRewrite "Heq". iPureIntro. by rewrite assoc (comm _ Q2).
-Qed.
-
-Lemma slice_combine E q f P Q1 Q2 γ1 γ2 b :
- ↑N ⊆ E → γ1 ≠γ2 → f !! γ1 = Some b → f !! γ2 = Some b →
- slice N γ1 Q1 -∗ slice N γ2 Q2 -∗ ▷?q box N f P ={E}=∗ ∃ γ,
- ⌜delete γ2 (delete γ1 f) !! γ = None⌠∗ slice N γ (Q1 ∗ Q2) ∗
- ▷?q box N (<[γ := b]>(delete γ2 (delete γ1 f))) P.
-Proof.
- iIntros (????) "#Hslice1 #Hslice2 Hbox". destruct b.
- - iMod (slice_delete_full with "Hslice1 Hbox") as (P1) "(HQ1 & Heq1 & Hbox)"; try done.
- iMod (slice_delete_full with "Hslice2 Hbox") as (P2) "(HQ2 & Heq2 & Hbox)"; first done.
- { by simplify_map_eq. }
- iMod (slice_insert_full _ _ _ _ (Q1 ∗ Q2)%I with "[$HQ1 $HQ2] Hbox")
- as (γ ?) "[#Hslice Hbox]"; first done.
- iExists γ. iIntros "{$% $#} !>". iNext.
- iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq1 Heq2] Hbox").
- iNext. iRewrite "Heq1". iRewrite "Heq2". by rewrite assoc.
- - iMod (slice_delete_empty with "Hslice1 Hbox") as (P1) "(Heq1 & Hbox)"; try done.
- iMod (slice_delete_empty with "Hslice2 Hbox") as (P2) "(Heq2 & Hbox)"; first done.
- { by simplify_map_eq. }
- iMod (slice_insert_empty with "Hbox") as (γ ?) "[#Hslice Hbox]".
- iExists γ. iIntros "{$% $#} !>". iNext.
- iApply (internal_eq_rewrite_contractive _ _ (λ P, _) with "[Heq1 Heq2] Hbox").
- iNext. iRewrite "Heq1". iRewrite "Heq2". by rewrite assoc.
-Qed.
-End box.
-
-Typeclasses Opaque slice box.
diff --git a/theories/base_logic/lib/cancelable_invariants.v b/theories/base_logic/lib/cancelable_invariants.v
index 78288c7e08ebd9fd2dc521eab426f6cb1d3af7ed..c5efef5da165cb654a6aa348de05fb0e3fd919d8 100644
--- a/theories/base_logic/lib/cancelable_invariants.v
+++ b/theories/base_logic/lib/cancelable_invariants.v
@@ -5,14 +5,14 @@ From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.
-Class cinvG Σ := cinv_inG :> inG Σ fracR.
-Definition cinvΣ : gFunctors := #[GFunctor fracR].
+Class cinvG {SI} Σ := cinv_inG :> inG Σ (fracR SI).
+Definition cinvΣ SI : gFunctors SI := #[GFunctor (fracR SI)].
-Instance subG_cinvΣ {Σ} : subG cinvΣ Σ → cinvG Σ.
+Instance subG_cinvΣ {SI} {Σ} : subG (cinvΣ SI) Σ → cinvG Σ.
Proof. solve_inG. Qed.
Section defs.
- Context `{!invG Σ, !cinvG Σ}.
+ Context {SI} {Σ : gFunctors SI} `{!invG Σ, !cinvG Σ}.
Definition cinv_own (γ : gname) (p : frac) : iProp Σ := own γ p.
@@ -20,10 +20,10 @@ Section defs.
(∃ P', □ ▷ (P ↔ P') ∗ inv N (P' ∨ cinv_own γ 1%Qp))%I.
End defs.
-Instance: Params (@cinv) 5 := {}.
+Instance: Params (@cinv) 6 := {}.
Section proofs.
- Context `{!invG Σ, !cinvG Σ}.
+ Context {SI} {Σ : gFunctors SI} `{!invG Σ, !cinvG Σ}.
Global Instance cinv_own_timeless γ p : Timeless (cinv_own γ p).
Proof. rewrite /cinv_own; apply _. Qed.
@@ -64,7 +64,7 @@ Section proofs.
Lemma cinv_alloc_strong (I : gname → Prop) E N :
pred_infinite I →
- (|={E}=> ∃ γ, ⌜ I γ ⌠∧ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P)%I.
+ ⊢ (|={E}=> ∃ γ, ⌜ I γ ⌠∧ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P)%I.
Proof.
iIntros (?). iMod (own_alloc_strong 1%Qp I) as (γ) "[Hfresh Hγ]"; [done|done|].
iExists γ; iIntros "!> {$Hγ $Hfresh}" (P) "HP".
@@ -73,13 +73,13 @@ Section proofs.
Qed.
Lemma cinv_alloc_cofinite (G : gset gname) E N :
- (|={E}=> ∃ γ, ⌜ γ ∉ G ⌠∧ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P)%I.
+ ⊢ (|={E}=> ∃ γ, ⌜ γ ∉ G ⌠∧ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P)%I.
Proof.
apply cinv_alloc_strong. apply (pred_infinite_set (C:=gset gname))=> E'.
exists (fresh (G ∪ E')). apply not_elem_of_union, is_fresh.
Qed.
- Lemma cinv_open_strong E N γ p P :
+ Lemma cinv_open_strong `{FiniteBoundedExistential SI} E N γ p P :
↑N ⊆ E →
cinv N γ P -∗ cinv_own γ p ={E,E∖↑N}=∗
▷ P ∗ cinv_own γ p ∗ (▷ P ∨ cinv_own γ 1 ={E∖↑N,E}=∗ True).
@@ -100,14 +100,14 @@ Section proofs.
iExists γ. iFrame "Hγ". by iApply "Halloc".
Qed.
- Lemma cinv_cancel E N γ P : ↑N ⊆ E → cinv N γ P -∗ cinv_own γ 1 ={E}=∗ ▷ P.
+ Lemma cinv_cancel `{FiniteBoundedExistential SI} E N γ P : ↑N ⊆ E → cinv N γ P -∗ cinv_own γ 1 ={E}=∗ ▷ P.
Proof.
iIntros (?) "#Hinv Hγ".
iMod (cinv_open_strong with "Hinv Hγ") as "($ & Hγ & H)"; first done.
iApply "H". by iRight.
Qed.
- Lemma cinv_open E N γ p P :
+ Lemma cinv_open `{FiniteBoundedExistential SI} E N γ p P :
↑N ⊆ E →
cinv N γ P -∗ cinv_own γ p ={E,E∖↑N}=∗ ▷ P ∗ cinv_own γ p ∗ (▷ P ={E∖↑N,E}=∗ True).
Proof.
@@ -118,7 +118,7 @@ Section proofs.
Global Instance into_inv_cinv N γ P : IntoInv (cinv N γ P) N := {}.
- Global Instance into_acc_cinv E N γ P p :
+ Global Instance into_acc_cinv `{FiniteBoundedExistential SI} E N γ P p :
IntoAcc (X:=unit) (cinv N γ P)
(↑N ⊆ E) (cinv_own γ p) (fupd E (E∖↑N)) (fupd (E∖↑N) E)
(λ _, ▷ P ∗ cinv_own γ p)%I (λ _, ▷ P)%I (λ _, None)%I.
diff --git a/theories/base_logic/lib/fancy_updates.v b/theories/base_logic/lib/fancy_updates.v
index 6dfaa0d0c3a4fa48a50287bc15751e36b22f12db..f340c8826de89b4eee83ab70c2782ad018209b75 100644
--- a/theories/base_logic/lib/fancy_updates.v
+++ b/theories/base_logic/lib/fancy_updates.v
@@ -1,20 +1,21 @@
From iris.base_logic.lib Require Export own.
From stdpp Require Export coPset.
From iris.base_logic.lib Require Import wsat.
+From iris.base_logic Require Import satisfiable.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Export invG.
Import uPred.
-Definition uPred_fupd_def `{!invG Σ} (E1 E2 : coPset) (P : iProp Σ) : iProp Σ :=
+Definition uPred_fupd_def {SI} {Σ: gFunctors SI} `{!invG Σ} (E1 E2 : coPset) (P : iProp Σ) : iProp Σ :=
(wsat ∗ ownE E1 ==∗ ◇ (wsat ∗ ownE E2 ∗ P))%I.
-Definition uPred_fupd_aux `{!invG Σ} : seal uPred_fupd_def. by eexists. Qed.
-Definition uPred_fupd `{!invG Σ} : FUpd (iProp Σ):= uPred_fupd_aux.(unseal).
-Definition uPred_fupd_eq `{!invG Σ} : @fupd _ uPred_fupd = uPred_fupd_def :=
+Definition uPred_fupd_aux {SI} {Σ: gFunctors SI} `{!invG Σ} : seal uPred_fupd_def. by eexists. Qed.
+Definition uPred_fupd {SI} {Σ: gFunctors SI} `{!invG Σ} : FUpd (iProp Σ):= uPred_fupd_aux.(unseal).
+Definition uPred_fupd_eq {SI} {Σ: gFunctors SI} `{!invG Σ} : @fupd _ uPred_fupd = uPred_fupd_def :=
uPred_fupd_aux.(seal_eq).
-Lemma uPred_fupd_mixin `{!invG Σ} : BiFUpdMixin (uPredSI (iResUR Σ)) uPred_fupd.
+Lemma uPred_fupd_mixin {SI} {Σ: gFunctors SI} `{!invG Σ} : BiFUpdMixin (uPredSI (iResUR Σ)) uPred_fupd.
Proof.
split.
- rewrite uPred_fupd_eq. solve_proper.
@@ -32,13 +33,13 @@ Proof.
iIntros "!> !>". by iApply "HP".
- rewrite uPred_fupd_eq /uPred_fupd_def. by iIntros (????) "[HwP $]".
Qed.
-Instance uPred_bi_fupd `{!invG Σ} : BiFUpd (uPredSI (iResUR Σ)) :=
+Instance uPred_bi_fupd {SI} {Σ: gFunctors SI} `{!invG Σ} : BiFUpd (uPredSI (iResUR Σ)) :=
{| bi_fupd_mixin := uPred_fupd_mixin |}.
-Instance uPred_bi_bupd_fupd `{!invG Σ} : BiBUpdFUpd (uPredSI (iResUR Σ)).
+Instance uPred_bi_bupd_fupd {SI} {Σ: gFunctors SI} `{!invG Σ} : BiBUpdFUpd (uPredSI (iResUR Σ)).
Proof. rewrite /BiBUpdFUpd uPred_fupd_eq. by iIntros (E P) ">? [$ $] !> !>". Qed.
-Instance uPred_bi_fupd_plainly `{!invG Σ} : BiFUpdPlainly (uPredSI (iResUR Σ)).
+Instance uPred_bi_fupd_plainly {SI} {Σ: gFunctors SI} `{!invG Σ} : BiFUpdPlainly (uPredSI (iResUR Σ)).
Proof.
split.
- rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E P) "H [Hw HE]".
@@ -59,7 +60,7 @@ Proof.
by iFrame.
Qed.
-Lemma fupd_plain_soundness `{!invPreG Σ} E1 E2 (P: iProp Σ) `{!Plain P}:
+Lemma fupd_plain_soundness {SI} {Σ: gFunctors SI} `{!invPreG Σ} E1 E2 (P: iProp Σ) `{!Plain P}:
(∀ `{Hinv: !invG Σ}, bi_emp_valid (|={E1,E2}=> P)) → bi_emp_valid P.
Proof.
iIntros (Hfupd). apply later_soundness. iMod wsat_alloc as (Hinv) "[Hw HE]".
@@ -69,8 +70,8 @@ Proof.
iMod ("H" with "[$]") as "[Hw [HE >H']]"; iFrame.
Qed.
-Lemma step_fupdN_soundness `{!invPreG Σ} φ n :
- (∀ `{Hinv: !invG Σ}, (|={⊤,∅}▷=>^n |={⊤,∅}=> ⌜ φ ⌠: iProp Σ)%I) →
+Lemma step_fupdN_soundness {SI} {Σ: gFunctors SI} `{!invPreG Σ} φ n :
+ (∀ `{Hinv: !invG Σ}, bi_emp_valid (|={⊤,∅}▷=>^n |={⊤,∅}=> ⌜ φ ⌠: iProp Σ)%I) →
φ.
Proof.
intros Hiter.
@@ -83,15 +84,141 @@ Proof.
{ by iApply fupd_plain_mask_empty. }
rewrite -step_fupdN_S_fupd.
iMod (step_fupdN_plain with "H'") as "Hφ". iModIntro. iNext.
- rewrite -later_laterN laterN_later.
+ simpl; rewrite -later_laterN laterN_later.
iNext. by iMod "Hφ".
Qed.
-Lemma step_fupdN_soundness' `{!invPreG Σ} φ n :
- (∀ `{Hinv: !invG Σ}, (|={⊤,∅}▷=>^n ⌜ φ ⌠: iProp Σ)%I) →
+Lemma step_fupdN_soundness' {SI} {Σ: gFunctors SI} `{!invPreG Σ} φ n :
+ (∀ `{Hinv: !invG Σ}, bi_emp_valid (|={⊤,∅}▷=>^n ⌜ φ ⌠: iProp Σ)%I) →
φ.
Proof.
iIntros (Hiter). eapply (step_fupdN_soundness _ n).
iIntros (Hinv). iPoseProof (Hiter Hinv) as "Hiter".
iApply (step_fupdN_wand with "Hiter"). by iApply (fupd_mask_weaken _ _ _).
Qed.
+
+
+Section satisfiable_at.
+ Context {SI} {Σ: gFunctors SI} `{invG SI Σ}.
+
+ Definition satisfiable_at E P := satisfiable (wsat ∗ ownE E ∗ P)%I.
+
+ Lemma satisfiable_at_fupd E1 E2 P:
+ satisfiable_at E1 (|={E1, E2}=> P)%I → satisfiable_at E2 P.
+ Proof.
+ intros Hs. apply satisfiable_later, satisfiable_bupd.
+ apply (satisfiable_mono _ _ Hs).
+ iIntros "(W & O & P)". rewrite uPred_fupd_eq /uPred_fupd_def.
+ iSpecialize ("P" with "[W O]"); first by iFrame.
+ iMod "P". iModIntro. iApply except_0_later.
+ iMod "P". iModIntro. by iNext.
+ Qed.
+
+ (* TODO: satisfiable_at is almost an instance of Satisfiable.
+ By redesigning Satisfiable, we could get away without proving the following lemmas. *)
+ Section satisfiable_at_lifting.
+
+ Lemma satisfiable_at_mono E P Q: satisfiable_at E P → (P ⊢ Q) → satisfiable_at E Q.
+ Proof. intros Hs HPQ. apply (satisfiable_mono _ _ Hs). by rewrite HPQ. Qed.
+
+ Lemma satisfiable_at_elim E P: satisfiable_at E P → Plain P → True ⊢ P.
+ Proof.
+ intros Hs HP; apply satisfiable_elim; auto.
+ apply (satisfiable_mono _ _ Hs); iIntros "(_ & _ & $)".
+ Qed.
+
+ Lemma satisfiable_at_later E P: satisfiable_at E (▷ P)%I → satisfiable_at E P.
+ Proof.
+ intros Hs; apply satisfiable_later, (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & $)".
+ Qed.
+
+ Lemma satisfiable_at_finite_exists E `{FiniteExistential SI} (X: Type) P Q: satisfiable_at E (∃ x: X, P x)%I → pred_finite Q → (∀ x, P x ⊢ ⌜Q xâŒ) → ∃ x: X, satisfiable_at E (P x).
+ Proof.
+ intros Hs ??; eapply satisfiable_finite_exists; eauto.
+ - apply (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & $)".
+ - iIntros (x) "(_ & _ & P)". by iApply H2.
+ Qed.
+
+ Lemma satisfiable_at_exists E `{LargeIndex SI} (X: Type) P: satisfiable_at E (∃ x: X, P x)%I → ∃ x: X, satisfiable_at E (P x).
+ Proof.
+ intros Hs; apply satisfiable_exists, (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & $)".
+ Qed.
+
+ Lemma satisfiable_at_bupd E P: satisfiable_at E (|==> P)%I → satisfiable_at E P.
+ Proof.
+ intros Hs; apply satisfiable_bupd, (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & $)".
+ Qed.
+
+ Lemma satisfiable_at_forall E {X} (x: X) P: satisfiable_at E (∀ x, P x)%I → satisfiable_at E (P x).
+ Proof.
+ intros Hs; apply (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & H)"; auto.
+ Qed.
+
+ Lemma satisfiable_at_impl E P Q: satisfiable_at E (P → Q)%I → (True ⊢ P) → satisfiable_at E Q.
+ Proof.
+ intros Hs Hent; apply (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & PQ)". iApply "PQ". by iApply Hent.
+ Qed.
+
+ Lemma satisfiable_at_wand E P Q: satisfiable_at E (P -∗ Q)%I → (True ⊢ P) → satisfiable_at E Q.
+ Proof.
+ intros Hs Hent; apply (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & PQ)". iApply "PQ". by iApply Hent.
+ Qed.
+
+ Lemma satisfiable_at_pers E P: satisfiable_at E (<pers> P)%I → satisfiable_at E P.
+ Proof.
+ intros Hs; apply (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & P)". iApply "P".
+ Qed.
+
+ Lemma satisfiable_at_intuitionistically E P: satisfiable_at E (□ P)%I → satisfiable_at E P.
+ Proof.
+ intros Hs; apply (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & P)". iApply "P".
+ Qed.
+
+ Lemma satisfiable_at_or `{FiniteExistential SI} E P Q: satisfiable_at E (P ∨ Q)%I → satisfiable_at E P ∨ satisfiable_at E Q.
+ Proof.
+ intros Hs; apply satisfiable_or, (satisfiable_mono _ _ Hs).
+ iIntros "($ & $ & $)".
+ Qed.
+
+ (* TODO: add this for satisfiable. *)
+ Lemma satisfiable_at_sep P Q E: satisfiable_at E (P ∗ Q)%I → satisfiable_at E P ∧ satisfiable_at E Q.
+ Proof.
+ intros Hsat; split; apply (satisfiable_at_mono _ _ _ Hsat).
+ all: iIntros "[? ?]"; iFrame.
+ Qed.
+
+ Global Instance satisfiable_at_equiv E: Proper (equiv ==> iff) (satisfiable_at E).
+ Proof.
+ intros P Q HPQ; unfold satisfiable_at; by rewrite HPQ.
+ Qed.
+
+ End satisfiable_at_lifting.
+
+ Lemma satisfiable_at_pure E φ: satisfiable_at E (⌜φâŒ)%I → φ.
+ Proof.
+ intros Hsat. apply satisfiable_at_elim in Hsat; last apply _.
+ by apply uPred.pure_soundness in Hsat.
+ Qed.
+End satisfiable_at.
+
+Lemma satisfiable_at_intro {SI} `{LargeIndex SI} {Σ: gFunctors SI} `{!invPreG Σ}:
+ ∃ Hinv: invG Σ, satisfiable_at ⊤ True%I.
+Proof.
+ specialize wsat_alloc_strong.
+ intros HC % satisfiable_intro % satisfiable_bupd.
+ apply satisfiable_exists in HC. destruct HC as [γI HC].
+ apply satisfiable_exists in HC. destruct HC as [γE HC].
+ apply satisfiable_exists in HC. destruct HC as [γD HC].
+ exists (WsatG _ _ _ _ _ γI γE γD).
+ apply (satisfiable_mono _ _ HC).
+ by iIntros "($ & $)".
+Qed.
diff --git a/theories/base_logic/lib/fancy_updates_from_vs.v b/theories/base_logic/lib/fancy_updates_from_vs.v
deleted file mode 100644
index b47fa0df6b8b48693d4c8baf4df9ede3836f884e..0000000000000000000000000000000000000000
--- a/theories/base_logic/lib/fancy_updates_from_vs.v
+++ /dev/null
@@ -1,71 +0,0 @@
-(* This file shows that the fancy update can be encoded in terms of the
-view shift, and that the laws of the fancy update can be derived from the
-laws of the view shift. *)
-From iris.base_logic Require Export base_logic.
-From iris.proofmode Require Import tactics.
-From stdpp Require Export coPset.
-Set Default Proof Using "Type*".
-
-Section fupd.
-Context {M} (vs : coPset → coPset → uPred M → uPred M → uPred M).
-
-Notation "P ={ E1 , E2 }=> Q" := (vs E1 E2 P Q)
- (at level 99, E1,E2 at level 50, Q at level 200,
- format "P ={ E1 , E2 }=> Q") : bi_scope.
-
-Context (vs_ne : ∀ E1 E2, NonExpansive2 (vs E1 E2)).
-Context (vs_persistent : ∀ E1 E2 P Q, Persistent (P ={E1,E2}=> Q)).
-
-Context (vs_impl : ∀ E P Q, □ (P → Q) ⊢ P ={E,E}=> Q).
-Context (vs_transitive : ∀ E1 E2 E3 P Q R,
- (P ={E1,E2}=> Q) ∧ (Q ={E2,E3}=> R) ⊢ P ={E1,E3}=> R).
-Context (vs_mask_frame_r : ∀ E1 E2 Ef P Q,
- E1 ## Ef → (P ={E1,E2}=> Q) ⊢ P ={E1 ∪ Ef,E2 ∪ Ef}=> Q).
-Context (vs_frame_r : ∀ E1 E2 P Q R, (P ={E1,E2}=> Q) ⊢ P ∗ R ={E1,E2}=> Q ∗ R).
-Context (vs_exists : ∀ {A} E1 E2 (Φ : A → uPred M) Q,
- (∀ x, Φ x ={E1,E2}=> Q) ⊢ (∃ x, Φ x) ={E1,E2}=> Q).
-Context (vs_persistent_intro_r : ∀ E1 E2 P Q R,
- Persistent R →
- (R -∗ (P ={E1,E2}=> Q)) ⊢ P ∗ R ={E1,E2}=> Q).
-
-Definition fupd (E1 E2 : coPset) (P : uPred M) : uPred M :=
- (∃ R, R ∗ vs E1 E2 R P)%I.
-
-Notation "|={ E1 , E2 }=> Q" := (fupd E1 E2 Q)
- (at level 99, E1, E2 at level 50, Q at level 200,
- format "|={ E1 , E2 }=> Q") : bi_scope.
-
-Global Instance fupd_ne E1 E2 : NonExpansive (@fupd E1 E2).
-Proof. solve_proper. Qed.
-
-Lemma fupd_intro E P : P ⊢ |={E,E}=> P.
-Proof. iIntros "HP". iExists P. iFrame "HP". iApply vs_impl; auto. Qed.
-
-Lemma fupd_mono E1 E2 P Q : (P ⊢ Q) → (|={E1,E2}=> P) ⊢ |={E1,E2}=> Q.
-Proof.
- iIntros (HPQ); iDestruct 1 as (R) "[HR Hvs]".
- iExists R; iFrame "HR". iApply (vs_transitive with "[$Hvs]").
- iApply vs_impl. iIntros "!# HP". by iApply HPQ.
-Qed.
-
-Lemma fupd_trans E1 E2 E3 P : (|={E1,E2}=> |={E2,E3}=> P) ⊢ |={E1,E3}=> P.
-Proof.
- iDestruct 1 as (R) "[HR Hvs]". iExists R. iFrame "HR".
- iApply (vs_transitive with "[$Hvs]"). clear R.
- iApply vs_exists; iIntros (R). iApply vs_persistent_intro_r; iIntros "Hvs".
- iApply (vs_transitive with "[$Hvs]"). iApply vs_impl; auto.
-Qed.
-
-Lemma fupd_mask_frame_r E1 E2 Ef P :
- E1 ## Ef → (|={E1,E2}=> P) ⊢ |={E1 ∪ Ef,E2 ∪ Ef}=> P.
-Proof.
- iIntros (HE); iDestruct 1 as (R) "[HR Hvs]". iExists R; iFrame "HR".
- by iApply vs_mask_frame_r.
-Qed.
-
-Lemma fupd_frame_r E1 E2 P Q : (|={E1,E2}=> P) ∗ Q ⊢ |={E1,E2}=> P ∗ Q.
-Proof.
- iIntros "[Hvs HQ]". iDestruct "Hvs" as (R) "[HR Hvs]".
- iExists (R ∗ Q)%I. iFrame "HR HQ". by iApply vs_frame_r.
-Qed.
-End fupd.
diff --git a/theories/base_logic/lib/gen_heap.v b/theories/base_logic/lib/gen_heap.v
index 309940e3b067c6766ff234dafb0645acde1cbb82..610b34f0e401d56bbc16f534b7abbb43aff67c48 100644
--- a/theories/base_logic/lib/gen_heap.v
+++ b/theories/base_logic/lib/gen_heap.v
@@ -57,55 +57,58 @@ of both values and ghost names for meta information, for example:
[gmap L (option (fracR * agreeR V) ∗ option (agree gname)]. Due to the [option]s,
this RA would be quite inconvenient to deal with. *)
-Definition gen_heapUR (L V : Type) `{Countable L} : ucmraT :=
- gmapUR L (prodR fracR (agreeR (leibnizO V))).
-Definition gen_metaUR (L : Type) `{Countable L} : ucmraT :=
- gmapUR L (agreeR gnameO).
-
-Definition to_gen_heap {L V} `{Countable L} : gmap L V → gen_heapUR L V :=
- fmap (λ v, (1%Qp, to_agree (v : leibnizO V))).
-Definition to_gen_meta `{Countable L} : gmap L gname → gen_metaUR L :=
+Definition gen_heapUR (SI: indexT) (L V : Type) `{Countable L} : ucmraT SI :=
+ gmapUR L (prodR (fracR SI) (agreeR (leibnizO SI V))).
+Definition gen_metaUR (SI: indexT) (L : Type) `{Countable L} : ucmraT SI :=
+ gmapUR L (agreeR (gnameO SI)).
+
+Definition to_gen_heap {SI L V} `{Countable L} : gmap L V → gen_heapUR SI L V :=
+ fmap (λ v, (1%Qp, to_agree (v : leibnizO SI V))).
+Definition to_gen_meta {SI} `{Countable L} : gmap L gname → gen_metaUR SI L :=
fmap to_agree.
+Arguments to_gen_heap _ {_ _ _ _} _.
+Arguments to_gen_meta _ {_ _ _} _.
+
(** The CMRA we need. *)
-Class gen_heapG (L V : Type) (Σ : gFunctors) `{Countable L} := GenHeapG {
- gen_heap_inG :> inG Σ (authR (gen_heapUR L V));
- gen_meta_inG :> inG Σ (authR (gen_metaUR L));
- gen_meta_data_inG :> inG Σ (namespace_mapR (agreeR positiveO));
+Class gen_heapG {SI} (L V : Type) (Σ : gFunctors SI) `{Countable L} := GenHeapG {
+ gen_heap_inG :> inG Σ (authR (gen_heapUR SI L V));
+ gen_meta_inG :> inG Σ (authR (gen_metaUR SI L));
+ gen_meta_data_inG :> inG Σ (namespace_mapR (agreeR (positiveO SI)));
gen_heap_name : gname;
gen_meta_name : gname
}.
-Arguments gen_heap_name {_ _ _ _ _} _ : assert.
-Arguments gen_meta_name {_ _ _ _ _} _ : assert.
+Arguments gen_heap_name {_ _ _ _ _ _} _ : assert.
+Arguments gen_meta_name {_ _ _ _ _ _} _ : assert.
-Class gen_heapPreG (L V : Type) (Σ : gFunctors) `{Countable L} := {
- gen_heap_preG_inG :> inG Σ (authR (gen_heapUR L V));
- gen_meta_preG_inG :> inG Σ (authR (gen_metaUR L));
- gen_meta_data_preG_inG :> inG Σ (namespace_mapR (agreeR positiveO));
+Class gen_heapPreG {SI} (L V : Type) (Σ : gFunctors SI) `{Countable L} := {
+ gen_heap_preG_inG :> inG Σ (authR (gen_heapUR SI L V));
+ gen_meta_preG_inG :> inG Σ (authR (gen_metaUR SI L));
+ gen_meta_data_preG_inG :> inG Σ (namespace_mapR (agreeR (positiveO SI)));
}.
-Definition gen_heapΣ (L V : Type) `{Countable L} : gFunctors := #[
- GFunctor (authR (gen_heapUR L V));
- GFunctor (authR (gen_metaUR L));
- GFunctor (namespace_mapR (agreeR positiveO))
+Definition gen_heapΣ {SI} (L V : Type) `{Countable L} : gFunctors SI := #[
+ GFunctor (authR (gen_heapUR SI L V));
+ GFunctor (authR (gen_metaUR SI L));
+ GFunctor (namespace_mapR (agreeR (positiveO SI)))
].
-Instance subG_gen_heapPreG {Σ L V} `{Countable L} :
+Instance subG_gen_heapPreG {SI} {Σ: gFunctors SI} {L V} `{Countable L} :
subG (gen_heapΣ L V) Σ → gen_heapPreG L V Σ.
Proof. solve_inG. Qed.
Section definitions.
- Context `{Countable L, hG : !gen_heapG L V Σ}.
+ Context {SI} {Σ: gFunctors SI} `{Countable L, hG : !gen_heapG L V Σ}.
Definition gen_heap_ctx (σ : gmap L V) : iProp Σ := (∃ m,
(* The [⊆] is used to avoid assigning ghost information to the locations in
the initial heap (see [gen_heap_init]). *)
⌜ dom _ m ⊆ dom (gset L) σ ⌠∧
- own (gen_heap_name hG) (◠(to_gen_heap σ)) ∗
- own (gen_meta_name hG) (â— (to_gen_meta m)))%I.
+ own (gen_heap_name hG) (◠(to_gen_heap SI σ)) ∗
+ own (gen_meta_name hG) (â— (to_gen_meta SI m)))%I.
Definition mapsto_def (l : L) (q : Qp) (v: V) : iProp Σ :=
- own (gen_heap_name hG) (â—¯ {[ l := (q, to_agree (v : leibnizO V)) ]}).
+ own (gen_heap_name hG) (â—¯ {[ l := (q, to_agree (v : leibnizO SI V)) ]}).
Definition mapsto_aux : seal (@mapsto_def). by eexists. Qed.
Definition mapsto := mapsto_aux.(unseal).
Definition mapsto_eq : @mapsto = @mapsto_def := mapsto_aux.(seal_eq).
@@ -134,53 +137,53 @@ Local Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
Local Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope.
Section to_gen_heap.
- Context (L V : Type) `{Countable L}.
+ Context {SI: indexT} (L V : Type) `{Countable L}.
Implicit Types σ : gmap L V.
Implicit Types m : gmap L gname.
(** Conversion to heaps and back *)
- Lemma to_gen_heap_valid σ : ✓ to_gen_heap σ.
+ Lemma to_gen_heap_valid σ : ✓ to_gen_heap SI σ.
Proof. intros l. rewrite lookup_fmap. by case (σ !! l). Qed.
- Lemma lookup_to_gen_heap_None σ l : σ !! l = None → to_gen_heap σ !! l = None.
+ Lemma lookup_to_gen_heap_None σ l : σ !! l = None → to_gen_heap SI σ !! l = None.
Proof. by rewrite /to_gen_heap lookup_fmap=> ->. Qed.
Lemma gen_heap_singleton_included σ l q v :
- {[l := (q, to_agree v)]} ≼ to_gen_heap σ → σ !! l = Some v.
+ {[l := (q, to_agree v)]} ≼ to_gen_heap SI σ → σ !! l = Some v.
Proof.
rewrite singleton_included=> -[[q' av] []].
rewrite /to_gen_heap lookup_fmap fmap_Some_equiv => -[v' [Hl [/= -> ->]]].
move=> /Some_pair_included_total_2 [_] /to_agree_included /leibniz_equiv_iff -> //.
Qed.
Lemma to_gen_heap_insert l v σ :
- to_gen_heap (<[l:=v]> σ) = <[l:=(1%Qp, to_agree (v:leibnizO V))]> (to_gen_heap σ).
+ to_gen_heap SI (<[l:=v]> σ) = <[l:=(1%Qp, to_agree (v:leibnizO SI V))]> (to_gen_heap SI σ).
Proof. by rewrite /to_gen_heap fmap_insert. Qed.
- Lemma to_gen_meta_valid m : ✓ to_gen_meta m.
+ Lemma to_gen_meta_valid m : ✓ to_gen_meta SI m.
Proof. intros l. rewrite lookup_fmap. by case (m !! l). Qed.
- Lemma lookup_to_gen_meta_None m l : m !! l = None → to_gen_meta m !! l = None.
+ Lemma lookup_to_gen_meta_None m l : m !! l = None → to_gen_meta SI m !! l = None.
Proof. by rewrite /to_gen_meta lookup_fmap=> ->. Qed.
Lemma to_gen_meta_insert l m γm :
- to_gen_meta (<[l:=γm]> m) = <[l:=to_agree γm]> (to_gen_meta m).
+ to_gen_meta SI (<[l:=γm]> m) = <[l:=to_agree γm]> (to_gen_meta SI m).
Proof. by rewrite /to_gen_meta fmap_insert. Qed.
End to_gen_heap.
-Lemma gen_heap_init `{Countable L, !gen_heapPreG L V Σ} σ :
- (|==> ∃ _ : gen_heapG L V Σ, gen_heap_ctx σ)%I.
+Lemma gen_heap_init {SI} {Σ: gFunctors SI} `{Countable L, !gen_heapPreG L V Σ} σ :
+ sbi_emp_valid (|==> ∃ _ : gen_heapG L V Σ, gen_heap_ctx σ)%I.
Proof.
- iMod (own_alloc (◠to_gen_heap σ)) as (γh) "Hh".
+ iMod (own_alloc (◠to_gen_heap SI σ)) as (γh) "Hh".
{ rewrite auth_auth_valid. exact: to_gen_heap_valid. }
- iMod (own_alloc (◠to_gen_meta ∅)) as (γm) "Hm".
+ iMod (own_alloc (◠to_gen_meta SI ∅)) as (γm) "Hm".
{ rewrite auth_auth_valid. exact: to_gen_meta_valid. }
- iModIntro. iExists (GenHeapG L V Σ _ _ _ _ _ γh γm).
+ iModIntro. iExists (GenHeapG SI L V Σ _ _ _ _ _ γh γm).
iExists ∅; simpl. iFrame "Hh Hm". by rewrite dom_empty_L.
Qed.
Section gen_heap.
- Context {L V} `{Countable L, !gen_heapG L V Σ}.
+ Context {SI} {Σ: gFunctors SI} {L V} `{Countable L, !gen_heapG L V Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : V → iProp Σ.
Implicit Types σ : gmap L V.
Implicit Types m : gmap L gname.
- Implicit Types h g : gen_heapUR L V.
+ Implicit Types h g : gen_heapUR SI L V.
Implicit Types l : L.
Implicit Types v : V.
@@ -285,7 +288,7 @@ Section gen_heap.
rewrite singleton_valid. apply: agree_op_invL'. }
iDestruct (own_valid_2 with "Hm1 Hm2") as %Hγ; iPureIntro.
move: Hγ. rewrite -namespace_map_data_op namespace_map_data_valid.
- move=> /agree_op_invL'. naive_solver.
+ move=> /agree_op_invL'. intros Heq. naive_solver.
Qed.
Lemma meta_set `{Countable A} E l (x : A) N :
↑ N ⊆ E → meta_token l E ==∗ meta l N x.
@@ -304,7 +307,7 @@ Section gen_heap.
iDestruct 1 as (m Hσm) "[Hσ Hm]".
iMod (own_update with "Hσ") as "[Hσ Hl]".
{ eapply auth_update_alloc,
- (alloc_singleton_local_update _ _ (1%Qp, to_agree (v:leibnizO _)))=> //.
+ (alloc_singleton_local_update _ _ (1%Qp, to_agree (v:leibnizO SI _)))=> //.
by apply lookup_to_gen_heap_None. }
iMod (own_alloc (namespace_map_token ⊤)) as (γm) "Hγm".
{ apply namespace_map_token_valid. }
@@ -350,10 +353,87 @@ Section gen_heap.
as %[Hl%gen_heap_singleton_included _]%auth_both_valid.
iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]".
{ eapply auth_update, singleton_local_update,
- (exclusive_local_update _ (1%Qp, to_agree (v2:leibnizO _)))=> //.
+ (exclusive_local_update _ (1%Qp, to_agree (v2:leibnizO SI _)))=> //.
by rewrite /to_gen_heap lookup_fmap Hl. }
iModIntro. iFrame "Hl". iExists m. rewrite to_gen_heap_insert. iFrame.
iPureIntro. apply (elem_of_dom_2 (D:=gset L)) in Hl.
rewrite dom_insert_L. set_solver.
Qed.
End gen_heap.
+
+
+
+(* Global Gen Heap Instance *)
+Definition γ_gen_heap : gname := encode "gen_heap.heap".
+Definition γ_gen_heap_meta : gname := encode "gen_heap.meta".
+Definition gen_heap_gnames : coPset := {[ γ_gen_heap; γ_gen_heap_meta ]}.
+
+(* mirrors gen_heapPreG but for type class inference reasons we do not reuse gen_heapPreG *)
+Class gen_heapS {SI} (L V : Type) (Σ : gFunctors SI) `{Countable L} := {
+ gen_heapS_inG :> inG Σ (authR (gen_heapUR SI L V));
+ gen_heapS_meta_inG :> inG Σ (authR (gen_metaUR SI L));
+ gen_heapS_data_inG :> inG Σ (namespace_mapR (agreeR (positiveO SI)))
+}.
+
+Instance gen_heapS_gen_heapG {SI} {Σ : gFunctors SI} `{Countable L} `{gen_heapS SI L V Σ} : gen_heapG L V Σ :=
+ GenHeapG _ _ _ _ _ _ _ _ _ γ_gen_heap γ_gen_heap_meta.
+
+
+Lemma alloc_gen_heap {SI} {Σ : gFunctors SI} L V `{Countable L} `{gen_heapPreG SI L V Σ} (σ: gmap L V):
+ sbi_emp_valid (|==> ∃ γ_gen_heap γ_gen_heap_meta, let H := GenHeapG SI L V _ _ _ _ _ _ γ_gen_heap γ_gen_heap_meta in gen_heap_ctx σ)%I.
+Proof.
+ iMod (own_alloc (◠to_gen_heap SI σ)) as (γ_gen_heap) "H1".
+ { rewrite auth_auth_valid; exact: to_gen_heap_valid. }
+ iMod (own_alloc (◠to_gen_meta SI ∅)) as (γ_gen_heap_meta) "H2".
+ { rewrite auth_auth_valid; exact: to_gen_meta_valid. }
+ iModIntro. iExists γ_gen_heap. iExists γ_gen_heap_meta.
+ iExists ∅;simpl.
+ iFrame "H1 H2". by rewrite dom_empty_L.
+Qed.
+
+Lemma heap_init_to_bigOp {SI} {Σ : gFunctors SI} `{hG: gen_heapG SI L V Σ} σ:
+ own (gen_heap_name hG) (◯ (to_gen_heap SI σ)) -∗
+ [∗ map] i↦v ∈ σ, i ↦ v .
+Proof.
+ induction σ using map_ind.
+ - iIntros. rewrite //=.
+ - iIntros "Hown".
+ rewrite big_opM_insert //.
+ iAssert (own (gen_heap_name _)
+ (◯ to_gen_heap SI m) ∗
+ (i ↦ x))%I
+ with "[Hown]" as "[Hrest $]".
+ {
+ rewrite mapsto_eq /mapsto_def //.
+ rewrite to_gen_heap_insert insert_singleton_op; last by apply lookup_to_gen_heap_None.
+ rewrite auth_frag_op. iDestruct "Hown" as "(?&?)". iFrame.
+ }
+ by iApply IHσ.
+Qed.
+
+Lemma alloc_gen_heap_strong {SI} {Σ : gFunctors SI} L V `{Countable L} `{gen_heapPreG SI L V Σ} (σ: gmap L V):
+ sbi_emp_valid (|==> ∃ γ_gen_heap γ_gen_heap_meta, let H := GenHeapG SI L V _ _ _ _ _ _ γ_gen_heap γ_gen_heap_meta in gen_heap_ctx σ ∗ [∗ map] i↦v ∈ σ, i ↦ v)%I.
+Proof.
+ iMod (own_alloc (◠to_gen_heap SI σ ⋅ ◯ to_gen_heap SI σ)) as (γ_gen_heap) "(H1&Hfrag)".
+ { apply auth_both_valid; split; auto. exact: to_gen_heap_valid. }
+ iMod (own_alloc (◠to_gen_meta SI ∅)) as (γ_gen_heap_meta) "H2".
+ { rewrite auth_auth_valid; exact: to_gen_meta_valid. }
+ iModIntro. iExists γ_gen_heap. iExists γ_gen_heap_meta.
+ iSplitR "Hfrag".
+ - iExists ∅; simpl. iFrame "H1 H2". by rewrite dom_empty_L.
+ - by iApply heap_init_to_bigOp.
+Qed.
+
+Lemma initial_gen_heap {SI} {Σ : gFunctors SI} L V `{Countable L} `{gen_heapS SI L V Σ} (σ: gmap L V):
+ initial gen_heap_gnames (gen_heap_ctx σ)%I.
+Proof.
+ feed pose proof (initial_alloc γ_gen_heap (◠to_gen_heap SI σ)) as HH.
+ { rewrite auth_auth_valid; exact: to_gen_heap_valid. }
+ feed pose proof (initial_alloc γ_gen_heap_meta (◠to_gen_meta SI ∅)) as HM.
+ { rewrite auth_auth_valid; exact: to_gen_meta_valid. }
+ feed pose proof (initial_combine _ _ _ _ HH HM) as H';
+ first set_solver.
+ eapply initial_mono; last eauto.
+ iIntros "[H M]". iExists ∅;simpl.
+ iFrame "H M". by rewrite dom_empty_L.
+Qed.
diff --git a/theories/base_logic/lib/invariants.v b/theories/base_logic/lib/invariants.v
index cadd6f23126e056083bc2b25ef879546657e7eef..c9c64c925f0b4bf832f821f0f71eb9f258d5450e 100644
--- a/theories/base_logic/lib/invariants.v
+++ b/theories/base_logic/lib/invariants.v
@@ -6,123 +6,206 @@ From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.
-(** Derived forms and lemmas about them. *)
-Definition inv_def `{!invG Σ} (N : namespace) (P : iProp Σ) : iProp Σ :=
- (∃ i P', ⌜i ∈ (↑N:coPset)⌠∧ ▷ □ (P' ↔ P) ∧ ownI i P')%I.
-Definition inv_aux : seal (@inv_def). by eexists. Qed.
-Definition inv {Σ i} := inv_aux.(unseal) Σ i.
+(** Semantic Invariants *)
+Definition inv_def {SI} {Σ: gFunctors SI} `{!invG Σ} (N : namespace) (P : iProp Σ) : iProp Σ :=
+ (□ ∀ E, ⌜↑N ⊆ E⌠→ |={E,E ∖ ↑N}=> ▷ P ∗ (▷ P ={E ∖ ↑N,E}=∗ True))%I.
+Definition inv_aux : seal (@inv_def). Proof. by eexists. Qed.
+Definition inv := inv_aux.(unseal).
+Arguments inv {SI Σ _} N P.
Definition inv_eq : @inv = @inv_def := inv_aux.(seal_eq).
-Instance: Params (@inv) 3 := {}.
-Typeclasses Opaque inv.
+Instance: Params (@inv) 4 := {}.
+(** * Invariants *)
Section inv.
-Context `{!invG Σ}.
-Implicit Types i : positive.
-Implicit Types N : namespace.
-Implicit Types P Q R : iProp Σ.
-
-Global Instance inv_contractive N : Contractive (inv N).
-Proof. rewrite inv_eq. solve_contractive. Qed.
-
-Global Instance inv_ne N : NonExpansive (inv N).
-Proof. apply contractive_ne, _. Qed.
-
-Global Instance inv_proper N : Proper ((⊣⊢) ==> (⊣⊢)) (inv N).
-Proof. apply ne_proper, _. Qed.
-
-Global Instance inv_persistent N P : Persistent (inv N P).
-Proof. rewrite inv_eq /inv; apply _. Qed.
-
-Lemma inv_iff N P Q : ▷ □ (P ↔ Q) -∗ inv N P -∗ inv N Q.
-Proof.
- iIntros "#HPQ". rewrite inv_eq. iDestruct 1 as (i P') "(?&#HP&?)".
- iExists i, P'. iFrame. iNext; iAlways; iSplit.
- - iIntros "HP'". iApply "HPQ". by iApply "HP".
- - iIntros "HQ". iApply "HP". by iApply "HPQ".
-Qed.
-
-Lemma fresh_inv_name (E : gset positive) N : ∃ i, i ∉ E ∧ i ∈ (↑N:coPset).
-Proof.
- exists (coPpick (↑ N ∖ gset_to_coPset E)).
- rewrite -elem_of_gset_to_coPset (comm and) -elem_of_difference.
- apply coPpick_elem_of=> Hfin.
- eapply nclose_infinite, (difference_finite_inv _ _), Hfin.
- apply gset_to_coPset_finite.
-Qed.
-
-Lemma inv_alloc N E P : ▷ P ={E}=∗ inv N P.
-Proof.
- rewrite inv_eq /inv_def uPred_fupd_eq. iIntros "HP [Hw $]".
- iMod (ownI_alloc (∈ (↑N : coPset)) P with "[$HP $Hw]")
- as (i ?) "[$ ?]"; auto using fresh_inv_name.
- do 2 iModIntro. iExists i, P. rewrite -(iff_refl True%I). auto.
-Qed.
-
-Lemma inv_alloc_open N E P :
- ↑N ⊆ E → (|={E, E∖↑N}=> inv N P ∗ (▷P ={E∖↑N, E}=∗ True))%I.
-Proof.
- rewrite inv_eq /inv_def uPred_fupd_eq. iIntros (Sub) "[Hw HE]".
- iMod (ownI_alloc_open (∈ (↑N : coPset)) P with "Hw")
- as (i ?) "(Hw & #Hi & HD)"; auto using fresh_inv_name.
- iAssert (ownE {[i]} ∗ ownE (↑ N ∖ {[i]}) ∗ ownE (E ∖ ↑ N))%I
- with "[HE]" as "(HEi & HEN\i & HE\N)".
- { rewrite -?ownE_op; [|set_solver..].
- rewrite assoc_L -!union_difference_L //. set_solver. }
- do 2 iModIntro. iFrame "HE\N". iSplitL "Hw HEi"; first by iApply "Hw".
- iSplitL "Hi".
- { iExists i, P. rewrite -(iff_refl True%I). auto. }
- iIntros "HP [Hw HE\N]".
- iDestruct (ownI_close with "[$Hw $Hi $HP $HD]") as "[$ HEi]".
- do 2 iModIntro. iSplitL; [|done].
- iCombine "HEi HEN\i HE\N" as "HEN".
- rewrite -?ownE_op; [|set_solver..].
- rewrite assoc_L -!union_difference_L //; set_solver.
-Qed.
-
-Lemma inv_open E N P :
- ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
-Proof.
- rewrite inv_eq /inv_def uPred_fupd_eq /uPred_fupd_def.
- iDestruct 1 as (i P') "(Hi & #HP' & #HiP)".
- iDestruct "Hi" as % ?%elem_of_subseteq_singleton.
- rewrite {1 4}(union_difference_L (↑ N) E) // ownE_op; last set_solver.
- rewrite {1 5}(union_difference_L {[ i ]} (↑ N)) // ownE_op; last set_solver.
- iIntros "(Hw & [HE $] & $) !> !>".
- iDestruct (ownI_open i with "[$Hw $HE $HiP]") as "($ & HP & HD)".
- iDestruct ("HP'" with "HP") as "$".
- iIntros "HP [Hw $] !> !>". iApply (ownI_close _ P'). iFrame "HD Hw HiP".
- iApply "HP'". iFrame.
-Qed.
-
-Lemma inv_open_strong E N P :
- ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ ∀ E', ▷ P ={E',↑N ∪ E'}=∗ True.
-Proof.
- iIntros (?) "Hinv".
- iPoseProof (inv_open (↑ N) N P with "Hinv") as "H"; first done.
- rewrite difference_diag_L.
- iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
- rewrite left_id_L -union_difference_L //. iMod "H" as "[$ H]"; iModIntro.
- iIntros (E') "HP".
- iPoseProof (fupd_mask_frame_r _ _ E' with "(H HP)") as "H"; first set_solver.
- by rewrite left_id_L.
-Qed.
-
-Global Instance into_inv_inv N P : IntoInv (inv N P) N := {}.
-
-Global Instance into_acc_inv E N P :
- IntoAcc (X:=unit) (inv N P)
- (↑N ⊆ E) True (fupd E (E∖↑N)) (fupd (E∖↑N) E)
- (λ _, ▷ P)%I (λ _, ▷ P)%I (λ _, None)%I.
-Proof.
- rewrite /IntoAcc /accessor exist_unit.
- iIntros (?) "#Hinv _". iApply inv_open; done.
-Qed.
-
-Lemma inv_open_timeless E N P `{!Timeless P} :
- ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ P ∗ (P ={E∖↑N,E}=∗ True).
-Proof.
- iIntros (?) "Hinv". iMod (inv_open with "Hinv") as "[>HP Hclose]"; auto.
- iIntros "!> {$HP} HP". iApply "Hclose"; auto.
-Qed.
+ Context {SI} {Σ: gFunctors SI} `{!invG Σ}.
+ Implicit Types i : positive.
+ Implicit Types N : namespace.
+ Implicit Types E : coPset.
+ Implicit Types P Q R : iProp Σ.
+
+ (** ** Internal model of invariants *)
+ Definition own_inv (N : namespace) (P : iProp Σ) : iProp Σ :=
+ (∃ i, ⌜i ∈ (↑N:coPset)⌠∧ ownI i P)%I.
+
+ Lemma own_inv_acc E N P :
+ ↑N ⊆ E → own_inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
+ Proof.
+ rewrite uPred_fupd_eq /uPred_fupd_def. iDestruct 1 as (i) "[Hi #HiP]".
+ iDestruct "Hi" as % ?%elem_of_subseteq_singleton.
+ rewrite {1 4}(union_difference_L (↑ N) E) // ownE_op; last set_solver.
+ rewrite {1 5}(union_difference_L {[ i ]} (↑ N)) // ownE_op; last set_solver.
+ iIntros "(Hw & [HE $] & $) !> !>".
+ iDestruct (ownI_open i with "[$Hw $HE $HiP]") as "($ & $ & HD)".
+ iIntros "HP [Hw $] !> !>". iApply (ownI_close _ P). by iFrame.
+ Qed.
+
+ Lemma fresh_inv_name (E : gset positive) N : ∃ i, i ∉ E ∧ i ∈ (↑N:coPset).
+ Proof.
+ exists (coPpick (↑ N ∖ gset_to_coPset E)).
+ rewrite -elem_of_gset_to_coPset (comm and) -elem_of_difference.
+ apply coPpick_elem_of=> Hfin.
+ eapply nclose_infinite, (difference_finite_inv _ _), Hfin.
+ apply gset_to_coPset_finite.
+ Qed.
+
+ Lemma own_inv_alloc N E P : ▷ P ={E}=∗ own_inv N P.
+ Proof.
+ rewrite uPred_fupd_eq. iIntros "HP [Hw $]".
+ iMod (ownI_alloc (.∈ (↑N : coPset)) P with "[$HP $Hw]")
+ as (i ?) "[$ ?]"; auto using fresh_inv_name.
+ do 2 iModIntro. iExists i. auto.
+ Qed.
+
+ (* This does not imply [own_inv_alloc] due to the extra assumption [↑N ⊆ E]. *)
+ Lemma own_inv_alloc_open N E P :
+ ↑N ⊆ E → ⊢ |={E, E∖↑N}=> own_inv N P ∗ (▷P ={E∖↑N, E}=∗ True).
+ Proof.
+ rewrite uPred_fupd_eq. iIntros (Sub) "[Hw HE]".
+ iMod (ownI_alloc_open (.∈ (↑N : coPset)) P with "Hw")
+ as (i ?) "(Hw & #Hi & HD)"; auto using fresh_inv_name.
+ iAssert (ownE {[i]} ∗ ownE (↑ N ∖ {[i]}) ∗ ownE (E ∖ ↑ N))%I
+ with "[HE]" as "(HEi & HEN\i & HE\N)".
+ { rewrite -?ownE_op; [|set_solver..].
+ rewrite assoc_L -!union_difference_L //. set_solver. }
+ do 2 iModIntro. iFrame "HE\N". iSplitL "Hw HEi"; first by iApply "Hw".
+ iSplitL "Hi".
+ { iExists i. auto. }
+ iIntros "HP [Hw HE\N]".
+ iDestruct (ownI_close with "[$Hw $Hi $HP $HD]") as "[$ HEi]".
+ do 2 iModIntro. iSplitL; [|done].
+ iCombine "HEi HEN\i HE\N" as "HEN".
+ rewrite -?ownE_op; [|set_solver..].
+ rewrite assoc_L -!union_difference_L //; set_solver.
+ Qed.
+
+ Lemma own_inv_to_inv M P: own_inv M P -∗ inv M P.
+ Proof.
+ iIntros "#I". rewrite inv_eq. iIntros (E H).
+ iPoseProof (own_inv_acc with "I") as "H"; eauto.
+ Qed.
+
+ (** ** Public API of invariants *)
+ Global Instance inv_contractive N : Contractive (inv N).
+ Proof. rewrite inv_eq. solve_contractive. Qed.
+
+ Global Instance inv_ne N : NonExpansive (inv N).
+ Proof. apply contractive_ne, _. Qed.
+
+ Global Instance inv_proper N : Proper (equiv ==> equiv) (inv N).
+ Proof. apply ne_proper, _. Qed.
+
+ Global Instance inv_persistent N P : Persistent (inv N P).
+ Proof. rewrite inv_eq. apply _. Qed.
+
+ (* This seems to need later/sep commuting rule *)
+ (*
+ Lemma inv_alter N P Q : inv N P -∗ ▷ □ (P -∗ Q ∗ (Q -∗ P)) -∗ inv N Q.
+ Proof.
+ rewrite inv_eq. iIntros "#HI #HPQ !>" (E H).
+ iMod ("HI" $! E H) as "[HP Hclose]".
+ iDestruct ("HPQ" with "HP") as "[$ HQP]".
+ iIntros "!> HQ". iApply "Hclose". iApply "HQP". done.
+ Qed.
+ *)
+
+ Lemma inv_alter_timeless P N Q {HT: Timeless P} : inv N P -∗ □ (P -∗ Q ∗ ▷ (Q -∗ P)) -∗ inv N Q.
+ Proof.
+ rewrite inv_eq. iIntros "#HI #HPQ !>" (E H).
+ iMod ("HI" $! E H) as "[>HP Hclose]".
+ iDestruct ("HPQ" with "HP") as "[$ HQP]".
+ iIntros "!> HQ". iApply "Hclose". iApply "HQP". done.
+ Qed.
+
+ Lemma inv_iff N P Q : inv N P -∗ ▷ □ (P ↔ Q) -∗ inv N Q.
+ Proof.
+ rewrite inv_eq. iIntros "#HI #HPQ !>" (E H).
+ iMod ("HI" $! E H) as "[HP Hclose]".
+ iDestruct ("HPQ" with "HP") as "$".
+ iIntros "!> HQ". iApply "Hclose". iApply "HPQ". done.
+ Qed.
+
+ Lemma inv_alloc N E P : ▷ P ={E}=∗ inv N P.
+ Proof.
+ iIntros "HP". iApply own_inv_to_inv.
+ iApply (own_inv_alloc N E with "HP").
+ Qed.
+
+ Lemma inv_alloc_open N E P :
+ ↑N ⊆ E → ⊢ |={E, E∖↑N}=> inv N P ∗ (▷P ={E∖↑N, E}=∗ True).
+ Proof.
+ iIntros (?). iMod own_inv_alloc_open as "[HI $]"; first done.
+ iApply own_inv_to_inv. done.
+ Qed.
+
+ Lemma inv_acc E N P :
+ ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
+ Proof.
+ rewrite inv_eq /inv_def; iIntros (?) "#HI". by iApply "HI".
+ Qed.
+
+ (* This seems to need later/sep commuting rule *)
+ (*
+ Lemma inv_combine N1 N2 N P Q :
+ N1 ## N2 →
+ ↑N1 ∪ ↑N2 ⊆@{coPset} ↑N →
+ inv N1 P -∗ inv N2 Q -∗ inv N (P ∗ Q).
+ Proof.
+ rewrite inv_eq. iIntros (??) "#HinvP #HinvQ !>"; iIntros (E ?).
+ iMod ("HinvP" with "[%]") as "[$ HcloseP]"; first set_solver.
+ iMod ("HinvQ" with "[%]") as "[$ HcloseQ]"; first set_solver.
+ iMod (fupd_intro_mask' _ (E ∖ ↑N)) as "Hclose"; first set_solver.
+ iIntros "!> [HP HQ]".
+ iMod "Hclose" as %_. iMod ("HcloseQ" with "HQ") as %_. by iApply "HcloseP".
+ Qed.
+ *)
+
+ (** ** Proof mode integration *)
+ Global Instance into_inv_inv N P : IntoInv (inv N P) N := {}.
+
+ Global Instance into_acc_inv N P E:
+ IntoAcc (X := unit) (inv N P)
+ (↑N ⊆ E) True (fupd E (E ∖ ↑N)) (fupd (E ∖ ↑N) E)
+ (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
+ Proof.
+ rewrite inv_eq /IntoAcc /accessor bi.exist_unit.
+ iIntros (?) "#Hinv _". iApply "Hinv"; done.
+ Qed.
+
+ (** ** Derived properties *)
+ Lemma inv_acc_strong E N P :
+ ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ ∀ E', ▷ P ={E',↑N ∪ E'}=∗ True.
+ Proof.
+ iIntros (?) "Hinv".
+ iPoseProof (inv_acc (↑ N) N with "Hinv") as "H"; first done.
+ rewrite difference_diag_L.
+ iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
+ rewrite left_id_L -union_difference_L //. iMod "H" as "[$ H]"; iModIntro.
+ iIntros (E') "HP".
+ iPoseProof (fupd_mask_frame_r _ _ E' with "(H HP)") as "H"; first set_solver.
+ by rewrite left_id_L.
+ Qed.
+
+ Lemma inv_acc_timeless E N P `{!Timeless P} :
+ ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ P ∗ (P ={E∖↑N,E}=∗ True).
+ Proof.
+ iIntros (?) "Hinv". iMod (inv_acc with "Hinv") as "[>HP Hclose]"; auto.
+ iIntros "!> {$HP} HP". iApply "Hclose"; auto.
+ Qed.
+
+ Lemma inv_split_l_timeless N P Q `{!Timeless P} `{!Timeless Q}: inv N (P ∗ Q) -∗ inv N P.
+ Proof.
+ iIntros "#HI". iApply (inv_alter_timeless with "[$]"); eauto.
+ iIntros "!> [$ $]". iNext; eauto.
+ Qed.
+ Lemma inv_split_r_timeless N P Q `{!Timeless P} `{!Timeless Q}: inv N (P ∗ Q) -∗ inv N Q.
+ Proof.
+ rewrite (comm _ P Q). eapply inv_split_l_timeless; auto.
+ Qed.
+ Lemma inv_split N P Q `{!Timeless P} `{!Timeless Q}: inv N (P ∗ Q) -∗ inv N P ∗ inv N Q.
+ Proof.
+ iIntros "#H".
+ iPoseProof (inv_split_l_timeless with "H") as "$".
+ iPoseProof (inv_split_r_timeless with "H") as "$".
+ Qed.
End inv.
diff --git a/theories/base_logic/lib/iprop.v b/theories/base_logic/lib/iprop.v
index 809bfe6409449898a8fd393ec71652509825f76f..6fd9b652c974de30fb78ce4633341bf9d0476736 100644
--- a/theories/base_logic/lib/iprop.v
+++ b/theories/base_logic/lib/iprop.v
@@ -24,11 +24,11 @@ the agreement CMRA. *)
(** * Locally contractive functors *)
(** The type [gFunctor] bundles a functor from the category of COFEs to the
category of CMRAs with a proof that it is locally contractive. *)
-Structure gFunctor := GFunctor {
- gFunctor_F :> rFunctor;
+Structure gFunctor (SI: indexT) := GFunctor {
+ gFunctor_F :> rFunctor SI;
gFunctor_contractive : rFunctorContractive gFunctor_F;
}.
-Arguments GFunctor _ {_}.
+Arguments GFunctor {_} _ {_}.
Existing Instance gFunctor_contractive.
Add Printing Constructor gFunctor.
@@ -38,17 +38,17 @@ of [gFunctor]s.
Note that [gFunctors] is isomorphic to [list gFunctor], but defined in an
alternative way to avoid universe inconsistencies with respect to the universe
monomorphic [list] type. *)
-Definition gFunctors := { n : nat & fin n → gFunctor }.
+Definition gFunctors SI := { n : nat & fin n → gFunctor SI }.
-Definition gid (Σ : gFunctors) := fin (projT1 Σ).
-Definition gFunctors_lookup (Σ : gFunctors) : gid Σ → gFunctor := projT2 Σ.
+Definition gid {SI} (Σ : gFunctors SI) := fin (projT1 Σ).
+Definition gFunctors_lookup {SI} (Σ : gFunctors SI) : gid Σ → gFunctor SI := projT2 Σ.
Coercion gFunctors_lookup : gFunctors >-> Funclass.
Definition gname := positive.
-Canonical Structure gnameO := leibnizO gname.
+Canonical Structure gnameO SI := leibnizO SI gname.
(** The resources functor [iResF Σ A := ∀ i : gid, gname -fin-> (Σ i) A]. *)
-Definition iResF (Σ : gFunctors) : urFunctor :=
+Definition iResF {SI} (Σ : gFunctors SI) : urFunctor SI :=
discrete_funURF (λ i, gmapURF gname (Σ i)).
@@ -56,12 +56,12 @@ Definition iResF (Σ : gFunctors) : urFunctor :=
functors, and the append operator on lists of functors. These are used to
compose [gFunctors] out of smaller pieces. *)
Module gFunctors.
- Definition nil : gFunctors := existT 0 (fin_0_inv _).
+ Definition nil {SI} : gFunctors SI := existT 0 (fin_0_inv _).
- Definition singleton (F : gFunctor) : gFunctors :=
- existT 1 (fin_S_inv (λ _, gFunctor) F (fin_0_inv _)).
+ Definition singleton {SI} (F : gFunctor SI) : gFunctors SI :=
+ existT 1 (fin_S_inv (λ _, gFunctor SI) F (fin_0_inv _)).
- Definition app (Σ1 Σ2 : gFunctors) : gFunctors :=
+ Definition app {SI} (Σ1 Σ2 : gFunctors SI) : gFunctors SI :=
existT (projT1 Σ1 + projT1 Σ2) (fin_plus_inv _ (projT2 Σ1) (projT2 Σ2)).
End gFunctors.
@@ -81,30 +81,31 @@ lock invariant.
The contraints to can be expressed using the type class [subG Σ1 Σ2], which
expresses that the functors [Σ1] are contained in [Σ2]. *)
-Class subG (Σ1 Σ2 : gFunctors) := in_subG i : { j | Σ1 i = Σ2 j }.
+Class subG {SI} (Σ1 Σ2 : gFunctors SI) := in_subG i : { j | Σ1 i = Σ2 j }.
(** Avoid trigger happy type class search: this line ensures that type class
search is only triggered if the arguments of [subG] do not contain evars. Since
instance search for [subG] is restrained, instances should persistently have [subG] as
their first parameter to avoid loops. For example, the instances [subG_authΣ]
and [auth_discrete] otherwise create a cycle that pops up arbitrarily. *)
-Hint Mode subG ! + : typeclass_instances.
+Hint Mode subG - ! + : typeclass_instances.
-Lemma subG_inv Σ1 Σ2 Σ : subG (gFunctors.app Σ1 Σ2) Σ → subG Σ1 Σ * subG Σ2 Σ.
+Lemma subG_inv {SI} (Σ1 Σ2 Σ: gFunctors SI) :
+ subG (gFunctors.app Σ1 Σ2) Σ → subG Σ1 Σ * subG Σ2 Σ.
Proof.
move=> H; split.
- move=> i; move: H=> /(_ (Fin.L _ i)) [j] /=. rewrite fin_plus_inv_L; eauto.
- move=> i; move: H=> /(_ (Fin.R _ i)) [j] /=. rewrite fin_plus_inv_R; eauto.
Qed.
-Instance subG_refl Σ : subG Σ Σ.
+Instance subG_refl {SI} (Σ: gFunctors SI) : subG Σ Σ.
Proof. move=> i; by exists i. Qed.
-Instance subG_app_l Σ Σ1 Σ2 : subG Σ Σ1 → subG Σ (gFunctors.app Σ1 Σ2).
+Instance subG_app_l {SI} (Σ Σ1 Σ2: gFunctors SI) : subG Σ Σ1 → subG Σ (gFunctors.app Σ1 Σ2).
Proof.
move=> H i; move: H=> /(_ i) [j ?].
exists (Fin.L _ j). by rewrite /= fin_plus_inv_L.
Qed.
-Instance subG_app_r Σ Σ1 Σ2 : subG Σ Σ2 → subG Σ (gFunctors.app Σ1 Σ2).
+Instance subG_app_r {SI} (Σ Σ1 Σ2 : gFunctors SI): subG Σ Σ2 → subG Σ (gFunctors.app Σ1 Σ2).
Proof.
move=> H i; move: H=> /(_ i) [j ?].
exists (Fin.R _ j). by rewrite /= fin_plus_inv_R.
@@ -116,46 +117,45 @@ Qed.
the construction, this way we are sure we do not use any properties of the
construction, and also avoid Coq from blindly unfolding it. *)
Module Type iProp_solution_sig.
- Parameter iPreProp : gFunctors → ofeT.
- Global Declare Instance iPreProp_cofe {Σ} : Cofe (iPreProp Σ).
+ Parameter iPreProp : ∀ {SI: indexT}, gFunctors SI → ofeT SI.
+ Global Declare Instance iPreProp_cofe {SI}{Σ: gFunctors SI} : Cofe (iPreProp Σ).
- Definition iResUR (Σ : gFunctors) : ucmraT :=
+ Definition iResUR {SI} (Σ : gFunctors SI) : ucmraT SI :=
discrete_funUR (λ i, gmapUR gname (Σ i (iPreProp Σ) _)).
Notation iProp Σ := (uPredO (iResUR Σ)).
Notation iPropI Σ := (uPredI (iResUR Σ)).
Notation iPropSI Σ := (uPredSI (iResUR Σ)).
- Parameter iProp_unfold: ∀ {Σ}, iProp Σ -n> iPreProp Σ.
- Parameter iProp_fold: ∀ {Σ}, iPreProp Σ -n> iProp Σ.
- Parameter iProp_fold_unfold: ∀ {Σ} (P : iProp Σ),
+ Parameter iProp_unfold: ∀ {SI} {Σ: gFunctors SI}, iProp Σ -n> iPreProp Σ.
+ Parameter iProp_fold: ∀ {SI} {Σ: gFunctors SI}, iPreProp Σ -n> iProp Σ.
+ Parameter iProp_fold_unfold: ∀ {SI} {Σ: gFunctors SI} (P : iProp Σ),
iProp_fold (iProp_unfold P) ≡ P.
- Parameter iProp_unfold_fold: ∀ {Σ} (P : iPreProp Σ),
+ Parameter iProp_unfold_fold: ∀ {SI} {Σ: gFunctors SI} (P : iPreProp Σ),
iProp_unfold (iProp_fold P) ≡ P.
End iProp_solution_sig.
Module Export iProp_solution : iProp_solution_sig.
Import cofe_solver.
- Definition iProp_result (Σ : gFunctors) :
- solution (uPredOF (iResF Σ)) := solver.result _.
- Definition iPreProp (Σ : gFunctors) : ofeT := iProp_result Σ.
- Global Instance iPreProp_cofe {Σ} : Cofe (iPreProp Σ) := _.
+ Definition iProp_result {SI} (Σ : gFunctors SI) :
+ solution (uPredOF (iResF Σ)) := solver.solution_F _ (uPredOF (iResF Σ)) (uPred_pure True).
+ Definition iPreProp {SI} (Σ : gFunctors SI) : ofeT SI := iProp_result Σ.
+ Global Instance iPreProp_cofe {SI} {Σ: gFunctors SI} : Cofe (iPreProp Σ) := _.
- Definition iResUR (Σ : gFunctors) : ucmraT :=
+ Definition iResUR {SI} (Σ : gFunctors SI) : ucmraT SI :=
discrete_funUR (λ i, gmapUR gname (Σ i (iPreProp Σ) _)).
Notation iProp Σ := (uPredO (iResUR Σ)).
- Definition iProp_unfold {Σ} : iProp Σ -n> iPreProp Σ :=
- solution_fold (iProp_result Σ).
- 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.
+ Definition iProp_unfold {SI} {Σ: gFunctors SI} : iProp Σ -n> iPreProp Σ :=
+ solution_fold _ (iProp_result Σ).
+ Definition iProp_fold {SI} {Σ: gFunctors SI} : iPreProp Σ -n> iProp Σ := solution_unfold _ _.
+ Lemma iProp_fold_unfold {SI} {Σ: gFunctors SI} (P : iProp Σ) : iProp_fold (iProp_unfold P) ≡ P.
+ Proof. apply @solution_unfold_fold. Qed.
+ Lemma iProp_unfold_fold {SI} {Σ: gFunctors SI} (P : iPreProp Σ) : iProp_unfold (iProp_fold P) ≡ P.
+ Proof. apply @solution_fold_unfold. Qed.
End iProp_solution.
-
(** * Properties of the solution to the recursive domain equation *)
-Lemma iProp_unfold_equivI {Σ} (P Q : iProp Σ) :
+Lemma iProp_unfold_equivI {SI} {Σ: gFunctors SI} (P Q : iProp Σ) :
iProp_unfold P ≡ iProp_unfold Q ⊢@{iPropI Σ} P ≡ Q.
Proof.
rewrite -{2}(iProp_fold_unfold P) -{2}(iProp_fold_unfold Q). apply: bi.f_equiv.
diff --git a/theories/base_logic/lib/logical_step.v b/theories/base_logic/lib/logical_step.v
new file mode 100644
index 0000000000000000000000000000000000000000..2f5e3f6aa9e899d53184827e0c525eb21627f7bf
--- /dev/null
+++ b/theories/base_logic/lib/logical_step.v
@@ -0,0 +1,402 @@
+From iris.base_logic.lib Require Export fancy_updates.
+From iris.proofmode Require Import base tactics classes.
+Set Default Proof Using "Type".
+Import uPred.
+
+
+Section eventually.
+
+ Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
+ Global Instance elim_fupd_step p E (P Q: PROP):
+ ElimModal True p false (|={E}â–·=> P) P (|={E}â–·=> Q) Q.
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iMod "P". iModIntro. iNext;simpl. iMod "P". iModIntro. by iApply "HPQ".
+ Qed.
+
+ Fixpoint eventuallyN n E P : PROP :=
+ match n with
+ | 0 => (|={E}=> P)%I
+ | S n => (|={E}=> â–· |={E}=> eventuallyN n E P)%I
+ end.
+
+ Definition eventually E P : PROP := (|={E}=> ∃ n, eventuallyN n E P)%I.
+
+ Notation "< E > P" := (eventually E P) (at level 99, E at level 50, P at level 200, format "< E > P").
+ Notation "< E >_ n P" := (eventuallyN n E P) (at level 99, E at level 50, n at level 9, P at level 200, format "< E >_ n P").
+
+ Global Instance eventuallyN_ne n E: NonExpansive (eventuallyN n E).
+ Proof.
+ intros α P Q EQ.
+ induction n as [|n IH]; simpl; f_equiv; eauto; by rewrite IH.
+ Qed.
+
+ Global Instance eventually_ne E: NonExpansive (eventually E).
+ Proof.
+ intros α P Q EQ. unfold eventually. f_equiv. f_equiv. intros ?. by apply eventuallyN_ne.
+ Qed.
+
+ Lemma eventuallyN_intro P E: P ⊢ <E>_0 P.
+ Proof.
+ iIntros "P". by iModIntro.
+ Qed.
+
+ Lemma eventuallyN_eventually n E P: (<E>_n P)%I ⊢ (<E> P)%I.
+ Proof. iIntros "H". iModIntro. by iExists n. Qed.
+
+ Lemma eventuallyN_fupd_left n E P: (|={E}=> <E>_n P)%I ⊢ (<E>_n P)%I.
+ Proof.
+ iIntros "H". destruct n as [|n]; simpl.
+ - by iMod "H".
+ - by do 2 iMod "H".
+ Qed.
+
+ Lemma eventuallyN_fupd_right n E P: (<E>_n |={E}=> P)%I ⊢ (<E>_n P)%I.
+ Proof.
+ iIntros "H". iInduction n as [|n] "IH"; simpl.
+ - by iMod "H".
+ - iMod "H". by iApply "IH".
+ Qed.
+
+ Lemma eventuallyN_step_left n E P: (▷ <E>_n P)%I ⊢ (<E>_(S n) P)%I.
+ Proof.
+ iIntros "H"; simpl. iModIntro. iNext;simpl. by iModIntro.
+ Qed.
+
+ Lemma eventuallyN_intro_n n E P : P ⊢ (<E>_n P).
+ Proof.
+ iIntros "H". iInduction n as [ | n] "IH"; simpl.
+ - iModIntro. iApply "H".
+ - iApply eventuallyN_step_left. iNext. by iApply "IH".
+ Qed.
+
+ Lemma eventuallyN_mono P E n1 n2 : n1 ≤ n2 → (<E>_n1 P) ⊢ <E>_n2 P.
+ Proof.
+ iIntros (H) "P". iRevert (n2 H). iInduction n1 as [ | n1] "IH"; iIntros ([ | n2] H).
+ - iApply "P".
+ - iMod "P". iApply eventuallyN_intro_n. iModIntro. iNext. iModIntro. iApply "P".
+ - lia.
+ - simpl. iMod "P". iApply ("IH" with "P [%]"). lia.
+ Qed.
+
+ Lemma eventuallyN_step_right n E P: (<E>_n ▷ P)%I ⊢ (<E>_(S n) P)%I.
+ Proof.
+ iIntros "H"; simpl. iInduction n as [|n] "IH"; simpl.
+ - iMod "H". iModIntro. iNext;simpl. by do 2 iModIntro.
+ - iMod "H". by iApply "IH".
+ Qed.
+
+ Lemma eventually_fupd_left E P: (|={E}=> <E> P)%I ⊢ (<E> P)%I.
+ Proof.
+ iIntros "H". by iMod "H".
+ Qed.
+
+ Lemma eventually_fupd_right E P: (<E> |={E}=> P)%I ⊢ (<E> P)%I.
+ Proof.
+ iIntros "H". iMod "H". iDestruct "H" as (n) "H". iModIntro.
+ iExists n. by iApply eventuallyN_fupd_right.
+ Qed.
+
+ Lemma eventually_step_right E P: (<E> ▷ P)%I ⊢ (<E> P)%I.
+ Proof.
+ iIntros "H"; simpl. iMod "H". iModIntro. iDestruct "H" as (n) "H".
+ iExists (S n). by iApply eventuallyN_step_right.
+ Qed.
+
+ Lemma eventuallyN_mask_mono E1 E2 P n: E1 ⊆ E2 → (<E1>_n P) ⊢ <E2>_n P.
+ Proof.
+ iIntros (Hsub) "P". iInduction n as [|n] "IH"; simpl.
+ - by iApply fupd_mask_mono.
+ - iApply fupd_mask_mono; eauto. iMod "P". iModIntro. iNext; simpl.
+ iApply fupd_mask_mono; eauto.
+ iMod (fupd_intro_mask') as "H'"; eauto.
+ iMod "P". iMod "H'" as "_". iModIntro. by iApply "IH".
+ Qed.
+
+
+ Lemma eventually_mask_mono E1 E2 P: E1 ⊆ E2 → (<E1> P) ⊢ <E2> P.
+ Proof.
+ iIntros (Hsub) "P". iApply fupd_mask_mono; eauto.
+ iMod "P". iModIntro. iDestruct "P" as (n) "P".
+ iExists n. by iApply eventuallyN_mask_mono.
+ Qed.
+
+ Lemma eventuallyN_compose E n m P : (<E>_n <E>_m P) ⊢ <E>_(n+m) P.
+ Proof.
+ iIntros "H". iInduction n as [ | n] "IH".
+ - simpl. destruct m as [ | m]; iMod "H"; iApply "H".
+ - simpl. iMod "H". by iApply "IH".
+ Qed.
+
+ Global Instance elim_eventuallyN p E (P Q : PROP) n:
+ ElimModal True p false (<E>_n P) P (<E>_n Q) (Q).
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iInduction n as [ | n] "IH".
+ - iMod "P". iModIntro. by iApply "HPQ".
+ - simpl. iMod "P". by iApply ("IH" with "[HPQ]").
+ Qed.
+
+ Lemma eventuallyN_compose' E n m P Q: (<E>_n P)%I ∗ (<E>_m (P -∗ Q))%I ⊢ (<E>_(n + m) Q).
+ Proof.
+ iIntros "[P PQ]". iApply eventuallyN_compose. iMod "P". iMod "PQ". by iApply "PQ".
+ Qed.
+
+ Lemma eventually_compose E P Q: (<E> P)%I ∗ (<E> P -∗ Q)%I ⊢ (<E> Q).
+ Proof.
+ iIntros "[P PQ]". iMod "P". iMod "PQ".
+ iDestruct "P" as (n) "P". iDestruct "PQ" as (m) "PQ".
+ iModIntro. iExists (n + m). iApply eventuallyN_compose'; iFrame.
+ Qed.
+
+ Instance elim_eventually p E (P Q: PROP):
+ ElimModal True p false (<E> P) emp (<E> Q) (<E> P -∗ Q)%I.
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iApply eventually_compose; iFrame. by iApply "HPQ".
+ Qed.
+
+ Lemma eventually_intro P E: P ⊢ <E> P.
+ Proof.
+ iIntros "P". iModIntro. iExists 0. by iApply eventuallyN_intro.
+ Qed.
+
+ Global Instance eventuallyN_equiv n E: Proper (equiv ==> equiv) (eventuallyN n E).
+ Proof.
+ intros P Q EQ. induction n; simpl.
+ - by f_equiv.
+ - by do 3 f_equiv.
+ Qed.
+
+ Global Instance eventually_equiv E: Proper (equiv ==> equiv) (eventually E).
+ Proof.
+ intros P Q EQ. unfold eventually. by repeat f_equiv.
+ Qed.
+
+End eventually.
+
+Notation "< E > P" := (eventually E P) (at level 99, E at level 50, P at level 200, format "< E > P").
+Notation "< E >_ n P" := (eventuallyN n E P) (at level 99, E at level 50, n at level 9, P at level 200, format "< E >_ n P").
+
+
+Section general_step.
+
+ Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
+
+ Definition gstepN (n: nat) Ei E1 E2 P : PROP := (|={E1, Ei}=> <Ei>_n |={Ei, E2}=> P)%I.
+ Definition gstep Ei E1 E2 P : PROP := (|={E1, Ei}=> <Ei> |={Ei, E2}=> P)%I.
+
+ Notation "'>={' E1 '}={' Ei '}={' E2 '}=>_' n P" := (gstepN n Ei E1 E2 P) (at level 99, E1, E2, Ei at level 60, n at level 9, P at level 200 (*, format "|={ E1 , E2 }=>> P" *)).
+ Notation "'>={' E1 '}={' Ei '}={' E2 '}=>' P" := (gstep Ei E1 E2 P) (at level 99, E1, E2, Ei at level 60, P at level 200 (*, format "|={ E1 , E2 }=>^ n P"*)).
+
+
+ (* Fancy Updates *)
+ Lemma gstepN_fupd_left n Ei E1 E2 E3 P: (|={E1, E2}=> >={ E2 }={ Ei }={ E3 }=>_n P)%I ⊢ (>={E1}={Ei}={E3}=>_n P)%I.
+ Proof.
+ iIntros "H". iMod "H". iMod "H". by iModIntro.
+ Qed.
+
+ Lemma gstepN_fupd_right n Ei E1 E2 E3 P: (>={ E1 }={ Ei }={ E2 }=>_n |={E2, E3}=> P)%I ⊢ (>={E1}={Ei}={E3}=>_n P)%I.
+ Proof.
+ iIntros "H". iMod "H"; iModIntro. iPoseProof (eventuallyN_compose' _ n 0) as "Q".
+ assert (n + 0 = 0 + n)%nat as -> by lia. iApply "Q"; iFrame.
+ iApply eventuallyN_intro. iIntros "H". by iMod "H".
+ Qed.
+
+ Lemma gstep_fupd_left Ei E1 E2 E3 P: (|={E1, E2}=> >={ E2 }={ Ei }={ E3 }=> P)%I ⊢ (>={E1}={Ei}={E3}=> P)%I.
+ Proof.
+ iIntros "H". iMod "H". iMod "H". by iModIntro.
+ Qed.
+
+ Existing Instance elim_eventually.
+ Lemma gstep_fupd_right Ei E1 E2 E3 P: (>={ E1 }={ Ei }={ E2 }=> |={E2, E3}=> P)%I ⊢ (>={E1}={Ei}={E3}=> P)%I.
+ Proof.
+ iIntros "H". iMod "H"; iModIntro. iMod "H" as "_".
+ iApply eventually_intro. iIntros "H". by iMod "H".
+ Qed.
+
+
+ (* Later Steps *)
+ Lemma gstepN_gstep Ei E1 E2 n P: (>={ E1 }={ Ei }={ E2 }=>_n P)%I ⊢ (>={ E1 }={ Ei }={ E2 }=> P)%I.
+ Proof.
+ iIntros "H". iMod "H". iModIntro.
+ by iApply eventuallyN_eventually.
+ Qed.
+
+ Lemma gstepN_later Ei E1 E2 n P: Ei ⊆ E1 → (▷ >={E1}={Ei}={E2}=>_n P)%I ⊢ (>={E1}={Ei}={E2}=>_(S n) P)%I.
+ Proof.
+ iIntros (Hsub) "H". iMod (fupd_intro_mask') as "E1"; eauto.
+ iModIntro. simpl. iModIntro. iNext;simpl.
+ by iMod "E1" as "_".
+ Qed.
+
+ Lemma gstepN_intro Ei E1 E2 P: Ei ⊆ E2 → (|={E1, E2}=> P)%I ⊢ (>={E1}={Ei}={E2}=>_0 P)%I.
+ Proof.
+ iIntros (Hsub) "H". iMod "H". iMod (fupd_intro_mask') as "E1"; eauto.
+ iModIntro. iApply eventuallyN_intro. iMod "E1". by iModIntro.
+ Qed.
+
+ Lemma gstepN_intro' Ei E1 E2 P: Ei ⊆ E1 → (|={E1, E2}=> P)%I ⊢ (>={E1}={Ei}={E2}=>_0 P)%I.
+ Proof.
+ iIntros (Hsub) "H". iMod (fupd_intro_mask') as "Ei1"; eauto. iModIntro.
+ iApply eventuallyN_intro. by iMod "Ei1".
+ Qed.
+
+ Lemma gstep_squash Ei E1 E2 P: Ei ⊆ E2 → (>={ E1 }={ Ei }={ E2 }=> ▷ P)%I ⊢ (>={ E1 }={ Ei }={ E2 }=> P)%I.
+ Proof.
+ iIntros (Hsub) "H". do 2 iMod "H". do 2 iModIntro. iDestruct "H" as (n) "H".
+ iExists (n + 1). iInduction n as [|n] "IH"; simpl.
+ - iMod "H". iMod "H". iMod (fupd_intro_mask') as "Ei2"; eauto.
+ iModIntro. iNext. do 2 iModIntro. iMod "Ei2". by iModIntro.
+ - iMod "H". by iApply "IH".
+ Qed.
+
+
+ Lemma gstepN_change_iter n Ei Ej E1 E2 P: Ej ⊆ Ei →
+ (>={E1}={Ei}={E2}=>_n P)%I ⊢ (>={E1}={Ej}={E2}=>_n P).
+ Proof.
+ iIntros (Hsub) "H". iMod "H".
+ iMod (fupd_intro_mask') as "Eji"; eauto.
+ iModIntro. iInduction n as [|n] "IH"; simpl.
+ - iModIntro. iMod "Eji" as "_". by iMod "H".
+ - iMod "Eji" as "_". iMod "H". iMod (fupd_intro_mask') as "Eji"; eauto.
+ iModIntro. iNext. iModIntro. iApply ("IH" with "[H] Eji").
+ iApply eventuallyN_fupd_left. iMod "H". by iModIntro.
+ Qed.
+
+ Lemma gstep_change_iter Ei Ej E1 E2 P: Ej ⊆ Ei →
+ (>={E1}={Ei}={E2}=> P)%I ⊢ (>={E1}={Ej}={E2}=> P).
+ Proof.
+ iIntros (Hsub) "H". do 2 iMod "H".
+ iMod (fupd_intro_mask') as "Eji"; eauto.
+ iModIntro. iDestruct "H" as (n) "H". iModIntro. iExists n.
+ iApply eventuallyN_fupd_left. iApply gstepN_change_iter; eauto.
+ iMod "Eji". by iModIntro.
+ Qed.
+
+ Lemma gstep_compose Ei Ej E1 E2 E3 P Q: E2 ⊆ Ei ⊆ Ej →
+ (>={E1}={Ei}={E2}=> P) -∗ (>={E2}={Ej}={E3}=> Q) -∗ >={E1}={Ej}={E3}=> P ∗ Q.
+ Proof.
+ iIntros (Hsub) "P Q". do 2 iMod "P".
+ iMod (fupd_intro_mask' _ E2) as "E2i"; first set_solver.
+ do 2 iMod "Q". iModIntro. iModIntro.
+ iDestruct "P" as (n1) "P". iDestruct "Q" as (n2) "Q".
+ iExists (n1 + n2). iInduction n1 as [|n1] "IH"; [iInduction n2 as [|n2] "IH"|]; simpl.
+ - iMod "Q". iAssert (|={E2}=> P)%I with "[P E2i]" as "P".
+ { iMod "E2i" as "_". by iMod "P". }
+ iMod (fupd_intro_mask' _ E2) as "E2j"; first set_solver.
+ iMod "P". iMod "E2j" as "_". iModIntro. by iFrame.
+ - iMod "Q". by iApply ("IH" with "P Q E2i").
+ - iMod (fupd_intro_mask' _ Ei) as "Eij"; first set_solver.
+ iMod "P". iMod "Eij" as "_". iModIntro. iNext.
+ iSpecialize ("IH" with "[P] Q E2i").
+ { by iApply eventuallyN_fupd_left. }
+ by iModIntro.
+ Qed.
+
+ Lemma gstepN_mono Ei E1 E2 P k1 k2: k1 ≤ k2 → (>={E1}={Ei}={E2}=>_k1 P) ⊢ >={E1}={Ei}={E2}=>_k2 P.
+ Proof.
+ iIntros (H) "P". iMod "P". iModIntro. by iApply (eventuallyN_mono _ _ k1 k2 H).
+ Qed.
+
+ Global Instance gstep_equiv Ei E1 E2: Proper (equiv ==> equiv) (gstep Ei E1 E2).
+ Proof.
+ intros P Q EQ. unfold gstep. by repeat f_equiv.
+ Qed.
+
+ Global Instance gstepN_equiv n Ei E1 E2: Proper (equiv ==> equiv) (gstepN n Ei E1 E2).
+ Proof.
+ intros P Q EQ. unfold gstepN. by repeat f_equiv.
+ Qed.
+
+
+ Instance elim_gstep p Ei E1 E2 (P Q: PROP):
+ ElimModal True p false (>={E1}={Ei}={E2}=> P) P (>={E1}={Ei}={E2}=> Q) Q.
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iMod "P". iModIntro. iMod "P" as "_". iModIntro. iExists 0. iModIntro. iIntros ">P".
+ iModIntro. by iApply "HPQ".
+ Qed.
+
+ Existing Instance elim_eventuallyN.
+ Instance elim_gstepN p Ei E1 E2 n (P Q: PROP):
+ ElimModal True p false (>={E1}={Ei}={E2}=>_n P) P (>={E1}={Ei}={E2}=>_n Q) Q.
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iMod "P". iModIntro. iMod "P". iMod "P". iModIntro. by iApply "HPQ".
+ Qed.
+
+ Notation "'>={' E1 '}=={' E2 '}=>^' n P" :=
+ (Nat.iter n (gstep ∅ E1 E2) P)
+ (at level 99, E1, E2 at level 60, n at level 9, P at level 200,
+ format "'>={' E1 '}=={' E2 '}=>^' n P").
+
+ Instance elim_gstep_N E1 E2 p n P Q :
+ ElimModal True p false (>={E1}=={E2}=>^n P) P (>={E1}=={E2}=>^n Q) Q.
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iInduction n as [ | n] "IH". by iApply "HPQ".
+ iMod "P". iApply ("IH" with "HPQ P").
+ Qed.
+
+ Global Instance gstep_ne E1 E2 E3: NonExpansive (gstep E2 E1 E3).
+ Proof. intros α x y Heq. unfold gstep. by do 3 f_equiv. Qed.
+
+ Global Instance gstepN_ne E1 E2 E3 n: NonExpansive (gstepN n E2 E1 E3).
+ Proof. intros α x y Heq. unfold gstepN. by do 3 f_equiv. Qed.
+End general_step.
+Notation "'>={' E1 '}={' Ei '}={' E2 '}=>_' n P" := (gstepN n Ei E1 E2 P) (at level 99, E1, E2, Ei at level 60, n at level 9, P at level 200 , format "'>={' E1 '}={' Ei '}={' E2 '}=>_' n P" ).
+Notation "'>={' E1 '}={' Ei '}={' E2 '}=>' P" := (gstep Ei E1 E2 P) (at level 99, E1, E2, Ei at level 60, P at level 200 (*, format "|={ E1 , E2 }=>^ n P"*)).
+
+Section logical_step.
+
+ Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
+ Implicit Types (P Q: PROP).
+
+ Notation "'>={' E1 '}=={' E2 '}=>_' n P" := (gstepN n ∅ E1 E2 P) (at level 99, E1, E2 at level 60, n at level 9, P at level 200 (*, format "|={ E1 , E2 }=>> P" *)).
+ Notation "'>={' E1 '}=={' E2 '}=>' P" := (gstep ∅ E1 E2 P) (at level 99, E1, E2 at level 60, P at level 200 (*, format "|={ E1 , E2 }=>^ n P"*)).
+
+
+ (* Fancy Updates *)
+ Lemma lstep_fupd_left E1 E2 E3 P: (|={E1, E2}=> >={E2}=={E3}=> P)%I ⊢ (>={E1}=={E3}=> P)%I.
+ Proof. apply gstep_fupd_left. Qed.
+
+ Lemma lstep_fupd_right E1 E2 E3 P: (>={E1}=={E2}=> |={E2, E3}=> P)%I ⊢ (>={E1}=={E3}=> P)%I.
+ Proof. apply gstep_fupd_right. Qed.
+
+ Lemma lstepN_fupd_left n E1 E2 E3 P: (|={E1, E2}=> >={E2}=={E3}=>_n P)%I ⊢ (>={E1}=={E3}=>_n P)%I.
+ Proof. apply gstepN_fupd_left. Qed.
+
+ Lemma lstepN_fupd_right n E1 E2 E3 P: (>={E1}=={E2}=>_n |={E2, E3}=> P)%I ⊢ (>={E1}=={E3}=>_n P)%I.
+ Proof. apply gstepN_fupd_right. Qed.
+
+
+ (* Later *)
+ Lemma lstepN_lstep E1 E2 n P: (>={ E1 }=={ E2 }=>_n P)%I ⊢ (>={ E1 }=={ E2 }=> P)%I.
+ Proof. apply gstepN_gstep. Qed.
+
+ Lemma lstepN_later E1 E2 n P: (▷ >={E1}=={E2}=>_n P)%I ⊢ (>={E1}=={E2}=>_(S n) P)%I.
+ Proof. apply gstepN_later. set_solver. Qed.
+
+ Lemma lstepN_intro' E1 E2 P: (|={E1, E2}=> P)%I ⊢ (>={E1}=={E2}=>_0 P)%I.
+ Proof. apply gstepN_intro. set_solver. Qed.
+ Lemma lstepN_intro E1 E2 n P: (|={E1, E2}=> P)%I ⊢ (>={E1}=={E2}=>_n P)%I.
+ Proof. iIntros "H". iApply gstepN_mono. 2: by iApply lstepN_intro'. lia. Qed.
+
+
+ Lemma lstep_squash E1 E2 P: (>={E1}=={E2}=> ▷ P) ⊢ (>={E1}=={E2}=> P).
+ Proof. apply gstep_squash. set_solver. Qed.
+
+
+ Lemma lstep_intro E1 E2 P : (|={E1, E2}=> P)%I ⊢ (>={E1}=={E2}=> P)%I.
+ Proof.
+ iIntros "H". iApply lstepN_lstep. by iApply lstepN_intro'.
+ Qed.
+
+End logical_step.
+Notation "'>={' E1 '}=={' E2 '}=>_' n P" := (gstepN n ∅ E1 E2 P) (at level 99, E1, E2 at level 60, n at level 9, P at level 200 , format "'>={' E1 '}=={' E2 '}=>_' n P" ).
+Notation "'>={' E1 '}=={' E2 '}=>' P" := (gstep ∅ E1 E2 P) (at level 99, E1, E2 at level 60, P at level 200 , format "'>={' E1 '}=={' E2 '}=>' P").
+Notation "'>={' E1 '}=={' E2 '}=>^' n P" :=
+ (Nat.iter n (gstep ∅ E1 E2) P)
+ (at level 99, E1, E2 at level 60, n at level 9, P at level 200,
+ format "'>={' E1 '}=={' E2 '}=>^' n P").
diff --git a/theories/base_logic/lib/na_invariants.v b/theories/base_logic/lib/na_invariants.v
index c92594bf03bd69529cc77263d2a513d64c3fe8ef..ee8a0bc737163ba24fc1f8b190d522c3f0914a8b 100644
--- a/theories/base_logic/lib/na_invariants.v
+++ b/theories/base_logic/lib/na_invariants.v
@@ -5,18 +5,18 @@ Set Default Proof Using "Type".
Import uPred.
(* Non-atomic ("thread-local") invariants. *)
-
Definition na_inv_pool_name := gname.
-Class na_invG Σ :=
- na_inv_inG :> inG Σ (prodR coPset_disjR (gset_disjR positive)).
-Definition na_invΣ : gFunctors :=
- #[ GFunctor (constRF (prodR coPset_disjR (gset_disjR positive))) ].
-Instance subG_na_invG {Σ} : subG na_invΣ Σ → na_invG Σ.
+
+Class na_invG {SI} Σ :=
+ na_inv_inG :> inG Σ (prodR (coPset_disjR SI) (gset_disjR positive)).
+Definition na_invΣ {SI} : gFunctors SI :=
+ #[ GFunctor (constRF (prodR (coPset_disjR SI) (gset_disjR positive))) ].
+Instance subG_na_invG {SI} {Σ: gFunctors SI} : subG na_invΣ Σ → na_invG Σ.
Proof. solve_inG. Qed.
Section defs.
- Context `{!invG Σ, !na_invG Σ}.
+ Context {SI} {Σ: gFunctors SI} `{!invG Σ, !na_invG Σ}.
Definition na_own (p : na_inv_pool_name) (E : coPset) : iProp Σ :=
own p (CoPset E, GSet ∅).
@@ -30,7 +30,7 @@ Instance: Params (@na_inv) 3 := {}.
Typeclasses Opaque na_own na_inv.
Section proofs.
- Context `{!invG Σ, !na_invG Σ}.
+ Context {SI} {Σ: gFunctors SI} `{!invG Σ, !na_invG Σ}.
Global Instance na_own_timeless p E : Timeless (na_own p E).
Proof. rewrite /na_own; apply _. Qed.
@@ -43,27 +43,27 @@ Section proofs.
Global Instance na_inv_persistent p N P : Persistent (na_inv p N P).
Proof. rewrite /na_inv; apply _. Qed.
- Lemma na_inv_iff p N P Q : ▷ □ (P ↔ Q) -∗ na_inv p N P -∗ na_inv p N Q.
+ Lemma na_inv_iff p N P Q : na_inv p N P -∗ ▷ □ (P ↔ Q) -∗ na_inv p N Q.
Proof.
- iIntros "#HPQ". rewrite /na_inv. iDestruct 1 as (i ?) "#Hinv".
- iExists i. iSplit; first done. iApply (inv_iff with "[] Hinv").
- iNext; iAlways.
+ iIntros "HI #HPQ". rewrite /na_inv. iDestruct "HI" as (i ?) "HI".
+ iExists i. iSplit; first done. iApply (inv_iff with "[$HI]"); eauto.
+ iIntros "!> !>".
iSplit; iIntros "[[? Ho]|$]"; iLeft; iFrame "Ho"; by iApply "HPQ".
Qed.
- Lemma na_alloc : (|==> ∃ p, na_own p ⊤)%I.
+ Lemma na_alloc : True ⊢ |==> ∃ p, na_own p ⊤.
Proof. by apply own_alloc. Qed.
Lemma na_own_disjoint p E1 E2 : na_own p E1 -∗ na_own p E2 -∗ ⌜E1 ## E2âŒ.
Proof.
- apply wand_intro_r.
+ apply bi.wand_intro_r.
rewrite /na_own -own_op own_valid -coPset_disj_valid_op. by iIntros ([? _]).
Qed.
Lemma na_own_union p E1 E2 :
E1 ## E2 → na_own p (E1 ∪ E2) ⊣⊢ na_own p E1 ∗ na_own p E2.
Proof.
- intros ?. by rewrite /na_own -own_op pair_op left_id coPset_disj_union.
+ intros ?. by rewrite /na_own -own_op pair_op coPset_disj_union // gset_disj_union // left_id_L.
Qed.
Lemma na_own_acc E2 E1 tid :
@@ -76,7 +76,7 @@ Section proofs.
Lemma na_inv_alloc p E N P : ▷ P ={E}=∗ na_inv p N P.
Proof.
iIntros "HP".
- iMod (own_unit (prodUR coPset_disjUR (gset_disjUR positive)) p) as "Hempty".
+ iMod (own_unit (prodUR (coPset_disjUR SI) (gset_disjUR positive)) p) as "Hempty".
iMod (own_updateP with "Hempty") as ([m1 m2]) "[Hm Hown]".
{ apply prod_updateP'. apply cmra_updateP_id, (reflexivity (R:=eq)).
apply (gset_disj_alloc_empty_updateP_strong' (λ i, i ∈ (↑N:coPset))).
@@ -91,7 +91,76 @@ Section proofs.
iNext. iLeft. by iFrame.
Qed.
- Lemma na_inv_open p E F N P :
+
+ (* This is a slightly more general rule than the na_inv_acc_open_timeless rule. We use it only to derive na_inv_acc_open_timeless for now. *)
+ Lemma na_inv_acc_open_timeless_weakening p E F N P Q :
+ Timeless Q → ↑N ⊆ E → ↑N ⊆ F →
+ na_inv p N P -∗ na_own p F -∗ (□ (P -∗ Q)) ={E}=∗ Q ∗ na_own p (F∖↑N) ∗ (▷ P ∗ na_own p (F∖↑N) -∗ |={E}=> na_own p F).
+ Proof.
+ rewrite /na_inv. iIntros (???) "#Hnainv Htoks #HPQ".
+ iDestruct "Hnainv" as (i) "[% Hinv]".
+ rewrite [F as X in na_own p X](union_difference_L (↑N) F) //.
+ rewrite [X in (X ∪ _)](union_difference_L {[i]} (↑N)) ?na_own_union; [|set_solver..].
+ iDestruct "Htoks" as "[[Htoki Q] R]".
+ iInv "Hinv" as "Inv" "Hclose".
+ iAssert (▷ (Q ∗ own p (CoPset ∅, GSet {[i]}) ∨ na_own p {[i]}))%I with "[HPQ Inv]" as ">Inv".
+ { iNext. iDestruct "Inv" as "[[P H]|H]"; eauto. iLeft. iFrame "H". by iApply "HPQ". }
+ iDestruct "Inv" as "[Hl|Htoki2]".
+ - iMod ("Hclose" with "[Htoki]") as "_"; first auto.
+ iModIntro. iDestruct "Hl" as "[P Hdis]".
+ iFrame. iIntros "[P HNA]".
+ iInv "Hinv" as "Inv" "Hclose".
+ iAssert (▷ (Q ∗ own p (CoPset ∅, GSet {[i]}) ∨ na_own p {[i]}))%I with "[HPQ Inv]" as ">Inv".
+ { iNext. iDestruct "Inv" as "[[P H]|H]"; eauto. iLeft. iFrame "H". by iApply "HPQ". }
+ iDestruct "Inv" as "[[Hl Hdis2]|Hitok]".
+ + iDestruct (own_valid_2 with "Hdis Hdis2") as %[_ Hval%gset_disj_valid_op].
+ set_solver.
+ + iMod ("Hclose" with "[P Hdis]") as "_".
+ { iNext; simpl. iLeft. iFrame. }
+ iModIntro. iFrame.
+ - iDestruct (na_own_disjoint with "Htoki Htoki2") as %?. set_solver.
+ Qed.
+
+ Lemma na_inv_acc_open_timeless p E F N P :
+ Timeless P → ↑N ⊆ E → ↑N ⊆ F →
+ na_inv p N P -∗ na_own p F ={E}=∗ P ∗ na_own p (F∖↑N)
+ ∗ (▷ P ∗ na_own p (F∖↑N) -∗ |={E}=> na_own p F).
+ Proof.
+ intros ???. iIntros "HI Hna". iApply (na_inv_acc_open_timeless_weakening with "HI Hna"); auto.
+ Qed.
+
+ Lemma na_inv_acc_open `{FiniteBoundedExistential SI} p E F N P :
+ ↑N ⊆ E → ↑N ⊆ F →
+ na_inv p N P -∗ na_own p F ={E}=∗ ▷ (P ∗ na_own p (F∖↑N)
+ ∗ (▷ P ∗ na_own p (F∖↑N) -∗ |={E}=> na_own p F)).
+ Proof.
+ rewrite /na_inv. iIntros (??) "#Hnainv Htoks".
+ iDestruct "Hnainv" as (i) "[% Hinv]".
+ rewrite [F as X in na_own p X](union_difference_L (↑N) F) //.
+ rewrite [X in (X ∪ _)](union_difference_L {[i]} (↑N)) ?na_own_union; [|set_solver..].
+ iDestruct "Htoks" as "[[Htoki Q] R]".
+ iInv "Hinv" as "Inv" "Hclose".
+ iPoseProof (later_or with "Inv") as "Inv".
+ iDestruct "Inv" as "[Hl|Htoki2]".
+ - iMod ("Hclose" with "[Htoki]") as "_"; first auto.
+ iModIntro. iNext. iDestruct "Hl" as "[P Hdis]".
+ iFrame. iIntros "[P HNA]".
+ iInv "Hinv" as "Inv" "Hclose".
+ iPoseProof (later_or with "Inv") as "Inv".
+ iDestruct "Inv" as "[Hl|Hitok]".
+ + iApply except_0_fupd. unfold sbi_except_0. iLeft.
+ iNext; simpl. iDestruct "Hl" as "[_ Hdis2]".
+ iDestruct (own_valid_2 with "Hdis Hdis2") as %[_ Hval%gset_disj_valid_op].
+ set_solver.
+ + iMod ("Hclose" with "[P Hdis]") as "_".
+ { iNext; simpl. iLeft. iFrame. }
+ iDestruct "Hitok" as ">Hitok".
+ iModIntro. iFrame.
+ - iApply except_0_fupd. unfold sbi_except_0. iLeft. iNext.
+ iDestruct (na_own_disjoint with "Htoki Htoki2") as %?. set_solver.
+ Qed.
+
+ Lemma na_inv_open `{FiniteIndex SI} p E F N P :
↑N ⊆ E → ↑N ⊆ F →
na_inv p N P -∗ na_own p F ={E}=∗ ▷ P ∗ na_own p (F∖↑N) ∗
(▷ P ∗ na_own p (F∖↑N) ={E}=∗ na_own p F).
@@ -113,7 +182,7 @@ Section proofs.
Global Instance into_inv_na p N P : IntoInv (na_inv p N P) N := {}.
- Global Instance into_acc_na p F E N P :
+ Global Instance into_acc_na `{FiniteIndex SI} p F E N P :
IntoAcc (X:=unit) (na_inv p N P)
(↑N ⊆ E ∧ ↑N ⊆ F) (na_own p F) (fupd E E) (fupd E E)
(λ _, ▷ P ∗ na_own p (F∖↑N))%I (λ _, ▷ P ∗ na_own p (F∖↑N))%I
diff --git a/theories/base_logic/lib/own.v b/theories/base_logic/lib/own.v
index 822b32f30330798256bdd1240fb75abd38ad84dd..3e2314186e571f4384cf9aa64f73ecf2a732c8e1 100644
--- a/theories/base_logic/lib/own.v
+++ b/theories/base_logic/lib/own.v
@@ -1,3 +1,4 @@
+From stdpp Require Import coPset.
From iris.algebra Require Import functions gmap.
From iris.base_logic.lib Require Export iprop.
From iris.algebra Require Import proofmode_classes.
@@ -9,11 +10,11 @@ Import uPred.
individual CMRAs instead of (lists of) CMRA *functors*. This additional class is
needed because Coq is otherwise unable to solve type class constraints due to
higher-order unification problems. *)
-Class inG (Σ : gFunctors) (A : cmraT) :=
+Class inG {SI} (Σ : gFunctors SI) (A : cmraT SI) :=
InG { inG_id : gid Σ; inG_prf : A = Σ inG_id (iPreProp Σ) _ }.
-Arguments inG_id {_ _} _.
+Arguments inG_id {_ _ _} _.
-Lemma subG_inG Σ (F : gFunctor) : subG F Σ → inG Σ (F (iPreProp Σ) _).
+Lemma subG_inG {SI} Σ (F : gFunctor SI) : subG F Σ → inG Σ (F (iPreProp Σ) _).
Proof. move=> /(_ 0%fin) /= [j ->]. by exists j. Qed.
(** This tactic solves the usual obligations "subG ? Σ → {in,?}G ? Σ" *)
@@ -22,6 +23,7 @@ Ltac solve_inG :=
intros;
(* Unfold the top-level xΣ. We need to support this to be a function. *)
lazymatch goal with
+ | H : subG (?xΣ _ _ _ _ _) _ |- _ => try unfold xΣ in H
| H : subG (?xΣ _ _ _ _) _ |- _ => try unfold xΣ in H
| H : subG (?xΣ _ _ _) _ |- _ => try unfold xΣ in H
| H : subG (?xΣ _ _) _ |- _ => try unfold xΣ in H
@@ -47,26 +49,26 @@ Ltac solve_inG :=
split; (assumption || by apply _).
(** * Definition of the connective [own] *)
-Definition iRes_singleton {Σ A} {i : inG Σ A} (γ : gname) (a : A) : iResUR Σ :=
+Definition iRes_singleton {SI} {Σ: gFunctors SI} {A} {i : inG Σ A} (γ : gname) (a : A) : iResUR Σ :=
discrete_fun_singleton (inG_id i) {[ γ := cmra_transport inG_prf a ]}.
Instance: Params (@iRes_singleton) 4 := {}.
-Definition own_def `{!inG Σ A} (γ : gname) (a : A) : iProp Σ :=
+Definition own_def {SI} {Σ: gFunctors SI} `{!inG Σ A} (γ : gname) (a : A) : iProp Σ :=
uPred_ownM (iRes_singleton γ a).
Definition own_aux : seal (@own_def). by eexists. Qed.
-Definition own {Σ A i} := own_aux.(unseal) Σ A i.
+Definition own {SI Σ A i} := own_aux.(unseal) SI Σ A i.
Definition own_eq : @own = @own_def := own_aux.(seal_eq).
-Instance: Params (@own) 4 := {}.
+Instance: Params (@own) 5 := {}.
Typeclasses Opaque own.
(** * Properties about ghost ownership *)
Section global.
-Context `{Hin: !inG Σ A}.
+Context {SI} {Σ: gFunctors SI} `{Hin: !inG Σ A}.
Implicit Types a : A.
(** ** Properties of [iRes_singleton] *)
Global Instance iRes_singleton_ne γ :
- NonExpansive (@iRes_singleton Σ A _ γ).
+ NonExpansive (@iRes_singleton SI Σ A _ γ).
Proof. by intros n a a' Ha; apply discrete_fun_singleton_ne; rewrite Ha. Qed.
Lemma iRes_singleton_op γ a1 a2 :
iRes_singleton γ (a1 ⋅ a2) ≡ iRes_singleton γ a1 ⋅ iRes_singleton γ a2.
@@ -75,17 +77,17 @@ Proof.
Qed.
(** ** Properties of [own] *)
-Global Instance own_ne γ : NonExpansive (@own Σ A _ γ).
+Global Instance own_ne γ : NonExpansive (@own SI Σ A _ γ).
Proof. rewrite !own_eq. solve_proper. Qed.
Global Instance own_proper γ :
- Proper ((≡) ==> (⊣⊢)) (@own Σ A _ γ) := ne_proper _.
+ Proper ((≡) ==> (⊣⊢)) (@own SI Σ A _ γ) := ne_proper _.
Lemma own_op γ a1 a2 : own γ (a1 ⋅ a2) ⊣⊢ own γ a1 ∗ own γ a2.
Proof. by rewrite !own_eq /own_def -ownM_op iRes_singleton_op. Qed.
Lemma own_mono γ a1 a2 : a2 ≼ a1 → own γ a1 ⊢ own γ a2.
Proof. move=> [c ->]. by rewrite own_op sep_elim_l. Qed.
-Global Instance own_mono' γ : Proper (flip (≼) ==> (⊢)) (@own Σ A _ γ).
+Global Instance own_mono' γ : Proper (flip (≼) ==> (⊢)) (@own SI Σ A _ γ).
Proof. intros a1 a2. apply own_mono. Qed.
Lemma own_valid γ a : own γ a ⊢ ✓ a.
@@ -110,7 +112,7 @@ Proof. rewrite !own_eq /own_def; apply _. Qed.
Global Instance own_core_persistent γ a : CoreId a → Persistent (own γ a).
Proof. rewrite !own_eq /own_def; apply _. Qed.
-Lemma later_own γ a : ▷ own γ a -∗ ◇ (∃ b, own γ b ∧ ▷ (a ≡ b)).
+Lemma later_own `{FiniteIndex SI} γ a : ▷ own γ a -∗ ◇ (∃ b, own γ b ∧ ▷ (a ≡ b)).
Proof.
rewrite own_eq /own_def later_ownM. apply exist_elim=> r.
assert (NonExpansive (λ r : iResUR Σ, r (inG_id Hin) !! γ)).
@@ -121,7 +123,7 @@ Proof.
{ by rewrite and_elim_r /sbi_except_0 -or_intro_l. }
rewrite -except_0_intro -(exist_intro (cmra_transport (eq_sym inG_prf) b)).
apply and_mono.
- - rewrite /iRes_singleton. assert (∀ {A A' : cmraT} (Heq : A' = A) (a : A),
+ - rewrite /iRes_singleton. assert (∀ {A A' : cmraT SI} (Heq : A' = A) (a : A),
cmra_transport Heq (cmra_transport (eq_sym Heq) a) = a) as ->
by (by intros ?? ->).
apply ownM_mono=> /=.
@@ -135,7 +137,7 @@ Proof.
+ rewrite discrete_fun_lookup_insert_ne //.
by rewrite discrete_fun_lookup_singleton_ne // left_id.
- apply later_mono.
- by assert (∀ {A A' : cmraT} (Heq : A' = A) (a' : A') (a : A),
+ by assert (∀ {A A' : cmraT SI} (Heq : A' = A) (a' : A') (a : A),
cmra_transport Heq a' ≡ a ⊢@{iPropI Σ}
a' ≡ cmra_transport (eq_sym Heq) a) as -> by (by intros ?? ->).
Qed.
@@ -145,7 +147,7 @@ Qed.
assertion. However, the map_updateP_alloc does not suffice to show this. *)
Lemma own_alloc_strong a (P : gname → Prop) :
pred_infinite P →
- ✓ a → (|==> ∃ γ, ⌜P γ⌠∧ own γ a)%I.
+ ✓ a → bi_emp_valid (|==> ∃ γ, ⌜P γ⌠∧ own γ a)%I.
Proof.
intros HP Ha.
rewrite -(bupd_mono (∃ m, ⌜∃ γ, P γ ∧ m = iRes_singleton γ a⌠∧ uPred_ownM m)%I).
@@ -157,7 +159,7 @@ Proof.
by rewrite !own_eq /own_def -(exist_intro γ) pure_True // left_id.
Qed.
Lemma own_alloc_cofinite a (G : gset gname) :
- ✓ a → (|==> ∃ γ, ⌜γ ∉ G⌠∧ own γ a)%I.
+ ✓ a → bi_emp_valid (|==> ∃ γ, ⌜γ ∉ G⌠∧ own γ a)%I.
Proof.
intros Ha.
apply (own_alloc_strong a (λ γ, γ ∉ G))=> //.
@@ -165,7 +167,7 @@ Proof.
intros E. set (i := fresh (G ∪ E)).
exists i. apply not_elem_of_union, is_fresh.
Qed.
-Lemma own_alloc a : ✓ a → (|==> ∃ γ, own γ a)%I.
+Lemma own_alloc a : ✓ a → bi_emp_valid (|==> ∃ γ, own γ a)%I.
Proof.
intros Ha. rewrite /uPred_valid /bi_emp_valid (own_alloc_cofinite a ∅) //; [].
apply bupd_mono, exist_mono=>?. eauto using and_elim_r.
@@ -185,7 +187,7 @@ Qed.
Lemma own_update γ a a' : a ~~> a' → own γ a ==∗ own γ a'.
Proof.
- intros; rewrite (own_updateP (a' =)); last by apply cmra_update_updateP.
+ intros; rewrite (own_updateP (eq a')); last by apply cmra_update_updateP.
by apply bupd_mono, exist_elim=> a''; apply pure_elim_l=> ->.
Qed.
Lemma own_update_2 γ a1 a2 a' :
@@ -196,17 +198,17 @@ Lemma own_update_3 γ a1 a2 a3 a' :
Proof. intros. do 2 apply wand_intro_r. rewrite -!own_op. by apply own_update. Qed.
End global.
-Arguments own_valid {_ _} [_] _ _.
-Arguments own_valid_2 {_ _} [_] _ _ _.
-Arguments own_valid_3 {_ _} [_] _ _ _ _.
-Arguments own_valid_l {_ _} [_] _ _.
-Arguments own_valid_r {_ _} [_] _ _.
-Arguments own_updateP {_ _} [_] _ _ _ _.
-Arguments own_update {_ _} [_] _ _ _ _.
-Arguments own_update_2 {_ _} [_] _ _ _ _ _.
-Arguments own_update_3 {_ _} [_] _ _ _ _ _ _.
+Arguments own_valid {_ _ _} [_] _ _.
+Arguments own_valid_2 {_ _ _} [_] _ _ _.
+Arguments own_valid_3 {_ _ _} [_] _ _ _ _.
+Arguments own_valid_l {_ _ _} [_] _ _.
+Arguments own_valid_r {_ _ _} [_] _ _.
+Arguments own_updateP {_ _ _} [_] _ _ _ _.
+Arguments own_update {_ _ _} [_] _ _ _ _.
+Arguments own_update_2 {_ _ _} [_] _ _ _ _ _.
+Arguments own_update_3 {_ _ _} [_] _ _ _ _ _ _.
-Lemma own_unit A `{!inG Σ (A:ucmraT)} γ : (|==> own γ ε)%I.
+Lemma own_unit {SI} A `{!inG Σ (A:ucmraT SI)} γ : (|==> own γ ε)%I.
Proof.
rewrite /uPred_valid /bi_emp_valid (ownM_unit emp) !own_eq /own_def.
apply bupd_ownM_update, discrete_fun_singleton_update_empty.
@@ -215,14 +217,43 @@ Proof.
- intros x; destruct inG_prf. by rewrite left_id.
Qed.
+(* TODO: this is a nice property but we do not have a usecase yet. *)
+Lemma cmra_own_exists_commute {SI} {Σ: gFunctors SI} (A: cmraT SI) `{Hin: !inG Σ A} X (φ: X → iProp Σ) a γ : ✓ a → (∀ b n, ✓{n} b → ✓{n} (b ⋅ a)) → ((own γ a -∗ ∃ x, φ x) ⊢ (∃ x, own γ a -∗ φ x))%I.
+Proof.
+ intros HvalA Hval. rewrite own_eq /own_def; apply uPred_primitive.exists_own_wand.
+ intros f n Hv. intros id γ'; simpl.
+ rewrite discrete_fun_lookup_op /iRes_singleton.
+ destruct (decide (inG_id _ = id)) as [[]|].
+ - rewrite discrete_fun_lookup_singleton lookup_op.
+ destruct (decide (γ = γ')) as [->|].
+ + rewrite lookup_singleton. specialize (Hv (inG_id Hin) γ').
+ destruct ((@lookup gname _ _ (@gmap_lookup gname _ _ (@cmra_car SI _)) γ' (f (inG_id Hin)))) as [u|].
+ * rewrite -Some_op /cmra_transport. destruct inG_prf. simpl.
+ apply Some_validN, Hval, Hv.
+ * rewrite left_id. apply Some_validN, cmra_transport_validN.
+ apply cmra_valid_validN, HvalA.
+ + rewrite lookup_singleton_ne; auto.
+ rewrite right_id. by apply Hv.
+ - rewrite discrete_fun_lookup_singleton_ne; auto.
+ rewrite right_id. by apply Hv.
+Qed.
+
+
+Lemma ucmra_own_exists_commute {SI} {Σ: gFunctors SI} (A: ucmraT SI) `{Hin: !inG Σ A} X (φ: X → iProp Σ) a γ : (∀ b n, ✓{n} b → ✓{n} (b ⋅ a)) → ((own γ a -∗ ∃ x, φ x) ⊢ (∃ x, own γ a -∗ φ x))%I.
+Proof.
+ intros Hval. apply cmra_own_exists_commute; last done.
+ assert (a ≡ ε ⋅ a) as -> by (rewrite left_id //=).
+ apply cmra_valid_validN; intros n; apply Hval, ucmra_unit_validN.
+Qed.
+
(** Big op class instances *)
-Instance own_cmra_sep_homomorphism `{!inG Σ (A:ucmraT)} :
+Instance own_cmra_sep_homomorphism {SI} `{!inG Σ (A:ucmraT SI)} :
WeakMonoidHomomorphism op uPred_sep (≡) (own γ).
Proof. split; try apply _. apply own_op. Qed.
(** Proofmode class instances *)
Section proofmode_classes.
- Context `{!inG Σ A}.
+ Context {SI} {Σ: gFunctors SI} `{!inG Σ A}.
Implicit Types a b : A.
Global Instance into_sep_own γ a b1 b2 :
@@ -243,3 +274,91 @@ Section proofmode_classes.
destruct Hb; by rewrite persistent_and_sep.
Qed.
End proofmode_classes.
+
+
+Definition initial_def {SI} {Σ: gFunctors SI} (G: coPset) (P: iProp Σ): Prop :=
+ (∃ m: iResUR Σ, ✓ m ∧ (∀ i, dom _ (m i) ⊆ G) ∧ (uPred_ownM m ⊢ P)).
+Definition initial_aux : seal (@initial_def). by eexists. Qed.
+Definition initial {SI Σ} := initial_aux.(unseal) SI Σ.
+Definition initial_eq : @initial = @initial_def := initial_aux.(seal_eq).
+Instance: Params (@initial) 4 := {}.
+Typeclasses Opaque initial.
+
+
+(* TODO: the following lemma is a modified version of dom_op. There should be a lemma generalizing both. *)
+Lemma dom_coPset_op {SI} {A : cmraT SI} (m1 m2: gmap gname A) : dom coPset (m1 ⋅ m2) = dom _ m1 ∪ dom _ m2.
+Proof.
+ apply elem_of_equiv_L=> i; rewrite elem_of_union !elem_of_dom.
+ unfold is_Some; setoid_rewrite lookup_op.
+ destruct (@lookup positive _ _ (@gmap_lookup positive _ _ (@cmra_car SI A)) i m1),
+ (@lookup positive _ _ (@gmap_lookup positive _ _ (@cmra_car SI A)) i m2);
+ naive_solver.
+Qed.
+
+Lemma initial_alloc {SI} {Σ: gFunctors SI} `{!inG Σ A} (γ : gname) (a : A):
+ ✓ a → initial {[ γ ]} (own γ a).
+Proof.
+ rewrite initial_eq /initial_def.
+ intros Hv. exists (iRes_singleton γ a). split; [|split].
+ - unfold iRes_singleton.
+ apply cmra_valid_validN. intros α.
+ apply discrete_fun_singleton_validN.
+ by apply cmra_valid_validN, singleton_valid, cmra_transport_valid.
+ - intros i γ'. rewrite /iRes_singleton.
+ unfold discrete_fun_singleton, discrete_fun_insert.
+ destruct decide.
+ + destruct e; simpl. by rewrite dom_singleton.
+ + naive_solver.
+ - by rewrite own_eq /own_def.
+Qed.
+
+
+Lemma initial_combine {SI} {Σ: gFunctors SI} G1 G2 (P Q: iProp Σ):
+ initial G1 P → initial G2 Q → G1 ## G2 → initial (G1 ∪ G2) (P ∗ Q)%I.
+Proof.
+ rewrite initial_eq /initial_def; intros (m1 & V1 & H1 & HP) (m2 & V2 & H2 & HQ) G12.
+ exists (λ i, m1 i ⋅ m2 i). split; [|split].
+ - intros i γ. rewrite lookup_op.
+ specialize (H1 i). specialize (H2 i).
+ destruct (m1 i !! γ) as [r|] eqn: EQ1; first destruct (m2 i !! γ) as [r'|] eqn: EQ2.
+ + assert (γ ∈ dom coPset (m1 i))
+ by by apply (elem_of_dom_2 (m1 i) γ r (D := coPset)).
+ assert (γ ∈ dom coPset (m2 i))
+ by by apply (elem_of_dom_2 (m2 i) γ r' (D := coPset)).
+ set_solver.
+ + rewrite EQ2 right_id. apply V1.
+ + rewrite EQ1 left_id. apply V2.
+ - intros i. rewrite dom_coPset_op. set_solver.
+ - by rewrite ownM_op HP HQ.
+Qed.
+
+Lemma initial_mono {SI} {Σ: gFunctors SI} G (P Q: iProp Σ):
+ (P ⊢ Q) → initial G P → initial G Q.
+Proof.
+ rewrite initial_eq /initial_def.
+ intros PQ (m & V & H & HP).
+ exists m; split; last split; eauto.
+ by rewrite HP PQ.
+Qed.
+
+Lemma initial_weaken {SI} {Σ: gFunctors SI} G1 G2 (P: iProp Σ):
+ initial G1 P → G1 ⊆ G2 → initial G2 P.
+Proof.
+ rewrite initial_eq /initial_def.
+ intros (m & V & H & HP) Hsub.
+ exists m; split; last split; eauto.
+ set_solver.
+Qed.
+
+From iris.base_logic Require Import satisfiable.
+Lemma initial_satisfiable {SI} {Σ: gFunctors SI} G (P: iProp Σ):
+ initial G P → satisfiable P.
+Proof.
+ rewrite initial_eq /initial_def.
+ intros (m & V & H & HP). simpl.
+ intros α. exists m. split.
+ - by apply cmra_valid_validN.
+ - destruct HP as [HP]. apply HP; first by apply cmra_valid_validN.
+ unseal. rewrite /uPred_ownM_def. exists ε.
+ by rewrite right_id.
+Qed.
\ No newline at end of file
diff --git a/theories/base_logic/lib/proph_map.v b/theories/base_logic/lib/proph_map.v
index 28962d6cb847994872931281ec300323e14fd12b..79a4b01fc9fbf97a2db048a390ea83d87479244d 100644
--- a/theories/base_logic/lib/proph_map.v
+++ b/theories/base_logic/lib/proph_map.v
@@ -7,31 +7,31 @@ Import uPred.
Local Notation proph_map P V := (gmap P (list V)).
Definition proph_val_list (P V : Type) := list (P * V).
-Definition proph_mapUR (P V : Type) `{Countable P} : ucmraT :=
- gmapUR P $ exclR $ listO $ leibnizO V.
+Definition proph_mapUR (SI: indexT) (P V : Type) `{Countable P} : ucmraT SI :=
+ gmapUR P $ exclR $ listO $ leibnizO SI V.
-Definition to_proph_map {P V} `{Countable P} (pvs : proph_map P V) : proph_mapUR P V :=
- fmap (λ vs, Excl (vs : list (leibnizO V))) pvs.
+Definition to_proph_map SI {P V} `{Countable P} (pvs : proph_map P V) : proph_mapUR SI P V :=
+ fmap (λ vs, Excl (vs : list (leibnizO SI V))) pvs.
(** The CMRA we need. *)
-Class proph_mapG (P V : Type) (Σ : gFunctors) `{Countable P} := ProphMapG {
- proph_map_inG :> inG Σ (authR (proph_mapUR P V));
+Class proph_mapG {SI} (P V : Type) (Σ : gFunctors SI) `{Countable P} := ProphMapG {
+ proph_map_inG :> inG Σ (authR (proph_mapUR SI P V));
proph_map_name : gname
}.
-Arguments proph_map_name {_ _ _ _ _} _ : assert.
+Arguments proph_map_name {_ _ _ _ _ _} _ : assert.
-Class proph_mapPreG (P V : Type) (Σ : gFunctors) `{Countable P} :=
- { proph_map_preG_inG :> inG Σ (authR (proph_mapUR P V)) }.
+Class proph_mapPreG {SI} (P V : Type) (Σ : gFunctors SI) `{Countable P} :=
+ { proph_map_preG_inG :> inG Σ (authR (proph_mapUR SI P V)) }.
-Definition proph_mapΣ (P V : Type) `{Countable P} : gFunctors :=
- #[GFunctor (authR (proph_mapUR P V))].
+Definition proph_mapΣ {SI} (P V : Type) `{Countable P} : gFunctors SI :=
+ #[GFunctor (authR (proph_mapUR SI P V))].
-Instance subG_proph_mapPreG {Σ P V} `{Countable P} :
+Instance subG_proph_mapPreG {SI} {Σ: gFunctors SI} {P V} `{Countable P} :
subG (proph_mapΣ P V) Σ → proph_mapPreG P V Σ.
Proof. solve_inG. Qed.
Section definitions.
- Context `{pG : proph_mapG P V Σ}.
+ Context {SI} {Σ: gFunctors SI} `{pG : proph_mapG SI P V Σ}.
Implicit Types pvs : proph_val_list P V.
Implicit Types R : proph_map P V.
Implicit Types p : P.
@@ -50,7 +50,7 @@ Section definitions.
Definition proph_map_ctx pvs (ps : gset P) : iProp Σ :=
(∃ R, ⌜proph_resolves_in_list R pvs ∧
dom (gset _) R ⊆ ps⌠∗
- own (proph_map_name pG) (â— (to_proph_map R)))%I.
+ own (proph_map_name pG) (â— (to_proph_map SI R)))%I.
Definition proph_def (p : P) (vs : list V) : iProp Σ :=
own (proph_map_name pG) (â—¯ {[p := Excl vs]}).
@@ -79,45 +79,52 @@ Section list_resolves.
End list_resolves.
Section to_proph_map.
- Context (P V : Type) `{Countable P}.
+ Context (SI: indexT) (P V : Type) `{Countable P}.
Implicit Types p : P.
Implicit Types vs : list V.
Implicit Types R : proph_map P V.
- Lemma to_proph_map_valid R : ✓ to_proph_map R.
+ Lemma to_proph_map_valid R : ✓ to_proph_map SI R.
Proof. intros l. rewrite lookup_fmap. by case (R !! l). Qed.
Lemma to_proph_map_insert p vs R :
- to_proph_map (<[p := vs]> R) = <[p := Excl (vs: list (leibnizO V))]> (to_proph_map R).
+ to_proph_map SI (<[p := vs]> R) = <[p := Excl (vs: list (leibnizO SI V))]> (to_proph_map SI R).
Proof. by rewrite /to_proph_map fmap_insert. Qed.
Lemma to_proph_map_delete p R :
- to_proph_map (delete p R) = delete p (to_proph_map R).
+ to_proph_map SI (delete p R) = delete p (to_proph_map SI R).
Proof. by rewrite /to_proph_map fmap_delete. Qed.
Lemma lookup_to_proph_map_None R p :
- R !! p = None → to_proph_map R !! p = None.
+ R !! p = None → to_proph_map SI R !! p = None.
Proof. by rewrite /to_proph_map lookup_fmap=> ->. Qed.
Lemma proph_map_singleton_included R p vs :
- {[p := Excl vs]} ≼ to_proph_map R → R !! p = Some vs.
+ {[p := Excl vs]} ≼ to_proph_map SI R → R !! p = Some vs.
Proof.
rewrite singleton_included_exclusive; last by apply to_proph_map_valid.
by rewrite leibniz_equiv_iff /to_proph_map lookup_fmap fmap_Some=> -[v' [-> [->]]].
Qed.
End to_proph_map.
-Lemma proph_map_init `{Countable P, !proph_mapPreG P V PVS} pvs ps :
- (|==> ∃ _ : proph_mapG P V PVS, proph_map_ctx pvs ps)%I.
+Lemma proph_map_init' {SI: indexT} {Σ: gFunctors SI} `{Countable P, !proph_mapPreG P V Σ} pvs ps :
+ sbi_emp_valid (|==> ∃ γ, let H := ProphMapG SI P V Σ _ _ _ γ in proph_map_ctx pvs ps)%I.
Proof.
- iMod (own_alloc (◠to_proph_map ∅)) as (γ) "Hh".
+ iMod (own_alloc (◠to_proph_map SI ∅)) as (γ) "Hh".
{ rewrite auth_auth_valid. exact: to_proph_map_valid. }
- iModIntro. iExists (ProphMapG P V PVS _ _ _ γ), ∅. iSplit; last by iFrame.
+ iModIntro. iExists γ, ∅. iSplit; last by iFrame.
iPureIntro. split =>//.
Qed.
+Lemma proph_map_init {SI: indexT} {PVS: gFunctors SI} `{Countable P, !proph_mapPreG P V PVS} pvs ps :
+ sbi_emp_valid (|==> ∃ _ : proph_mapG P V PVS, proph_map_ctx pvs ps)%I.
+Proof.
+ iMod (proph_map_init' pvs ps) as (γ) "H". iModIntro.
+ by iExists (ProphMapG SI P V PVS _ _ _ γ).
+Qed.
+
Section proph_map.
- Context `{proph_mapG P V Σ}.
+ Context {SI} {Σ: gFunctors SI} `{proph_mapG SI P V Σ}.
Implicit Types p : P.
Implicit Types v : V.
Implicit Types vs : list V.
@@ -170,7 +177,7 @@ Section proph_map.
{ (* FIXME: FIXME(Coq #6294): needs new unification *)
eapply auth_update. apply: singleton_local_update.
- by rewrite /to_proph_map lookup_fmap HR.
- - by apply (exclusive_local_update _ (Excl (proph_list_resolves pvs p : list (leibnizO V)))). }
+ - by apply (exclusive_local_update _ (Excl (proph_list_resolves pvs p : list (leibnizO SI V)))). }
rewrite /to_proph_map -fmap_insert.
iModIntro. iExists (proph_list_resolves pvs p). iFrame. iSplitR.
- iPureIntro. done.
diff --git a/theories/base_logic/lib/saved_prop.v b/theories/base_logic/lib/saved_prop.v
index 2af2c2712b171376218f3f8f27131dceac20591b..2e9ea8c6f37de313802643e2b1f257c90627eac3 100644
--- a/theories/base_logic/lib/saved_prop.v
+++ b/theories/base_logic/lib/saved_prop.v
@@ -1,5 +1,5 @@
From iris.base_logic Require Export own.
-From iris.algebra Require Import agree.
+From iris.algebra Require Import agree ofe.
From stdpp Require Import gmap.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
@@ -8,26 +8,26 @@ Import uPred.
(* "Saved anything" -- this can give you saved propositions, saved predicates,
saved whatever-you-like. *)
-Class savedAnythingG (Σ : gFunctors) (F : oFunctor) := SavedAnythingG {
- saved_anything_inG :> inG Σ (agreeR (F (iPreProp Σ) _));
+Class savedAnythingG (SI : indexT) (Σ : gFunctors SI) (F : oFunctor SI) := SavedAnythingG {
+ saved_anything_inG :> inG Σ (agreeR (F (iPreProp Σ)));
saved_anything_contractive : oFunctorContractive F (* NOT an instance to avoid cycles with [subG_savedAnythingΣ]. *)
}.
-Definition savedAnythingΣ (F : oFunctor) `{!oFunctorContractive F} : gFunctors :=
+Definition savedAnythingΣ (SI : indexT) (F : oFunctor SI) `{!oFunctorContractive F} : gFunctors SI :=
#[ GFunctor (agreeRF F) ].
-Instance subG_savedAnythingΣ {Σ F} `{!oFunctorContractive F} :
- subG (savedAnythingΣ F) Σ → savedAnythingG Σ F.
+Instance subG_savedAnythingΣ {SI Σ} {F : oFunctor SI} `{!oFunctorContractive F} :
+ subG (savedAnythingΣ SI F) Σ → savedAnythingG SI Σ F.
Proof. solve_inG. Qed.
-Definition saved_anything_own `{!savedAnythingG Σ F}
- (γ : gname) (x : F (iProp Σ) _) : iProp Σ :=
+Definition saved_anything_own {SI} `{!savedAnythingG SI Σ F}
+ (γ : gname) (x : F (iProp Σ)) : iProp Σ :=
own γ (to_agree $ (oFunctor_map F (iProp_fold, iProp_unfold) x)).
Typeclasses Opaque saved_anything_own.
Instance: Params (@saved_anything_own) 4 := {}.
Section saved_anything.
- Context `{!savedAnythingG Σ F}.
- Implicit Types x y : F (iProp Σ) _.
+ Context `{!savedAnythingG SI Σ F}.
+ Implicit Types x y : F (iProp Σ).
Implicit Types γ : gname.
Global Instance saved_anything_persistent γ x :
@@ -41,14 +41,14 @@ Section saved_anything.
Lemma saved_anything_alloc_strong x (I : gname → Prop) :
pred_infinite I →
- (|==> ∃ γ, ⌜I γ⌠∧ saved_anything_own γ x)%I.
+ ⊢ |==> ∃ γ, ⌜I γ⌠∧ saved_anything_own γ x.
Proof. intros ?. by apply own_alloc_strong. Qed.
Lemma saved_anything_alloc_cofinite x (G : gset gname) :
- (|==> ∃ γ, ⌜γ ∉ G⌠∧ saved_anything_own γ x)%I.
+ ⊢ |==> ∃ γ, ⌜γ ∉ G⌠∧ saved_anything_own γ x.
Proof. by apply own_alloc_cofinite. Qed.
- Lemma saved_anything_alloc x : (|==> ∃ γ, saved_anything_own γ x)%I.
+ Lemma saved_anything_alloc x : ⊢ |==> ∃ γ, saved_anything_own γ x.
Proof. by apply own_alloc. Qed.
Lemma saved_anything_agree γ x y :
@@ -58,7 +58,7 @@ Section saved_anything.
iDestruct (own_valid_2 with "Hx Hy") as "Hv".
rewrite agree_validI agree_equivI.
set (G1 := oFunctor_map F (iProp_fold, iProp_unfold)).
- set (G2 := oFunctor_map F (@iProp_unfold Σ, @iProp_fold Σ)).
+ set (G2 := oFunctor_map F (@iProp_unfold _ Σ, @iProp_fold _ Σ)).
assert (∀ z, G2 (G1 z) ≡ z) as help.
{ intros z. rewrite /G1 /G2 -oFunctor_compose -{2}[z]oFunctor_id.
apply (ne_proper (oFunctor_map F)); split=>?; apply iProp_fold_unfold. }
@@ -69,63 +69,65 @@ End saved_anything.
(** Provide specialized versions of this for convenience. **)
(* Saved propositions. *)
-Notation savedPropG Σ := (savedAnythingG Σ (▶ ∙)).
-Notation savedPropΣ := (savedAnythingΣ (▶ ∙)).
+Notation savedPropG Σ := (savedAnythingG _ Σ (▶ ( ∙ _))).
+Notation savedPropΣ := (savedAnythingΣ _ (▶ (∙ _))).
-Definition saved_prop_own `{!savedPropG Σ} (γ : gname) (P: iProp Σ) :=
- saved_anything_own (F := ▶ ∙) γ (Next P).
+Definition saved_prop_own {SI} {Σ : gFunctors SI} `{!savedPropG Σ} (γ : gname) (P: iProp Σ) :=
+ saved_anything_own (F := ▶ (∙ _)) γ (Next P).
-Instance saved_prop_own_contractive `{!savedPropG Σ} γ :
+Instance saved_prop_own_contractive {SI} {Σ : gFunctors SI} `{!savedPropG Σ} γ :
Contractive (saved_prop_own γ).
Proof. solve_contractive. Qed.
-Lemma saved_prop_alloc_strong `{!savedPropG Σ} (I : gname → Prop) (P: iProp Σ) :
+Lemma saved_prop_alloc_strong {SI} {Σ : gFunctors SI} `{!savedPropG Σ} (I : gname → Prop) (P: iProp Σ) :
pred_infinite I →
- (|==> ∃ γ, ⌜I γ⌠∧ saved_prop_own γ P)%I.
+ ⊢ |==> ∃ γ, ⌜I γ⌠∧ saved_prop_own γ P.
Proof. iIntros (?). by iApply saved_anything_alloc_strong. Qed.
-Lemma saved_prop_alloc_cofinite `{!savedPropG Σ} (G : gset gname) (P: iProp Σ) :
- (|==> ∃ γ, ⌜γ ∉ G⌠∧ saved_prop_own γ P)%I.
+Lemma saved_prop_alloc_cofinite {SI} {Σ : gFunctors SI} `{!savedPropG Σ} (G : gset gname) (P: iProp Σ) :
+ ⊢ |==> ∃ γ, ⌜γ ∉ G⌠∧ saved_prop_own γ P.
Proof. iApply saved_anything_alloc_cofinite. Qed.
-Lemma saved_prop_alloc `{!savedPropG Σ} (P: iProp Σ) :
- (|==> ∃ γ, saved_prop_own γ P)%I.
+Lemma saved_prop_alloc `{Σ : gFunctors SI} `{!savedPropG Σ} (P: iProp Σ) :
+ ⊢ |==> ∃ γ, saved_prop_own γ P.
Proof. iApply saved_anything_alloc. Qed.
-Lemma saved_prop_agree `{!savedPropG Σ} γ P Q :
+Lemma saved_prop_agree `{Σ : gFunctors SI} `{!savedPropG Σ} γ P Q :
saved_prop_own γ P -∗ saved_prop_own γ Q -∗ ▷ (P ≡ Q).
Proof.
iIntros "HP HQ". iApply later_equivI. iApply (saved_anything_agree with "HP HQ").
Qed.
(* Saved predicates. *)
-Notation savedPredG Σ A := (savedAnythingG Σ (A -d> ▶ ∙)).
-Notation savedPredΣ A := (savedAnythingΣ (A -d> ▶ ∙)).
+Notation savedPredG Σ A := (savedAnythingG _ Σ (A -d> ▶ (∙ _))).
+Notation savedPredΣ A := (savedAnythingΣ _ (A -d> ▶ (∙ _))).
-Definition saved_pred_own `{!savedPredG Σ A} (γ : gname) (Φ : A → iProp Σ) :=
- saved_anything_own (F := A -d> ▶ ∙) γ (OfeMor Next ∘ Φ).
+Definition saved_pred_own `{Σ : gFunctors SI} `{!savedPredG Σ A} (γ : gname) (Φ : A → iProp Σ) :=
+ saved_anything_own (F := A -d> ▶ (∙ _)) γ (OfeMor Next ∘ Φ).
-Instance saved_pred_own_contractive `{!savedPredG Σ A} γ :
+Instance saved_pred_own_contractive `{Σ : gFunctors SI} `{!savedPredG Σ A} γ :
Contractive (saved_pred_own γ : (A -d> iProp Σ) → iProp Σ).
Proof.
- solve_proper_core ltac:(fun _ => first [ intros ?; progress simpl | by auto | f_contractive | f_equiv ]).
+ solve_proper_prepare.
+ f_equiv. intros a; simpl. f_contractive.
+ intros ??. by apply H.
Qed.
-Lemma saved_pred_alloc_strong `{!savedPredG Σ A} (I : gname → Prop) (Φ : A → iProp Σ) :
+Lemma saved_pred_alloc_strong `{Σ : gFunctors SI} `{!savedPredG Σ A} (I : gname → Prop) (Φ : A → iProp Σ) :
pred_infinite I →
- (|==> ∃ γ, ⌜I γ⌠∧ saved_pred_own γ Φ)%I.
+ ⊢ |==> ∃ γ, ⌜I γ⌠∧ saved_pred_own γ Φ.
Proof. iIntros (?). by iApply saved_anything_alloc_strong. Qed.
-Lemma saved_pred_alloc_cofinite `{!savedPredG Σ A} (G : gset gname) (Φ : A → iProp Σ) :
- (|==> ∃ γ, ⌜γ ∉ G⌠∧ saved_pred_own γ Φ)%I.
+Lemma saved_pred_alloc_cofinite `{Σ : gFunctors SI} `{!savedPredG Σ A} (G : gset gname) (Φ : A → iProp Σ) :
+ ⊢ |==> ∃ γ, ⌜γ ∉ G⌠∧ saved_pred_own γ Φ.
Proof. iApply saved_anything_alloc_cofinite. Qed.
-Lemma saved_pred_alloc `{!savedPredG Σ A} (Φ : A → iProp Σ) :
- (|==> ∃ γ, saved_pred_own γ Φ)%I.
+Lemma saved_pred_alloc `{Σ : gFunctors SI} `{!savedPredG Σ A} (Φ : A → iProp Σ) :
+ ⊢ |==> ∃ γ, saved_pred_own γ Φ.
Proof. iApply saved_anything_alloc. Qed.
(* We put the `x` on the outside to make this lemma easier to apply. *)
-Lemma saved_pred_agree `{!savedPredG Σ A} γ Φ Ψ x :
+Lemma saved_pred_agree `{Σ : gFunctors SI} `{!savedPredG Σ A} γ Φ Ψ x :
saved_pred_own γ Φ -∗ saved_pred_own γ Ψ -∗ ▷ (Φ x ≡ Ψ x).
Proof.
unfold saved_pred_own. iIntros "#HΦ #HΨ /=". iApply later_equivI.
diff --git a/theories/base_logic/lib/sts.v b/theories/base_logic/lib/sts.v
deleted file mode 100644
index 6004e1b4bb4d4d54fd25f42b6d862a2e57364da8..0000000000000000000000000000000000000000
--- a/theories/base_logic/lib/sts.v
+++ /dev/null
@@ -1,179 +0,0 @@
-From iris.base_logic.lib Require Export invariants.
-From iris.algebra Require Export sts.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-Import uPred.
-
-(** The CMRA we need. *)
-Class stsG Σ (sts : stsT) := StsG {
- sts_inG :> inG Σ (stsR sts);
- sts_inhabited :> Inhabited (sts.state sts);
-}.
-
-Definition stsΣ (sts : stsT) : gFunctors := #[ GFunctor (stsR sts) ].
-Instance subG_stsΣ Σ sts :
- subG (stsΣ sts) Σ → Inhabited (sts.state sts) → stsG Σ sts.
-Proof. solve_inG. Qed.
-
-Section definitions.
- Context `{!stsG Σ sts} (γ : gname).
-
- Definition sts_ownS (S : sts.states sts) (T : sts.tokens sts) : iProp Σ :=
- own γ (sts_frag S T).
- Definition sts_own (s : sts.state sts) (T : sts.tokens sts) : iProp Σ :=
- own γ (sts_frag_up s T).
- Definition sts_inv (φ : sts.state sts → iProp Σ) : iProp Σ :=
- (∃ s, own γ (sts_auth s ∅) ∗ φ s)%I.
- Definition sts_ctx `{!invG Σ} (N : namespace) (φ: sts.state sts → iProp Σ) : iProp Σ :=
- inv N (sts_inv φ).
-
- Global Instance sts_inv_ne n :
- Proper (pointwise_relation _ (dist n) ==> dist n) sts_inv.
- Proof. solve_proper. Qed.
- Global Instance sts_inv_proper :
- Proper (pointwise_relation _ (≡) ==> (≡)) sts_inv.
- Proof. solve_proper. Qed.
- Global Instance sts_ownS_proper : Proper ((≡) ==> (≡) ==> (⊣⊢)) sts_ownS.
- Proof. solve_proper. Qed.
- Global Instance sts_own_proper s : Proper ((≡) ==> (⊣⊢)) (sts_own s).
- Proof. solve_proper. Qed.
- Global Instance sts_ctx_ne `{!invG Σ} n N :
- Proper (pointwise_relation _ (dist n) ==> dist n) (sts_ctx N).
- Proof. solve_proper. Qed.
- Global Instance sts_ctx_proper `{!invG Σ} N :
- Proper (pointwise_relation _ (≡) ==> (⊣⊢)) (sts_ctx N).
- Proof. solve_proper. Qed.
- Global Instance sts_ctx_persistent `{!invG Σ} N φ : Persistent (sts_ctx N φ).
- Proof. apply _. Qed.
- Global Instance sts_own_persistent s : Persistent (sts_own s ∅).
- Proof. apply _. Qed.
- Global Instance sts_ownS_persistent S : Persistent (sts_ownS S ∅).
- Proof. apply _. Qed.
-End definitions.
-
-Instance: Params (@sts_inv) 4 := {}.
-Instance: Params (@sts_ownS) 4 := {}.
-Instance: Params (@sts_own) 5 := {}.
-Instance: Params (@sts_ctx) 6 := {}.
-
-Section sts.
- Context `{!invG Σ, !stsG Σ sts}.
- Implicit Types φ : sts.state sts → iProp Σ.
- Implicit Types N : namespace.
- Implicit Types P Q R : iProp Σ.
- Implicit Types γ : gname.
- Implicit Types S : sts.states sts.
- Implicit Types T : sts.tokens sts.
-
- (* The same rule as implication does *not* hold, as could be shown using
- sts_frag_included. *)
- Lemma sts_ownS_weaken γ S1 S2 T1 T2 :
- T2 ⊆ T1 → S1 ⊆ S2 → sts.closed S2 T2 →
- sts_ownS γ S1 T1 ==∗ sts_ownS γ S2 T2.
- Proof. intros ???. by apply own_update, sts_update_frag. Qed.
-
- Lemma sts_own_weaken γ s S T1 T2 :
- T2 ⊆ T1 → s ∈ S → sts.closed S T2 →
- sts_own γ s T1 ==∗ sts_ownS γ S T2.
- Proof. intros ???. by apply own_update, sts_update_frag_up. Qed.
-
- Lemma sts_own_weaken_state γ s1 s2 T :
- sts.frame_steps T s2 s1 → sts.tok s2 ## T →
- sts_own γ s1 T ==∗ sts_own γ s2 T.
- Proof.
- intros ??. apply own_update, sts_update_frag_up; [|done..].
- intros Hdisj. apply sts.closed_up. done.
- Qed.
-
- Lemma sts_own_weaken_tok γ s T1 T2 :
- T2 ⊆ T1 → sts_own γ s T1 ==∗ sts_own γ s T2.
- Proof.
- intros ?. apply own_update, sts_update_frag_up; last done.
- - intros. apply sts.closed_up. set_solver.
- - apply sts.elem_of_up.
- Qed.
-
- Lemma sts_ownS_op γ S1 S2 T1 T2 :
- T1 ## T2 → sts.closed S1 T1 → sts.closed S2 T2 →
- sts_ownS γ (S1 ∩ S2) (T1 ∪ T2) ⊣⊢ (sts_ownS γ S1 T1 ∗ sts_ownS γ S2 T2).
- Proof. intros. by rewrite /sts_ownS -own_op sts_op_frag. Qed.
-
- Lemma sts_own_op γ s T1 T2 :
- T1 ## T2 → sts_own γ s (T1 ∪ T2) ==∗ sts_own γ s T1 ∗ sts_own γ s T2.
- (* The other direction does not hold -- see sts.up_op. *)
- Proof.
- intros. rewrite /sts_own -own_op. iIntros "Hown".
- iDestruct (own_valid with "Hown") as %Hval%sts_frag_up_valid.
- rewrite -sts_op_frag.
- - iApply (sts_own_weaken with "Hown"); first done.
- + split; apply sts.elem_of_up.
- + eapply sts.closed_op; apply sts.closed_up; set_solver.
- - done.
- - apply sts.closed_up; set_solver.
- - apply sts.closed_up; set_solver.
- Qed.
-
- Typeclasses Opaque sts_own sts_ownS sts_inv sts_ctx.
-
- Lemma sts_alloc φ E N s :
- ▷ φ s ={E}=∗ ∃ γ, sts_ctx γ N φ ∧ sts_own γ s (⊤ ∖ sts.tok s).
- Proof.
- iIntros "Hφ". rewrite /sts_ctx /sts_own.
- iMod (own_alloc (sts_auth s (⊤ ∖ sts.tok s))) as (γ) "Hγ".
- { apply sts_auth_valid; set_solver. }
- iExists γ; iRevert "Hγ"; rewrite -sts_op_auth_frag_up; iIntros "[Hγ $]".
- iMod (inv_alloc N _ (sts_inv γ φ) with "[Hφ Hγ]") as "#?"; auto.
- rewrite /sts_inv. iNext. iExists s. by iFrame.
- Qed.
-
- Lemma sts_accS φ E γ S T :
- ▷ sts_inv γ φ ∗ sts_ownS γ S T ={E}=∗ ∃ s,
- ⌜s ∈ S⌠∗ ▷ φ s ∗ ∀ s' T',
- ⌜sts.steps (s, T) (s', T')⌠∗ ▷ φ s' ={E}=∗ ▷ sts_inv γ φ ∗ sts_own γ s' T'.
- Proof.
- iIntros "[Hinv Hγf]". rewrite /sts_ownS /sts_inv /sts_own.
- iDestruct "Hinv" as (s) "[>Hγ Hφ]".
- iDestruct (own_valid_2 with "Hγ Hγf") as %Hvalid.
- assert (s ∈ S) by eauto using sts_auth_frag_valid_inv.
- assert (✓ sts_frag S T) as [??] by eauto using cmra_valid_op_r.
- iModIntro; iExists s; iSplit; [done|]; iFrame "Hφ".
- iIntros (s' T') "[% Hφ]".
- iMod (own_update_2 with "Hγ Hγf") as "Hγ".
- { rewrite sts_op_auth_frag; [|done..]. by apply sts_update_auth. }
- iRevert "Hγ"; rewrite -sts_op_auth_frag_up; iIntros "[Hγ $]".
- iModIntro. iNext. iExists s'; by iFrame.
- Qed.
-
- Lemma sts_acc φ E γ s0 T :
- ▷ sts_inv γ φ ∗ sts_own γ s0 T ={E}=∗ ∃ s,
- ⌜sts.frame_steps T s0 s⌠∗ ▷ φ s ∗ ∀ s' T',
- ⌜sts.steps (s, T) (s', T')⌠∗ ▷ φ s' ={E}=∗ ▷ sts_inv γ φ ∗ sts_own γ s' T'.
- Proof. by apply sts_accS. Qed.
-
- Lemma sts_openS φ E N γ S T :
- ↑N ⊆ E →
- sts_ctx γ N φ ∗ sts_ownS γ S T ={E,E∖↑N}=∗ ∃ s,
- ⌜s ∈ S⌠∗ ▷ φ s ∗ ∀ s' T',
- ⌜sts.steps (s, T) (s', T')⌠∗ ▷ φ s' ={E∖↑N,E}=∗ sts_own γ s' T'.
- Proof.
- iIntros (?) "[#? Hγf]". rewrite /sts_ctx. iInv N as "Hinv" "Hclose".
- (* The following is essentially a very trivial composition of the accessors
- [sts_acc] and [inv_open] -- but since we don't have any good support
- for that currently, this gets more tedious than it should, with us having
- to unpack and repack various proofs.
- TODO: Make this mostly automatic, by supporting "opening accessors
- around accessors". *)
- iMod (sts_accS with "[Hinv Hγf]") as (s) "(?&?& HclSts)"; first by iFrame.
- iModIntro. iExists s. iFrame. iIntros (s' T') "H".
- iMod ("HclSts" $! s' T' with "H") as "(Hinv & ?)". by iMod ("Hclose" with "Hinv").
- Qed.
-
- Lemma sts_open φ E N γ s0 T :
- ↑N ⊆ E →
- sts_ctx γ N φ ∗ sts_own γ s0 T ={E,E∖↑N}=∗ ∃ s,
- ⌜sts.frame_steps T s0 s⌠∗ ▷ φ s ∗ ∀ s' T',
- ⌜sts.steps (s, T) (s', T')⌠∗ ▷ φ s' ={E∖↑N,E}=∗ sts_own γ s' T'.
- Proof. by apply sts_openS. Qed.
-End sts.
-
-Typeclasses Opaque sts_own sts_ownS sts_inv sts_ctx.
diff --git a/theories/base_logic/lib/viewshifts.v b/theories/base_logic/lib/viewshifts.v
index a727317d2af5ab0bf82a69e1de6e9e6da7c9cc8f..54f459c7bc8bf76aaa05c49a6d176d42512b2b7d 100644
--- a/theories/base_logic/lib/viewshifts.v
+++ b/theories/base_logic/lib/viewshifts.v
@@ -2,11 +2,11 @@ From iris.base_logic.lib Require Export invariants.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
-Definition vs `{!invG Σ} (E1 E2 : coPset) (P Q : iProp Σ) : iProp Σ :=
+Definition vs {SI} {Σ : gFunctors SI} `{!invG Σ} (E1 E2 : coPset) (P Q : iProp Σ) : iProp Σ :=
(□ (P -∗ |={E1,E2}=> Q))%I.
-Arguments vs {_ _} _ _ _%I _%I.
+Arguments vs {_ _ _} _ _ _%I _%I.
-Instance: Params (@vs) 4 := {}.
+Instance: Params (@vs) 5 := {}.
Notation "P ={ E1 , E2 }=> Q" := (vs E1 E2 P Q)
(at level 99, E1,E2 at level 50, Q at level 200,
format "P ={ E1 , E2 }=> Q") : bi_scope.
@@ -22,7 +22,7 @@ Notation "P ={ E }=> Q" := (P ={E}=> Q)%I
format "P ={ E }=> Q") : stdpp_scope.
Section vs.
-Context `{!invG Σ}.
+Context {SI} {Σ : gFunctors SI} `{!invG Σ}.
Implicit Types P Q R : iProp Σ.
Implicit Types N : namespace.
diff --git a/theories/base_logic/lib/wsat.v b/theories/base_logic/lib/wsat.v
index 6ffb41ff725616ab7e44b9e07fae6ac257635f84..3d1c30ee9d0409669d42c9b17434a3aacf64dadf 100644
--- a/theories/base_logic/lib/wsat.v
+++ b/theories/base_logic/lib/wsat.v
@@ -1,5 +1,5 @@
From iris.base_logic.lib Require Export own.
-From stdpp Require Export coPset.
+From stdpp Require Export coPset namespaces.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
@@ -8,63 +8,66 @@ Set Default Proof Using "Type".
exception of what's in the [invG] module. The module [invG] is thus exported in
[fancy_updates], which [wsat] is only imported. *)
Module invG.
- Class invG (Σ : gFunctors) : Set := WsatG {
+ Class invG {SI} (Σ : gFunctors SI) : Set := WsatG {
inv_inG :> inG Σ (authR (gmapUR positive (agreeR (laterO (iPreProp Σ)))));
- enabled_inG :> inG Σ coPset_disjR;
+ enabled_inG :> inG Σ (coPset_disjR SI);
disabled_inG :> inG Σ (gset_disjR positive);
invariant_name : gname;
enabled_name : gname;
disabled_name : gname;
}.
- Definition invΣ : gFunctors :=
- #[GFunctor (authRF (gmapURF positive (agreeRF (laterOF idOF))));
- GFunctor coPset_disjUR;
+ Definition invΣ (SI: indexT) : gFunctors SI :=
+ #[GFunctor (authRF (gmapURF positive (agreeRF (laterOF (idOF SI)))));
+ GFunctor (coPset_disjUR SI);
GFunctor (gset_disjUR positive)].
- Class invPreG (Σ : gFunctors) : Set := WsatPreG {
+ Class invPreG {SI} (Σ : gFunctors SI) : Set := WsatPreG {
inv_inPreG :> inG Σ (authR (gmapUR positive (agreeR (laterO (iPreProp Σ)))));
- enabled_inPreG :> inG Σ coPset_disjR;
+ enabled_inPreG :> inG Σ (coPset_disjR SI);
disabled_inPreG :> inG Σ (gset_disjR positive);
}.
- Instance subG_invΣ {Σ} : subG invΣ Σ → invPreG Σ.
+ Instance subG_invΣ {SI} {Σ: gFunctors SI} : subG (invΣ SI) Σ → invPreG Σ.
Proof. solve_inG. Qed.
End invG.
Import invG.
-Definition invariant_unfold {Σ} (P : iProp Σ) : agree (later (iPreProp Σ)) :=
+Definition invariant_unfold {SI} {Σ: gFunctors SI} (P : iProp Σ) : agree (later (iPreProp Σ)) :=
to_agree (Next (iProp_unfold P)).
-Definition ownI `{!invG Σ} (i : positive) (P : iProp Σ) : iProp Σ :=
+Definition ownI {SI} {Σ: gFunctors SI} `{!invG Σ} (i : positive) (P : iProp Σ) : iProp Σ :=
own invariant_name (â—¯ {[ i := invariant_unfold P ]}).
-Arguments ownI {_ _} _ _%I.
+Arguments ownI {_ _ _} _ _%I.
Typeclasses Opaque ownI.
-Instance: Params (@invariant_unfold) 1 := {}.
-Instance: Params (@ownI) 3 := {}.
+Instance: Params (@invariant_unfold) 2 := {}.
+Instance: Params (@ownI) 4 := {}.
-Definition ownE `{!invG Σ} (E : coPset) : iProp Σ :=
+Definition ownE {SI} {Σ: gFunctors SI} `{!invG Σ} (E : coPset) : iProp Σ :=
own enabled_name (CoPset E).
Typeclasses Opaque ownE.
-Instance: Params (@ownE) 3 := {}.
+Instance: Params (@ownE) 4 := {}.
-Definition ownD `{!invG Σ} (E : gset positive) : iProp Σ :=
+Definition ownD {SI} {Σ: gFunctors SI} `{!invG Σ} (E : gset positive) : iProp Σ :=
own disabled_name (GSet E).
Typeclasses Opaque ownD.
-Instance: Params (@ownD) 3 := {}.
+Instance: Params (@ownD) 4 := {}.
-Definition wsat `{!invG Σ} : iProp Σ :=
+Definition wsat {SI} {Σ: gFunctors SI} `{!invG Σ} : iProp Σ :=
locked (∃ I : gmap positive (iProp Σ),
own invariant_name (◠(invariant_unfold <$> I : gmap _ _)) ∗
[∗ map] i ↦ Q ∈ I, ▷ Q ∗ ownD {[i]} ∨ ownE {[i]})%I.
Section wsat.
-Context `{!invG Σ}.
+Context {SI} {Σ: gFunctors SI} `{!invG Σ}.
Implicit Types P : iProp Σ.
(* Invariants *)
-Instance invariant_unfold_contractive : Contractive (@invariant_unfold Σ).
-Proof. solve_contractive. Qed.
-Global Instance ownI_contractive i : Contractive (@ownI Σ _ i).
+Instance invariant_unfold_contractive : Contractive (@invariant_unfold SI Σ).
+Proof. intros α P Q H. unfold invariant_unfold.
+ f_equiv. eapply Next_contractive. intros β Hβ.
+ by rewrite (H β Hβ).
+Qed.
+Global Instance ownI_contractive i : Contractive (@ownI SI Σ _ i).
Proof. solve_contractive. Qed.
Global Instance ownI_persistent i P : Persistent (ownI i P).
Proof. rewrite /ownI. apply _. Qed.
@@ -72,7 +75,7 @@ Proof. rewrite /ownI. apply _. Qed.
Lemma ownE_empty : (|==> ownE ∅)%I.
Proof.
rewrite /uPred_valid /bi_emp_valid.
- by rewrite (own_unit (coPset_disjUR) enabled_name).
+ by rewrite (own_unit (coPset_disjUR SI) enabled_name).
Qed.
Lemma ownE_op E1 E2 : E1 ## E2 → ownE (E1 ∪ E2) ⊣⊢ ownE E1 ∗ ownE E2.
Proof. intros. by rewrite /ownE -own_op coPset_disj_union. Qed.
@@ -193,15 +196,59 @@ Proof.
Qed.
End wsat.
-(* Allocation of an initial world *)
-Lemma wsat_alloc `{!invPreG Σ} : (|==> ∃ _ : invG Σ, wsat ∗ ownE ⊤)%I.
+(* Allocation of an initial wolibrld *)
+Lemma wsat_alloc_strong {SI: indexT} {Σ: gFunctors SI} `{!invPreG Σ} :
+ bi_emp_valid (|==> ∃ γI γE γD : gname, let H := WsatG _ _ _ _ _ γI γE γD in wsat ∗ ownE ⊤)%I.
Proof.
iIntros.
- iMod (own_alloc (◠(∅ : gmap positive _))) as (γI) "HI";
- first by rewrite auth_auth_valid.
+ iMod (own_alloc (◠(∅ : gmap positive _))) as (γI) "HI"; first by rewrite auth_auth_valid.
iMod (own_alloc (CoPset ⊤)) as (γE) "HE"; first done.
iMod (own_alloc (GSet ∅)) as (γD) "HD"; first done.
- iModIntro; iExists (WsatG _ _ _ _ γI γE γD).
+ iModIntro; iExists γI, γE, γD.
rewrite /wsat /ownE -lock; iFrame.
iExists ∅. rewrite fmap_empty big_opM_empty. by iFrame.
Qed.
+
+
+Lemma wsat_alloc {SI: indexT} {Σ: gFunctors SI} `{!invPreG Σ} :
+ bi_emp_valid (|==> ∃ _ : invG Σ, wsat ∗ ownE ⊤)%I.
+Proof.
+ iIntros. iMod wsat_alloc_strong as (γI γE γD) "H". iModIntro.
+ by iExists _.
+Qed.
+
+
+(* Global Invariants Instance *)
+Definition γ_inv: gname := encode ("invariants.inv").
+Definition γ_enabled: gname := encode ("invariants.enabled").
+Definition γ_disabled: gname := encode ("invariants.disabled").
+Definition inv_gnames : coPset := {[ γ_inv; γ_enabled; γ_disabled ]}.
+
+Class invS {SI} (Σ : gFunctors SI) : Set := InvS {
+ invS_inv_inG :> inG Σ (authR (gmapUR positive (agreeR (laterO (iPreProp Σ)))));
+ invS_enabled_inG :> inG Σ (coPset_disjR SI);
+ invS_disabled_inG :> inG Σ (gset_disjR positive);
+}.
+
+Instance invS_invG {SI} {Σ : gFunctors SI} (IS: invS Σ) : invG Σ :=
+ WsatG _ _ _ _ _ γ_inv γ_enabled γ_disabled.
+
+
+Lemma initial_wsat {SI} {Σ : gFunctors SI} `{invS SI Σ}:
+ initial inv_gnames (wsat ∗ ownE ⊤)%I.
+Proof.
+ feed pose proof (initial_alloc γ_inv (◠(∅ : gmap positive _))) as HI;
+ first by rewrite auth_auth_valid.
+ feed pose proof (initial_alloc γ_enabled (CoPset ⊤)) as HE;
+ first done.
+ feed pose proof (initial_alloc γ_disabled (GSet ∅)) as HD;
+ first done.
+ feed pose proof (initial_combine _ _ _ _ HI HE) as H1;
+ first set_solver.
+ feed pose proof (initial_combine _ _ _ _ H1 HD) as H2;
+ first set_solver.
+ eapply initial_mono; last eauto.
+ rewrite /wsat /ownE -lock. iIntros "[[HI $] HD]".
+ iExists ∅. rewrite fmap_empty big_opM_empty. by iFrame.
+Qed.
+
diff --git a/theories/base_logic/proofmode.v b/theories/base_logic/proofmode.v
index 944b92e84cc49158e830d63ffbef3fdf2f6d2ed6..eaaa68891e3ce1141fc727fa6fb90e1a5d56dcb9 100644
--- a/theories/base_logic/proofmode.v
+++ b/theories/base_logic/proofmode.v
@@ -5,15 +5,15 @@ Import base_logic.bi.uPred.
(* Setup of the proof mode *)
Section class_instances.
-Context {M : ucmraT}.
+Context {SI} {M : ucmraT SI}.
Implicit Types P Q R : uPred M.
Global Instance into_pure_cmra_valid `{!CmraDiscrete A} (a : A) :
- @IntoPure (uPredI M) (✓ a) (✓ a).
+ @IntoPure SI (uPredI M) (✓ a) (✓ a).
Proof. by rewrite /IntoPure discrete_valid. Qed.
-Global Instance from_pure_cmra_valid {A : cmraT} (a : A) :
- @FromPure (uPredI M) false (✓ a) (✓ a).
+Global Instance from_pure_cmra_valid {A : cmraT SI} (a : A) :
+ @FromPure SI (uPredI M) false (✓ a) (✓ a).
Proof.
rewrite /FromPure /=. eapply bi.pure_elim=> // ?.
rewrite -uPred.cmra_valid_intro //.
diff --git a/theories/base_logic/satisfiable.v b/theories/base_logic/satisfiable.v
new file mode 100644
index 0000000000000000000000000000000000000000..ed174a704677eca156e6fe0cce5dbfb0bd359601
--- /dev/null
+++ b/theories/base_logic/satisfiable.v
@@ -0,0 +1,100 @@
+From iris.base_logic Require Import bi.
+From iris.bi Require Export satisfiable.
+
+
+Section uPred_satisfiable.
+ Context {SI: indexT} (M: ucmraT SI).
+
+ Definition uPred_satisfiable (P: uPred M) := ∀ n, ∃ x, ✓{n} x ∧ P n x.
+
+ Lemma uPred_satisfiable_intro P: (True ⊢ P) → uPred_satisfiable P.
+ Proof.
+ unfold uPred_satisfiable. intros [H]. revert H; uPred.unseal. intros H n. exists ε.
+ simpl in *; split; eauto using ucmra_unit_validN.
+ apply H; eauto using ucmra_unit_validN.
+ constructor.
+ Qed.
+
+ Lemma uPred_satisfiable_mono P Q: uPred_satisfiable P → (P ⊢ Q) → uPred_satisfiable Q.
+ Proof.
+ unfold uPred_satisfiable. intros HP [PQ] n.
+ destruct (HP n) as (x & Hv & HP'). exists x. split; eauto.
+ Qed.
+
+ Lemma uPred_satisfiable_elim P: uPred_satisfiable P → Plain P → True ⊢ P.
+ Proof.
+ unfold uPred_satisfiable, Plain. uPred.unseal. intros HP [H]. split=> n x Hv _.
+ destruct (HP n) as (y & Hv' & HP').
+ specialize (H n y Hv' HP').
+ eapply uPred_mono; first apply H; auto.
+ apply ucmra_unit_leastN.
+ Qed.
+
+ Lemma uPred_satisfiable_later P: uPred_satisfiable (▷ P) → uPred_satisfiable P.
+ Proof.
+ intros H n. destruct (H (stepindex.succ n)) as (x & Hv & HP).
+ exists x. split.
+ - eapply cmra_validN_le; eauto.
+ - revert HP. uPred.unseal. intros HP. apply HP. eauto with index.
+ Qed.
+
+ Lemma uPred_satisfiable_update P: uPred_satisfiable (|==> P) → uPred_satisfiable P.
+ Proof.
+ unfold uPred_satisfiable. uPred.unseal. intros H.
+ intros n. destruct (H n) as (y & Hv & Hupd).
+ destruct (Hupd n ε) as (z & Hv' & HP); eauto; first by rewrite right_id.
+ exists z; split; eauto. revert Hv'. by rewrite right_id.
+ Qed.
+
+ Lemma uPred_satisfiable_finite_exists `{FiniteExistential SI} A (P: A → uPred M) Q: uPred_satisfiable (∃ a, P a) → pred_finite Q → (∀ x, P x ⊢ ⌜Q xâŒ) → ∃ a, uPred_satisfiable (P a).
+ Proof.
+ unfold uPred_satisfiable. intros Hexist Hfin Hent.
+ eapply (can_commute_finite_exists _ (λ a n, ∃ x: M, ✓{n} x ∧ P a n x) Q); auto.
+ - intros a m n Hmn (x & Hv & HP). exists x. split.
+ + eapply cmra_validN_le; eauto.
+ + eapply uPred_mono; eauto.
+ - intros n. destruct (Hexist n) as (x & Hv & HP); eauto.
+ revert HP Hent. uPred.unseal. intros [a ?] H'; eauto.
+ exists a. split; eauto. specialize (H' a) as [H'].
+ by eapply H'.
+ Qed.
+
+ Lemma uPred_satisfiable_exists `{LargeIndex SI} A (P: A → uPred M): uPred_satisfiable (∃ a, P a) → ∃ a, uPred_satisfiable (P a).
+ Proof.
+ unfold uPred_satisfiable.
+ specialize (can_commute_exists _ (λ a n, ∃ x: M, ✓{n} x ∧ P a n x)) as Hcomm.
+ intros Hexist. edestruct Hcomm as (a & HP).
+ - intros a m n Hmn (x & Hv & HP). exists x. split.
+ + eapply cmra_validN_le; eauto.
+ + eapply uPred_mono; eauto.
+ - intros n. destruct (Hexist n) as (x & Hv & HP); eauto.
+ revert HP. uPred.unseal. intros [? ?]; eauto.
+ - exists a. intros n. apply HP.
+ Qed.
+
+
+ Lemma uPred_satisfiable_mixin: satisfiable_mixin uPred_satisfiable.
+ Proof.
+ constructor.
+ - apply uPred_satisfiable_intro.
+ - apply uPred_satisfiable_mono.
+ - apply uPred_satisfiable_elim.
+ - apply uPred_satisfiable_later.
+ - apply @uPred_satisfiable_finite_exists.
+ - apply @uPred_satisfiable_exists.
+ - apply uPred_satisfiable_update.
+ Qed.
+
+ Global Instance uPred_Satisfiable: Satisfiable (uPredSI M) :=
+ {| satisfiable := uPred_satisfiable;
+ satisfiable_satisfiable_mixin := uPred_satisfiable_mixin |}.
+
+
+End uPred_satisfiable.
+
+
+
+
+
+
+
diff --git a/theories/base_logic/upred.v b/theories/base_logic/upred.v
index e1b07ab63f6032f6d81c6813174ba5388c1661fc..6287c8ec15b235c034352301459ff95ce3cab299 100644
--- a/theories/base_logic/upred.v
+++ b/theories/base_logic/upred.v
@@ -1,11 +1,12 @@
+From Coq.Init Require Import Nat.
From iris.algebra Require Export cmra updates.
From iris.bi Require Import notation.
From stdpp Require Import finite.
-From Coq.Init Require Import Nat.
Set Default Proof Using "Type".
-Local Hint Extern 1 (_ ≼ _) => etrans; [eassumption|] : core.
-Local Hint Extern 1 (_ ≼ _) => etrans; [|eassumption] : core.
-Local Hint Extern 10 (_ ≤ _) => lia : core.
+Local Hint Extern 1 (_ ≼ _) => etrans; [eassumption|] : index.
+Local Hint Extern 1 (_ ≼ _) => etrans; [|eassumption] : index.
+(*Local Hint Extern 10 (_ ≤ _) => lia : core.*)
+Local Hint Extern 10 (_ ⪯ _) => by etransitivity : core.
(** The basic definition of the uPred type, its metric and functor laws.
You probably do not want to import this file. Instead, import
@@ -47,27 +48,27 @@ Local Hint Extern 10 (_ ≤ _) => lia : core.
connective.
*)
-Record uPred (M : ucmraT) : Type := UPred {
- uPred_holds :> nat → M → Prop;
+Record uPred {I: indexT} (M : ucmraT I) : Type := UPred {
+ uPred_holds :> I → M → Prop;
uPred_mono n1 n2 x1 x2 :
- uPred_holds n1 x1 → x1 ≼{n1} x2 → n2 ≤ n1 → uPred_holds n2 x2
+ uPred_holds n1 x1 → x1 ≼{n1} x2 → n2 ⪯ n1 → uPred_holds n2 x2
}.
Bind Scope bi_scope with uPred.
-Arguments uPred_holds {_} _%I _ _ : simpl never.
+Arguments uPred_holds {_ _} _%I _ _ : simpl never.
Add Printing Constructor uPred.
-Instance: Params (@uPred_holds) 3 := {}.
+Instance: Params (@uPred_holds) 4 := {}.
Section cofe.
- Context {M : ucmraT}.
+ Context {SI: indexT} {M : ucmraT SI}.
Inductive uPred_equiv' (P Q : uPred M) : Prop :=
{ uPred_in_equiv : ∀ n x, ✓{n} x → P n x ↔ Q n x }.
Instance uPred_equiv : Equiv (uPred M) := uPred_equiv'.
- Inductive uPred_dist' (n : nat) (P Q : uPred M) : Prop :=
- { uPred_in_dist : ∀ n' x, n' ≤ n → ✓{n'} x → P n' x ↔ Q n' x }.
- Instance uPred_dist : Dist (uPred M) := uPred_dist'.
- Definition uPred_ofe_mixin : OfeMixin (uPred M).
+ Inductive uPred_dist' (n : SI) (P Q : uPred M) : Prop :=
+ { uPred_in_dist : ∀ n' x, n' ⪯ n → ✓{n'} x → P n' x ↔ Q n' x }.
+ Instance uPred_dist : Dist SI (uPred M) := uPred_dist'.
+ Definition uPred_ofe_mixin : OfeMixin SI (uPred M).
Proof.
split.
- intros P Q; split.
@@ -78,49 +79,109 @@ Section cofe.
+ by intros P Q HPQ; split=> x i ??; symmetry; apply HPQ.
+ intros P Q Q' HP HQ; split=> i x ??.
by trans (Q i x);[apply HP|apply HQ].
- - intros n P Q HPQ; split=> i x ??; apply HPQ; auto.
+ - intros α β P Q HPQ Hpre; split=> i x ??; apply HPQ;[|eauto]. transitivity β; eauto.
Qed.
- Canonical Structure uPredO : ofeT := OfeT (uPred M) uPred_ofe_mixin.
+ Canonical Structure uPredO : ofeT SI := OfeT (uPred M) uPred_ofe_mixin.
- Program Definition uPred_compl : Compl uPredO := λ c,
- {| uPred_holds n x := ∀ n', n' ≤ n → ✓{n'}x → c n' n' x |}.
+ Program Definition uPred_compl : chain uPredO → uPredO := λ c,
+ {| uPred_holds n x := ∀ n', n' ⪯ n → ✓{n'}x → c n' n' x |}.
Next Obligation.
move=> /= c n1 n2 x1 x2 HP Hx12 Hn12 n3 Hn23 Hv. eapply uPred_mono.
- eapply HP, cmra_validN_includedN, cmra_includedN_le=>//; lia.
- eapply cmra_includedN_le=>//; lia. done.
+ eapply HP, cmra_validN_includedN, cmra_includedN_le=>//; transitivity n2; eauto.
+ eapply cmra_includedN_le=>//; transitivity n2; eauto. done.
+ Qed.
+
+ Program Definition uPred_bcompl' α : bchain uPredO α → uPredO := λ c,
+ {| uPred_holds n x := ∀ n' (Hn': n' ≺ α), n' ⪯ n → ✓{n'}x → c n' Hn' n' x |}.
+ Next Obligation.
+ move=> /= α c n1 n2 x1 x2 HP Hx12 Hn12 n3 Hn3 Hn23 Hv. eapply uPred_mono.
+ eapply HP, cmra_validN_includedN, cmra_includedN_le=>//; transitivity n2; eauto.
+ eapply cmra_includedN_le=>//; transitivity n2; eauto. done.
+ Qed.
+ Lemma uPred_bcompl'_ne α (c d : bchain uPredO α) (β : SI): (∀ (γ : SI) (Hγ : γ ≺ α), c γ Hγ ≡{β}≡ d γ Hγ) → uPred_bcompl' α c ≡{β}≡ uPred_bcompl' α d.
+ Proof.
+ intros Hne; split=> i x Hiβ Hv; split.
+ all: intros H' j Hjα Hji Hvj; specialize (H' j Hjα Hji Hvj); eapply Hne; eauto 4 with index.
Qed.
- Global Program Instance uPred_cofe : Cofe uPredO := {| compl := uPred_compl |}.
+
+ Definition uPred_bcompl α (Hα : zero ≺ α) := uPred_bcompl' α.
+
+ Global Program Instance uPred_cofe : Cofe uPredO :=
+ {| compl := uPred_compl; bcompl := uPred_bcompl |}.
Next Obligation.
- intros n c; split=>i x Hin Hv.
- etrans; [|by symmetry; apply (chain_cauchy c i n)]. split=>H; [by apply H|].
- repeat intro. apply (chain_cauchy c n' i)=>//. by eapply uPred_mono.
+ intros α c; split=>i x Hiα Hv.
+ etrans; [|by symmetry; apply (chain_cauchy' c)]. split=>H'; [by apply H'|].
+ intros n' Hin' H. eapply (chain_cauchy' c n' i); eauto.
+ by eapply uPred_mono.
Qed.
+ Next Obligation.
+ intros α Hα c; split=>i x Hiα Hv.
+ etrans; [|unshelve by symmetry; apply (bchain_cauchy' α c)]; eauto 2 with index.
+ split=>H'; [by apply H'|]. intros n' Hn' Hin' H. unshelve eapply (bchain_cauchy' α c n' i); eauto 2 with index.
+ by eapply uPred_mono.
+ Qed.
+ Next Obligation.
+ intros. by apply uPred_bcompl'_ne.
+ Qed.
+
+
+ Lemma bcompl_unfold α Hα (C: bchain uPredO α) n x: bcompl Hα C n x ↔ ∀ n' (Hn': n' ≺ α), n' ⪯ n → ✓{n'}x → C n' Hn' n' x.
+ Proof. reflexivity. Qed.
+
+ Lemma compl_unfold (C: chain uPredO) n x: compl C n x ↔ ∀ n', n' ⪯ n → ✓{n'}x → C n' n' x.
+ Proof. reflexivity. Qed.
+
+ Global Program Instance truncatable : ProtoTruncatable uPredO :=
+ {
+ proto_trunc α := λne a, uPred_bcompl' (index_succ _ α) (bchain_const a (index_succ _ α) );
+ }.
+ Next Obligation.
+ intros α α' x y Heq. by apply uPred_bcompl'_ne.
+ Qed.
+ Next Obligation.
+ intros α x y H. cbn. constructor => n x' Hvn; split.
+ all: intros H' j Hjα Hjn Hvj; cbn; apply H, H'; auto.
+ all: apply index_succ_iff in Hjα; auto.
+ Qed.
+ Next Obligation.
+ intros α x. cbn. constructor => n x' Hnα Hvn. split.
+ - intros H'. apply H'; auto. apply index_succ_iff; auto.
+ - intros H'. intros j Hjα Hjn Hvj. cbn. eapply uPred_mono.
+ apply H'. all: auto.
+ Qed.
+
+ Global Instance bcompl_unique : BcomplUnique uPredO.
+ Proof.
+ intros α Hα c d Heq. constructor => n x Hna Hvn.
+ rewrite !bcompl_unfold. split; intros H n' Hn' Hle Hvn'; apply Heq; eauto.
+ Qed.
+
End cofe.
-Arguments uPredO : clear implicits.
+Arguments uPredO {_} _.
-Instance uPred_ne {M} (P : uPred M) n : Proper (dist n ==> iff) (P n).
+Instance uPred_ne {I} {M: ucmraT I} (P : uPred M) n : Proper (dist n ==> iff) (P n).
Proof.
intros x1 x2 Hx; split=> ?; eapply uPred_mono; eauto; by rewrite Hx.
Qed.
-Instance uPred_proper {M} (P : uPred M) n : Proper ((≡) ==> iff) (P n).
+Instance uPred_proper {I} {M: ucmraT I} (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} (P Q : uPred M) n1 n2 x :
- P ≡{n2}≡ Q → n2 ≤ n1 → ✓{n2} x → Q n1 x → P n2 x.
+Lemma uPred_holds_ne {I} {M: ucmraT I} (P Q : uPred M) n1 n2 x :
+ P ≡{n2}≡ Q → n2 ⪯ n1 → ✓{n2} x → Q n1 x → P n2 x.
Proof.
intros [Hne] ???. eapply Hne; try done. eauto using uPred_mono, cmra_validN_le.
Qed.
(* Equivalence to the definition of uPred in the appendix. *)
-Lemma uPred_alt {M : ucmraT} (P: nat → M → Prop) :
- (∀ n1 n2 x1 x2, P n1 x1 → x1 ≼{n1} x2 → n2 ≤ n1 → P n2 x2) ↔
- ( (∀ x n1 n2, n2 ≤ n1 → P n1 x → P n2 x) (* Pointwise down-closed *)
- ∧ (∀ n x1 x2, x1 ≡{n}≡ x2 → ∀ m, m ≤ n → P m x1 ↔ P m x2) (* Non-expansive *)
- ∧ (∀ n x1 x2, x1 ≼{n} x2 → ∀ m, m ≤ n → P m x1 → P m x2) (* Monotonicity *)
+Lemma uPred_alt {I: indexT} {M : ucmraT I} (P: I → M → Prop) :
+ (∀ n1 n2 x1 x2, P n1 x1 → x1 ≼{n1} x2 → n2 ⪯ n1 → P n2 x2) ↔
+ ( (∀ x n1 n2, n2 ⪯ n1 → P n1 x → P n2 x) (* Pointwise down-closed *)
+ ∧ (∀ n x1 x2, x1 ≡{n}≡ x2 → ∀ m, m ⪯ n → P m x1 ↔ P m x2) (* Non-expansive *)
+ ∧ (∀ n x1 x2, x1 ≼{n} x2 → ∀ m, m ⪯ n → P m x1 → P m x2) (* Monotonicity *)
).
Proof.
(* Provide this lemma to eauto. *)
- assert (∀ n1 n2 (x1 x2 : M), n2 ≤ n1 → x1 ≡{n1}≡ x2 → x1 ≼{n2} x2).
+ assert (∀ n1 n2 (x1 x2 : M), n2 ⪯ n1 → x1 ≡{n1}≡ x2 → x1 ≼{n2} x2).
{ intros ????? H. eapply cmra_includedN_le; last done. by rewrite H. }
(* Now go ahead. *)
split.
@@ -129,211 +190,213 @@ Proof.
Qed.
(** functor *)
-Program Definition uPred_map {M1 M2 : ucmraT} (f : M2 -n> M1)
+Program Definition uPred_map {I: indexT} {M1 M2 : ucmraT I} (f : M2 -n> M1)
`{!CmraMorphism f} (P : uPred M1) :
uPred M2 := {| uPred_holds n x := P n (f x) |}.
Next Obligation. naive_solver eauto using uPred_mono, cmra_morphism_monotoneN. Qed.
-Instance uPred_map_ne {M1 M2 : ucmraT} (f : M2 -n> M1)
+Instance uPred_map_ne {I: indexT} {M1 M2 : ucmraT I} (f : M2 -n> M1)
`{!CmraMorphism f} n : Proper (dist n ==> dist n) (uPred_map f).
Proof.
intros x1 x2 Hx; split=> n' y ??.
split; apply Hx; auto using cmra_morphism_validN.
Qed.
-Lemma uPred_map_id {M : ucmraT} (P : uPred M): uPred_map cid P ≡ P.
+Lemma uPred_map_id {I} {M : ucmraT I} (P : uPred M): uPred_map cid P ≡ P.
Proof. by split=> n x ?. Qed.
-Lemma uPred_map_compose {M1 M2 M3 : ucmraT} (f : M1 -n> M2) (g : M2 -n> M3)
+Lemma uPred_map_compose {I} {M1 M2 M3 : ucmraT I} (f : M1 -n> M2) (g : M2 -n> M3)
`{!CmraMorphism f, !CmraMorphism g} (P : uPred M3):
uPred_map (g ◎ f) P ≡ uPred_map f (uPred_map g P).
Proof. by split=> n x Hx. Qed.
-Lemma uPred_map_ext {M1 M2 : ucmraT} (f g : M1 -n> M2)
+Lemma uPred_map_ext {I} {M1 M2 : ucmraT I} (f g : M1 -n> M2)
`{!CmraMorphism f} `{!CmraMorphism g}:
(∀ x, f x ≡ g x) → ∀ x, uPred_map f x ≡ uPred_map g x.
Proof. intros Hf P; split=> n x Hx /=; by rewrite /uPred_holds /= Hf. Qed.
-Definition uPredO_map {M1 M2 : ucmraT} (f : M2 -n> M1) `{!CmraMorphism f} :
+Definition uPredO_map {I} {M1 M2 : ucmraT I} (f : M2 -n> M1) `{!CmraMorphism f} :
uPredO M1 -n> uPredO M2 := OfeMor (uPred_map f : uPredO M1 → uPredO M2).
-Lemma uPredO_map_ne {M1 M2 : ucmraT} (f g : M2 -n> M1)
+Lemma uPredO_map_ne {I} {M1 M2 : ucmraT I} (f g : M2 -n> M1)
`{!CmraMorphism f, !CmraMorphism g} n :
f ≡{n}≡ g → uPredO_map f ≡{n}≡ uPredO_map g.
Proof.
by intros Hfg P; split=> n' y ??;
- rewrite /uPred_holds /= (dist_le _ _ _ _(Hfg y)); last lia.
+ rewrite /uPred_holds /= (dist_le _ _ _ _(Hfg y)).
Qed.
-Program Definition uPredOF (F : urFunctor) : oFunctor := {|
- oFunctor_car A _ B _ := uPredO (urFunctor_car F B A);
- oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := uPredO_map (urFunctor_map F (fg.2, fg.1))
+Program Definition uPredOF {I} (F : urFunctor I) : oFunctor I := {|
+ oFunctor_car A B := uPredO (urFunctor_car F B A);
+ oFunctor_map A1 A2 B1 B2 fg := uPredO_map (urFunctor_map F (fg.2, fg.1))
|}.
Next Obligation.
- intros F A1 ? A2 ? B1 ? B2 ? n P Q HPQ.
+ intros I F A1 A2 B1 B2 n P Q HPQ.
apply uPredO_map_ne, urFunctor_ne; split; by apply HPQ.
Qed.
Next Obligation.
- intros F A ? B ? P; simpl. rewrite -{2}(uPred_map_id P).
+ intros I F A B P; simpl. rewrite -{2}(uPred_map_id P).
apply uPred_map_ext=>y. by rewrite urFunctor_id.
Qed.
Next Obligation.
- intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' P; simpl. rewrite -uPred_map_compose.
+ intros I F A1 A2 A3 B1 B2 B3 f g f' g' P; simpl. rewrite -uPred_map_compose.
apply uPred_map_ext=>y; apply urFunctor_compose.
Qed.
-Instance uPredOF_contractive F :
+Instance uPredOF_contractive {I} (F: urFunctor I) :
urFunctorContractive F → oFunctorContractive (uPredOF F).
Proof.
- intros ? A1 ? A2 ? B1 ? B2 ? n P Q HPQ. apply uPredO_map_ne, urFunctor_contractive.
- destruct n; split; by apply HPQ.
+ intros ? A1 A2 B1 B2 n P Q HPQ. apply uPredO_map_ne, urFunctor_contractive.
+ intros β Hβ; split; by apply HPQ.
Qed.
(** logical entailement *)
-Inductive uPred_entails {M} (P Q : uPred M) : Prop :=
+Inductive uPred_entails {I} {M: ucmraT I} (P Q : uPred M) : Prop :=
{ uPred_in_entails : ∀ n x, ✓{n} x → P n x → Q n x }.
Hint Resolve uPred_mono : uPred_def.
(** logical connectives *)
-Program Definition uPred_pure_def {M} (φ : Prop) : uPred M :=
+Program Definition uPred_pure_def {I} {M: ucmraT I} (φ : Prop) : uPred M :=
{| uPred_holds n x := φ |}.
Solve Obligations with done.
Definition uPred_pure_aux : seal (@uPred_pure_def). by eexists. Qed.
-Definition uPred_pure {M} := uPred_pure_aux.(unseal) M.
+Definition uPred_pure {I} {M: ucmraT I} := uPred_pure_aux.(unseal) I M.
Definition uPred_pure_eq :
@uPred_pure = @uPred_pure_def := uPred_pure_aux.(seal_eq).
-Program Definition uPred_and_def {M} (P Q : uPred M) : uPred M :=
+Program Definition uPred_and_def {I} {M: ucmraT I} (P Q : uPred M) : uPred M :=
{| uPred_holds n x := P n x ∧ Q n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_and_aux : seal (@uPred_and_def). by eexists. Qed.
-Definition uPred_and {M} := uPred_and_aux.(unseal) M.
+Definition uPred_and {I} {M} := uPred_and_aux.(unseal) I M.
Definition uPred_and_eq: @uPred_and = @uPred_and_def := uPred_and_aux.(seal_eq).
-Program Definition uPred_or_def {M} (P Q : uPred M) : uPred M :=
+Program Definition uPred_or_def {I} {M: ucmraT I} (P Q : uPred M) : uPred M :=
{| uPred_holds n x := P n x ∨ Q n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_or_aux : seal (@uPred_or_def). by eexists. Qed.
-Definition uPred_or {M} := uPred_or_aux.(unseal) M.
+Definition uPred_or {I M} := uPred_or_aux.(unseal) I M.
Definition uPred_or_eq: @uPred_or = @uPred_or_def := uPred_or_aux.(seal_eq).
-Program Definition uPred_impl_def {M} (P Q : uPred M) : uPred M :=
+Program Definition uPred_impl_def {I} {M: ucmraT I} (P Q : uPred M) : uPred M :=
{| uPred_holds n x := ∀ n' x',
- x ≼ x' → n' ≤ n → ✓{n'} x' → P n' x' → Q n' x' |}.
+ x ≼ x' → n' ⪯ n → ✓{n'} x' → P n' x' → Q n' x' |}.
Next Obligation.
- intros M P Q n1 n1' x1 x1' HPQ [x2 Hx1'] Hn1 n2 x3 [x4 Hx3] ?; simpl in *.
+ intros I M P Q n1 n1' x1 x1' HPQ [x2 Hx1'] Hn1 n2 x3 [x4 Hx3] ?; simpl in *.
rewrite Hx3 (dist_le _ _ _ _ Hx1'); auto. intros ??.
eapply HPQ; auto. exists (x2 â‹… x4); by rewrite assoc.
Qed.
Definition uPred_impl_aux : seal (@uPred_impl_def). by eexists. Qed.
-Definition uPred_impl {M} := uPred_impl_aux.(unseal) M.
+Definition uPred_impl {I M} := uPred_impl_aux.(unseal) I M.
Definition uPred_impl_eq :
@uPred_impl = @uPred_impl_def := uPred_impl_aux.(seal_eq).
-Program Definition uPred_forall_def {M A} (Ψ : A → uPred M) : uPred M :=
+Program Definition uPred_forall_def {I} {M: ucmraT I} {A} (Ψ : A → uPred M) : uPred M :=
{| uPred_holds n x := ∀ a, Ψ a n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_forall_aux : seal (@uPred_forall_def). by eexists. Qed.
-Definition uPred_forall {M A} := uPred_forall_aux.(unseal) M A.
+Definition uPred_forall {I M A} := uPred_forall_aux.(unseal) I M A.
Definition uPred_forall_eq :
@uPred_forall = @uPred_forall_def := uPred_forall_aux.(seal_eq).
-Program Definition uPred_exist_def {M A} (Ψ : A → uPred M) : uPred M :=
+Program Definition uPred_exist_def {I} {M: ucmraT I} {A} (Ψ : A → uPred M) : uPred M :=
{| uPred_holds n x := ∃ a, Ψ a n x |}.
Solve Obligations with naive_solver eauto 2 with uPred_def.
Definition uPred_exist_aux : seal (@uPred_exist_def). by eexists. Qed.
-Definition uPred_exist {M A} := uPred_exist_aux.(unseal) M A.
+Definition uPred_exist {I M A} := uPred_exist_aux.(unseal) I M A.
Definition uPred_exist_eq: @uPred_exist = @uPred_exist_def := uPred_exist_aux.(seal_eq).
-Program Definition uPred_internal_eq_def {M} {A : ofeT} (a1 a2 : A) : uPred M :=
+Program Definition uPred_internal_eq_def {I} {M: ucmraT I} {A : ofeT I} (a1 a2 : A) : uPred M :=
{| uPred_holds n x := a1 ≡{n}≡ a2 |}.
Solve Obligations with naive_solver eauto 2 using (dist_le (A:=A)).
Definition uPred_internal_eq_aux : seal (@uPred_internal_eq_def). by eexists. Qed.
-Definition uPred_internal_eq {M A} := uPred_internal_eq_aux.(unseal) M A.
+Definition uPred_internal_eq {I M A} := uPred_internal_eq_aux.(unseal) I M A.
Definition uPred_internal_eq_eq:
@uPred_internal_eq = @uPred_internal_eq_def := uPred_internal_eq_aux.(seal_eq).
-Program Definition uPred_sep_def {M} (P Q : uPred M) : uPred M :=
+Program Definition uPred_sep_def {I} {M: ucmraT I} (P Q : uPred M) : uPred M :=
{| uPred_holds n x := ∃ x1 x2, x ≡{n}≡ x1 ⋅ x2 ∧ P n x1 ∧ Q n x2 |}.
Next Obligation.
- intros M P Q n1 n2 x y (x1&x2&Hx&?&?) [z Hy] Hn.
+ intros I M P Q n1 n2 x y (x1&x2&Hx&?&?) [z Hy] Hn.
exists x1, (x2 â‹… z); split_and?; eauto using uPred_mono, cmra_includedN_l.
eapply dist_le, Hn. by rewrite Hy Hx assoc.
Qed.
Definition uPred_sep_aux : seal (@uPred_sep_def). by eexists. Qed.
-Definition uPred_sep {M} := uPred_sep_aux.(unseal) M.
+Definition uPred_sep {I M} := uPred_sep_aux.(unseal) I M.
Definition uPred_sep_eq: @uPred_sep = @uPred_sep_def := uPred_sep_aux.(seal_eq).
-Program Definition uPred_wand_def {M} (P Q : uPred M) : uPred M :=
+Program Definition uPred_wand_def {I} {M: ucmraT I} (P Q : uPred M) : uPred M :=
{| uPred_holds n x := ∀ n' x',
- n' ≤ n → ✓{n'} (x ⋅ x') → P n' x' → Q n' (x ⋅ x') |}.
+ n' ⪯ n → ✓{n'} (x ⋅ x') → P n' x' → Q n' (x ⋅ x') |}.
Next Obligation.
- intros M P Q n1 n1' x1 x1' HPQ ? Hn n3 x3 ???; simpl in *.
+ intros I M P Q n1 n1' x1 x1' HPQ ? Hn n3 x3 ???; simpl in *.
eapply uPred_mono with n3 (x1 â‹… x3);
eauto using cmra_validN_includedN, cmra_monoN_r, cmra_includedN_le.
Qed.
Definition uPred_wand_aux : seal (@uPred_wand_def). by eexists. Qed.
-Definition uPred_wand {M} := uPred_wand_aux.(unseal) M.
+Definition uPred_wand {I M} := uPred_wand_aux.(unseal) I M.
Definition uPred_wand_eq :
@uPred_wand = @uPred_wand_def := uPred_wand_aux.(seal_eq).
(* Equivalently, this could be `∀ y, P n y`. That's closer to the intuition
of "embedding the step-indexed logic in Iris", but the two are equivalent
because Iris is afine. The following is easier to work with. *)
-Program Definition uPred_plainly_def {M} (P : uPred M) : uPred M :=
+Program Definition uPred_plainly_def {I} {M: ucmraT I} (P : uPred M) : uPred M :=
{| uPred_holds n x := P n ε |}.
Solve Obligations with naive_solver eauto using uPred_mono, ucmra_unit_validN.
Definition uPred_plainly_aux : seal (@uPred_plainly_def). by eexists. Qed.
-Definition uPred_plainly {M} := uPred_plainly_aux.(unseal) M.
+Definition uPred_plainly {I M} := uPred_plainly_aux.(unseal) I M.
Definition uPred_plainly_eq :
@uPred_plainly = @uPred_plainly_def := uPred_plainly_aux.(seal_eq).
-Program Definition uPred_persistently_def {M} (P : uPred M) : uPred M :=
+Program Definition uPred_persistently_def {I} {M: ucmraT I} (P : uPred M) : uPred M :=
{| uPred_holds n x := P n (core x) |}.
Next Obligation.
intros M; naive_solver eauto using uPred_mono, @cmra_core_monoN.
Qed.
Definition uPred_persistently_aux : seal (@uPred_persistently_def). by eexists. Qed.
-Definition uPred_persistently {M} := uPred_persistently_aux.(unseal) M.
+Definition uPred_persistently {I M} := uPred_persistently_aux.(unseal) I M.
Definition uPred_persistently_eq :
@uPred_persistently = @uPred_persistently_def := uPred_persistently_aux.(seal_eq).
-Program Definition uPred_later_def {M} (P : uPred M) : uPred M :=
- {| uPred_holds n x := match n return _ with 0 => True | S n' => P n' x end |}.
+Program Definition uPred_later_def {I} {M: ucmraT I} (P : uPred M) : uPred M :=
+ {| uPred_holds n x := ∀ n', n' ≺ n → P n' x |}.
Next Obligation.
- intros M P [|n1] [|n2] x1 x2; eauto using uPred_mono, cmra_includedN_S with lia.
+ intros I M P n1 n2 x1 x2 H1 H2 Hle n' Hlt; simpl in *.
+ eapply uPred_mono. eapply H1.
+ all: eauto using index_lt_le_trans, cmra_includedN_le.
Qed.
Definition uPred_later_aux : seal (@uPred_later_def). by eexists. Qed.
-Definition uPred_later {M} := uPred_later_aux.(unseal) M.
+Definition uPred_later {I M} := uPred_later_aux.(unseal) I M.
Definition uPred_later_eq :
@uPred_later = @uPred_later_def := uPred_later_aux.(seal_eq).
-Program Definition uPred_ownM_def {M : ucmraT} (a : M) : uPred M :=
+Program Definition uPred_ownM_def {I} {M: ucmraT I} (a : M) : uPred M :=
{| uPred_holds n x := a ≼{n} x |}.
Next Obligation.
- intros M a n1 n2 x1 x [a' Hx1] [x2 Hx] Hn. eapply cmra_includedN_le=>//.
+ intros I M a n1 n2 x1 x [a' Hx1] [x2 Hx] Hn. eapply cmra_includedN_le=>//.
exists (a' â‹… x2). by rewrite Hx(assoc op) Hx1.
Qed.
Definition uPred_ownM_aux : seal (@uPred_ownM_def). by eexists. Qed.
-Definition uPred_ownM {M} := uPred_ownM_aux.(unseal) M.
+Definition uPred_ownM {I M} := uPred_ownM_aux.(unseal) I M.
Definition uPred_ownM_eq :
@uPred_ownM = @uPred_ownM_def := uPred_ownM_aux.(seal_eq).
-Program Definition uPred_cmra_valid_def {M} {A : cmraT} (a : A) : uPred M :=
+Program Definition uPred_cmra_valid_def {I} {M: ucmraT I} {A : cmraT I} (a : A) : uPred M :=
{| uPred_holds n x := ✓{n} a |}.
Solve Obligations with naive_solver eauto 2 using cmra_validN_le.
Definition uPred_cmra_valid_aux : seal (@uPred_cmra_valid_def). by eexists. Qed.
-Definition uPred_cmra_valid {M A} := uPred_cmra_valid_aux.(unseal) M A.
+Definition uPred_cmra_valid {I M A} := uPred_cmra_valid_aux.(unseal) I M A.
Definition uPred_cmra_valid_eq :
@uPred_cmra_valid = @uPred_cmra_valid_def := uPred_cmra_valid_aux.(seal_eq).
-Program Definition uPred_bupd_def {M} (Q : uPred M) : uPred M :=
+Program Definition uPred_bupd_def {I} {M: ucmraT I} (Q : uPred M) : uPred M :=
{| uPred_holds n x := ∀ k yf,
- k ≤ n → ✓{k} (x ⋅ yf) → ∃ x', ✓{k} (x' ⋅ yf) ∧ Q k x' |}.
+ k ⪯ n → ✓{k} (x ⋅ yf) → ∃ x', ✓{k} (x' ⋅ yf) ∧ Q k x' |}.
Next Obligation.
- intros M Q n1 n2 x1 x2 HQ [x3 Hx] Hn k yf Hk.
- rewrite (dist_le _ _ _ _ Hx); last lia. intros Hxy.
+ intros I M Q n1 n2 x1 x2 HQ [x3 Hx] Hn k yf Hk.
+ rewrite (dist_le _ _ _ _ Hx); last auto. intros Hxy.
destruct (HQ k (x3 â‹… yf)) as (x'&?&?); [auto|by rewrite assoc|].
exists (x' â‹… x3); split; first by rewrite -assoc.
eauto using uPred_mono, cmra_includedN_l.
Qed.
Definition uPred_bupd_aux : seal (@uPred_bupd_def). by eexists. Qed.
-Definition uPred_bupd {M} := uPred_bupd_aux.(unseal) M.
+Definition uPred_bupd {I M} := uPred_bupd_aux.(unseal) I M.
Definition uPred_bupd_eq :
@uPred_bupd = @uPred_bupd_def := uPred_bupd_aux.(seal_eq).
@@ -353,17 +416,17 @@ Ltac unseal :=
rewrite !unseal_eqs /=.
Section primitive.
-Context {M : ucmraT}.
+Context {I: indexT} {M : ucmraT I}.
Implicit Types φ : Prop.
Implicit Types P Q : uPred M.
Implicit Types A : Type.
-Arguments uPred_holds {_} !_ _ _ /.
+Arguments uPred_holds {_ _} !_ _ _ /.
Hint Immediate uPred_in_entails : core.
-Notation "P ⊢ Q" := (@uPred_entails M P%I Q%I) : stdpp_scope.
-Notation "(⊢)" := (@uPred_entails M) (only parsing) : stdpp_scope.
-Notation "P ⊣⊢ Q" := (@uPred_equiv M P%I Q%I) : stdpp_scope.
-Notation "(⊣⊢)" := (@uPred_equiv M) (only parsing) : stdpp_scope.
+Notation "P ⊢ Q" := (@uPred_entails I M P%I Q%I) : stdpp_scope.
+Notation "(⊢)" := (@uPred_entails I M) (only parsing) : stdpp_scope.
+Notation "P ⊣⊢ Q" := (@uPred_equiv I M P%I Q%I) : stdpp_scope.
+Notation "(⊣⊢)" := (@uPred_equiv I M) (only parsing) : stdpp_scope.
Notation "'True'" := (uPred_pure True) : bi_scope.
Notation "'False'" := (uPred_pure False) : bi_scope.
@@ -382,7 +445,10 @@ Notation "â– P" := (uPred_plainly P) : bi_scope.
Notation "x ≡ y" := (uPred_internal_eq x y) : bi_scope.
Notation "â–· P" := (uPred_later P) : bi_scope.
Notation "|==> P" := (uPred_bupd P) : bi_scope.
-
+Notation "â–·^ n P" := (Nat.iter n uPred_later P) : bi_scope.
+Notation "â–·? p P" := (Nat.iter (Nat.b2n p) uPred_later P) : bi_scope.
+Notation "⧠P" := (∃ n, ▷^n P)%I : bi_scope.
+Notation "â§^ n P" := (Nat.iter n (λ Q, ⧠Q) P)%I : bi_scope.
(** Entailment *)
Lemma entails_po : PreOrder (⊢).
Proof.
@@ -402,33 +468,40 @@ Lemma entails_lim (cP cQ : chain (uPredO M)) :
(∀ n, cP n ⊢ cQ n) → compl cP ⊢ compl cQ.
Proof.
intros Hlim; split=> n m ? HP.
- eapply uPred_holds_ne, Hlim, HP; rewrite ?conv_compl; eauto.
+ eapply uPred_holds_ne, Hlim, HP; rewrite ?conv_compl; eauto using chain_cauchy.
+Qed.
+
+Lemma entails_blim α (cP cQ: bchain (uPredO M) α) Hα:
+ (∀ β Hβ, cP β Hβ ⊢ cQ β Hβ) → bcompl Hα cP ⊢ bcompl Hα cQ.
+Proof.
+ intros Hlim; split=> β m Hv HP δ Hδ Hδβ Hv'.
+ eapply Hlim, HP; eauto.
Qed.
(** Non-expansiveness and setoid morphisms *)
-Lemma pure_ne n : Proper (iff ==> dist n) (@uPred_pure M).
-Proof. intros φ1 φ2 Hφ. by unseal; split=> -[|m] ?; try apply Hφ. Qed.
+Lemma pure_ne n : Proper (iff ==> dist n) (@uPred_pure I M).
+Proof. intros φ1 φ2 Hφ. by unseal; split. Qed.
-Lemma and_ne : NonExpansive2 (@uPred_and M).
+Lemma and_ne : NonExpansive2 (@uPred_and I M).
Proof.
intros n P P' HP Q Q' HQ; unseal; split=> x n' ??.
split; (intros [??]; split; [by apply HP|by apply HQ]).
Qed.
-Lemma or_ne : NonExpansive2 (@uPred_or M).
+Lemma or_ne : NonExpansive2 (@uPred_or I M).
Proof.
intros n P P' HP Q Q' HQ; split=> x n' ??.
unseal; split; (intros [?|?]; [left; by apply HP|right; by apply HQ]).
Qed.
Lemma impl_ne :
- NonExpansive2 (@uPred_impl M).
+ NonExpansive2 (@uPred_impl I M).
Proof.
intros n P P' HP Q Q' HQ; split=> x n' ??.
unseal; split; intros HPQ x' n'' ????; apply HQ, HPQ, HP; auto.
Qed.
-Lemma sep_ne : NonExpansive2 (@uPred_sep M).
+Lemma sep_ne : NonExpansive2 (@uPred_sep I M).
Proof.
intros n P P' HP Q Q' HQ; split=> n' x ??.
unseal; split; intros (x1&x2&?&?&?); ofe_subst x;
@@ -437,65 +510,66 @@ Proof.
Qed.
Lemma wand_ne :
- NonExpansive2 (@uPred_wand M).
+ NonExpansive2 (@uPred_wand I M).
Proof.
intros n P P' HP Q Q' HQ; split=> n' x ??; unseal; split; intros HPQ x' n'' ???;
apply HQ, HPQ, HP; eauto using cmra_validN_op_r.
Qed.
-Lemma internal_eq_ne (A : ofeT) :
- NonExpansive2 (@uPred_internal_eq M A).
+Lemma internal_eq_ne (A : ofeT I) :
+ NonExpansive2 (@uPred_internal_eq I M A).
Proof.
intros n x x' Hx y y' Hy; split=> n' z; unseal; split; intros; simpl in *.
- - by rewrite -(dist_le _ _ _ _ Hx) -?(dist_le _ _ _ _ Hy); auto.
- - by rewrite (dist_le _ _ _ _ Hx) ?(dist_le _ _ _ _ Hy); auto.
+ - hnf. by rewrite -(dist_le _ _ _ _ Hx) -?(dist_le _ _ _ _ Hy).
+ - hnf. by rewrite (dist_le _ _ _ _ Hx) ?(dist_le _ _ _ _ Hy).
Qed.
Lemma forall_ne A n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_forall M A).
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_forall I M A).
Proof.
by intros Ψ1 Ψ2 HΨ; unseal; split=> n' x; split; intros HP a; apply HΨ.
Qed.
Lemma exist_ne A n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_exist M A).
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@uPred_exist I M A).
Proof.
intros Ψ1 Ψ2 HΨ.
unseal; split=> n' x ??; split; intros [a ?]; exists a; by apply HΨ.
Qed.
-Lemma later_contractive : Contractive (@uPred_later M).
+Lemma later_contractive : Contractive (@uPred_later I M).
Proof.
- unseal; intros [|n] P Q HPQ; split=> -[|n'] x ?? //=; try lia.
- apply HPQ; eauto using cmra_validN_S.
+ unseal; intros n P Q HPQ; split=> -n' x H ? //=; split=> Hl m Hm; eapply HPQ.
+ all: eauto using index_lt_le_trans, cmra_validN_le.
Qed.
-Lemma plainly_ne : NonExpansive (@uPred_plainly M).
+Lemma plainly_ne : NonExpansive (@uPred_plainly I M).
Proof.
intros n P1 P2 HP.
unseal; split=> n' x; split; apply HP; eauto using @ucmra_unit_validN.
Qed.
-Lemma persistently_ne : NonExpansive (@uPred_persistently M).
+Lemma persistently_ne : NonExpansive (@uPred_persistently I M).
Proof.
intros n P1 P2 HP.
unseal; split=> n' x; split; apply HP; eauto using @cmra_core_validN.
Qed.
-Lemma ownM_ne : NonExpansive (@uPred_ownM M).
+Lemma ownM_ne : NonExpansive (@uPred_ownM I M).
Proof.
intros n a b Ha.
- unseal; split=> n' x ? /=. by rewrite (dist_le _ _ _ _ Ha); last lia.
+ unseal; split=> n' x ? ? /=.
+ by rewrite (dist_le _ _ _ _ Ha).
Qed.
-Lemma cmra_valid_ne {A : cmraT} :
- NonExpansive (@uPred_cmra_valid M A).
+Lemma cmra_valid_ne {A : cmraT I} :
+ NonExpansive (@uPred_cmra_valid I M A).
Proof.
intros n a b Ha; unseal; split=> n' x ? /=.
- by rewrite (dist_le _ _ _ _ Ha); last lia.
+ by rewrite (dist_le _ _ _ _ Ha).
Qed.
-Lemma bupd_ne : NonExpansive (@uPred_bupd M).
+Lemma bupd_ne : NonExpansive (@uPred_bupd I M).
Proof.
intros n P Q HPQ.
unseal; split=> n' x; split; intros HP k yf ??;
@@ -527,8 +601,8 @@ Proof. intros HP HQ; unseal; split=> n x ? [?|?]. by apply HP. by apply HQ. Qed.
Lemma impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R.
Proof.
- unseal; intros HQ; split=> n x ?? n' x' ????. apply HQ;
- naive_solver eauto using uPred_mono, cmra_included_includedN.
+ unseal; intros HQ; split=> n x ?? n' x' ????. apply HQ; [eauto|].
+ split; eauto using uPred_mono, cmra_included_includedN.
Qed.
Lemma impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R.
Proof. unseal; intros HP ; split=> n x ? [??]; apply HP with n x; auto. Qed.
@@ -582,13 +656,13 @@ Proof.
eapply HPQR; eauto using cmra_validN_op_l.
Qed.
-(** Persistently *)
+
+(** persistently *)
Lemma persistently_mono P Q : (P ⊢ Q) → □ P ⊢ □ Q.
Proof. intros HP; unseal; split=> n x ? /=. by apply HP, cmra_core_validN. Qed.
Lemma persistently_elim P : □ P ⊢ P.
Proof.
- unseal; split=> n x ? /=.
- eauto using uPred_mono, @cmra_included_core, cmra_included_includedN.
+ unseal; split=> n x ? /= H; eauto using uPred_mono, cmra_included_core, cmra_included_includedN.
Qed.
Lemma persistently_idemp_2 P : □ P ⊢ □ □ P.
Proof. unseal; split=> n x ?? /=. by rewrite cmra_core_idemp. Qed.
@@ -641,40 +715,63 @@ Proof.
Qed.
(** Later *)
+
Lemma later_mono P Q : (P ⊢ Q) → ▷ P ⊢ ▷ Q.
Proof.
- unseal=> HP; split=>-[|n] x ??; [done|apply HP; eauto using cmra_validN_S].
+ unseal=> HP; split=> -n x ?? n' ?. apply HP; eauto using cmra_validN_le.
Qed.
Lemma later_intro P : P ⊢ ▷ P.
Proof.
- unseal; split=> -[|n] /= x ? HP; first done.
- apply uPred_mono with (S n) x; eauto using cmra_validN_S.
+ unseal; split=> n /= x ? HP n' Hn'.
+ apply uPred_mono with n x; eauto using cmra_validN_le.
Qed.
Lemma later_forall_2 {A} (Φ : A → uPred M) : (∀ a, ▷ Φ a) ⊢ ▷ ∀ a, Φ a.
-Proof. unseal; by split=> -[|n] x. Qed.
-Lemma later_exist_false {A} (Φ : A → uPred M) :
+Proof. unseal; split=> n x Hv H n' Hn' a. by eapply H. Qed.
+Lemma later_exist_false `{FI: FiniteIndex I} {A} (Φ : A → uPred M) :
+ (▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a).
+Proof.
+ unseal; split=> -n x Hv /= H; eauto.
+ destruct (finite_index n) as [|[m []]]; eauto.
+ right. edestruct H as [y]; eauto. exists y.
+ intros; eauto using uPred_mono.
+Qed.
+
+Lemma later_finite_exist_false `{BI: FiniteBoundedExistential I} {A} (Φ : A → uPred M) (Q: A → Prop):
+ pred_finite Q →
+ (∀ a, Φ a ⊢ ⌜Q aâŒ) →
(▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a).
-Proof. unseal; split=> -[|[|n]] x /=; eauto. Qed.
-Lemma later_sep_1 P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q.
Proof.
- unseal; split=> n x ?.
- destruct n as [|n]; simpl.
- { by exists x, (core x); rewrite cmra_core_r. }
- intros (x1&x2&Hx&?&?); destruct (cmra_extend 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].
+ intros Hq Hfin.
+ unseal; split=> -n x Hv /= H; eauto.
+ destruct (index_is_zero n) as [->|Hterm].
+ - left. intros ? [] % index_lt_zero_is_normal.
+ - destruct (can_commute_finite_bounded_exists _ (λ a n, Φ a n x) Q n); eauto using uPred_mono.
+ intros m Hmn. destruct (H m Hmn) as [y HΦ]. destruct (Hfin y) as [HQ].
+ exists y. split; eauto. revert HQ. unseal. intros HQ. eapply HQ; last eauto.
+ eauto using cmra_validN_le.
+Qed.
+
+Lemma later_sep_1 `{FI: FiniteIndex I} P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q.
+Proof.
+ unseal; split=> n x ? //= H.
+ destruct (finite_index n) as [Hterm|[m [Hmn ?]]]; eauto.
+ { exists x, (core x); rewrite cmra_core_r; (repeat split; eauto); intros ? [] % Hterm. }
+ destruct (H m Hmn) as (x1&x2&Hx&?&?). destruct (cmra_extend m x x1 x2) as (y1&y2&Hx'&Hy1&Hy2); eauto using cmra_validN_le; simpl in *.
+ exists y1, y2; split; [by rewrite Hx'|]; split=> n' Hn'; eapply uPred_mono; eauto; by rewrite ?Hy1 ?Hy2.
Qed.
Lemma later_sep_2 P Q : ▷ P ∗ ▷ Q ⊢ ▷ (P ∗ Q).
Proof.
- unseal; split=> n x ?.
- destruct n as [|n]; simpl; [done|intros (x1&x2&Hx&?&?)].
- exists x1, x2; eauto using dist_S.
+ unseal; split=> n x ? //=. intros (x1&x2&Hx&Hx1&Hx2) n' Hn'.
+ exists x1, x2; repeat split; eauto using dist_le.
Qed.
Lemma later_false_em P : ▷ P ⊢ ▷ False ∨ (▷ False → P).
Proof.
- unseal; split=> -[|n] x ? /= HP; [by left|right].
- intros [|n'] x' ????; eauto using uPred_mono, cmra_included_includedN.
+ unseal; split=> -n x ? /= HP. destruct (index_lt_dec_minimum n) as [|[n']]; eauto.
+ right. intros. eapply uPred_mono.
+ - eapply HP; eauto.
+ - eauto using cmra_included_includedN.
+ - erewrite index_zero_is_unique at 1; eauto using index_zero_minimum.
Qed.
Lemma later_persistently_1 P : ▷ □ P ⊢ □ ▷ P.
@@ -687,25 +784,25 @@ Lemma later_plainly_2 P : ■▷ P ⊢ ▷ ■P.
Proof. by unseal. Qed.
(** Internal equality *)
-Lemma internal_eq_refl {A : ofeT} P (a : A) : P ⊢ (a ≡ a).
+Lemma internal_eq_refl {A : ofeT I} P (a : A) : P ⊢ (a ≡ a).
Proof. unseal; by split=> n x ??; simpl. Qed.
-Lemma internal_eq_rewrite {A : ofeT} a b (Ψ : A → uPred M) :
+Lemma internal_eq_rewrite {A : ofeT I} a b (Ψ : A → uPred M) :
NonExpansive Ψ → a ≡ b ⊢ Ψ a → Ψ b.
Proof. intros HΨ. unseal; split=> n x ?? n' x' ??? Ha. by apply HΨ with n a. Qed.
-Lemma fun_ext {A} {B : A → ofeT} (g1 g2 : discrete_fun B) :
+Lemma fun_ext {A} {B : A → ofeT I} (g1 g2 : discrete_fun B) :
(∀ i, g1 i ≡ g2 i) ⊢ g1 ≡ g2.
Proof. by unseal. Qed.
-Lemma sig_eq {A : ofeT} (P : A → Prop) (x y : sigO P) :
+Lemma sig_eq {A : ofeT I} (P : A → Prop) (x y : sigO P) :
proj1_sig x ≡ proj1_sig y ⊢ x ≡ y.
Proof. by unseal. Qed.
-Lemma later_eq_1 {A : ofeT} (x y : A) : Next x ≡ Next y ⊢ ▷ (x ≡ y).
+Lemma later_eq_1 {A : ofeT I} (x y : A) : Next x ≡ Next y ⊢ ▷ (x ≡ y).
Proof. by unseal. Qed.
-Lemma later_eq_2 {A : ofeT} (x y : A) : ▷ (x ≡ y) ⊢ Next x ≡ Next y.
+Lemma later_eq_2 {A : ofeT I} (x y : A) : ▷ (x ≡ y) ⊢ Next x ≡ Next y.
Proof. by unseal. Qed.
-Lemma discrete_eq_1 {A : ofeT} (a b : A) : Discrete a → a ≡ b ⊢ ⌜a ≡ bâŒ.
+Lemma discrete_eq_1 {A : ofeT I} (a b : A) : Discrete a → a ≡ b ⊢ ⌜a ≡ bâŒ.
Proof.
unseal=> ?. split=> n x ?. by apply (discrete_iff n).
Qed.
@@ -728,7 +825,7 @@ Lemma bupd_frame_r P R : (|==> P) ∗ R ⊢ |==> P ∗ R.
Proof.
unseal; split; intros n x ? (x1&x2&Hx&HP&?) k yf ??.
destruct (HP k (x2 â‹… yf)) as (x'&?&?); eauto.
- { by rewrite assoc -(dist_le _ _ _ _ Hx); last lia. }
+ { by rewrite assoc -(dist_le _ _ _ _ Hx); last auto. }
exists (x' â‹… x2); split; first by rewrite -assoc.
exists x', x2. eauto using uPred_mono, cmra_validN_op_l, cmra_validN_op_r.
Qed.
@@ -756,12 +853,15 @@ Proof.
Qed.
Lemma ownM_unit P : P ⊢ (uPred_ownM ε).
Proof. unseal; split=> n x ??; by exists x; rewrite left_id. Qed.
-Lemma later_ownM a : ▷ uPred_ownM a ⊢ ∃ b, uPred_ownM b ∧ ▷ (a ≡ b).
+Lemma later_ownM `{FI: FiniteIndex I} a : ▷ uPred_ownM a ⊢ ∃ b, uPred_ownM b ∧ ▷ (a ≡ b).
Proof.
- unseal; split=> -[|n] x /= ? Hax; first by eauto using ucmra_unit_leastN.
- destruct Hax as [y ?].
- destruct (cmra_extend n x a y) as (a'&y'&Hx&?&?); auto using cmra_validN_S.
- exists a'. rewrite Hx. eauto using cmra_includedN_l.
+ unseal; split=> -n x /= ? Hax.
+ destruct (finite_index n) as [H|[m []]].
+ { exists x. split; eauto. intros ? [] % H. }
+ edestruct Hax as [y ?]; eauto.
+ destruct (cmra_extend m x a y) as (a'&y'&Hx&H2&?); eauto using cmra_validN_le.
+ exists a'. rewrite Hx. split; eauto using cmra_includedN_l.
+ intros; eapply dist_le. symmetry; eapply H2. eauto.
Qed.
Lemma bupd_ownM_updateP x (Φ : M → Prop) :
@@ -779,36 +879,196 @@ Lemma ownM_valid (a : M) : uPred_ownM a ⊢ ✓ a.
Proof.
unseal; split=> n x Hv [a' ?]; ofe_subst; eauto using cmra_validN_op_l.
Qed.
-Lemma cmra_valid_intro {A : cmraT} P (a : A) : ✓ a → P ⊢ (✓ a).
+Lemma cmra_valid_intro {A : cmraT I} P (a : A) : ✓ a → P ⊢ (✓ a).
Proof. unseal=> ?; split=> n x ? _ /=; by apply cmra_valid_validN. Qed.
-Lemma cmra_valid_elim {A : cmraT} (a : A) : ¬ ✓{0} a → ✓ a ⊢ False.
-Proof. unseal=> Ha; split=> n x ??; apply Ha, cmra_validN_le with n; auto. Qed.
-Lemma plainly_cmra_valid_1 {A : cmraT} (a : A) : ✓ a ⊢ ■✓ a.
+Lemma cmra_valid_elim {A : cmraT I} (a : A) : ¬ ✓{zero} a → ✓ a ⊢ False.
+Proof. unseal=> Ha; split=> n x ??; apply Ha, cmra_validN_le with n; auto using index_zero_minimum. Qed.
+Lemma plainly_cmra_valid_1 {A : cmraT I} (a : A) : ✓ a ⊢ ■✓ a.
Proof. by unseal. Qed.
-Lemma cmra_valid_weaken {A : cmraT} (a b : A) : ✓ (a ⋅ b) ⊢ ✓ a.
+Lemma cmra_valid_weaken {A : cmraT I} (a b : A) : ✓ (a ⋅ b) ⊢ ✓ a.
Proof. unseal; split=> n x _; apply cmra_validN_op_l. Qed.
-Lemma prod_validI {A B : cmraT} (x : A * B) : ✓ x ⊣⊢ ✓ x.1 ∧ ✓ x.2.
+Lemma prod_validI {A B : cmraT I} (x : A * B) : ✓ x ⊣⊢ ✓ x.1 ∧ ✓ x.2.
Proof. by unseal. Qed.
-Lemma option_validI {A : cmraT} (mx : option A) :
+Lemma option_validI {A : cmraT I} (mx : option A) :
✓ mx ⊣⊢ match mx with Some x => ✓ x | None => True : uPred M end.
Proof. unseal. by destruct mx. Qed.
-Lemma discrete_valid {A : cmraT} `{!CmraDiscrete A} (a : A) : ✓ a ⊣⊢ ⌜✓ aâŒ.
+Lemma discrete_valid {A : cmraT I} `{!CmraDiscrete A} (a : A) : ✓ a ⊣⊢ ⌜✓ aâŒ.
Proof. unseal; split=> n x _. by rewrite /= -cmra_discrete_valid_iff. Qed.
-Lemma discrete_fun_validI {A} {B : A → ucmraT} (g : discrete_fun B) : ✓ g ⊣⊢ ∀ i, ✓ g i.
+
+Lemma discrete_fun_validI {A} {B : A → ucmraT I} (g : discrete_fun B) : ✓ g ⊣⊢ ∀ i, ✓ g i.
Proof. by unseal. Qed.
+
+
(** Consistency/soundness statement *)
Lemma pure_soundness φ : (True ⊢ ⌜ φ âŒ) → φ.
-Proof. unseal=> -[H]. by apply (H 0 ε); eauto using ucmra_unit_validN. Qed.
+Proof. unseal=> -[H]. by apply (H zero ε); eauto using ucmra_unit_validN. Qed.
Lemma later_soundness P : (True ⊢ ▷ P) → (True ⊢ P).
Proof.
unseal=> -[HP]; split=> n x Hx _.
apply uPred_mono with n ε; eauto using ucmra_unit_leastN.
- by apply (HP (S n)); eauto using ucmra_unit_validN.
+ apply (HP (index_succ _ n)); eauto using ucmra_unit_validN.
+ constructor.
+Qed.
+
+Lemma big_later_soundness `{TransfiniteIndex I} P: (True ⊢ ⧠P) → (True ⊢ P).
+ unseal=> -[HP]; split=> n x Hx _. apply uPred_mono with n ε; eauto using ucmra_unit_leastN.
+ edestruct (HP (upper_limit n) ε) as [m LP]; first eauto using ucmra_unit_validN; first done.
+ eapply uPred_mono in LP; last (right; apply (upper_limit_is_limit m n));
+ eauto using ucmra_unit_validN.
+ induction m; eauto.
+ eapply IHm, uPred_mono; first eapply LP; eauto. simpl; eapply index_succ_greater.
+Qed.
+
+Lemma big_laterN_soundness `{TransfiniteIndex I} n P: (True ⊢ â§^n P) → (True ⊢ P).
+ intros B. induction n as [|n IH]; simpl in *; eauto using big_later_soundness.
+Qed.
+
+
+(* TODO: once we have fixed sbi, remove these -- currently, they are proved in the model because they cannot be derived from sbi *)
+Definition timeless (P: uPred M) := ▷ P ⊢ ▷ False ∨ P.
+Section move_once_fixed.
+ Lemma pure_timeless φ: timeless ⌜φâŒ.
+ Proof.
+ unfold timeless; unseal. split=> n x Hv //= Hφ.
+ destruct (index_lt_dec_minimum n) as [|[]]; eauto.
+ Qed.
+
+ Lemma timeless_zero P: timeless P → (▷ False → P) ⊢ P.
+ Proof.
+ unfold timeless; unseal; intros [H]; split=> n x Hv //= HP; simpl in *.
+ induction n as [n IH] using (well_founded_ind (index_lt_wf I)).
+ destruct (index_lt_dec_minimum n) as [H'|[m ?]]; eauto.
+ edestruct H; eauto.
+ intros; eapply IH; eauto using cmra_validN_le, index_le_lt_trans.
+ Qed.
+
+ Lemma later_or_timeless P Q: timeless P → timeless Q → ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
+ Proof.
+ intros HP % timeless_zero HQ % timeless_zero.
+ revert HP HQ; unseal; intros [HP] [HQ]. constructor => n x Hv.
+ split; last by (intros [HfP | HfQ] β Hβ; [left | right]; eauto).
+ move => //= HPQ; simpl in *.
+ destruct (index_lt_dec_minimum n) as [H'|[m ?]].
+ - left; intros; by edestruct H'.
+ - assert (zero ≺ n) as Hterm by eauto using index_le_lt_trans.
+ destruct (HPQ zero Hterm) as [HP'|HQ'].
+ + left; intros; eapply HP; eauto using cmra_validN_le.
+ intros m' x' Hext Hle Hv' Hterm'.
+ assert (m' = zero) as -> by eauto using index_zero_is_unique.
+ eauto using uPred_mono, cmra_included_includedN.
+ + right; intros; eapply HQ; eauto using cmra_validN_le.
+ intros m' x' Hext Hle Hv' Hterm'.
+ assert (m' = zero) as -> by eauto using index_zero_is_unique.
+ eauto using uPred_mono, cmra_included_includedN.
+ Qed.
+
+ Lemma later_sep_timeless P Q: timeless P → timeless Q → ▷ (P ∗ Q) ⊣⊢ ▷ P ∗ ▷ Q.
+ Proof.
+ intros HP % timeless_zero HQ % timeless_zero.
+ revert HP HQ; unseal; intros [HP] [HQ]; split=> n x Hv.
+ split. 2: { cbn. intros (x1 & x2 & Hx & Hx1 & Hx2) n' Hn'. exists x1, x2.
+ split; [ by eapply dist_mono | split; [by apply Hx1 | by apply Hx2]].
+ }
+ move=> //= HPQ; simpl in *.
+ destruct (index_lt_dec_minimum n) as [H'|[m ?]].
+ - exists (core x), x. repeat split.
+ { symmetry; eapply equiv_dist, cmra_core_l. }
+ all: intros ? ?; exfalso; by eapply H'.
+ - assert (zero ≺ n) as Hterm by eauto using index_le_lt_trans.
+ destruct (HPQ zero Hterm) as (x1&x2&Hx&Hx1&Hx2).
+ destruct (cmra_extend zero x x1 x2) as (y1&y2&Hx'&Hy1&Hy2); eauto using cmra_validN_le.
+ exists y1, y2. repeat split.
+ { by eapply equiv_dist. }
+ + intros. eapply HP.
+ { erewrite Hx' in Hv; eauto using cmra_validN_op_l, cmra_validN_le. }
+ intros m' x' Hext Hle Hv' Hterm'.
+ assert (m' = zero) as -> by eauto using index_zero_is_unique.
+ eapply uPred_mono; eauto. rewrite -Hy1; eauto using cmra_included_includedN.
+ + intros. eapply HQ.
+ { erewrite Hx' in Hv; eauto using cmra_validN_op_r, cmra_validN_le. }
+ intros m' x' Hext Hle Hv' Hterm'.
+ assert (m' = zero) as -> by eauto using index_zero_is_unique.
+ eapply uPred_mono; eauto. rewrite -Hy2; eauto using cmra_included_includedN.
+ Qed.
+
+ Lemma later_exist_timeless {A} (Ψ : A → uPred M) :
+ (∀ x, timeless (Ψ x)) → ▷ (∃ x, Ψ x) ⊢ ▷ False ∨ ∃ x, ▷ Ψ x.
+ Proof.
+ intros Htime. assert (∀ x, (▷ False → Ψ x) ⊢ Ψ x) as H0 by eauto using timeless_zero.
+ revert H0; unseal; intros H0; split=> n x Hv //= HΨ; simpl in *.
+ destruct (index_lt_dec_minimum n) as [H'|[m ?]].
+ - by left.
+ - right; assert (zero ≺ n) as Hterm by eauto using index_le_lt_trans.
+ destruct (HΨ zero Hterm) as [a Ha]. destruct (H0 a) as [H0']; simpl in *.
+ exists a; intros m' Hm'; apply H0'; eauto using cmra_validN_le.
+ intros n' ?????; assert (n' = zero) as -> by eauto using index_zero_is_unique.
+ eauto using uPred_mono, cmra_included_includedN.
+ Qed.
+End move_once_fixed.
+
+
+(* this is a nice property but we have no use case yet *)
+Lemma exists_own_wand X (φ: X → uPred M) a : (∀ b n, ✓{n} b → ✓{n} (b ⋅ a)) → (uPred_ownM a -∗ ∃ x, φ x) ⊢ (∃ x, uPred_ownM a -∗ φ x).
+Proof.
+ intros Hval; split=> n b Hv; unseal. intros Hex.
+ feed pose proof (Hex n a) as Hex; eauto.
+ destruct Hex as [x Hφ].
+ exists x. intros n' a' Hn' Hv' Ha.
+ eapply uPred_mono; last reflexivity; last first.
+ apply cmra_monoN_l, Ha.
+ eapply uPred_mono; first apply Hφ; eauto.
+Qed.
+
+
+
+Lemma later_or_commute_classically P Q:
+ (∀ X: Prop, X \/ ¬ X) →
+ ▷ (P ∨ Q) ⊢ ▷ P ∨ ▷ Q.
+Proof.
+ intros XM; unseal; split=> n x Hv //= HPQ.
+ destruct (XM ((∀ n' : I, n' ≺ n → P n' x) ∨ (∀ n' : I, n' ≺ n → Q n' x))) as [|H]; eauto.
+ left; intros n1 Hn1; destruct (XM (P n1 x)); eauto.
+ exfalso; eapply H.
+ right; intros n2 Hn2; destruct (XM (Q n2 x)); eauto.
+ exfalso.
+ destruct (index_le_total n1 n2).
+ - destruct (HPQ n2 Hn2) as []; eauto using uPred_mono.
+ - destruct (HPQ n1 Hn1) as []; eauto using uPred_mono.
Qed.
+
+
+Section later_or_is_classical.
+ Variable (ω: I) (m: M) (f: I → bool).
+ Hypothesis (ω_sup: ∀ n, n ≺ ω → index_succ I n ≺ ω).
+ Hypothesis (comm: ∀ P Q, ▷ (P ∨ Q) ⊢ ▷ P ∨ ▷ Q).
+ Hypothesis
+ (Hdec: (∀ n : I, n ≺ ω → (∀ m, m ⪯ n → f m = false) ∨ (∃ m : I, f m = true))).
+ Hypothesis (Hm: ✓{ω} m).
+ Hypothesis (Hl: zero ≺ ω).
+
+ Local Program Definition P : uPred M :=
+ {| uPred_holds n x := ∀ n', n' ⪯ n → f n' = false |}.
+ Next Obligation.
+ simpl; eauto.
+ Qed.
+
+ Let Q : uPred M := ⌜∃ m, f m = trueâŒ.
+
+ Lemma dec_halting: (∀ n, n ≺ ω → f n = false) ∨ (∃ m, f m = true).
+ Proof using Hdec Hl Hm I M Q comm f m ω.
+ specialize (comm P Q). revert comm. unfold Q. unseal.
+ intros [H]; simpl in H.
+ destruct (H ω m Hm Hdec) as [Ht|Hf].
+ - left; intros; eapply Ht; eauto.
+ - right; eapply Hf; eauto.
+ Qed.
+
+End later_or_is_classical.
+
End primitive.
End uPred_primitive.
diff --git a/theories/bi/bi.v b/theories/bi/bi.v
index 9e9de7dbae24213b688f9705816f74f5d8fd6415..4b0b9e3050a4ac307809afbea457d8cc132670a2 100644
--- a/theories/bi/bi.v
+++ b/theories/bi/bi.v
@@ -1,5 +1,5 @@
From iris.bi Require Export derived_laws_bi derived_laws_sbi
- big_op updates plainly embedding.
+ big_op updates plainly embedding.
Set Default Proof Using "Type".
Module Import bi.
diff --git a/theories/bi/big_op.v b/theories/bi/big_op.v
index 221dd24a62d9f268dc451cc92ca589ad520cf5ad..54a9bc441f6103444c53bf75dd1b02542f9fb5db 100644
--- a/theories/bi/big_op.v
+++ b/theories/bi/big_op.v
@@ -35,26 +35,26 @@ Notation "'[∗' 'mset]' x ∈ X , P" := (big_opMS bi_sep (λ x, P) X) : bi_scop
version also ensures that both lists have the same length. Although this version
can be defined in terms of the unary using a [zip] (see [big_sepL2_alt]), we do
not define it that way to get better computational behavior (for [simpl]). *)
-Fixpoint big_sepL2 {PROP : bi} {A B}
+Fixpoint big_sepL2 {SI} {PROP : bi SI} {A B}
(Φ : nat → A → B → PROP) (l1 : list A) (l2 : list B) : PROP :=
match l1, l2 with
| [], [] => emp
| x1 :: l1, x2 :: l2 => Φ 0 x1 x2 ∗ big_sepL2 (λ n, Φ (S n)) l1 l2
| _, _ => False
end%I.
-Instance: Params (@big_sepL2) 3 := {}.
-Arguments big_sepL2 {PROP A B} _ !_ !_ /.
+Instance: Params (@big_sepL2) 4 := {}.
+Arguments big_sepL2 {SI PROP A B} _ !_ !_ /.
Typeclasses Opaque big_sepL2.
Notation "'[∗' 'list]' k ↦ x1 ; x2 ∈ l1 ; l2 , P" :=
(big_sepL2 (λ k x1 x2, P) l1 l2) : bi_scope.
Notation "'[∗' 'list]' x1 ; x2 ∈ l1 ; l2 , P" :=
(big_sepL2 (λ _ x1 x2, P) l1 l2) : bi_scope.
-Definition big_sepM2 {PROP : bi} `{Countable K} {A B}
+Definition big_sepM2 {SI} {PROP : bi SI} `{Countable K} {A B}
(Φ : K → A → B → PROP) (m1 : gmap K A) (m2 : gmap K B) : PROP :=
(⌜ ∀ k, is_Some (m1 !! k) ↔ is_Some (m2 !! k) ⌠∧
[∗ map] k ↦ xy ∈ map_zip m1 m2, Φ k xy.1 xy.2)%I.
-Instance: Params (@big_sepM2) 6 := {}.
+Instance: Params (@big_sepM2) 7 := {}.
Typeclasses Opaque big_sepM2.
Notation "'[∗' 'map]' k ↦ x1 ; x2 ∈ m1 ; m2 , P" :=
(big_sepM2 (λ k x1 x2, P) m1 m2) : bi_scope.
@@ -63,7 +63,7 @@ Notation "'[∗' 'map]' x1 ; x2 ∈ m1 ; m2 , P" :=
(** * Properties *)
Section bi_big_op.
-Context {PROP : bi}.
+Context {SI} {PROP : bi SI}.
Implicit Types P Q : PROP.
Implicit Types Ps Qs : list PROP.
Implicit Types A : Type.
@@ -76,7 +76,7 @@ Section sep_list.
Lemma big_sepL_nil Φ : ([∗ list] k↦y ∈ nil, Φ k y) ⊣⊢ emp.
Proof. done. Qed.
- Lemma big_sepL_nil' `{BiAffine PROP} P Φ : P ⊢ [∗ list] k↦y ∈ nil, Φ k y.
+ Lemma big_sepL_nil' `{BiAffine SI PROP} P Φ : P ⊢ [∗ list] k↦y ∈ nil, Φ k y.
Proof. apply (affine _). Qed.
Lemma big_sepL_cons Φ x l :
([∗ list] k↦y ∈ x :: l, Φ k y) ⊣⊢ Φ 0 x ∗ [∗ list] k↦y ∈ l, Φ (S k) y.
@@ -96,7 +96,7 @@ Section sep_list.
(∀ k y, l !! k = Some y → Φ k y ⊣⊢ Ψ k y) →
([∗ list] k ↦ y ∈ l, Φ k y) ⊣⊢ ([∗ list] k ↦ y ∈ l, Ψ k y).
Proof. apply big_opL_proper. Qed.
- Lemma big_sepL_submseteq `{BiAffine PROP} (Φ : A → PROP) l1 l2 :
+ Lemma big_sepL_submseteq `{BiAffine SI PROP} (Φ : A → PROP) l1 l2 :
l1 ⊆+ l2 → ([∗ list] y ∈ l2, Φ y) ⊢ [∗ list] y ∈ l1, Φ y.
Proof.
intros [l ->]%submseteq_Permutation. by rewrite big_sepL_app sep_elim_l.
@@ -104,10 +104,10 @@ Section sep_list.
Global Instance big_sepL_mono' :
Proper (pointwise_relation _ (pointwise_relation _ (⊢)) ==> (=) ==> (⊢))
- (big_opL (@bi_sep PROP) (A:=A)).
+ (big_opL (@bi_sep SI PROP) (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opL_forall; apply _ || intros; apply Hf. Qed.
Global Instance big_sepL_id_mono' :
- Proper (Forall2 (⊢) ==> (⊢)) (big_opL (@bi_sep PROP) (λ _ P, P)).
+ Proper (Forall2 (⊢) ==> (⊢)) (big_opL (@bi_sep SI PROP) (λ _ P, P)).
Proof. by induction 1 as [|P Q Ps Qs HPQ ? IH]; rewrite /= ?HPQ ?IH. Qed.
Lemma big_sepL_emp l : ([∗ list] k↦y ∈ l, emp) ⊣⊢@{PROP} emp.
@@ -150,11 +150,11 @@ Section sep_list.
⊢ ([∗ list] k↦x ∈ l, Φ k x) ∧ ([∗ list] k↦x ∈ l, Ψ k x).
Proof. auto using and_intro, big_sepL_mono, and_elim_l, and_elim_r. Qed.
- Lemma big_sepL_persistently `{BiAffine PROP} Φ l :
+ Lemma big_sepL_persistently `{BiAffine SI PROP} Φ l :
<pers> ([∗ list] k↦x ∈ l, Φ k x) ⊣⊢ [∗ list] k↦x ∈ l, <pers> (Φ k x).
Proof. apply (big_opL_commute _). Qed.
- Lemma big_sepL_forall `{BiAffine PROP} Φ l :
+ Lemma big_sepL_forall `{BiAffine SI PROP} Φ l :
(∀ k x, Persistent (Φ k x)) →
([∗ list] k↦x ∈ l, Φ k x) ⊣⊢ (∀ k x, ⌜l !! k = Some x⌠→ Φ k x).
Proof.
@@ -268,7 +268,7 @@ Section sep_list2.
Lemma big_sepL2_nil Φ : ([∗ list] k↦y1;y2 ∈ []; [], Φ k y1 y2) ⊣⊢ emp.
Proof. done. Qed.
- Lemma big_sepL2_nil' `{BiAffine PROP} P Φ : P ⊢ [∗ list] k↦y1;y2 ∈ [];[], Φ k y1 y2.
+ Lemma big_sepL2_nil' `{BiAffine SI PROP} P Φ : P ⊢ [∗ list] k↦y1;y2 ∈ [];[], Φ k y1 y2.
Proof. apply (affine _). Qed.
Lemma big_sepL2_cons Φ x1 x2 l1 l2 :
@@ -436,7 +436,7 @@ Section sep_list2.
⊢ ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ∧ ([∗ list] k↦y1;y2 ∈ l1;l2, Ψ k y1 y2).
Proof. auto using and_intro, big_sepL2_mono, and_elim_l, and_elim_r. Qed.
- Lemma big_sepL2_persistently `{BiAffine PROP} Φ l1 l2 :
+ Lemma big_sepL2_persistently `{BiAffine SI PROP} Φ l1 l2 :
<pers> ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2)
⊣⊢ [∗ list] k↦y1;y2 ∈ l1;l2, <pers> (Φ k y1 y2).
Proof.
@@ -512,10 +512,10 @@ Section and_list.
Global Instance big_andL_mono' :
Proper (pointwise_relation _ (pointwise_relation _ (⊢)) ==> (=) ==> (⊢))
- (big_opL (@bi_and PROP) (A:=A)).
+ (big_opL (@bi_and SI PROP) (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opL_forall; apply _ || intros; apply Hf. Qed.
Global Instance big_andL_id_mono' :
- Proper (Forall2 (⊢) ==> (⊢)) (big_opL (@bi_and PROP) (λ _ P, P)).
+ Proper (Forall2 (⊢) ==> (⊢)) (big_opL (@bi_and SI PROP) (λ _ P, P)).
Proof. by induction 1 as [|P Q Ps Qs HPQ ? IH]; rewrite /= ?HPQ ?IH. Qed.
Lemma big_andL_lookup Φ l i x :
@@ -602,10 +602,10 @@ Section or_list.
Global Instance big_orL_mono' :
Proper (pointwise_relation _ (pointwise_relation _ (⊢)) ==> (=) ==> (⊢))
- (big_opL (@bi_or PROP) (A:=A)).
+ (big_opL (@bi_or SI PROP) (A:=A)).
Proof. intros f g Hf m ? <-. apply big_opL_forall; apply _ || intros; apply Hf. Qed.
Global Instance big_orL_id_mono' :
- Proper (Forall2 (⊢) ==> (⊢)) (big_opL (@bi_or PROP) (λ _ P, P)).
+ Proper (Forall2 (⊢) ==> (⊢)) (big_opL (@bi_or SI PROP) (λ _ P, P)).
Proof. by induction 1 as [|P Q Ps Qs HPQ ? IH]; rewrite /= ?HPQ ?IH. Qed.
Lemma big_orL_lookup Φ l i x :
@@ -685,18 +685,18 @@ Section map.
(∀ k x, m !! k = Some x → Φ k x ⊣⊢ Ψ k x) →
([∗ map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∗ map] k ↦ x ∈ m, Ψ k x).
Proof. apply big_opM_proper. Qed.
- Lemma big_sepM_subseteq `{BiAffine PROP} Φ m1 m2 :
+ Lemma big_sepM_subseteq `{BiAffine SI PROP} Φ m1 m2 :
m2 ⊆ m1 → ([∗ map] k ↦ x ∈ m1, Φ k x) ⊢ [∗ map] k ↦ x ∈ m2, Φ k x.
Proof. intros. by apply big_sepL_submseteq, map_to_list_submseteq. Qed.
Global Instance big_sepM_mono' :
Proper (pointwise_relation _ (pointwise_relation _ (⊢)) ==> (=) ==> (⊢))
- (big_opM (@bi_sep PROP) (K:=K) (A:=A)).
+ (big_opM (@bi_sep SI PROP) (K:=K) (A:=A)).
Proof. intros f g Hf m ? <-. apply big_sepM_mono=> ???; apply Hf. Qed.
Lemma big_sepM_empty Φ : ([∗ map] k↦x ∈ ∅, Φ k x) ⊣⊢ emp.
Proof. by rewrite big_opM_empty. Qed.
- Lemma big_sepM_empty' `{BiAffine PROP} P Φ : P ⊢ [∗ map] k↦x ∈ ∅, Φ k x.
+ Lemma big_sepM_empty' `{BiAffine SI PROP} P Φ : P ⊢ [∗ map] k↦x ∈ ∅, Φ k x.
Proof. rewrite big_sepM_empty. apply: affine. Qed.
Lemma big_sepM_insert Φ m i x :
@@ -807,11 +807,11 @@ Section map.
⊢ ([∗ map] k↦x ∈ m, Φ k x) ∧ ([∗ map] k↦x ∈ m, Ψ k x).
Proof. auto using and_intro, big_sepM_mono, and_elim_l, and_elim_r. Qed.
- Lemma big_sepM_persistently `{BiAffine PROP} Φ m :
+ Lemma big_sepM_persistently `{BiAffine SI PROP} Φ m :
(<pers> ([∗ map] k↦x ∈ m, Φ k x)) ⊣⊢ ([∗ map] k↦x ∈ m, <pers> (Φ k x)).
Proof. apply (big_opM_commute _). Qed.
- Lemma big_sepM_forall `{BiAffine PROP} Φ m :
+ Lemma big_sepM_forall `{BiAffine SI PROP} Φ m :
(∀ k x, Persistent (Φ k x)) →
([∗ map] k↦x ∈ m, Φ k x) ⊣⊢ (∀ k x, ⌜m !! k = Some x⌠→ Φ k x).
Proof.
@@ -916,7 +916,7 @@ Section map2.
rewrite /big_sepM2 pure_True ?left_id //.
intros k. rewrite !lookup_empty; split; by inversion 1.
Qed.
- Lemma big_sepM2_empty' `{BiAffine PROP} P Φ : P ⊢ [∗ map] k↦y1;y2 ∈ ∅;∅, Φ k y1 y2.
+ Lemma big_sepM2_empty' `{BiAffine SI PROP} P Φ : P ⊢ [∗ map] k↦y1;y2 ∈ ∅;∅, Φ k y1 y2.
Proof. rewrite big_sepM2_empty. apply (affine _). Qed.
Lemma big_sepM2_empty_l m1 Φ :
@@ -1110,7 +1110,7 @@ Section map2.
⊢ ([∗ map] k↦y1;y2 ∈ m1;m2, Φ k y1 y2) ∧ ([∗ map] k↦y1;y2 ∈ m1;m2, Ψ k y1 y2).
Proof. auto using and_intro, big_sepM2_mono, and_elim_l, and_elim_r. Qed.
- Lemma big_sepM2_persistently `{BiAffine PROP} Φ m1 m2 :
+ Lemma big_sepM2_persistently `{BiAffine SI PROP} Φ m1 m2 :
<pers> ([∗ map] k↦y1;y2 ∈ m1;m2, Φ k y1 y2)
⊣⊢ [∗ map] k↦y1;y2 ∈ m1;m2, <pers> (Φ k y1 y2).
Proof.
@@ -1118,7 +1118,7 @@ Section map2.
persistently_pure big_sepM_persistently.
Qed.
- Lemma big_sepM2_forall `{BiAffine PROP} Φ m1 m2 :
+ Lemma big_sepM2_forall `{BiAffine SI PROP} Φ m1 m2 :
(∀ k x1 x2, Persistent (Φ k x1 x2)) →
([∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2) ⊣⊢
⌜∀ k : K, is_Some (m1 !! k) ↔ is_Some (m2 !! k)âŒ
@@ -1189,12 +1189,12 @@ Section gset.
(∀ x, x ∈ X → Φ x ⊣⊢ Ψ x) →
([∗ set] x ∈ X, Φ x) ⊣⊢ ([∗ set] x ∈ X, Ψ x).
Proof. apply big_opS_proper. Qed.
- Lemma big_sepS_subseteq `{BiAffine PROP} Φ X Y :
+ Lemma big_sepS_subseteq `{BiAffine SI PROP} Φ X Y :
Y ⊆ X → ([∗ set] x ∈ X, Φ x) ⊢ [∗ set] x ∈ Y, Φ x.
Proof. intros. by apply big_sepL_submseteq, elements_submseteq. Qed.
Global Instance big_sepS_mono' :
- Proper (pointwise_relation _ (⊢) ==> (=) ==> (⊢)) (big_opS (@bi_sep PROP) (A:=A)).
+ Proper (pointwise_relation _ (⊢) ==> (=) ==> (⊢)) (big_opS (@bi_sep SI PROP) (A:=A)).
Proof. intros f g Hf m ? <-. by apply big_sepS_mono. Qed.
Lemma big_sepS_empty Φ : ([∗ set] x ∈ ∅, Φ x) ⊣⊢ emp.
@@ -1265,12 +1265,12 @@ Section gset.
by apply sep_mono_r, wand_intro_l.
Qed.
- Lemma big_sepS_filter `{BiAffine PROP}
+ Lemma big_sepS_filter `{BiAffine SI PROP}
(P : A → Prop) `{∀ x, Decision (P x)} Φ X :
([∗ set] y ∈ filter P X, Φ y) ⊣⊢ ([∗ set] y ∈ X, ⌜P y⌠→ Φ y).
Proof. setoid_rewrite <-decide_emp. apply big_sepS_filter'. Qed.
- Lemma big_sepS_filter_acc `{BiAffine PROP}
+ Lemma big_sepS_filter_acc `{BiAffine SI PROP}
(P : A → Prop) `{∀ y, Decision (P y)} Φ X Y :
(∀ y, y ∈ Y → P y → y ∈ X) →
([∗ set] y ∈ X, Φ y) -∗
@@ -1286,11 +1286,11 @@ Section gset.
([∗ set] y ∈ X, Φ y ∧ Ψ y) ⊢ ([∗ set] y ∈ X, Φ y) ∧ ([∗ set] y ∈ X, Ψ y).
Proof. auto using and_intro, big_sepS_mono, and_elim_l, and_elim_r. Qed.
- Lemma big_sepS_persistently `{BiAffine PROP} Φ X :
+ Lemma big_sepS_persistently `{BiAffine SI PROP} Φ X :
<pers> ([∗ set] y ∈ X, Φ y) ⊣⊢ [∗ set] y ∈ X, <pers> (Φ y).
Proof. apply (big_opS_commute _). Qed.
- Lemma big_sepS_forall `{BiAffine PROP} Φ X :
+ Lemma big_sepS_forall `{BiAffine SI PROP} Φ X :
(∀ x, Persistent (Φ x)) → ([∗ set] x ∈ X, Φ x) ⊣⊢ (∀ x, ⌜x ∈ X⌠→ Φ x).
Proof.
intros. apply (anti_symm _).
@@ -1351,12 +1351,12 @@ Section gmultiset.
(∀ x, x ∈ X → Φ x ⊣⊢ Ψ x) →
([∗ mset] x ∈ X, Φ x) ⊣⊢ ([∗ mset] x ∈ X, Ψ x).
Proof. apply big_opMS_proper. Qed.
- Lemma big_sepMS_subseteq `{BiAffine PROP} Φ X Y :
+ Lemma big_sepMS_subseteq `{BiAffine SI PROP} Φ X Y :
Y ⊆ X → ([∗ mset] x ∈ X, Φ x) ⊢ [∗ mset] x ∈ Y, Φ x.
Proof. intros. by apply big_sepL_submseteq, gmultiset_elements_submseteq. Qed.
Global Instance big_sepMS_mono' :
- Proper (pointwise_relation _ (⊢) ==> (=) ==> (⊢)) (big_opMS (@bi_sep PROP) (A:=A)).
+ Proper (pointwise_relation _ (⊢) ==> (=) ==> (⊢)) (big_opMS (@bi_sep SI PROP) (A:=A)).
Proof. intros f g Hf m ? <-. by apply big_sepMS_mono. Qed.
Lemma big_sepMS_empty Φ : ([∗ mset] x ∈ ∅, Φ x) ⊣⊢ emp.
@@ -1394,7 +1394,7 @@ Section gmultiset.
([∗ mset] y ∈ X, Φ y ∧ Ψ y) ⊢ ([∗ mset] y ∈ X, Φ y) ∧ ([∗ mset] y ∈ X, Ψ y).
Proof. auto using and_intro, big_sepMS_mono, and_elim_l, and_elim_r. Qed.
- Lemma big_sepMS_persistently `{BiAffine PROP} Φ X :
+ Lemma big_sepMS_persistently `{BiAffine SI PROP} Φ X :
<pers> ([∗ mset] y ∈ X, Φ y) ⊣⊢ [∗ mset] y ∈ X, <pers> (Φ y).
Proof. apply (big_opMS_commute _). Qed.
@@ -1415,7 +1415,7 @@ End bi_big_op.
(** * Properties for step-indexed BIs*)
Section sbi_big_op.
-Context {PROP : sbi}.
+Context {SI} {PROP : sbi SI}.
Implicit Types Ps Qs : list PROP.
Implicit Types A : Type.
@@ -1425,14 +1425,14 @@ Section list.
Implicit Types l : list A.
Implicit Types Φ Ψ : nat → A → PROP.
- Lemma big_sepL_later `{BiAffine PROP} Φ l :
+ Lemma big_sepL_later `{FiniteIndex SI} `{BiAffine SI PROP} Φ l :
▷ ([∗ list] k↦x ∈ l, Φ k x) ⊣⊢ ([∗ list] k↦x ∈ l, ▷ Φ k x).
Proof. apply (big_opL_commute _). Qed.
Lemma big_sepL_later_2 Φ l :
([∗ list] k↦x ∈ l, ▷ Φ k x) ⊢ ▷ [∗ list] k↦x ∈ l, Φ k x.
Proof. by rewrite (big_opL_commute _). Qed.
- Lemma big_sepL_laterN `{BiAffine PROP} Φ n l :
+ Lemma big_sepL_laterN `{FiniteIndex SI} `{BiAffine SI PROP} Φ n l :
▷^n ([∗ list] k↦x ∈ l, Φ k x) ⊣⊢ ([∗ list] k↦x ∈ l, ▷^n Φ k x).
Proof. apply (big_opL_commute _). Qed.
Lemma big_sepL_laterN_2 Φ n l :
@@ -1442,12 +1442,13 @@ Section list.
Global Instance big_sepL_nil_timeless `{!Timeless (emp%I : PROP)} Φ :
Timeless ([∗ list] k↦x ∈ [], Φ k x).
Proof. simpl; apply _. Qed.
- Global Instance big_sepL_timeless `{!Timeless (emp%I : PROP)} Φ l :
- (∀ k x, Timeless (Φ k x)) → Timeless ([∗ list] k↦x ∈ l, Φ k x).
- Proof. revert Φ. induction l as [|x l IH]=> Φ ? /=; apply _. Qed.
- Global Instance big_sepL_timeless_id `{!Timeless (emp%I : PROP)} Ps :
- TCForall Timeless Ps → Timeless ([∗] Ps).
- Proof. induction 1; simpl; apply _. Qed.
+ (*TODO: depends on sep_timeless *)
+ (*Global Instance big_sepL_timeless `{!Timeless (emp%I : PROP)} Φ l :*)
+ (*(∀ k x, Timeless (Φ k x)) → Timeless ([∗ list] k↦x ∈ l, Φ k x).*)
+ (*Proof. revert Φ. induction l as [|x l IH]=> Φ ? /=; apply _. Qed.*)
+ (*Global Instance big_sepL_timeless_id `{!Timeless (emp%I : PROP)} Ps :*)
+ (*TCForall Timeless Ps → Timeless ([∗] Ps).*)
+ (*Proof. induction 1; simpl; apply _. Qed.*)
Section plainly.
Context `{!BiPlainly PROP}.
@@ -1494,12 +1495,13 @@ Section list2.
Context {A B : Type}.
Implicit Types Φ Ψ : nat → A → B → PROP.
- Lemma big_sepL2_later_1 `{BiAffine PROP} Φ l1 l2 :
- (▷ [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ⊢ ◇ [∗ list] k↦y1;y2 ∈ l1;l2, ▷ Φ k y1 y2.
- Proof.
- rewrite !big_sepL2_alt later_and big_sepL_later (timeless ⌜ _ âŒ%I).
- rewrite except_0_and. auto using and_mono, except_0_intro.
- Qed.
+ (*TODO: depends on pure_timeless *)
+ (*Lemma big_sepL2_later_1 `{FiniteIndex SI} `{BiAffine SI PROP} Φ l1 l2 :*)
+ (*(▷ [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ⊢ ◇ [∗ list] k↦y1;y2 ∈ l1;l2, ▷ Φ k y1 y2.*)
+ (*Proof.*)
+ (*rewrite !big_sepL2_alt later_and big_sepL_later (timeless ⌜ _ âŒ%I).*)
+ (*rewrite except_0_and. auto using and_mono, except_0_intro.*)
+ (*Qed.*)
Lemma big_sepL2_later_2 Φ l1 l2 :
([∗ list] k↦y1;y2 ∈ l1;l2, ▷ Φ k y1 y2) ⊢ ▷ [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2.
@@ -1518,10 +1520,11 @@ Section list2.
Global Instance big_sepL2_nil_timeless `{!Timeless (emp%I : PROP)} Φ :
Timeless ([∗ list] k↦y1;y2 ∈ []; [], Φ k y1 y2).
Proof. simpl; apply _. Qed.
- Global Instance big_sepL2_timeless `{!Timeless (emp%I : PROP)} Φ l1 l2 :
- (∀ k x1 x2, Timeless (Φ k x1 x2)) →
- Timeless ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2).
- Proof. rewrite big_sepL2_alt. apply _. Qed.
+ (* TODO: depends on pure_timeless *)
+ (*Global Instance big_sepL2_timeless `{!Timeless (emp%I : PROP)} Φ l1 l2 :*)
+ (*(∀ k x1 x2, Timeless (Φ k x1 x2)) →*)
+ (*Timeless ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2).*)
+ (*Proof. rewrite big_sepL2_alt. apply _. Qed.*)
Section plainly.
Context `{!BiPlainly PROP}.
@@ -1548,14 +1551,14 @@ Section gmap.
Implicit Types m : gmap K A.
Implicit Types Φ Ψ : K → A → PROP.
- Lemma big_sepM_later `{BiAffine PROP} Φ m :
+ Lemma big_sepM_later `{FiniteIndex SI} `{BiAffine SI PROP} Φ m :
▷ ([∗ map] k↦x ∈ m, Φ k x) ⊣⊢ ([∗ map] k↦x ∈ m, ▷ Φ k x).
Proof. apply (big_opM_commute _). Qed.
Lemma big_sepM_later_2 Φ m :
([∗ map] k↦x ∈ m, ▷ Φ k x) ⊢ ▷ [∗ map] k↦x ∈ m, Φ k x.
Proof. by rewrite big_opM_commute. Qed.
- Lemma big_sepM_laterN `{BiAffine PROP} Φ n m :
+ Lemma big_sepM_laterN `{FiniteIndex SI} `{BiAffine SI PROP} Φ n m :
▷^n ([∗ map] k↦x ∈ m, Φ k x) ⊣⊢ ([∗ map] k↦x ∈ m, ▷^n Φ k x).
Proof. apply (big_opM_commute _). Qed.
Lemma big_sepM_laterN_2 Φ n m :
@@ -1565,21 +1568,22 @@ Section gmap.
Global Instance big_sepM_empty_timeless `{!Timeless (emp%I : PROP)} Φ :
Timeless ([∗ map] k↦x ∈ ∅, Φ k x).
Proof. rewrite /big_opM map_to_list_empty. apply _. Qed.
- Global Instance big_sepM_timeless `{!Timeless (emp%I : PROP)} Φ m :
- (∀ k x, Timeless (Φ k x)) → Timeless ([∗ map] k↦x ∈ m, Φ k x).
- Proof. intros. apply big_sepL_timeless=> _ [??]; apply _. Qed.
+ (* TODO : depends *)
+ (*Global Instance big_sepM_timeless `{!Timeless (emp%I : PROP)} Φ m :*)
+ (*(∀ k x, Timeless (Φ k x)) → Timeless ([∗ map] k↦x ∈ m, Φ k x).*)
+ (*Proof. intros. apply big_sepL_timeless=> _ [??]; apply _. Qed.*)
Section plainly.
Context `{!BiPlainly PROP}.
- Lemma big_sepM_plainly `{BiAffine PROP} Φ m :
+ Lemma big_sepM_plainly `{BiAffine SI PROP} Φ m :
■([∗ map] k↦x ∈ m, Φ k x) ⊣⊢ [∗ map] k↦x ∈ m, ■(Φ k x).
Proof. apply (big_opM_commute _). Qed.
- Global Instance big_sepM_empty_plain `{BiAffine PROP} Φ :
+ Global Instance big_sepM_empty_plain `{BiAffine SI PROP} Φ :
Plain ([∗ map] k↦x ∈ ∅, Φ k x).
Proof. rewrite /big_opM map_to_list_empty. apply _. Qed.
- Global Instance big_sepM_plain `{BiAffine PROP} Φ m :
+ Global Instance big_sepM_plain `{BiAffine SI PROP} Φ m :
(∀ k x, Plain (Φ k x)) → Plain ([∗ map] k↦x ∈ m, Φ k x).
Proof. intros. apply (big_sepL_plain _ _)=> _ [??]; apply _. Qed.
End plainly.
@@ -1589,14 +1593,15 @@ Section gmap2.
Context `{Countable K} {A B : Type}.
Implicit Types Φ Ψ : K → A → B → PROP.
- Lemma big_sepM2_later_1 `{BiAffine PROP} Φ m1 m2 :
- (▷ [∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2)
- ⊢ ◇ ([∗ map] k↦x1;x2 ∈ m1;m2, ▷ Φ k x1 x2).
- Proof.
- rewrite /big_sepM2 later_and (timeless ⌜_âŒ%I).
- rewrite big_sepM_later except_0_and.
- auto using and_mono_r, except_0_intro.
- Qed.
+ (* TODO : depends *)
+ (*Lemma big_sepM2_later_1 `{FiniteIndex SI} `{BiAffine SI PROP} Φ m1 m2 :*)
+ (*(▷ [∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2)*)
+ (*⊢ ◇ ([∗ map] k↦x1;x2 ∈ m1;m2, ▷ Φ k x1 x2).*)
+ (*Proof.*)
+ (*rewrite /big_sepM2 later_and (timeless ⌜_âŒ%I).*)
+ (*rewrite big_sepM_later except_0_and.*)
+ (*auto using and_mono_r, except_0_intro.*)
+ (*Qed.*)
Lemma big_sepM2_later_2 Φ m1 m2 :
([∗ map] k↦x1;x2 ∈ m1;m2, ▷ Φ k x1 x2)
⊢ ▷ [∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2.
@@ -1614,26 +1619,27 @@ Section gmap2.
apply big_sepM2_mono. eauto.
Qed.
- Global Instance big_sepM2_empty_timeless `{!Timeless (emp%I : PROP)} Φ :
- Timeless ([∗ map] k↦x1;x2 ∈ ∅;∅, Φ k x1 x2).
- Proof. rewrite /big_sepM2 map_zip_with_empty. apply _. Qed.
- Global Instance big_sepM2_timeless `{!Timeless (emp%I : PROP)} Φ m1 m2 :
- (∀ k x1 x2, Timeless (Φ k x1 x2)) →
- Timeless ([∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2).
- Proof. intros. rewrite /big_sepM2. apply _. Qed.
+ (* TODO *)
+ (*Global Instance big_sepM2_empty_timeless `{!Timeless (emp%I : PROP)} Φ :*)
+ (*Timeless ([∗ map] k↦x1;x2 ∈ ∅;∅, Φ k x1 x2).*)
+ (*Proof. rewrite /big_sepM2 map_zip_with_empty. apply _. Qed.*)
+ (*Global Instance big_sepM2_timeless `{!Timeless (emp%I : PROP)} Φ m1 m2 :*)
+ (*(∀ k x1 x2, Timeless (Φ k x1 x2)) →*)
+ (*Timeless ([∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2).*)
+ (*Proof. intros. rewrite /big_sepM2. apply _. Qed.*)
Section plainly.
Context `{!BiPlainly PROP}.
- Lemma big_sepM2_plainly `{BiAffine PROP} Φ m1 m2 :
+ Lemma big_sepM2_plainly `{BiAffine SI PROP} Φ m1 m2 :
■([∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2) ⊣⊢
[∗ map] k↦x1;x2 ∈ m1;m2, ■(Φ k x1 x2).
Proof. by rewrite /big_sepM2 plainly_and plainly_pure big_sepM_plainly. Qed.
- Global Instance big_sepM2_empty_plain `{BiAffine PROP} Φ :
+ Global Instance big_sepM2_empty_plain `{BiAffine SI PROP} Φ :
Plain ([∗ map] k↦x1;x2 ∈ ∅;∅, Φ k x1 x2).
Proof. rewrite /big_sepM2 map_zip_with_empty. apply _. Qed.
- Global Instance big_sepM2_plain `{BiAffine PROP} Φ m1 m2 :
+ Global Instance big_sepM2_plain `{BiAffine SI PROP} Φ m1 m2 :
(∀ k x1 x2, Plain (Φ k x1 x2)) →
Plain ([∗ map] k↦x1;x2 ∈ m1;m2, Φ k x1 x2).
Proof. intros. rewrite /big_sepM2. apply _. Qed.
@@ -1646,14 +1652,14 @@ Section gset.
Implicit Types X : gset A.
Implicit Types Φ : A → PROP.
- Lemma big_sepS_later `{BiAffine PROP} Φ X :
+ Lemma big_sepS_later `{FiniteIndex SI} `{BiAffine SI PROP} Φ X :
▷ ([∗ set] y ∈ X, Φ y) ⊣⊢ ([∗ set] y ∈ X, ▷ Φ y).
Proof. apply (big_opS_commute _). Qed.
Lemma big_sepS_later_2 Φ X :
([∗ set] y ∈ X, ▷ Φ y) ⊢ ▷ ([∗ set] y ∈ X, Φ y).
Proof. by rewrite big_opS_commute. Qed.
- Lemma big_sepS_laterN `{BiAffine PROP} Φ n X :
+ Lemma big_sepS_laterN `{FiniteIndex SI} `{BiAffine SI PROP} Φ n X :
▷^n ([∗ set] y ∈ X, Φ y) ⊣⊢ ([∗ set] y ∈ X, ▷^n Φ y).
Proof. apply (big_opS_commute _). Qed.
Lemma big_sepS_laterN_2 Φ n X :
@@ -1663,20 +1669,21 @@ Section gset.
Global Instance big_sepS_empty_timeless `{!Timeless (emp%I : PROP)} Φ :
Timeless ([∗ set] x ∈ ∅, Φ x).
Proof. rewrite /big_opS elements_empty. apply _. Qed.
- Global Instance big_sepS_timeless `{!Timeless (emp%I : PROP)} Φ X :
- (∀ x, Timeless (Φ x)) → Timeless ([∗ set] x ∈ X, Φ x).
- Proof. rewrite /big_opS. apply _. Qed.
+ (* TODO *)
+ (*Global Instance big_sepS_timeless `{!Timeless (emp%I : PROP)} Φ X :*)
+ (*(∀ x, Timeless (Φ x)) → Timeless ([∗ set] x ∈ X, Φ x).*)
+ (*Proof. rewrite /big_opS. apply _. Qed.*)
Section plainly.
Context `{!BiPlainly PROP}.
- Lemma big_sepS_plainly `{BiAffine PROP} Φ X :
+ Lemma big_sepS_plainly `{BiAffine SI PROP} Φ X :
■([∗ set] y ∈ X, Φ y) ⊣⊢ [∗ set] y ∈ X, ■(Φ y).
Proof. apply (big_opS_commute _). Qed.
- Global Instance big_sepS_empty_plain `{BiAffine PROP} Φ : Plain ([∗ set] x ∈ ∅, Φ x).
+ Global Instance big_sepS_empty_plain `{BiAffine SI PROP} Φ : Plain ([∗ set] x ∈ ∅, Φ x).
Proof. rewrite /big_opS elements_empty. apply _. Qed.
- Global Instance big_sepS_plain `{BiAffine PROP} Φ X :
+ Global Instance big_sepS_plain `{BiAffine SI PROP} Φ X :
(∀ x, Plain (Φ x)) → Plain ([∗ set] x ∈ X, Φ x).
Proof. rewrite /big_opS. apply _. Qed.
End plainly.
@@ -1688,14 +1695,14 @@ Section gmultiset.
Implicit Types X : gmultiset A.
Implicit Types Φ : A → PROP.
- Lemma big_sepMS_later `{BiAffine PROP} Φ X :
+ Lemma big_sepMS_later `{FiniteIndex SI} `{BiAffine SI PROP} Φ X :
▷ ([∗ mset] y ∈ X, Φ y) ⊣⊢ ([∗ mset] y ∈ X, ▷ Φ y).
Proof. apply (big_opMS_commute _). Qed.
Lemma big_sepMS_later_2 Φ X :
([∗ mset] y ∈ X, ▷ Φ y) ⊢ ▷ [∗ mset] y ∈ X, Φ y.
Proof. by rewrite big_opMS_commute. Qed.
- Lemma big_sepMS_laterN `{BiAffine PROP} Φ n X :
+ Lemma big_sepMS_laterN `{FiniteIndex SI} `{BiAffine SI PROP} Φ n X :
▷^n ([∗ mset] y ∈ X, Φ y) ⊣⊢ ([∗ mset] y ∈ X, ▷^n Φ y).
Proof. apply (big_opMS_commute _). Qed.
Lemma big_sepMS_laterN_2 Φ n X :
@@ -1705,20 +1712,21 @@ Section gmultiset.
Global Instance big_sepMS_empty_timeless `{!Timeless (emp%I : PROP)} Φ :
Timeless ([∗ mset] x ∈ ∅, Φ x).
Proof. rewrite /big_opMS gmultiset_elements_empty. apply _. Qed.
- Global Instance big_sepMS_timeless `{!Timeless (emp%I : PROP)} Φ X :
- (∀ x, Timeless (Φ x)) → Timeless ([∗ mset] x ∈ X, Φ x).
- Proof. rewrite /big_opMS. apply _. Qed.
+ (* TODO *)
+ (*Global Instance big_sepMS_timeless `{!Timeless (emp%I : PROP)} Φ X :*)
+ (*(∀ x, Timeless (Φ x)) → Timeless ([∗ mset] x ∈ X, Φ x).*)
+ (*Proof. rewrite /big_opMS. apply _. Qed.*)
Section plainly.
Context `{!BiPlainly PROP}.
- Lemma big_sepMS_plainly `{BiAffine PROP} Φ X :
+ Lemma big_sepMS_plainly `{BiAffine SI PROP} Φ X :
■([∗ mset] y ∈ X, Φ y) ⊣⊢ [∗ mset] y ∈ X, ■(Φ y).
Proof. apply (big_opMS_commute _). Qed.
- Global Instance big_sepMS_empty_plain `{BiAffine PROP} Φ : Plain ([∗ mset] x ∈ ∅, Φ x).
+ Global Instance big_sepMS_empty_plain `{BiAffine SI PROP} Φ : Plain ([∗ mset] x ∈ ∅, Φ x).
Proof. rewrite /big_opMS gmultiset_elements_empty. apply _. Qed.
- Global Instance big_sepMS_plain `{BiAffine PROP} Φ X :
+ Global Instance big_sepMS_plain `{BiAffine SI PROP} Φ X :
(∀ x, Plain (Φ x)) → Plain ([∗ mset] x ∈ X, Φ x).
Proof. rewrite /big_opMS. apply _. Qed.
End plainly.
diff --git a/theories/bi/derived_connectives.v b/theories/bi/derived_connectives.v
index 8576c152523bf359bddbc7bd52c32e13fade7ae6..0fece1be1b0262808e6f065a32ea45fb1656fdab 100644
--- a/theories/bi/derived_connectives.v
+++ b/theories/bi/derived_connectives.v
@@ -1,118 +1,108 @@
From iris.bi Require Export interface.
From iris.algebra Require Import monoid.
-Definition bi_iff {PROP : bi} (P Q : PROP) : PROP := ((P → Q) ∧ (Q → P))%I.
-Arguments bi_iff {_} _%I _%I : simpl never.
-Instance: Params (@bi_iff) 1 := {}.
+Definition bi_iff `{PROP : bi SI} (P Q : PROP) : PROP := ((P → Q) ∧ (Q → P))%I.
+Arguments bi_iff {_ _} _%I _%I : simpl never.
+Instance: Params (@bi_iff) 2 := {}.
Infix "↔" := bi_iff : bi_scope.
-Definition bi_wand_iff {PROP : bi} (P Q : PROP) : PROP :=
+Definition bi_wand_iff `{PROP : bi SI} (P Q : PROP) : PROP :=
((P -∗ Q) ∧ (Q -∗ P))%I.
-Arguments bi_wand_iff {_} _%I _%I : simpl never.
-Instance: Params (@bi_wand_iff) 1 := {}.
+Arguments bi_wand_iff {_ _} _%I _%I : simpl never.
+Instance: Params (@bi_wand_iff) 2 := {}.
Infix "∗-∗" := bi_wand_iff : bi_scope.
-Class Persistent {PROP : bi} (P : PROP) := persistent : P ⊢ <pers> P.
-Arguments Persistent {_} _%I : simpl never.
-Arguments persistent {_} _%I {_}.
-Hint Mode Persistent + ! : typeclass_instances.
-Instance: Params (@Persistent) 1 := {}.
+Class Persistent `{PROP : bi SI} (P : PROP) := persistent : P ⊢ <pers> P.
+Arguments Persistent {_ _} _%I : simpl never.
+Arguments persistent {_ _} _%I {_}.
+Hint Mode Persistent - + ! : typeclass_instances.
+Instance: Params (@Persistent) 2 := {}.
-Definition bi_affinely {PROP : bi} (P : PROP) : PROP := (emp ∧ P)%I.
-Arguments bi_affinely {_} _%I : simpl never.
-Instance: Params (@bi_affinely) 1 := {}.
+Definition bi_affinely `{PROP : bi SI} (P : PROP) : PROP := (emp ∧ P)%I.
+Arguments bi_affinely {_ _} _%I : simpl never.
+Instance: Params (@bi_affinely) 2 := {}.
Typeclasses Opaque bi_affinely.
Notation "'<affine>' P" := (bi_affinely P) : bi_scope.
-Class Affine {PROP : bi} (Q : PROP) := affine : Q ⊢ emp.
-Arguments Affine {_} _%I : simpl never.
-Arguments affine {_} _%I {_}.
-Hint Mode Affine + ! : typeclass_instances.
+Class Affine `{PROP : bi SI} (Q : PROP) := affine : Q ⊢ emp.
+Arguments Affine {_ _} _%I : simpl never.
+Arguments affine {_ _} _%I {_}.
+Hint Mode Affine - + ! : typeclass_instances.
-Class BiAffine (PROP : bi) := absorbing_bi (Q : PROP) : Affine Q.
-Hint Mode BiAffine ! : typeclass_instances.
+Class BiAffine `(PROP : bi SI) := absorbing_bi (Q : PROP) : Affine Q.
+Hint Mode BiAffine - ! : typeclass_instances.
Existing Instance absorbing_bi | 0.
-Class BiPositive (PROP : bi) :=
+Class BiPositive `(PROP : bi SI) :=
bi_positive (P Q : PROP) : <affine> (P ∗ Q) ⊢ <affine> P ∗ Q.
-Hint Mode BiPositive ! : typeclass_instances.
+Hint Mode BiPositive - ! : typeclass_instances.
-Definition bi_absorbingly {PROP : bi} (P : PROP) : PROP := (True ∗ P)%I.
-Arguments bi_absorbingly {_} _%I : simpl never.
-Instance: Params (@bi_absorbingly) 1 := {}.
+Definition bi_absorbingly `{PROP : bi SI} (P : PROP) : PROP := (True ∗ P)%I.
+Arguments bi_absorbingly {_ _} _%I : simpl never.
+Instance: Params (@bi_absorbingly) 2 := {}.
Typeclasses Opaque bi_absorbingly.
Notation "'<absorb>' P" := (bi_absorbingly P) : bi_scope.
-Class Absorbing {PROP : bi} (P : PROP) := absorbing : <absorb> P ⊢ P.
-Arguments Absorbing {_} _%I : simpl never.
-Arguments absorbing {_} _%I.
-Hint Mode Absorbing + ! : typeclass_instances.
+Class Absorbing `{PROP : bi SI} (P : PROP) := absorbing : <absorb> P ⊢ P.
+Arguments Absorbing {_ _} _%I : simpl never.
+Arguments absorbing {_ _} _%I.
+Hint Mode Absorbing - + ! : typeclass_instances.
-Definition bi_persistently_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
+Definition bi_persistently_if `{PROP : bi SI} (p : bool) (P : PROP) : PROP :=
(if p then <pers> P else P)%I.
-Arguments bi_persistently_if {_} !_ _%I /.
-Instance: Params (@bi_persistently_if) 2 := {}.
+Arguments bi_persistently_if {_ _} !_ _%I /.
+Instance: Params (@bi_persistently_if) 3 := {}.
Typeclasses Opaque bi_persistently_if.
Notation "'<pers>?' p P" := (bi_persistently_if p P) : bi_scope.
-Definition bi_affinely_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
+Definition bi_affinely_if `{PROP : bi SI} (p : bool) (P : PROP) : PROP :=
(if p then <affine> P else P)%I.
-Arguments bi_affinely_if {_} !_ _%I /.
-Instance: Params (@bi_affinely_if) 2 := {}.
+Arguments bi_affinely_if {_ _} !_ _%I /.
+Instance: Params (@bi_affinely_if) 3 := {}.
Typeclasses Opaque bi_affinely_if.
Notation "'<affine>?' p P" := (bi_affinely_if p P) : bi_scope.
-Definition bi_absorbingly_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
+Definition bi_absorbingly_if `{PROP : bi SI} (p : bool) (P : PROP) : PROP :=
(if p then <absorb> P else P)%I.
-Arguments bi_absorbingly_if {_} !_ _%I /.
-Instance: Params (@bi_absorbingly_if) 2 := {}.
+Arguments bi_absorbingly_if {_ _} !_ _%I /.
+Instance: Params (@bi_absorbingly_if) 3 := {}.
Typeclasses Opaque bi_absorbingly_if.
Notation "'<absorb>?' p P" := (bi_absorbingly_if p P) : bi_scope.
-Definition bi_intuitionistically {PROP : bi} (P : PROP) : PROP :=
+Definition bi_intuitionistically `{PROP : bi SI} (P : PROP) : PROP :=
(<affine> <pers> P)%I.
-Arguments bi_intuitionistically {_} _%I : simpl never.
-Instance: Params (@bi_intuitionistically) 1 := {}.
+Arguments bi_intuitionistically {_ _} _%I : simpl never.
+Instance: Params (@bi_intuitionistically) 2 := {}.
Typeclasses Opaque bi_intuitionistically.
Notation "â–¡ P" := (bi_intuitionistically P) : bi_scope.
-Definition bi_intuitionistically_if {PROP : bi} (p : bool) (P : PROP) : PROP :=
+Definition bi_intuitionistically_if `{PROP : bi SI} (p : bool) (P : PROP) : PROP :=
(if p then â–¡ P else P)%I.
-Arguments bi_intuitionistically_if {_} !_ _%I /.
-Instance: Params (@bi_intuitionistically_if) 2 := {}.
+Arguments bi_intuitionistically_if {_ _} !_ _%I /.
+Instance: Params (@bi_intuitionistically_if) 3 := {}.
Typeclasses Opaque bi_intuitionistically_if.
Notation "'â–¡?' p P" := (bi_intuitionistically_if p P) : bi_scope.
-Fixpoint sbi_laterN {PROP : sbi} (n : nat) (P : PROP) : PROP :=
- match n with
- | O => P
- | S n' => â–· sbi_laterN n' P
- end%I.
-Arguments sbi_laterN {_} !_%nat_scope _%I.
-Instance: Params (@sbi_laterN) 2 := {}.
-Notation "â–·^ n P" := (sbi_laterN n P) : bi_scope.
-Notation "â–·? p P" := (sbi_laterN (Nat.b2n p) P) : bi_scope.
-
-Definition sbi_except_0 {PROP : sbi} (P : PROP) : PROP := (▷ False ∨ P)%I.
-Arguments sbi_except_0 {_} _%I : simpl never.
+Definition sbi_except_0 `{PROP : sbi SI} (P : PROP) : PROP := (▷ False ∨ P)%I.
+Arguments sbi_except_0 {_ _} _%I : simpl never.
Notation "â—‡ P" := (sbi_except_0 P) : bi_scope.
-Instance: Params (@sbi_except_0) 1 := {}.
+Instance: Params (@sbi_except_0) 2 := {}.
Typeclasses Opaque sbi_except_0.
-Class Timeless {PROP : sbi} (P : PROP) := timeless : ▷ P ⊢ ◇ P.
-Arguments Timeless {_} _%I : simpl never.
-Arguments timeless {_} _%I {_}.
-Hint Mode Timeless + ! : typeclass_instances.
-Instance: Params (@Timeless) 1 := {}.
+Class Timeless `{PROP : sbi SI} (P : PROP) := timeless : ▷ P ⊢ ◇ P.
+Arguments Timeless {_ _} _%I : simpl never.
+Arguments timeless {_ _} _%I {_}.
+Hint Mode Timeless - + ! : typeclass_instances.
+Instance: Params (@Timeless) 2 := {}.
(** An optional precondition [mP] to [Q].
TODO: We may actually consider generalizing this to a list of preconditions,
and e.g. also using it for texan triples. *)
-Definition bi_wandM {PROP : bi} (mP : option PROP) (Q : PROP) : PROP :=
+Definition bi_wandM `{PROP : bi SI} (mP : option PROP) (Q : PROP) : PROP :=
match mP with
| None => Q
| Some P => (P -∗ Q)%I
end.
-Arguments bi_wandM {_} !_%I _%I /.
+Arguments bi_wandM {_ _} !_%I _%I /.
Notation "mP -∗? Q" := (bi_wandM mP Q)
(at level 99, Q at level 200, right associativity) : bi_scope.
diff --git a/theories/bi/derived_laws_bi.v b/theories/bi/derived_laws_bi.v
index 21577804761d304c86cba1139015039703e8c94d..452260dc8983f785f5cfe1bee570d175c1e30e86 100644
--- a/theories/bi/derived_laws_bi.v
+++ b/theories/bi/derived_laws_bi.v
@@ -11,7 +11,7 @@ From iris.algebra Require Import monoid.
Module bi.
Import interface.bi.
Section bi_derived.
-Context {PROP : bi}.
+Context {SI: indexT} {PROP : bi SI}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types Ps : list PROP.
@@ -24,7 +24,7 @@ Notation "P ⊢ Q" := (P ⊢@{PROP} Q).
Notation "P ⊣⊢ Q" := (P ⊣⊢@{PROP} Q).
(* Derived stuff about the entailment *)
-Global Instance entails_anti_sym : AntiSymm (⊣⊢) (@bi_entails PROP).
+Global Instance entails_anti_sym : AntiSymm (⊣⊢) (@bi_entails SI PROP).
Proof. intros P Q ??. by apply equiv_spec. Qed.
Lemma equiv_entails P Q : (P ⊣⊢ Q) → (P ⊢ Q).
Proof. apply equiv_spec. Qed.
@@ -41,41 +41,41 @@ Lemma entails_equiv_l P Q R : (P ⊣⊢ Q) → (Q ⊢ R) → (P ⊢ R).
Proof. by intros ->. Qed.
Lemma entails_equiv_r P Q R : (P ⊢ Q) → (Q ⊣⊢ R) → (P ⊢ R).
Proof. by intros ? <-. Qed.
-Global Instance bi_emp_valid_proper : Proper ((⊣⊢) ==> iff) (@bi_emp_valid PROP).
+Global Instance bi_emp_valid_proper : Proper ((⊣⊢) ==> iff) (@bi_emp_valid SI PROP).
Proof. solve_proper. Qed.
-Global Instance bi_emp_valid_mono : Proper ((⊢) ==> impl) (@bi_emp_valid PROP).
+Global Instance bi_emp_valid_mono : Proper ((⊢) ==> impl) (@bi_emp_valid SI PROP).
Proof. solve_proper. Qed.
Global Instance bi_emp_valid_flip_mono :
- Proper (flip (⊢) ==> flip impl) (@bi_emp_valid PROP).
+ Proper (flip (⊢) ==> flip impl) (@bi_emp_valid SI PROP).
Proof. solve_proper. Qed.
(* Propers *)
-Global Instance pure_proper : Proper (iff ==> (⊣⊢)) (@bi_pure PROP) | 0.
+Global Instance pure_proper : Proper (iff ==> (⊣⊢)) (@bi_pure SI PROP) | 0.
Proof. intros φ1 φ2 Hφ. apply equiv_dist=> n. by apply pure_ne. Qed.
Global Instance and_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_and PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_and SI PROP) := ne_proper_2 _.
Global Instance or_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_or PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_or SI PROP) := ne_proper_2 _.
Global Instance impl_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_impl PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_impl SI PROP) := ne_proper_2 _.
Global Instance sep_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_sep PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_sep SI PROP) := ne_proper_2 _.
Global Instance wand_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_wand PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_wand SI PROP) := ne_proper_2 _.
Global Instance forall_proper A :
- Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_forall PROP A).
+ Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_forall SI PROP A).
Proof.
intros Φ1 Φ2 HΦ. apply equiv_dist=> n.
apply forall_ne=> x. apply equiv_dist, HΦ.
Qed.
Global Instance exist_proper A :
- Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_exist PROP A).
+ Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_exist SI PROP A).
Proof.
intros Φ1 Φ2 HΦ. apply equiv_dist=> n.
apply exist_ne=> x. apply equiv_dist, HΦ.
Qed.
Global Instance persistently_proper :
- Proper ((⊣⊢) ==> (⊣⊢)) (@bi_persistently PROP) := ne_proper _.
+ Proper ((⊣⊢) ==> (⊣⊢)) (@bi_persistently SI PROP) := ne_proper _.
(* Derived logical stuff *)
Lemma and_elim_l' P Q R : (P ⊢ R) → P ∧ Q ⊢ R.
@@ -96,7 +96,7 @@ Hint Resolve or_elim or_intro_l' or_intro_r' : core.
Hint Resolve and_intro and_elim_l' and_elim_r' : core.
Lemma impl_intro_l P Q R : (Q ∧ P ⊢ R) → P ⊢ Q → R.
-Proof. intros HR; apply impl_intro_r; rewrite -HR; auto. Qed.
+Proof. intros HR; apply impl_intro_r; rewrite -HR. auto. Qed.
Lemma impl_elim P Q R : (P ⊢ Q → R) → (P ⊢ Q) → P ⊢ R.
Proof. intros. rewrite -(impl_elim_l' P Q R); auto. Qed.
Lemma impl_elim_r' P Q R : (Q ⊢ P → R) → P ∧ Q ⊢ R.
@@ -152,64 +152,64 @@ Lemma exist_mono {A} (Φ Ψ : A → PROP) :
(∀ a, Φ a ⊢ Ψ a) → (∃ a, Φ a) ⊢ ∃ a, Ψ a.
Proof. intros HΦ. apply exist_elim=> a; rewrite (HΦ a); apply exist_intro. Qed.
-Global Instance and_mono' : Proper ((⊢) ==> (⊢) ==> (⊢)) (@bi_and PROP).
+Global Instance and_mono' : Proper ((⊢) ==> (⊢) ==> (⊢)) (@bi_and SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply and_mono. Qed.
Global Instance and_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_and PROP).
+ Proper (flip (⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_and SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply and_mono. Qed.
-Global Instance or_mono' : Proper ((⊢) ==> (⊢) ==> (⊢)) (@bi_or PROP).
+Global Instance or_mono' : Proper ((⊢) ==> (⊢) ==> (⊢)) (@bi_or SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply or_mono. Qed.
Global Instance or_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_or PROP).
+ Proper (flip (⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_or SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply or_mono. Qed.
Global Instance impl_mono' :
- Proper (flip (⊢) ==> (⊢) ==> (⊢)) (@bi_impl PROP).
+ Proper (flip (⊢) ==> (⊢) ==> (⊢)) (@bi_impl SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply impl_mono. Qed.
Global Instance impl_flip_mono' :
- Proper ((⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_impl PROP).
+ Proper ((⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_impl SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply impl_mono. Qed.
Global Instance forall_mono' A :
- Proper (pointwise_relation _ (⊢) ==> (⊢)) (@bi_forall PROP A).
+ Proper (pointwise_relation _ (⊢) ==> (⊢)) (@bi_forall SI PROP A).
Proof. intros P1 P2; apply forall_mono. Qed.
Global Instance forall_flip_mono' A :
- Proper (pointwise_relation _ (flip (⊢)) ==> flip (⊢)) (@bi_forall PROP A).
+ Proper (pointwise_relation _ (flip (⊢)) ==> flip (⊢)) (@bi_forall SI PROP A).
Proof. intros P1 P2; apply forall_mono. Qed.
Global Instance exist_mono' A :
- Proper (pointwise_relation _ ((⊢)) ==> (⊢)) (@bi_exist PROP A).
+ Proper (pointwise_relation _ ((⊢)) ==> (⊢)) (@bi_exist SI PROP A).
Proof. intros P1 P2; apply exist_mono. Qed.
Global Instance exist_flip_mono' A :
- Proper (pointwise_relation _ (flip (⊢)) ==> flip (⊢)) (@bi_exist PROP A).
+ Proper (pointwise_relation _ (flip (⊢)) ==> flip (⊢)) (@bi_exist SI PROP A).
Proof. intros P1 P2; apply exist_mono. Qed.
-Global Instance and_idem : IdemP (⊣⊢) (@bi_and PROP).
+Global Instance and_idem : IdemP (⊣⊢) (@bi_and SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance or_idem : IdemP (⊣⊢) (@bi_or PROP).
+Global Instance or_idem : IdemP (⊣⊢) (@bi_or SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance and_comm : Comm (⊣⊢) (@bi_and PROP).
+Global Instance and_comm : Comm (⊣⊢) (@bi_and SI PROP).
Proof. intros P Q; apply (anti_symm (⊢)); auto. Qed.
-Global Instance True_and : LeftId (⊣⊢) True%I (@bi_and PROP).
+Global Instance True_and : LeftId (⊣⊢) True%I (@bi_and SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance and_True : RightId (⊣⊢) True%I (@bi_and PROP).
+Global Instance and_True : RightId (⊣⊢) True%I (@bi_and SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance False_and : LeftAbsorb (⊣⊢) False%I (@bi_and PROP).
+Global Instance False_and : LeftAbsorb (⊣⊢) False%I (@bi_and SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance and_False : RightAbsorb (⊣⊢) False%I (@bi_and PROP).
+Global Instance and_False : RightAbsorb (⊣⊢) False%I (@bi_and SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance True_or : LeftAbsorb (⊣⊢) True%I (@bi_or PROP).
+Global Instance True_or : LeftAbsorb (⊣⊢) True%I (@bi_or SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance or_True : RightAbsorb (⊣⊢) True%I (@bi_or PROP).
+Global Instance or_True : RightAbsorb (⊣⊢) True%I (@bi_or SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance False_or : LeftId (⊣⊢) False%I (@bi_or PROP).
+Global Instance False_or : LeftId (⊣⊢) False%I (@bi_or SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance or_False : RightId (⊣⊢) False%I (@bi_or PROP).
+Global Instance or_False : RightId (⊣⊢) False%I (@bi_or SI PROP).
Proof. intros P; apply (anti_symm (⊢)); auto. Qed.
-Global Instance and_assoc : Assoc (⊣⊢) (@bi_and PROP).
+Global Instance and_assoc : Assoc (⊣⊢) (@bi_and SI PROP).
Proof. intros P Q R; apply (anti_symm (⊢)); auto. Qed.
-Global Instance or_comm : Comm (⊣⊢) (@bi_or PROP).
+Global Instance or_comm : Comm (⊣⊢) (@bi_or SI PROP).
Proof. intros P Q; apply (anti_symm (⊢)); auto. Qed.
-Global Instance or_assoc : Assoc (⊣⊢) (@bi_or PROP).
+Global Instance or_assoc : Assoc (⊣⊢) (@bi_or SI PROP).
Proof. intros P Q R; apply (anti_symm (⊢)); auto. Qed.
-Global Instance True_impl : LeftId (⊣⊢) True%I (@bi_impl PROP).
+Global Instance True_impl : LeftId (⊣⊢) True%I (@bi_impl SI PROP).
Proof.
intros P; apply (anti_symm (⊢)).
- by rewrite -(left_id True%I (∧)%I (_ → _)%I) impl_elim_r.
@@ -300,10 +300,10 @@ Qed.
Lemma entails_equiv_and P Q : (P ⊣⊢ Q ∧ P) ↔ (P ⊢ Q).
Proof. split. by intros ->; auto. intros; apply (anti_symm _); auto. Qed.
-Global Instance iff_ne : NonExpansive2 (@bi_iff PROP).
+Global Instance iff_ne : NonExpansive2 (@bi_iff SI PROP).
Proof. unfold bi_iff; solve_proper. Qed.
Global Instance iff_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_iff PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_iff SI PROP) := ne_proper_2 _.
Lemma iff_refl Q P : Q ⊢ P ↔ P.
Proof. rewrite /bi_iff; apply and_intro; apply impl_intro_l; auto. Qed.
@@ -315,36 +315,36 @@ Lemma sep_mono_l P P' Q : (P ⊢ Q) → P ∗ P' ⊢ Q ∗ P'.
Proof. by intros; apply sep_mono. Qed.
Lemma sep_mono_r P P' Q' : (P' ⊢ Q') → P ∗ P' ⊢ P ∗ Q'.
Proof. by apply sep_mono. Qed.
-Global Instance sep_mono' : Proper ((⊢) ==> (⊢) ==> (⊢)) (@bi_sep PROP).
+Global Instance sep_mono' : Proper ((⊢) ==> (⊢) ==> (⊢)) (@bi_sep SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply sep_mono. Qed.
Global Instance sep_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_sep PROP).
+ Proper (flip (⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_sep SI PROP).
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. by apply wand_elim_l'.
Qed.
-Global Instance wand_mono' : Proper (flip (⊢) ==> (⊢) ==> (⊢)) (@bi_wand PROP).
+Global Instance wand_mono' : Proper (flip (⊢) ==> (⊢) ==> (⊢)) (@bi_wand SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply wand_mono. Qed.
Global Instance wand_flip_mono' :
- Proper ((⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_wand PROP).
+ Proper ((⊢) ==> flip (⊢) ==> flip (⊢)) (@bi_wand SI PROP).
Proof. by intros P P' HP Q Q' HQ; apply wand_mono. Qed.
-Global Instance sep_comm : Comm (⊣⊢) (@bi_sep PROP).
+Global Instance sep_comm : Comm (⊣⊢) (@bi_sep SI PROP).
Proof. intros P Q; apply (anti_symm _); auto using sep_comm'. Qed.
-Global Instance sep_assoc : Assoc (⊣⊢) (@bi_sep PROP).
+Global Instance sep_assoc : Assoc (⊣⊢) (@bi_sep SI PROP).
Proof.
intros P Q R; apply (anti_symm _); auto using sep_assoc'.
by rewrite !(comm _ P) !(comm _ _ R) sep_assoc'.
Qed.
-Global Instance emp_sep : LeftId (⊣⊢) emp%I (@bi_sep PROP).
+Global Instance emp_sep : LeftId (⊣⊢) emp%I (@bi_sep SI PROP).
Proof. intros P; apply (anti_symm _); auto using emp_sep_1, emp_sep_2. Qed.
-Global Instance sep_emp : RightId (⊣⊢) emp%I (@bi_sep PROP).
+Global Instance sep_emp : RightId (⊣⊢) emp%I (@bi_sep SI PROP).
Proof. by intros P; rewrite comm left_id. Qed.
-Global Instance sep_False : LeftAbsorb (⊣⊢) False%I (@bi_sep PROP).
+Global Instance sep_False : LeftAbsorb (⊣⊢) False%I (@bi_sep SI PROP).
Proof. intros P; apply (anti_symm _); auto using wand_elim_l'. Qed.
-Global Instance False_sep : RightAbsorb (⊣⊢) False%I (@bi_sep PROP).
+Global Instance False_sep : RightAbsorb (⊣⊢) False%I (@bi_sep SI PROP).
Proof. intros P. by rewrite comm left_absorb. Qed.
Lemma True_sep_2 P : P ⊢ True ∗ P.
@@ -352,13 +352,13 @@ Proof. rewrite -{1}[P](left_id emp%I bi_sep). auto using sep_mono. Qed.
Lemma sep_True_2 P : P ⊢ P ∗ True.
Proof. by rewrite comm -True_sep_2. Qed.
-Lemma sep_intro_emp_valid_l P Q R : P → (R ⊢ Q) → R ⊢ P ∗ Q.
+Lemma sep_intro_emp_valid_l P Q R : (emp ⊢ P) → (R ⊢ Q) → R ⊢ P ∗ Q.
Proof. intros ? ->. rewrite -{1}(left_id emp%I _ Q). by apply sep_mono. Qed.
-Lemma sep_intro_emp_valid_r P Q R : (R ⊢ P) → Q → R ⊢ P ∗ Q.
+Lemma sep_intro_emp_valid_r P Q R : (R ⊢ P) → (emp ⊢ Q) → R ⊢ P ∗ Q.
Proof. intros -> ?. rewrite comm. by apply sep_intro_emp_valid_l. Qed.
-Lemma sep_elim_emp_valid_l P Q R : P → (P ∗ R ⊢ Q) → R ⊢ Q.
+Lemma sep_elim_emp_valid_l P Q R : (emp ⊢ P) → (P ∗ R ⊢ Q) → R ⊢ Q.
Proof. intros <- <-. by rewrite left_id. Qed.
-Lemma sep_elim_emp_valid_r P Q R : P → (R ∗ P ⊢ Q) → R ⊢ Q.
+Lemma sep_elim_emp_valid_r P Q R : (emp ⊢ P) → (R ∗ P ⊢ Q) → R ⊢ Q.
Proof. intros <- <-. by rewrite right_id. Qed.
Lemma wand_intro_l P Q R : (Q ∗ P ⊢ R) → P ⊢ Q -∗ R.
@@ -379,7 +379,7 @@ Proof.
apply sep_mono_r, wand_elim_r.
Qed.
-Global Instance emp_wand : LeftId (⊣⊢) emp%I (@bi_wand PROP).
+Global Instance emp_wand : LeftId (⊣⊢) emp%I (@bi_wand SI PROP).
Proof.
intros P. apply (anti_symm _).
- by rewrite -[(emp -∗ P)%I]left_id wand_elim_r.
@@ -427,38 +427,38 @@ Proof. by apply forall_intro=> a; rewrite forall_elim. Qed.
Lemma sep_forall_r {A} (Φ : A → PROP) Q : (∀ a, Φ a) ∗ Q ⊢ ∀ a, Φ a ∗ Q.
Proof. by apply forall_intro=> a; rewrite forall_elim. Qed.
-Global Instance wand_iff_ne : NonExpansive2 (@bi_wand_iff PROP).
+Global Instance wand_iff_ne : NonExpansive2 (@bi_wand_iff SI PROP).
Proof. solve_proper. Qed.
Global Instance wand_iff_proper :
- Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_wand_iff PROP) := ne_proper_2 _.
+ Proper ((⊣⊢) ==> (⊣⊢) ==> (⊣⊢)) (@bi_wand_iff SI PROP) := ne_proper_2 _.
Lemma wand_iff_refl P : emp ⊢ P ∗-∗ P.
Proof. apply and_intro; apply wand_intro_l; by rewrite right_id. Qed.
-Lemma wand_entails P Q : (P -∗ Q)%I → P ⊢ Q.
+Lemma wand_entails P Q : (emp ⊢ (P -∗ Q)%I) → P ⊢ Q.
Proof. intros. rewrite -[P]emp_sep. by apply wand_elim_l'. Qed.
-Lemma entails_wand P Q : (P ⊢ Q) → (P -∗ Q)%I.
+Lemma entails_wand P Q : (P ⊢ Q) → emp ⊢ (P -∗ Q)%I.
Proof. intros ->. apply wand_intro_r. by rewrite left_id. Qed.
(* A version that works with rewrite, in which bi_emp_valid is unfolded. *)
Lemma entails_wand' P Q : (P ⊢ Q) → emp ⊢ (P -∗ Q).
Proof. apply entails_wand. Qed.
-Lemma equiv_wand_iff P Q : (P ⊣⊢ Q) → (P ∗-∗ Q)%I.
+Lemma equiv_wand_iff P Q : (P ⊣⊢ Q) → emp ⊢ (P ∗-∗ Q)%I.
Proof. intros ->; apply wand_iff_refl. Qed.
-Lemma wand_iff_equiv P Q : (P ∗-∗ Q)%I → (P ⊣⊢ Q).
+Lemma wand_iff_equiv P Q : (emp ⊢ (P ∗-∗ Q)%I) → (P ⊣⊢ Q).
Proof.
intros HPQ; apply (anti_symm (⊢));
apply wand_entails; rewrite /bi_emp_valid HPQ /bi_wand_iff; auto.
Qed.
-Lemma entails_impl P Q : (P ⊢ Q) → (P → Q)%I.
+Lemma entails_impl P Q : (P ⊢ Q) → emp ⊢ (P → Q)%I.
Proof. intros ->. apply impl_intro_l. auto. Qed.
-Lemma impl_entails P Q `{!Affine P} : (P → Q)%I → P ⊢ Q.
+Lemma impl_entails P Q `{!Affine P} : (emp ⊢ P → Q) → P ⊢ Q.
Proof. intros HPQ. apply impl_elim with P=>//. by rewrite {1}(affine P). Qed.
-Lemma equiv_iff P Q : (P ⊣⊢ Q) → (P ↔ Q)%I.
+Lemma equiv_iff P Q : (P ⊣⊢ Q) → (emp ⊢ P ↔ Q).
Proof. intros ->; apply iff_refl. Qed.
-Lemma iff_equiv P Q `{!Affine P, !Affine Q} : (P ↔ Q)%I → (P ⊣⊢ Q).
+Lemma iff_equiv P Q `{!Affine P, !Affine Q} : (emp ⊢ P ↔ Q) → (P ⊣⊢ Q).
Proof.
intros HPQ; apply (anti_symm (⊢));
apply: impl_entails; rewrite /bi_emp_valid HPQ /bi_iff; auto.
@@ -485,9 +485,9 @@ Proof.
Qed.
Lemma pure_mono φ1 φ2 : (φ1 → φ2) → ⌜φ1⌠⊢ ⌜φ2âŒ.
Proof. auto using pure_elim', pure_intro. Qed.
-Global Instance pure_mono' : Proper (impl ==> (⊢)) (@bi_pure PROP).
+Global Instance pure_mono' : Proper (impl ==> (⊢)) (@bi_pure SI PROP).
Proof. intros φ1 φ2; apply pure_mono. Qed.
-Global Instance pure_flip_mono : Proper (flip impl ==> flip (⊢)) (@bi_pure PROP).
+Global Instance pure_flip_mono : Proper (flip impl ==> flip (⊢)) (@bi_pure SI PROP).
Proof. intros φ1 φ2; apply pure_mono. Qed.
Lemma pure_iff φ1 φ2 : (φ1 ↔ φ2) → ⌜φ1⌠⊣⊢ ⌜φ2âŒ.
Proof. intros [??]; apply (anti_symm _); auto using pure_mono. Qed.
@@ -554,14 +554,14 @@ Proof.
Qed.
(* Properties of the affinely modality *)
-Global Instance affinely_ne : NonExpansive (@bi_affinely PROP).
+Global Instance affinely_ne : NonExpansive (@bi_affinely SI PROP).
Proof. solve_proper. Qed.
-Global Instance affinely_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_affinely PROP).
+Global Instance affinely_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_affinely SI PROP).
Proof. solve_proper. Qed.
-Global Instance affinely_mono' : Proper ((⊢) ==> (⊢)) (@bi_affinely PROP).
+Global Instance affinely_mono' : Proper ((⊢) ==> (⊢)) (@bi_affinely SI PROP).
Proof. solve_proper. Qed.
Global Instance affinely_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_affinely PROP).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_affinely SI PROP).
Proof. solve_proper. Qed.
Lemma affinely_elim_emp P : <affine> P ⊢ emp.
@@ -593,7 +593,7 @@ Proof.
- by rewrite !and_elim_l right_id.
- by rewrite !and_elim_r.
Qed.
-Lemma affinely_sep `{BiPositive PROP} P Q :
+Lemma affinely_sep `{BiPositive SI PROP} P Q :
<affine> (P ∗ Q) ⊣⊢ <affine> P ∗ <affine> Q.
Proof.
apply (anti_symm _), affinely_sep_2.
@@ -615,14 +615,14 @@ Lemma affinely_and_lr P Q : <affine> P ∧ Q ⊣⊢ P ∧ <affine> Q.
Proof. by rewrite affinely_and_l affinely_and_r. Qed.
(* Properties of the absorbingly modality *)
-Global Instance absorbingly_ne : NonExpansive (@bi_absorbingly PROP).
+Global Instance absorbingly_ne : NonExpansive (@bi_absorbingly SI PROP).
Proof. solve_proper. Qed.
-Global Instance absorbingly_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_absorbingly PROP).
+Global Instance absorbingly_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_absorbingly SI PROP).
Proof. solve_proper. Qed.
-Global Instance absorbingly_mono' : Proper ((⊢) ==> (⊢)) (@bi_absorbingly PROP).
+Global Instance absorbingly_mono' : Proper ((⊢) ==> (⊢)) (@bi_absorbingly SI PROP).
Proof. solve_proper. Qed.
Global Instance absorbingly_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_absorbingly PROP).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_absorbingly SI PROP).
Proof. solve_proper. Qed.
Lemma absorbingly_intro P : P ⊢ <absorb> P.
@@ -670,9 +670,9 @@ Proof.
Qed.
(* Affine and absorbing propositions *)
-Global Instance Affine_proper : Proper ((⊣⊢) ==> iff) (@Affine PROP).
+Global Instance Affine_proper : Proper ((⊣⊢) ==> iff) (@Affine SI PROP).
Proof. solve_proper. Qed.
-Global Instance Absorbing_proper : Proper ((⊣⊢) ==> iff) (@Absorbing PROP).
+Global Instance Absorbing_proper : Proper ((⊣⊢) ==> iff) (@Absorbing SI PROP).
Proof. solve_proper. Qed.
Lemma affine_affinely P `{!Affine P} : <affine> P ⊣⊢ P.
@@ -732,7 +732,7 @@ Proof.
Qed.
Section bi_affine.
- Context `{BiAffine PROP}.
+ Context `{BiAffine SI PROP}.
Global Instance bi_affine_absorbing P : Absorbing P | 0.
Proof. by rewrite /Absorbing /bi_absorbingly (affine True%I) left_id. Qed.
@@ -742,14 +742,14 @@ Section bi_affine.
Lemma True_emp : True ⊣⊢ emp.
Proof. apply (anti_symm _); auto using affine. Qed.
- Global Instance emp_and' : LeftId (⊣⊢) emp%I (@bi_and PROP).
+ Global Instance emp_and' : LeftId (⊣⊢) emp%I (@bi_and SI PROP).
Proof. intros P. by rewrite -True_emp left_id. Qed.
- Global Instance and_emp' : RightId (⊣⊢) emp%I (@bi_and PROP).
+ Global Instance and_emp' : RightId (⊣⊢) emp%I (@bi_and SI PROP).
Proof. intros P. by rewrite -True_emp right_id. Qed.
- Global Instance True_sep' : LeftId (⊣⊢) True%I (@bi_sep PROP).
+ Global Instance True_sep' : LeftId (⊣⊢) True%I (@bi_sep SI PROP).
Proof. intros P. by rewrite True_emp left_id. Qed.
- Global Instance sep_True' : RightId (⊣⊢) True%I (@bi_sep PROP).
+ Global Instance sep_True' : RightId (⊣⊢) True%I (@bi_sep SI PROP).
Proof. intros P. by rewrite True_emp right_id. Qed.
Lemma impl_wand_1 P Q : (P → Q) ⊢ P -∗ Q.
@@ -766,10 +766,10 @@ End bi_affine.
(* Properties of the persistence modality *)
Hint Resolve persistently_mono : core.
-Global Instance persistently_mono' : Proper ((⊢) ==> (⊢)) (@bi_persistently PROP).
+Global Instance persistently_mono' : Proper ((⊢) ==> (⊢)) (@bi_persistently SI PROP).
Proof. intros P Q; apply persistently_mono. Qed.
Global Instance persistently_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_persistently PROP).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_persistently SI PROP).
Proof. intros P Q; apply persistently_mono. Qed.
Lemma absorbingly_elim_persistently P : <absorb> <pers> P ⊣⊢ <pers> P.
@@ -897,7 +897,7 @@ Proof.
Qed.
Lemma persistently_sep_2 P Q : <pers> P ∗ <pers> Q ⊢ <pers> (P ∗ Q).
Proof. by rewrite -persistently_and_sep persistently_and -and_sep_persistently. Qed.
-Lemma persistently_sep `{BiPositive PROP} P Q : <pers> (P ∗ Q) ⊣⊢ <pers> P ∗ <pers> Q.
+Lemma persistently_sep `{BiPositive SI PROP} P Q : <pers> (P ∗ Q) ⊣⊢ <pers> P ∗ <pers> Q.
Proof.
apply (anti_symm _); auto using persistently_sep_2.
rewrite -persistently_affinely_elim affinely_sep -and_sep_persistently. apply and_intro.
@@ -939,7 +939,7 @@ Lemma impl_wand_persistently_2 P Q : (<pers> P -∗ Q) ⊢ (<pers> P → Q).
Proof. apply impl_intro_l. by rewrite persistently_and_sep_l_1 wand_elim_r. Qed.
Section persistently_affine_bi.
- Context `{BiAffine PROP}.
+ Context `{BiAffine SI PROP}.
Lemma persistently_emp : <pers> emp ⊣⊢ emp.
Proof. by rewrite -!True_emp persistently_pure. Qed.
@@ -978,14 +978,14 @@ Section persistently_affine_bi.
End persistently_affine_bi.
(* The intuitionistic modality *)
-Global Instance intuitionistically_ne : NonExpansive (@bi_intuitionistically PROP).
+Global Instance intuitionistically_ne : NonExpansive (@bi_intuitionistically SI PROP).
Proof. solve_proper. Qed.
-Global Instance intuitionistically_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_intuitionistically PROP).
+Global Instance intuitionistically_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_intuitionistically SI PROP).
Proof. solve_proper. Qed.
-Global Instance intuitionistically_mono' : Proper ((⊢) ==> (⊢)) (@bi_intuitionistically PROP).
+Global Instance intuitionistically_mono' : Proper ((⊢) ==> (⊢)) (@bi_intuitionistically SI PROP).
Proof. solve_proper. Qed.
Global Instance intuitionistically_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_intuitionistically PROP).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_intuitionistically SI PROP).
Proof. solve_proper. Qed.
Lemma intuitionistically_elim P : □ P ⊢ P.
@@ -1020,7 +1020,7 @@ Lemma intuitionistically_exist {A} (Φ : A → PROP) : □ (∃ x, Φ x) ⊣⊢
Proof. by rewrite /bi_intuitionistically persistently_exist affinely_exist. Qed.
Lemma intuitionistically_sep_2 P Q : □ P ∗ □ Q ⊢ □ (P ∗ Q).
Proof. by rewrite /bi_intuitionistically affinely_sep_2 persistently_sep_2. Qed.
-Lemma intuitionistically_sep `{BiPositive PROP} P Q : □ (P ∗ Q) ⊣⊢ □ P ∗ □ Q.
+Lemma intuitionistically_sep `{BiPositive SI PROP} P Q : □ (P ∗ Q) ⊣⊢ □ P ∗ □ Q.
Proof. by rewrite /bi_intuitionistically -affinely_sep -persistently_sep. Qed.
Lemma intuitionistically_idemp P : □ □ P ⊣⊢ □ P.
@@ -1097,21 +1097,21 @@ Proof.
Qed.
Section bi_affine_intuitionistically.
- Context `{BiAffine PROP}.
+ Context `{BiAffine SI PROP}.
Lemma intuitionistically_into_persistently P : □ P ⊣⊢ <pers> P.
Proof. rewrite /bi_intuitionistically affine_affinely //. Qed.
End bi_affine_intuitionistically.
(* Conditional affinely modality *)
-Global Instance affinely_if_ne p : NonExpansive (@bi_affinely_if PROP p).
+Global Instance affinely_if_ne p : NonExpansive (@bi_affinely_if SI PROP p).
Proof. solve_proper. Qed.
-Global Instance affinely_if_proper p : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_affinely_if PROP p).
+Global Instance affinely_if_proper p : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_affinely_if SI PROP p).
Proof. solve_proper. Qed.
-Global Instance affinely_if_mono' p : Proper ((⊢) ==> (⊢)) (@bi_affinely_if PROP p).
+Global Instance affinely_if_mono' p : Proper ((⊢) ==> (⊢)) (@bi_affinely_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance affinely_if_flip_mono' p :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_affinely_if PROP p).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_affinely_if SI PROP p).
Proof. solve_proper. Qed.
Lemma affinely_if_mono p P Q : (P ⊢ Q) → <affine>?p P ⊢ <affine>?p Q.
@@ -1137,7 +1137,7 @@ Lemma affinely_if_exist {A} p (Ψ : A → PROP) :
Proof. destruct p; simpl; auto using affinely_exist. Qed.
Lemma affinely_if_sep_2 p P Q : <affine>?p P ∗ <affine>?p Q ⊢ <affine>?p (P ∗ Q).
Proof. destruct p; simpl; auto using affinely_sep_2. Qed.
-Lemma affinely_if_sep `{BiPositive PROP} p P Q :
+Lemma affinely_if_sep `{BiPositive SI PROP} p P Q :
<affine>?p (P ∗ Q) ⊣⊢ <affine>?p P ∗ <affine>?p Q.
Proof. destruct p; simpl; auto using affinely_sep. Qed.
@@ -1152,14 +1152,14 @@ Lemma affinely_if_and_lr p P Q : <affine>?p P ∧ Q ⊣⊢ P ∧ <affine>?p Q.
Proof. destruct p; simpl; auto using affinely_and_lr. Qed.
(* Conditional absorbingly modality *)
-Global Instance absorbingly_if_ne p : NonExpansive (@bi_absorbingly_if PROP p).
+Global Instance absorbingly_if_ne p : NonExpansive (@bi_absorbingly_if SI PROP p).
Proof. solve_proper. Qed.
-Global Instance absorbingly_if_proper p : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_absorbingly_if PROP p).
+Global Instance absorbingly_if_proper p : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_absorbingly_if SI PROP p).
Proof. solve_proper. Qed.
-Global Instance absorbingly_if_mono' p : Proper ((⊢) ==> (⊢)) (@bi_absorbingly_if PROP p).
+Global Instance absorbingly_if_mono' p : Proper ((⊢) ==> (⊢)) (@bi_absorbingly_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance absorbingly_if_flip_mono' p :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_absorbingly_if PROP p).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_absorbingly_if SI PROP p).
Proof. solve_proper. Qed.
Lemma absorbingly_if_absorbingly p P : <absorb>?p P ⊢ <absorb> P.
@@ -1203,16 +1203,16 @@ Lemma affinely_if_absorbingly_if_elim `{!BiPositive PROP} p P :
Proof. destruct p; simpl; auto using affinely_absorbingly_elim. Qed.
(* Conditional persistently *)
-Global Instance persistently_if_ne p : NonExpansive (@bi_persistently_if PROP p).
+Global Instance persistently_if_ne p : NonExpansive (@bi_persistently_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance persistently_if_proper p :
- Proper ((⊣⊢) ==> (⊣⊢)) (@bi_persistently_if PROP p).
+ Proper ((⊣⊢) ==> (⊣⊢)) (@bi_persistently_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance persistently_if_mono' p :
- Proper ((⊢) ==> (⊢)) (@bi_persistently_if PROP p).
+ Proper ((⊢) ==> (⊢)) (@bi_persistently_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance persistently_if_flip_mono' p :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_persistently_if PROP p).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_persistently_if SI PROP p).
Proof. solve_proper. Qed.
Lemma persistently_if_mono p P Q : (P ⊢ Q) → <pers>?p P ⊢ <pers>?p Q.
@@ -1229,7 +1229,7 @@ Lemma persistently_if_exist {A} p (Ψ : A → PROP) :
Proof. destruct p; simpl; auto using persistently_exist. Qed.
Lemma persistently_if_sep_2 p P Q : <pers>?p P ∗ <pers>?p Q ⊢ <pers>?p (P ∗ Q).
Proof. destruct p; simpl; auto using persistently_sep_2. Qed.
-Lemma persistently_if_sep `{BiPositive PROP} p P Q :
+Lemma persistently_if_sep `{BiPositive SI PROP} p P Q :
<pers>?p (P ∗ Q) ⊣⊢ <pers>?p P ∗ <pers>?p Q.
Proof. destruct p; simpl; auto using persistently_sep. Qed.
@@ -1237,16 +1237,16 @@ Lemma persistently_if_idemp p P : <pers>?p <pers>?p P ⊣⊢ <pers>?p P.
Proof. destruct p; simpl; auto using persistently_idemp. Qed.
(* Conditional intuitionistically *)
-Global Instance intuitionistically_if_ne p : NonExpansive (@bi_intuitionistically_if PROP p).
+Global Instance intuitionistically_if_ne p : NonExpansive (@bi_intuitionistically_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance intuitionistically_if_proper p :
- Proper ((⊣⊢) ==> (⊣⊢)) (@bi_intuitionistically_if PROP p).
+ Proper ((⊣⊢) ==> (⊣⊢)) (@bi_intuitionistically_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance intuitionistically_if_mono' p :
- Proper ((⊢) ==> (⊢)) (@bi_intuitionistically_if PROP p).
+ Proper ((⊢) ==> (⊢)) (@bi_intuitionistically_if SI PROP p).
Proof. solve_proper. Qed.
Global Instance intuitionistically_if_flip_mono' p :
- Proper (flip (⊢) ==> flip (⊢)) (@bi_intuitionistically_if PROP p).
+ Proper (flip (⊢) ==> flip (⊢)) (@bi_intuitionistically_if SI PROP p).
Proof. solve_proper. Qed.
Lemma intuitionistically_if_mono p P Q : (P ⊢ Q) → □?p P ⊢ □?p Q.
@@ -1275,7 +1275,7 @@ Lemma intuitionistically_if_exist {A} p (Ψ : A → PROP) :
Proof. destruct p; simpl; auto using intuitionistically_exist. Qed.
Lemma intuitionistically_if_sep_2 p P Q : □?p P ∗ □?p Q ⊢ □?p (P ∗ Q).
Proof. destruct p; simpl; auto using intuitionistically_sep_2. Qed.
-Lemma intuitionistically_if_sep `{BiPositive PROP} p P Q :
+Lemma intuitionistically_if_sep `{BiPositive SI PROP} p P Q :
□?p (P ∗ Q) ⊣⊢ □?p P ∗ □?p Q.
Proof. destruct p; simpl; auto using intuitionistically_sep. Qed.
@@ -1286,7 +1286,7 @@ Lemma intuitionistically_if_unfold p P : □?p P ⊣⊢ <affine>?p <pers>?p P.
Proof. by destruct p. Qed.
(* Properties of persistent propositions *)
-Global Instance Persistent_proper : Proper ((≡) ==> iff) (@Persistent PROP).
+Global Instance Persistent_proper : Proper ((≡) ==> iff) (@Persistent SI PROP).
Proof. solve_proper. Qed.
Lemma persistent_persistently_2 P `{!Persistent P} : P ⊢ <pers> P.
@@ -1358,7 +1358,7 @@ Lemma impl_wand_2 P `{!Persistent P} Q : (P -∗ Q) ⊢ P → Q.
Proof. apply impl_intro_l. by rewrite persistent_and_sep_1 wand_elim_r. Qed.
Section persistent_bi_absorbing.
- Context `{BiAffine PROP}.
+ Context `{BiAffine SI PROP}.
Lemma persistent_and_sep P Q `{HPQ : !TCOr (Persistent P) (Persistent Q)} :
P ∧ Q ⊣⊢ P ∗ Q.
@@ -1488,56 +1488,56 @@ Global Instance from_option_persistent {A} P (Ψ : A → PROP) (mx : option A) :
Proof. destruct mx; apply _. Qed.
(* For big ops *)
-Global Instance bi_and_monoid : Monoid (@bi_and PROP) :=
+Global Instance bi_and_monoid : Monoid (@bi_and SI PROP) :=
{| monoid_unit := True%I |}.
-Global Instance bi_or_monoid : Monoid (@bi_or PROP) :=
+Global Instance bi_or_monoid : Monoid (@bi_or SI PROP) :=
{| monoid_unit := False%I |}.
-Global Instance bi_sep_monoid : Monoid (@bi_sep PROP) :=
+Global Instance bi_sep_monoid : Monoid (@bi_sep SI PROP) :=
{| monoid_unit := emp%I |}.
Global Instance bi_persistently_and_homomorphism :
- MonoidHomomorphism bi_and bi_and (≡) (@bi_persistently PROP).
+ MonoidHomomorphism bi_and bi_and (≡) (@bi_persistently SI PROP).
Proof.
split; [split|]; try apply _. apply persistently_and. apply persistently_pure.
Qed.
Global Instance bi_persistently_or_homomorphism :
- MonoidHomomorphism bi_or bi_or (≡) (@bi_persistently PROP).
+ MonoidHomomorphism bi_or bi_or (≡) (@bi_persistently SI PROP).
Proof.
split; [split|]; try apply _. apply persistently_or. apply persistently_pure.
Qed.
-Global Instance bi_persistently_sep_weak_homomorphism `{BiPositive PROP} :
- WeakMonoidHomomorphism bi_sep bi_sep (≡) (@bi_persistently PROP).
+Global Instance bi_persistently_sep_weak_homomorphism `{BiPositive SI PROP} :
+ WeakMonoidHomomorphism bi_sep bi_sep (≡) (@bi_persistently SI PROP).
Proof. split; try apply _. apply persistently_sep. Qed.
-Global Instance bi_persistently_sep_homomorphism `{BiAffine PROP} :
- MonoidHomomorphism bi_sep bi_sep (≡) (@bi_persistently PROP).
+Global Instance bi_persistently_sep_homomorphism `{BiAffine SI PROP} :
+ MonoidHomomorphism bi_sep bi_sep (≡) (@bi_persistently SI PROP).
Proof. split. apply _. apply persistently_emp. Qed.
Global Instance bi_persistently_sep_entails_weak_homomorphism :
- WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_persistently PROP).
+ WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_persistently SI PROP).
Proof. split; try apply _. intros P Q; by rewrite persistently_sep_2. Qed.
Global Instance bi_persistently_sep_entails_homomorphism :
- MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_persistently PROP).
+ MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@bi_persistently SI PROP).
Proof. split. apply _. simpl. apply persistently_emp_intro. Qed.
(* Limits *)
-Lemma limit_preserving_entails {A : ofeT} `{Cofe A} (Φ Ψ : A → PROP) :
+Lemma limit_preserving_entails {A : ofeT SI} `{Cofe SI A} (Φ Ψ : A → PROP) :
NonExpansive Φ → NonExpansive Ψ → LimitPreserving (λ x, Φ x ⊢ Ψ x).
Proof.
- intros HΦ HΨ c Hc. apply entails_eq_True, equiv_dist=>n.
- rewrite conv_compl. apply equiv_dist, entails_eq_True. done.
+ intros HΦ HΨ c HC. apply entails_eq_True, equiv_dist=>n.
+ rewrite conv_compl; eauto using chain_cauchy. apply equiv_dist, entails_eq_True. done.
Qed.
-Lemma limit_preserving_equiv {A : ofeT} `{Cofe A} (Φ Ψ : A → PROP) :
+Lemma limit_preserving_equiv {A : ofeT SI} `{Cofe SI A} (Φ Ψ : A → PROP) :
NonExpansive Φ → NonExpansive Ψ → LimitPreserving (λ x, Φ x ⊣⊢ Ψ x).
Proof.
intros HΦ HΨ. eapply limit_preserving_ext.
{ intros x. symmetry; apply equiv_spec. }
apply limit_preserving_and; by apply limit_preserving_entails.
Qed.
-Global Instance limit_preserving_Persistent {A:ofeT} `{Cofe A} (Φ : A → PROP) :
+Global Instance limit_preserving_Persistent {A:ofeT SI} `{Cofe SI A} (Φ : A → PROP) :
NonExpansive Φ → LimitPreserving (λ x, Persistent (Φ x)).
Proof. intros. apply limit_preserving_entails; solve_proper. Qed.
End bi_derived.
diff --git a/theories/bi/derived_laws_sbi.v b/theories/bi/derived_laws_sbi.v
index fe60dc3a7f7ee6289979842b80f947504a754d8e..6705b4515168b3b448a3b7a8885ff0aedd6dd87d 100644
--- a/theories/bi/derived_laws_sbi.v
+++ b/theories/bi/derived_laws_sbi.v
@@ -5,7 +5,7 @@ Module bi.
Import interface.bi.
Import derived_laws_bi.bi.
Section sbi_derived.
-Context {PROP : sbi}.
+Context {SI: indexT} {PROP : sbi SI}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types Ps : list PROP.
@@ -18,34 +18,34 @@ Notation "P ⊣⊢ Q" := (P ⊣⊢@{PROP} Q).
Hint Resolve or_elim or_intro_l' or_intro_r' True_intro False_elim : core.
Hint Resolve and_elim_l' and_elim_r' and_intro forall_intro : core.
-Global Instance internal_eq_proper (A : ofeT) :
- Proper ((≡) ==> (≡) ==> (⊣⊢)) (@sbi_internal_eq PROP A) := ne_proper_2 _.
+Global Instance internal_eq_proper (A : ofeT SI) :
+ Proper ((≡) ==> (≡) ==> (⊣⊢)) (@sbi_internal_eq SI PROP A) := ne_proper_2 _.
Global Instance later_proper :
- Proper ((⊣⊢) ==> (⊣⊢)) (@sbi_later PROP) := ne_proper _.
+ Proper ((⊣⊢) ==> (⊣⊢)) (@sbi_later SI PROP) := ne_proper _.
(* Equality *)
Hint Resolve internal_eq_refl : core.
Hint Extern 100 (NonExpansive _) => solve_proper : core.
-Lemma equiv_internal_eq {A : ofeT} P (a b : A) : a ≡ b → P ⊢ a ≡ b.
+Lemma equiv_internal_eq {A : ofeT SI} P (a b : A) : a ≡ b → P ⊢ a ≡ b.
Proof. intros ->. auto. Qed.
-Lemma internal_eq_rewrite' {A : ofeT} a b (Ψ : A → PROP) P
+Lemma internal_eq_rewrite' {A : ofeT SI} a b (Ψ : A → PROP) P
{HΨ : NonExpansive Ψ} : (P ⊢ a ≡ b) → (P ⊢ Ψ a) → P ⊢ Ψ b.
Proof.
intros Heq HΨa. rewrite -(idemp bi_and P) {1}Heq HΨa.
apply impl_elim_l'. by apply internal_eq_rewrite.
Qed.
-Lemma internal_eq_sym {A : ofeT} (a b : A) : a ≡ b ⊢ b ≡ a.
+Lemma internal_eq_sym {A : ofeT SI} (a b : A) : a ≡ b ⊢ b ≡ a.
Proof. apply (internal_eq_rewrite' a b (λ b, b ≡ a)%I); auto. Qed.
Lemma internal_eq_iff P Q : P ≡ Q ⊢ P ↔ Q.
Proof. apply (internal_eq_rewrite' P Q (λ Q, P ↔ Q))%I; auto using iff_refl. Qed.
-Lemma f_equiv {A B : ofeT} (f : A → B) `{!NonExpansive f} x y :
+Lemma f_equiv {A B : ofeT SI} (f : A → B) `{!NonExpansive f} x y :
x ≡ y ⊢ f x ≡ f y.
Proof. apply (internal_eq_rewrite' x y (λ y, f x ≡ f y)%I); auto. Qed.
-Lemma prod_equivI {A B : ofeT} (x y : A * B) : x ≡ y ⊣⊢ x.1 ≡ y.1 ∧ x.2 ≡ y.2.
+Lemma prod_equivI {A B : ofeT SI} (x y : A * B) : x ≡ y ⊣⊢ x.1 ≡ y.1 ∧ x.2 ≡ y.2.
Proof.
apply (anti_symm _).
- apply and_intro; apply f_equiv; apply _.
@@ -53,7 +53,7 @@ Proof.
apply (internal_eq_rewrite' (x.1) (y.1) (λ a, (x.1,x.2) ≡ (a,y.2))%I); auto.
apply (internal_eq_rewrite' (x.2) (y.2) (λ b, (x.1,x.2) ≡ (x.1,b))%I); auto.
Qed.
-Lemma sum_equivI {A B : ofeT} (x y : A + B) :
+Lemma sum_equivI {A B : ofeT SI} (x y : A + B) :
x ≡ y ⊣⊢
match x, y with
| inl a, inl a' => a ≡ a' | inr b, inr b' => b ≡ b' | _, _ => False
@@ -67,7 +67,7 @@ Proof.
destruct x; auto.
- destruct x as [a|b], y as [a'|b']; auto; apply f_equiv, _.
Qed.
-Lemma option_equivI {A : ofeT} (x y : option A) :
+Lemma option_equivI {A : ofeT SI} (x y : option A) :
x ≡ y ⊣⊢ match x, y with
| Some a, Some a' => a ≡ a' | None, None => True | _, _ => False
end.
@@ -81,13 +81,13 @@ Proof.
- destruct x as [a|], y as [a'|]; auto. apply f_equiv, _.
Qed.
-Lemma sig_equivI {A : ofeT} (P : A → Prop) (x y : sig P) : `x ≡ `y ⊣⊢ x ≡ y.
+Lemma sig_equivI {A : ofeT SI} (P : A → Prop) (x y : sig P) : `x ≡ `y ⊣⊢ x ≡ y.
Proof. apply (anti_symm _). apply sig_eq. apply f_equiv, _. Qed.
Section sigT_equivI.
Import EqNotations.
-Lemma sigT_equivI {A : Type} {P : A → ofeT} (x y : sigT P) :
+Lemma sigT_equivI {A : Type} {P : A → ofeT SI} (x y : sigT P) :
x ≡ y ⊣⊢
∃ eq : projT1 x = projT1 y, rew eq in projT2 x ≡ projT2 y.
Proof.
@@ -103,13 +103,14 @@ Proof.
Qed.
End sigT_equivI.
-Lemma discrete_fun_equivI {A} {B : A → ofeT} (f g : discrete_fun B) : f ≡ g ⊣⊢ ∀ x, f x ≡ g x.
+Lemma discrete_fun_equivI {A} {B : A → ofeT SI} (f g : discrete_fun B) : f ≡ g ⊣⊢ ∀ x, f x ≡ g x.
Proof.
apply (anti_symm _); auto using fun_ext.
apply (internal_eq_rewrite' f g (λ g, ∀ x : A, f x ≡ g x)%I); auto.
intros n h h' Hh; apply forall_ne=> x; apply internal_eq_ne; auto.
Qed.
-Lemma ofe_morO_equivI {A B : ofeT} (f g : A -n> B) : f ≡ g ⊣⊢ ∀ x, f x ≡ g x.
+
+Lemma ofe_morO_equivI {A B : ofeT SI} (f g : A -n> B) : f ≡ g ⊣⊢ ∀ x, f x ≡ g x.
Proof.
apply (anti_symm _).
- apply (internal_eq_rewrite' f g (λ g, ∀ x : A, f x ≡ g x)%I); auto.
@@ -117,26 +118,26 @@ Proof.
set (h1 (f : A -n> B) :=
exist (λ f : A -d> B, NonExpansive (f : A → B)) f (ofe_mor_ne A B f)).
set (h2 (f : sigO (λ f : A -d> B, NonExpansive (f : A → B))) :=
- @OfeMor A B (`f) (proj2_sig f)).
+ @OfeMor SI A B (`f) (proj2_sig f)).
assert (∀ f, h2 (h1 f) = f) as Hh by (by intros []).
assert (NonExpansive h2) by (intros ??? EQ; apply EQ).
by rewrite -{2}[f]Hh -{2}[g]Hh -f_equiv -sig_equivI.
Qed.
-Lemma pure_internal_eq {A : ofeT} (x y : A) : ⌜x ≡ y⌠⊢ x ≡ y.
+Lemma pure_internal_eq {A : ofeT SI} (x y : A) : ⌜x ≡ y⌠⊢ x ≡ y.
Proof. apply pure_elim'=> ->. apply internal_eq_refl. Qed.
-Lemma discrete_eq {A : ofeT} (a b : A) : Discrete a → a ≡ b ⊣⊢ ⌜a ≡ bâŒ.
+Lemma discrete_eq {A : ofeT SI} (a b : A) : Discrete a → a ≡ b ⊣⊢ ⌜a ≡ bâŒ.
Proof.
intros. apply (anti_symm _); auto using discrete_eq_1, pure_internal_eq.
Qed.
-Lemma absorbingly_internal_eq {A : ofeT} (x y : A) : <absorb> (x ≡ y) ⊣⊢ x ≡ y.
+Lemma absorbingly_internal_eq {A : ofeT SI} (x y : A) : <absorb> (x ≡ y) ⊣⊢ x ≡ y.
Proof.
apply (anti_symm _), absorbingly_intro.
apply wand_elim_r', (internal_eq_rewrite' x y (λ y, True -∗ x ≡ y)%I); auto.
apply wand_intro_l, internal_eq_refl.
Qed.
-Lemma persistently_internal_eq {A : ofeT} (a b : A) : <pers> (a ≡ b) ⊣⊢ a ≡ b.
+Lemma persistently_internal_eq {A : ofeT SI} (a b : A) : <pers> (a ≡ b) ⊣⊢ a ≡ b.
Proof.
apply (anti_symm (⊢)).
{ by rewrite persistently_into_absorbingly absorbingly_internal_eq. }
@@ -144,36 +145,36 @@ Proof.
rewrite -(internal_eq_refl emp%I a). apply persistently_emp_intro.
Qed.
-Global Instance internal_eq_absorbing {A : ofeT} (x y : A) :
+Global Instance internal_eq_absorbing {A : ofeT SI} (x y : A) :
Absorbing (PROP:=PROP) (x ≡ y).
Proof. by rewrite /Absorbing absorbingly_internal_eq. Qed.
-Global Instance internal_eq_persistent {A : ofeT} (a b : A) :
+Global Instance internal_eq_persistent {A : ofeT SI} (a b : A) :
Persistent (PROP:=PROP) (a ≡ b).
Proof. by intros; rewrite /Persistent persistently_internal_eq. Qed.
(* Equality under a later. *)
-Lemma internal_eq_rewrite_contractive {A : ofeT} a b (Ψ : A → PROP)
+Lemma internal_eq_rewrite_contractive {A : ofeT SI} a b (Ψ : A → PROP)
{HΨ : Contractive Ψ} : ▷ (a ≡ b) ⊢ Ψ a → Ψ b.
Proof.
rewrite later_eq_2. move: HΨ=>/contractive_alt [g [? HΨ]]. rewrite !HΨ.
by apply internal_eq_rewrite.
Qed.
-Lemma internal_eq_rewrite_contractive' {A : ofeT} a b (Ψ : A → PROP) P
+Lemma internal_eq_rewrite_contractive' {A : ofeT SI} a b (Ψ : A → PROP) P
{HΨ : Contractive Ψ} : (P ⊢ ▷ (a ≡ b)) → (P ⊢ Ψ a) → P ⊢ Ψ b.
Proof.
rewrite later_eq_2. move: HΨ=>/contractive_alt [g [? HΨ]]. rewrite !HΨ.
by apply internal_eq_rewrite'.
Qed.
-Lemma later_equivI {A : ofeT} (x y : A) : Next x ≡ Next y ⊣⊢ ▷ (x ≡ y).
+Lemma later_equivI {A : ofeT SI} (x y : A) : Next x ≡ Next y ⊣⊢ ▷ (x ≡ y).
Proof. apply (anti_symm _); auto using later_eq_1, later_eq_2. Qed.
(* Later derived *)
Hint Resolve later_mono : core.
-Global Instance later_mono' : Proper ((⊢) ==> (⊢)) (@sbi_later PROP).
+Global Instance later_mono' : Proper ((⊢) ==> (⊢)) (@sbi_later SI PROP).
Proof. intros P Q; apply later_mono. Qed.
Global Instance later_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@sbi_later PROP).
+ Proper (flip (⊢) ==> flip (⊢)) (@sbi_later SI PROP).
Proof. intros P Q; apply later_mono. Qed.
Lemma later_True : ▷ True ⊣⊢ True.
@@ -187,22 +188,38 @@ Proof.
Qed.
Lemma later_exist_2 {A} (Φ : A → PROP) : (∃ a, ▷ Φ a) ⊢ ▷ (∃ a, Φ a).
Proof. apply exist_elim; eauto using exist_intro. Qed.
-Lemma later_exist `{Inhabited A} (Φ : A → PROP) : ▷ (∃ a, Φ a) ⊣⊢ (∃ a, ▷ Φ a).
+Lemma later_exist `{FiniteIndex SI} `{Inhabited A} (Φ : A → PROP) : ▷ (∃ a, Φ a) ⊣⊢ (∃ a, ▷ Φ a).
Proof.
apply: anti_symm; [|apply later_exist_2].
rewrite later_exist_false. apply or_elim; last done.
rewrite -(exist_intro inhabitant); auto.
Qed.
+Lemma later_finite_exist `{FiniteBoundedExistential SI} `{Inhabited A} (Φ : A → PROP) (Q: A → Prop):
+ pred_finite Q →
+ (∀ a : A, Φ a -∗ ⌜Q aâŒ) →
+ ▷ (∃ a, Φ a) ⊣⊢ (∃ a, ▷ Φ a).
+Proof.
+ intros Hfin Himp. apply: anti_symm; [|apply later_exist_2].
+ rewrite (later_finite_exist_false _ Q); auto. apply or_elim; last done.
+ rewrite -(exist_intro inhabitant); auto.
+Qed.
Lemma later_and P Q : ▷ (P ∧ Q) ⊣⊢ ▷ P ∧ ▷ Q.
Proof. rewrite !and_alt later_forall. by apply forall_proper=> -[]. Qed.
-Lemma later_or P Q : ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
-Proof. rewrite !or_alt later_exist. by apply exist_proper=> -[]. Qed.
+
+Lemma later_or `{FiniteBoundedExistential SI} P Q : ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
+Proof.
+ rewrite !or_alt (later_finite_exist _ (λ b, True)); auto.
+ - by apply exist_proper=> -[].
+ - exists [true; false]. intros []; rewrite !elem_of_cons; naive_solver.
+Qed.
Lemma later_impl P Q : ▷ (P → Q) ⊢ ▷ P → ▷ Q.
Proof. apply impl_intro_l. by rewrite -later_and impl_elim_r. Qed.
-Lemma later_sep P Q : ▷ (P ∗ Q) ⊣⊢ ▷ P ∗ ▷ Q.
+(* NOTE: seems to be false in the model for transfinite indices *)
+Lemma later_sep `{FiniteIndex SI} P Q : ▷ (P ∗ Q) ⊣⊢ ▷ P ∗ ▷ Q.
Proof. apply (anti_symm _); auto using later_sep_1, later_sep_2. Qed.
+(* NOTE: true, proof slightly changed *)
Lemma later_wand P Q : ▷ (P -∗ Q) ⊢ ▷ P -∗ ▷ Q.
-Proof. apply wand_intro_l. by rewrite -later_sep wand_elim_r. Qed.
+Proof. apply wand_intro_l. by rewrite later_sep_2 wand_elim_r. Qed.
Lemma later_iff P Q : ▷ (P ↔ Q) ⊢ ▷ P ↔ ▷ Q.
Proof. by rewrite /bi_iff later_and !later_impl. Qed.
Lemma later_persistently P : ▷ <pers> P ⊣⊢ <pers> ▷ P.
@@ -213,8 +230,17 @@ Lemma later_intuitionistically_2 P : □ ▷ P ⊢ ▷ □ P.
Proof. by rewrite /bi_intuitionistically -later_persistently later_affinely_2. Qed.
Lemma later_intuitionistically_if_2 p P : □?p ▷ P ⊢ ▷ □?p P.
Proof. destruct p; simpl; auto using later_intuitionistically_2. Qed.
-Lemma later_absorbingly P : ▷ <absorb> P ⊣⊢ <absorb> ▷ P.
-Proof. by rewrite /bi_absorbingly later_sep later_True. Qed.
+(*TODO: currently added BiAffine to make this trivial -- our model is affine *)
+(*Lemma later_absorbingly `{FiniteIndex SI} P : ▷ <absorb> P ⊣⊢ <absorb> ▷ P.*)
+(*Proof. rewrite /bi_absorbingly. by rewrite later_sep later_True. Abort.*)
+Lemma later_absorbingly `{BiAffine SI PROP} P : ▷ <absorb> P ⊣⊢ <absorb> ▷ P.
+Proof.
+ rewrite /bi_absorbingly. apply (anti_symm _).
+ - apply sep_intro_emp_valid_l. by auto. apply later_mono.
+ apply sep_elim_r. apply _.
+ - etransitivity. { apply sep_elim_r. apply _. }
+ apply later_mono. apply sep_intro_emp_valid_l; auto.
+Qed.
Lemma later_affinely `{!BiAffine PROP} P : ▷ <affine> P ⊣⊢ <affine> ▷ P.
Proof. by rewrite !affine_affinely. Qed.
@@ -225,7 +251,9 @@ Proof. destruct p; simpl; auto using later_intuitionistically. Qed.
Global Instance later_persistent P : Persistent P → Persistent (▷ P).
Proof. intros. by rewrite /Persistent -later_persistently {1}(persistent P). Qed.
-Global Instance later_absorbing P : Absorbing P → Absorbing (▷ P).
+(*TODO: currently proved in the model -- depends on BiAffine*)
+(* NOTE: depends on later_absorbingly *)
+Global Instance later_absorbing `{BiAffine SI PROP} P : Absorbing P → Absorbing (▷ P).
Proof. intros ?. by rewrite /Absorbing -later_absorbingly absorbing. Qed.
Section löb.
@@ -257,10 +285,10 @@ Section löb.
End löb.
(* Iterated later modality *)
-Global Instance laterN_ne m : NonExpansive (@sbi_laterN PROP m).
+Global Instance laterN_ne m : NonExpansive (Nat.iter m (@sbi_later SI PROP)).
Proof. induction m; simpl. by intros ???. solve_proper. Qed.
Global Instance laterN_proper m :
- Proper ((⊣⊢) ==> (⊣⊢)) (@sbi_laterN PROP m) := ne_proper _.
+ Proper ((⊣⊢) ==> (⊣⊢)) (Nat.iter m (@sbi_later SI PROP)) := ne_proper _.
Lemma laterN_0 P : ▷^0 P ⊣⊢ P.
Proof. done. Qed.
@@ -278,10 +306,10 @@ Proof. induction n; f_equal/=; auto. Qed.
Lemma laterN_mono n P Q : (P ⊢ Q) → ▷^n P ⊢ ▷^n Q.
Proof. induction n; simpl; auto. Qed.
-Global Instance laterN_mono' n : Proper ((⊢) ==> (⊢)) (@sbi_laterN PROP n).
+Global Instance laterN_mono' n : Proper ((⊢) ==> (⊢)) (Nat.iter n (@sbi_later SI PROP)).
Proof. intros P Q; apply laterN_mono. Qed.
Global Instance laterN_flip_mono' n :
- Proper (flip (⊢) ==> flip (⊢)) (@sbi_laterN PROP n).
+ Proper (flip (⊢) ==> flip (⊢)) (Nat.iter n (@sbi_later SI PROP)).
Proof. intros P Q; apply laterN_mono. Qed.
Lemma laterN_intro n P : P ⊢ ▷^n P.
@@ -295,19 +323,25 @@ Lemma laterN_forall {A} n (Φ : A → PROP) : (▷^n ∀ a, Φ a) ⊣⊢ (∀ a,
Proof. induction n as [|n IH]; simpl; rewrite -?later_forall ?IH; auto. Qed.
Lemma laterN_exist_2 {A} n (Φ : A → PROP) : (∃ a, ▷^n Φ a) ⊢ ▷^n (∃ a, Φ a).
Proof. apply exist_elim; eauto using exist_intro, laterN_mono. Qed.
-Lemma laterN_exist `{Inhabited A} n (Φ : A → PROP) :
+(* NOTE: right to left also holds for transfinite indexing *)
+Lemma laterN_exist `{FiniteIndex SI} `{Inhabited A} n (Φ : A → PROP) :
(▷^n ∃ a, Φ a) ⊣⊢ ∃ a, ▷^n Φ a.
Proof. induction n as [|n IH]; simpl; rewrite -?later_exist ?IH; auto. Qed.
Lemma laterN_and n P Q : ▷^n (P ∧ Q) ⊣⊢ ▷^n P ∧ ▷^n Q.
Proof. induction n as [|n IH]; simpl; rewrite -?later_and ?IH; auto. Qed.
-Lemma laterN_or n P Q : ▷^n (P ∨ Q) ⊣⊢ ▷^n P ∨ ▷^n Q.
+(* NOTE: right to left also holds for transfinite indexing *)
+Lemma laterN_or `{FiniteBoundedExistential SI} n P Q : ▷^n (P ∨ Q) ⊣⊢ ▷^n P ∨ ▷^n Q.
Proof. induction n as [|n IH]; simpl; rewrite -?later_or ?IH; auto. Qed.
Lemma laterN_impl n P Q : ▷^n (P → Q) ⊢ ▷^n P → ▷^n Q.
Proof. apply impl_intro_l. by rewrite -laterN_and impl_elim_r. Qed.
-Lemma laterN_sep n P Q : ▷^n (P ∗ Q) ⊣⊢ ▷^n P ∗ ▷^n Q.
+Lemma laterN_sep_2 n P Q :▷^n P ∗ ▷^n Q ⊢ ▷^n (P ∗ Q).
+Proof. induction n as [|n IH]; simpl; rewrite ?later_sep_2 ?IH; auto. Qed.
+(* NOTE: right to left also for transifinite indexing, see laterN_sep2, depends on later sep *)
+Lemma laterN_sep `{FiniteIndex SI} n P Q : ▷^n (P ∗ Q) ⊣⊢ ▷^n P ∗ ▷^n Q.
Proof. induction n as [|n IH]; simpl; rewrite -?later_sep ?IH; auto. Qed.
+(* NOTE: true, proof slightly changed *)
Lemma laterN_wand n P Q : ▷^n (P -∗ Q) ⊢ ▷^n P -∗ ▷^n Q.
-Proof. apply wand_intro_l. by rewrite -laterN_sep wand_elim_r. Qed.
+Proof. induction n as [|n IH]; simpl; eauto. by rewrite IH later_wand. Qed.
Lemma laterN_iff n P Q : ▷^n (P ↔ Q) ⊢ ▷^n P ↔ ▷^n Q.
Proof. by rewrite /bi_iff laterN_and !laterN_impl. Qed.
Lemma laterN_persistently n P : ▷^n <pers> P ⊣⊢ <pers> ▷^n P.
@@ -318,23 +352,26 @@ Lemma laterN_intuitionistically_2 n P : □ ▷^n P ⊢ ▷^n □ P.
Proof. by rewrite /bi_intuitionistically -laterN_persistently laterN_affinely_2. Qed.
Lemma laterN_intuitionistically_if_2 n p P : □?p ▷^n P ⊢ ▷^n □?p P.
Proof. destruct p; simpl; auto using laterN_intuitionistically_2. Qed.
-Lemma laterN_absorbingly n P : ▷^n <absorb> P ⊣⊢ <absorb> ▷^n P.
-Proof. by rewrite /bi_absorbingly laterN_sep laterN_True. Qed.
+(* NOTE: true, proof slightly changed, depends on later_absorbingly *)
+(* TODO: currently depends on BiAffine *)
+Lemma laterN_absorbingly `{BiAffine SI PROP} n P : ▷^n <absorb> P ⊣⊢ <absorb> ▷^n P.
+Proof. induction n as [|n IH]; simpl; eauto. by rewrite IH later_absorbingly. Qed.
Global Instance laterN_persistent n P : Persistent P → Persistent (▷^n P).
Proof. induction n; apply _. Qed.
-Global Instance laterN_absorbing n P : Absorbing P → Absorbing (▷^n P).
+(* NOTE: true, proof slightly changed, depends on later_absorbingly *)
+Global Instance laterN_absorbing `{BiAffine SI PROP} n P : Absorbing P → Absorbing (▷^n P).
Proof. induction n; apply _. Qed.
(* Except-0 *)
-Global Instance except_0_ne : NonExpansive (@sbi_except_0 PROP).
+Global Instance except_0_ne : NonExpansive (@sbi_except_0 SI PROP).
Proof. solve_proper. Qed.
-Global Instance except_0_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@sbi_except_0 PROP).
+Global Instance except_0_proper : Proper ((⊣⊢) ==> (⊣⊢)) (@sbi_except_0 SI PROP).
Proof. solve_proper. Qed.
-Global Instance except_0_mono' : Proper ((⊢) ==> (⊢)) (@sbi_except_0 PROP).
+Global Instance except_0_mono' : Proper ((⊢) ==> (⊢)) (@sbi_except_0 SI PROP).
Proof. solve_proper. Qed.
Global Instance except_0_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@sbi_except_0 PROP).
+ Proper (flip (⊢) ==> flip (⊢)) (@sbi_except_0 SI PROP).
Proof. solve_proper. Qed.
Lemma except_0_intro P : P ⊢ ◇ P.
@@ -352,13 +389,14 @@ Lemma except_0_or P Q : ◇ (P ∨ Q) ⊣⊢ ◇ P ∨ ◇ Q.
Proof. rewrite /sbi_except_0. apply (anti_symm _); auto. Qed.
Lemma except_0_and P Q : ◇ (P ∧ Q) ⊣⊢ ◇ P ∧ ◇ Q.
Proof. by rewrite /sbi_except_0 or_and_l. Qed.
-Lemma except_0_sep P Q : ◇ (P ∗ Q) ⊣⊢ ◇ P ∗ ◇ Q.
+(* NOTE: true, proof slightly changed *)
+Lemma except_0_sep P Q: ◇ (P ∗ Q) ⊣⊢ ◇ P ∗ ◇ Q.
Proof.
rewrite /sbi_except_0. apply (anti_symm _).
- apply or_elim; last by auto using sep_mono.
- by rewrite -!or_intro_l -persistently_pure -later_sep -persistently_sep_dup.
+ by rewrite -!or_intro_l -persistently_pure !later_persistently -persistently_sep_dup.
- rewrite sep_or_r !sep_or_l {1}(later_intro P) {1}(later_intro Q).
- rewrite -!later_sep !left_absorb right_absorb. auto.
+ rewrite !later_sep_2 !left_absorb right_absorb. auto.
Qed.
Lemma except_0_forall {A} (Φ : A → PROP) : ◇ (∀ a, Φ a) ⊣⊢ ∀ a, ◇ Φ a.
Proof.
@@ -381,8 +419,9 @@ Proof.
- rewrite -(exist_intro inhabitant). by apply or_intro_l.
- apply exist_mono=> a. apply except_0_intro.
Qed.
+(* NOTE: true, proof slightly changed *)
Lemma except_0_later P : ◇ ▷ P ⊢ ▷ P.
-Proof. by rewrite /sbi_except_0 -later_or False_or. Qed.
+Proof. rewrite /sbi_except_0; eauto using or_elim. Qed.
Lemma except_0_persistently P : ◇ <pers> P ⊣⊢ <pers> ◇ P.
Proof.
by rewrite /sbi_except_0 persistently_or -later_persistently persistently_pure.
@@ -393,12 +432,12 @@ Lemma except_0_intuitionistically_2 P : □ ◇ P ⊢ ◇ □ P.
Proof. by rewrite /bi_intuitionistically -except_0_persistently except_0_affinely_2. Qed.
Lemma except_0_intuitionistically_if_2 p P : □?p ◇ P ⊢ ◇ □?p P.
Proof. destruct p; simpl; auto using except_0_intuitionistically_2. Qed.
-Lemma except_0_absorbingly P : ◇ <absorb> P ⊣⊢ <absorb> ◇ P.
+Lemma except_0_absorbingly P : ◇ <absorb> P ⊣⊢ <absorb> ◇ P.
Proof. by rewrite /bi_absorbingly except_0_sep except_0_True. Qed.
-Lemma except_0_frame_l P Q : P ∗ ◇ Q ⊢ ◇ (P ∗ Q).
+Lemma except_0_frame_l P Q : P ∗ ◇ Q ⊢ ◇ (P ∗ Q).
Proof. by rewrite {1}(except_0_intro P) except_0_sep. Qed.
-Lemma except_0_frame_r P Q : ◇ P ∗ Q ⊢ ◇ (P ∗ Q).
+Lemma except_0_frame_r P Q : ◇ P ∗ Q ⊢ ◇ (P ∗ Q).
Proof. by rewrite {1}(except_0_intro Q) except_0_sep. Qed.
Lemma later_affinely_1 `{!Timeless (PROP:=PROP) emp} P : ▷ <affine> P ⊢ ◇ <affine> ▷ P.
@@ -409,25 +448,15 @@ Qed.
Global Instance except_0_persistent P : Persistent P → Persistent (◇ P).
Proof. rewrite /sbi_except_0; apply _. Qed.
-Global Instance except_0_absorbing P : Absorbing P → Absorbing (◇ P).
+Global Instance except_0_absorbing `{BiAffine SI PROP} P : Absorbing P → Absorbing (◇ P).
Proof. rewrite /sbi_except_0; apply _. Qed.
(* Timeless instances *)
-Global Instance Timeless_proper : Proper ((≡) ==> iff) (@Timeless PROP).
+Global Instance Timeless_proper : Proper ((≡) ==> iff) (@Timeless SI PROP).
Proof. solve_proper. Qed.
-Global Instance pure_timeless φ : Timeless (PROP:=PROP) ⌜φâŒ.
-Proof.
- rewrite /Timeless /sbi_except_0 pure_alt later_exist_false.
- apply or_elim, exist_elim; [auto|]=> Hφ. rewrite -(exist_intro Hφ). auto.
-Qed.
-Global Instance emp_timeless `{BiAffine PROP} : Timeless (PROP:=PROP) emp.
-Proof. rewrite -True_emp. apply _. Qed.
-
Global Instance and_timeless P Q : Timeless P → Timeless Q → Timeless (P ∧ Q).
Proof. intros; rewrite /Timeless except_0_and later_and; auto. Qed.
-Global Instance or_timeless P Q : Timeless P → Timeless Q → Timeless (P ∨ Q).
-Proof. intros; rewrite /Timeless except_0_or later_or; auto. Qed.
Global Instance impl_timeless P Q : Timeless Q → Timeless (P → Q).
Proof.
@@ -437,12 +466,10 @@ Proof.
rewrite HQ /sbi_except_0 !and_or_r. apply or_elim; last auto.
by rewrite assoc (comm _ _ P) -assoc !impl_elim_r.
Qed.
-Global Instance sep_timeless P Q: Timeless P → Timeless Q → Timeless (P ∗ Q).
-Proof.
- intros; rewrite /Timeless except_0_sep later_sep; auto using sep_mono.
-Qed.
-Global Instance wand_timeless P Q : Timeless Q → Timeless (P -∗ Q).
+
+(* TODO : depends on later_absorbingly -- therefore we assume BiAffine here*)
+Global Instance wand_timeless `{BiAffine SI PROP} P Q : Timeless Q → Timeless (P -∗ Q).
Proof.
rewrite /Timeless=> HQ. rewrite later_false_em.
apply or_mono, wand_intro_l; first done.
@@ -456,14 +483,9 @@ Proof.
rewrite /Timeless=> HQ. rewrite except_0_forall later_forall.
apply forall_mono; auto.
Qed.
-Global Instance exist_timeless {A} (Ψ : A → PROP) :
- (∀ x, Timeless (Ψ x)) → Timeless (∃ x, Ψ x).
-Proof.
- rewrite /Timeless=> ?. rewrite later_exist_false. apply or_elim.
- - rewrite /sbi_except_0; auto.
- - apply exist_elim=> x. rewrite -(exist_intro x); auto.
-Qed.
-Global Instance persistently_timeless P : Timeless P → Timeless (<pers> P).
+
+(* TODO: depends on absorb/affine BI *)
+Global Instance persistently_timeless `{BiAffine SI PROP} P : Timeless P → Timeless (<pers> P).
Proof.
intros. rewrite /Timeless /sbi_except_0 later_persistently_1.
by rewrite (timeless P) /sbi_except_0 persistently_or {1}persistently_elim.
@@ -472,79 +494,75 @@ Qed.
Global Instance affinely_timeless P :
Timeless (PROP:=PROP) emp → Timeless P → Timeless (<affine> P).
Proof. rewrite /bi_affinely; apply _. Qed.
-Global Instance absorbingly_timeless P : Timeless P → Timeless (<absorb> P).
-Proof. rewrite /bi_absorbingly; apply _. Qed.
-Global Instance intuitionistically_timeless P :
+(* TODO : depends on absorb/affine BI *)
+Global Instance intuitionistically_timeless `{BiAffine SI PROP} P :
Timeless (PROP:=PROP) emp → Timeless P → Timeless (□ P).
Proof. rewrite /bi_intuitionistically; apply _. Qed.
-Global Instance eq_timeless {A : ofeT} (a b : A) :
- Discrete a → Timeless (PROP:=PROP) (a ≡ b).
-Proof. intros. rewrite /Discrete !discrete_eq. apply (timeless _). Qed.
Global Instance from_option_timeless {A} P (Ψ : A → PROP) (mx : option A) :
(∀ x, Timeless (Ψ x)) → Timeless P → Timeless (from_option Ψ P mx).
Proof. destruct mx; apply _. Qed.
(* Big op stuff *)
Global Instance sbi_later_monoid_and_homomorphism :
- MonoidHomomorphism bi_and bi_and (≡) (@sbi_later PROP).
+ MonoidHomomorphism bi_and bi_and (≡) (@sbi_later SI PROP).
Proof. split; [split|]; try apply _. apply later_and. apply later_True. Qed.
Global Instance sbi_laterN_and_homomorphism n :
- MonoidHomomorphism bi_and bi_and (≡) (@sbi_laterN PROP n).
+ MonoidHomomorphism bi_and bi_and (≡) (Nat.iter n (@sbi_later SI PROP)).
Proof. split; [split|]; try apply _. apply laterN_and. apply laterN_True. Qed.
Global Instance sbi_except_0_and_homomorphism :
- MonoidHomomorphism bi_and bi_and (≡) (@sbi_except_0 PROP).
+ MonoidHomomorphism bi_and bi_and (≡) (@sbi_except_0 SI PROP).
Proof. split; [split|]; try apply _. apply except_0_and. apply except_0_True. Qed.
-Global Instance sbi_later_monoid_or_homomorphism :
- WeakMonoidHomomorphism bi_or bi_or (≡) (@sbi_later PROP).
+Global Instance sbi_later_monoid_or_homomorphism `{FiniteBoundedExistential SI} :
+ WeakMonoidHomomorphism bi_or bi_or (≡) (@sbi_later SI PROP).
Proof. split; try apply _. apply later_or. Qed.
-Global Instance sbi_laterN_or_homomorphism n :
- WeakMonoidHomomorphism bi_or bi_or (≡) (@sbi_laterN PROP n).
+Global Instance sbi_laterN_or_homomorphism `{FiniteBoundedExistential SI} n :
+ WeakMonoidHomomorphism bi_or bi_or (≡) (Nat.iter n (@sbi_later SI PROP)).
Proof. split; try apply _. apply laterN_or. Qed.
Global Instance sbi_except_0_or_homomorphism :
- WeakMonoidHomomorphism bi_or bi_or (≡) (@sbi_except_0 PROP).
+ WeakMonoidHomomorphism bi_or bi_or (≡) (@sbi_except_0 SI PROP).
Proof. split; try apply _. apply except_0_or. Qed.
-Global Instance sbi_later_monoid_sep_weak_homomorphism :
- WeakMonoidHomomorphism bi_sep bi_sep (≡) (@sbi_later PROP).
+Global Instance sbi_later_monoid_sep_weak_homomorphism `{FiniteIndex SI} :
+ WeakMonoidHomomorphism bi_sep bi_sep (≡) (@sbi_later SI PROP).
Proof. split; try apply _. apply later_sep. Qed.
-Global Instance sbi_laterN_sep_weak_homomorphism n :
- WeakMonoidHomomorphism bi_sep bi_sep (≡) (@sbi_laterN PROP n).
+Global Instance sbi_laterN_sep_weak_homomorphism `{FiniteIndex SI} n :
+ WeakMonoidHomomorphism bi_sep bi_sep (≡) (Nat.iter n (@sbi_later SI PROP)).
Proof. split; try apply _. apply laterN_sep. Qed.
Global Instance sbi_except_0_sep_weak_homomorphism :
- WeakMonoidHomomorphism bi_sep bi_sep (≡) (@sbi_except_0 PROP).
-Proof. split; try apply _. apply except_0_sep. Qed.
+ WeakMonoidHomomorphism bi_sep bi_sep (≡) (@sbi_except_0 SI PROP).
+Proof. split; try apply _. intros; by apply except_0_sep. Qed.
-Global Instance sbi_later_monoid_sep_homomorphism `{!BiAffine PROP} :
- MonoidHomomorphism bi_sep bi_sep (≡) (@sbi_later PROP).
+Global Instance sbi_later_monoid_sep_homomorphism `{FiniteIndex SI} `{!BiAffine PROP} :
+ MonoidHomomorphism bi_sep bi_sep (≡) (@sbi_later SI PROP).
Proof. split; try apply _. apply later_emp. Qed.
-Global Instance sbi_laterN_sep_homomorphism `{!BiAffine PROP} n :
- MonoidHomomorphism bi_sep bi_sep (≡) (@sbi_laterN PROP n).
+Global Instance sbi_laterN_sep_homomorphism `{FiniteIndex SI} `{!BiAffine PROP} n :
+ MonoidHomomorphism bi_sep bi_sep (≡) (Nat.iter n (@sbi_later SI PROP)).
Proof. split; try apply _. apply laterN_emp. Qed.
Global Instance sbi_except_0_sep_homomorphism `{!BiAffine PROP} :
- MonoidHomomorphism bi_sep bi_sep (≡) (@sbi_except_0 PROP).
+ MonoidHomomorphism bi_sep bi_sep (≡) (@sbi_except_0 SI PROP).
Proof. split; try apply _. apply except_0_emp. Qed.
Global Instance sbi_later_monoid_sep_entails_weak_homomorphism :
- WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_later PROP).
-Proof. split; try apply _. intros P Q. by rewrite later_sep. Qed.
+ WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_later SI PROP).
+Proof. split; try apply _. intros P Q. by rewrite later_sep_2. Qed.
Global Instance sbi_laterN_sep_entails_weak_homomorphism n :
- WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_laterN PROP n).
-Proof. split; try apply _. intros P Q. by rewrite laterN_sep. Qed.
+ WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (Nat.iter n (@sbi_later SI PROP)).
+Proof. split; try apply _. intros P Q. by rewrite laterN_sep_2. Qed.
Global Instance sbi_except_0_sep_entails_weak_homomorphism :
- WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_except_0 PROP).
+ WeakMonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_except_0 SI PROP).
Proof. split; try apply _. intros P Q. by rewrite except_0_sep. Qed.
Global Instance sbi_later_monoid_sep_entails_homomorphism :
- MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_later PROP).
+ MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_later SI PROP).
Proof. split; try apply _. apply later_intro. Qed.
Global Instance sbi_laterN_sep_entails_homomorphism n :
- MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_laterN PROP n).
+ MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (Nat.iter n (@sbi_later SI PROP)).
Proof. split; try apply _. apply laterN_intro. Qed.
Global Instance sbi_except_0_sep_entails_homomorphism :
- MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_except_0 PROP).
+ MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@sbi_except_0 SI PROP).
Proof. split; try apply _. apply except_0_intro. Qed.
End sbi_derived.
End bi.
diff --git a/theories/bi/embedding.v b/theories/bi/embedding.v
index 2410b808b75581e115f6bef5f54d57965b63c73e..94d0fb6be100cd074623722bbe9f1a4c958c0081 100644
--- a/theories/bi/embedding.v
+++ b/theories/bi/embedding.v
@@ -11,7 +11,7 @@ Hint Mode Embed ! - : typeclass_instances.
Hint Mode Embed - ! : typeclass_instances.
(* Mixins allow us to create instances easily without having to use Program *)
-Record BiEmbedMixin (PROP1 PROP2 : bi) `(Embed PROP1 PROP2) := {
+Record BiEmbedMixin {SI} (PROP1 PROP2 : bi SI) `(Embed PROP1 PROP2) := {
bi_embed_mixin_ne : NonExpansive (embed (A:=PROP1) (B:=PROP2));
bi_embed_mixin_mono : Proper ((⊢) ==> (⊢)) (embed (A:=PROP1) (B:=PROP2));
bi_embed_mixin_emp_valid_inj (P : PROP1) :
@@ -31,51 +31,51 @@ Record BiEmbedMixin (PROP1 PROP2 : bi) `(Embed PROP1 PROP2) := {
⎡<pers> P⎤ ⊣⊢@{PROP2} <pers> ⎡P⎤
}.
-Class BiEmbed (PROP1 PROP2 : bi) := {
+Class BiEmbed {SI} (PROP1 PROP2 : bi SI) := {
bi_embed_embed :> Embed PROP1 PROP2;
bi_embed_mixin : BiEmbedMixin PROP1 PROP2 bi_embed_embed;
}.
-Hint Mode BiEmbed ! - : typeclass_instances.
-Hint Mode BiEmbed - ! : typeclass_instances.
+Hint Mode BiEmbed - ! - : typeclass_instances.
+Hint Mode BiEmbed - - ! : typeclass_instances.
Arguments bi_embed_embed : simpl never.
-Class BiEmbedEmp (PROP1 PROP2 : bi) `{BiEmbed PROP1 PROP2} := {
+Class BiEmbedEmp {SI} (PROP1 PROP2 : bi SI) `{BiEmbed SI PROP1 PROP2} := {
embed_emp_1 : ⎡ emp : PROP1 ⎤ ⊢ emp;
}.
-Hint Mode BiEmbedEmp ! - - : typeclass_instances.
-Hint Mode BiEmbedEmp - ! - : typeclass_instances.
+Hint Mode BiEmbedEmp - ! - - : typeclass_instances.
+Hint Mode BiEmbedEmp - - ! - : typeclass_instances.
-Class SbiEmbed (PROP1 PROP2 : sbi) `{BiEmbed PROP1 PROP2} := {
- embed_internal_eq_1 (A : ofeT) (x y : A) : ⎡x ≡ y⎤ ⊢ x ≡ y;
+Class SbiEmbed {SI} (PROP1 PROP2 : sbi SI) `{BiEmbed SI PROP1 PROP2} := {
+ embed_internal_eq_1 (A : ofeT SI) (x y : A) : ⎡x ≡ y⎤ ⊢ x ≡ y;
embed_later P : ⎡▷ P⎤ ⊣⊢ ▷ ⎡P⎤;
- embed_interal_inj (PROP' : sbi) (P Q : PROP1) : ⎡P⎤ ≡ ⎡Q⎤ ⊢@{PROP'} (P ≡ Q);
+ embed_interal_inj (PROP' : sbi SI) (P Q : PROP1) : ⎡P⎤ ≡ ⎡Q⎤ ⊢@{PROP'} (P ≡ Q);
}.
-Hint Mode SbiEmbed ! - - : typeclass_instances.
-Hint Mode SbiEmbed - ! - : typeclass_instances.
+Hint Mode SbiEmbed - ! - - : typeclass_instances.
+Hint Mode SbiEmbed - - ! - : typeclass_instances.
-Class BiEmbedBUpd (PROP1 PROP2 : bi)
- `{BiEmbed PROP1 PROP2, BiBUpd PROP1, BiBUpd PROP2} := {
+Class BiEmbedBUpd {SI} (PROP1 PROP2 : bi SI)
+ `{BiEmbed SI PROP1 PROP2, BiBUpd SI PROP1, BiBUpd SI PROP2} := {
embed_bupd P : ⎡|==> P⎤ ⊣⊢@{PROP2} |==> ⎡P⎤
}.
-Hint Mode BiEmbedBUpd - ! - - - : typeclass_instances.
-Hint Mode BiEmbedBUpd ! - - - - : typeclass_instances.
+Hint Mode BiEmbedBUpd - - ! - - - : typeclass_instances.
+Hint Mode BiEmbedBUpd - ! - - - - : typeclass_instances.
-Class BiEmbedFUpd (PROP1 PROP2 : sbi)
- `{BiEmbed PROP1 PROP2, BiFUpd PROP1, BiFUpd PROP2} := {
+Class BiEmbedFUpd {SI} (PROP1 PROP2 : sbi SI)
+ `{BiEmbed SI PROP1 PROP2, BiFUpd SI PROP1, BiFUpd SI PROP2} := {
embed_fupd E1 E2 P : ⎡|={E1,E2}=> P⎤ ⊣⊢@{PROP2} |={E1,E2}=> ⎡P⎤
}.
-Hint Mode BiEmbedFUpd - ! - - - : typeclass_instances.
-Hint Mode BiEmbedFUpd ! - - - - : typeclass_instances.
+Hint Mode BiEmbedFUpd - - ! - - - : typeclass_instances.
+Hint Mode BiEmbedFUpd - ! - - - - : typeclass_instances.
-Class BiEmbedPlainly (PROP1 PROP2 : sbi)
- `{BiEmbed PROP1 PROP2, BiPlainly PROP1, BiPlainly PROP2} := {
+Class BiEmbedPlainly {SI} (PROP1 PROP2 : sbi SI)
+ `{BiEmbed SI PROP1 PROP2, BiPlainly SI PROP1, BiPlainly SI PROP2} := {
embed_plainly_2 (P : PROP1) : ■⎡P⎤ ⊢ (⎡■P⎤ : PROP2)
}.
-Hint Mode BiEmbedPlainly - ! - - - : typeclass_instances.
-Hint Mode BiEmbedPlainly ! - - - - : typeclass_instances.
+Hint Mode BiEmbedPlainly - - ! - - - : typeclass_instances.
+Hint Mode BiEmbedPlainly - ! - - - - : typeclass_instances.
Section embed_laws.
- Context `{BiEmbed PROP1 PROP2}.
+ Context {SI} `{BiEmbed SI PROP1 PROP2}.
Local Notation embed := (embed (A:=PROP1) (B:=PROP2)).
Local Notation "⎡ P ⎤" := (embed P) : bi_scope.
Implicit Types P : PROP1.
@@ -84,7 +84,7 @@ Section embed_laws.
Proof. eapply bi_embed_mixin_ne, bi_embed_mixin. Qed.
Global Instance embed_mono : Proper ((⊢) ==> (⊢)) embed.
Proof. eapply bi_embed_mixin_mono, bi_embed_mixin. Qed.
- Lemma embed_emp_valid_inj P : (⎡P⎤ : PROP2)%I → P.
+ Lemma embed_emp_valid_inj P : (bi_emp_valid ⎡P⎤)%I → bi_emp_valid P.
Proof. eapply bi_embed_mixin_emp_valid_inj, bi_embed_mixin. Qed.
Lemma embed_emp_2 : emp ⊢ ⎡emp⎤.
Proof. eapply bi_embed_mixin_emp_2, bi_embed_mixin. Qed.
@@ -103,7 +103,7 @@ Section embed_laws.
End embed_laws.
Section embed.
- Context `{BiEmbed PROP1 PROP2}.
+ Context `{BiEmbed SI PROP1 PROP2}.
Local Notation embed := (embed (A:=PROP1) (B:=PROP2)).
Local Notation "⎡ P ⎤" := (embed P) : bi_scope.
Implicit Types P Q R : PROP1.
@@ -123,7 +123,7 @@ Section embed.
intros P Q EQ. apply bi.equiv_spec, conj; apply (inj embed); rewrite EQ //.
Qed.
- Lemma embed_emp_valid (P : PROP1) : ⎡P⎤%I ↔ P.
+ Lemma embed_emp_valid (P : PROP1) : (bi_emp_valid ⎡P⎤%I) ↔ (bi_emp_valid P).
Proof.
rewrite /bi_emp_valid. split=> HP.
- by apply embed_emp_valid_inj.
@@ -159,7 +159,7 @@ Section embed.
Qed.
Lemma embed_pure φ : ⎡⌜φâŒâŽ¤ ⊣⊢ ⌜φâŒ.
Proof.
- rewrite (@bi.pure_alt PROP1) (@bi.pure_alt PROP2) embed_exist.
+ rewrite (@bi.pure_alt SI PROP1) (@bi.pure_alt SI PROP2) embed_exist.
do 2 f_equiv. apply bi.equiv_spec. split; [apply bi.True_intro|].
rewrite -(_ : (emp → emp : PROP1) ⊢ True) ?embed_impl;
last apply bi.True_intro.
@@ -262,10 +262,10 @@ Section embed.
End embed.
Section sbi_embed.
- Context `{SbiEmbed PROP1 PROP2}.
+ Context `{SbiEmbed SI PROP1 PROP2}.
Implicit Types P Q R : PROP1.
- Lemma embed_internal_eq (A : ofeT) (x y : A) : ⎡x ≡ y⎤ ⊣⊢ x ≡ y.
+ Lemma embed_internal_eq (A : ofeT SI) (x y : A) : ⎡x ≡ y⎤ ⊣⊢ x ≡ y.
Proof.
apply bi.equiv_spec; split; [apply embed_internal_eq_1|].
etrans; [apply (bi.internal_eq_rewrite x y (λ y, ⎡x ≡ y⎤%I)); solve_proper|].
diff --git a/theories/bi/interface.v b/theories/bi/interface.v
index 3d3ea3b860ff401c580599f2f18074f3f8b8e6bc..189e3d5f37b9f70ceec89b0f737a3d2da1dedc14 100644
--- a/theories/bi/interface.v
+++ b/theories/bi/interface.v
@@ -3,7 +3,7 @@ From iris.bi Require Export notation.
Set Primitive Projections.
Section bi_mixin.
- Context {PROP : Type} `{Dist PROP, Equiv PROP}.
+ Context {SI: indexT} {PROP : Type} `{Dist SI PROP, Equiv PROP}.
Context (bi_entails : PROP → PROP → Prop).
Context (bi_emp : PROP).
Context (bi_pure : Prop → PROP).
@@ -15,7 +15,7 @@ Section bi_mixin.
Context (bi_sep : PROP → PROP → PROP).
Context (bi_wand : PROP → PROP → PROP).
Context (bi_persistently : PROP → PROP).
- Context (sbi_internal_eq : ∀ A : ofeT, A → A → PROP).
+ Context (sbi_internal_eq : ∀ A : ofeT SI, A → A → PROP).
Context (sbi_later : PROP → PROP).
Local Infix "⊢" := bi_entails.
@@ -119,27 +119,29 @@ Section bi_mixin.
Record SbiMixin := {
sbi_mixin_later_contractive : Contractive sbi_later;
- sbi_mixin_internal_eq_ne (A : ofeT) : NonExpansive2 (sbi_internal_eq A);
+ sbi_mixin_internal_eq_ne (A : ofeT SI) : NonExpansive2 (sbi_internal_eq A);
(* Equality *)
- sbi_mixin_internal_eq_refl {A : ofeT} P (a : A) : P ⊢ a ≡ a;
- sbi_mixin_internal_eq_rewrite {A : ofeT} a b (Ψ : A → PROP) :
+ sbi_mixin_internal_eq_refl {A : ofeT SI} P (a : A) : P ⊢ a ≡ a;
+ sbi_mixin_internal_eq_rewrite {A : ofeT SI} a b (Ψ : A → PROP) :
NonExpansive Ψ → a ≡ b ⊢ Ψ a → Ψ b;
- sbi_mixin_fun_ext {A} {B : A → ofeT} (f g : discrete_fun B) : (∀ x, f x ≡ g x) ⊢ f ≡ g;
- sbi_mixin_sig_eq {A : ofeT} (P : A → Prop) (x y : sig P) : `x ≡ `y ⊢ x ≡ y;
- sbi_mixin_discrete_eq_1 {A : ofeT} (a b : A) : Discrete a → a ≡ b ⊢ ⌜a ≡ bâŒ;
+ sbi_mixin_fun_ext {A} {B : A → ofeT SI} (f g : discrete_fun B) : (∀ x, f x ≡ g x) ⊢ f ≡ g;
+ sbi_mixin_sig_eq {A : ofeT SI} (P : A → Prop) (x y : sig P) : `x ≡ `y ⊢ x ≡ y;
+ sbi_mixin_discrete_eq_1 {A : ofeT SI} (a b : A) : Discrete a → a ≡ b ⊢ ⌜a ≡ bâŒ;
(* Later *)
- sbi_mixin_later_eq_1 {A : ofeT} (x y : A) : Next x ≡ Next y ⊢ ▷ (x ≡ y);
- sbi_mixin_later_eq_2 {A : ofeT} (x y : A) : ▷ (x ≡ y) ⊢ Next x ≡ Next y;
+ sbi_mixin_later_eq_1 {A : ofeT SI} (x y : A) : Next x ≡ Next y ⊢ ▷ (x ≡ y);
+ sbi_mixin_later_eq_2 {A : ofeT SI} (x y : A) : ▷ (x ≡ y) ⊢ Next x ≡ Next y;
sbi_mixin_later_mono P Q : (P ⊢ Q) → ▷ P ⊢ ▷ Q;
sbi_mixin_later_intro P : P ⊢ ▷ P;
sbi_mixin_later_forall_2 {A} (Φ : A → PROP) : (∀ a, ▷ Φ a) ⊢ ▷ ∀ a, Φ a;
- sbi_mixin_later_exist_false {A} (Φ : A → PROP) :
+ sbi_mixin_later_exist_false `{FiniteIndex SI} {A} (Φ : A → PROP) :
(▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a);
- sbi_mixin_later_sep_1 P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q;
+ sbi_mixin_later_finite_exist_false `{FiniteBoundedExistential SI} {A} (Φ : A → PROP) (Q: A → Prop):
+ pred_finite Q → (∀ a, Φ a ⊢ ⌜Q aâŒ) → (â–· ∃ a, Φ a) ⊢ â–· False ∨ (∃ a, â–· Φ a);
+ sbi_mixin_later_sep_1 `{FiniteIndex SI} P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q;
sbi_mixin_later_sep_2 P Q : ▷ P ∗ ▷ Q ⊢ ▷ (P ∗ Q);
sbi_mixin_later_persistently_1 P : ▷ <pers> P ⊢ <pers> ▷ P;
sbi_mixin_later_persistently_2 P : <pers> ▷ P ⊢ ▷ <pers> P;
@@ -148,9 +150,9 @@ Section bi_mixin.
}.
End bi_mixin.
-Structure bi := Bi {
+Structure bi (SI: indexT) := Bi {
bi_car :> Type;
- bi_dist : Dist bi_car;
+ bi_dist : Dist SI bi_car;
bi_equiv : Equiv bi_car;
bi_entails : bi_car → bi_car → Prop;
bi_emp : bi_car;
@@ -163,44 +165,44 @@ Structure bi := Bi {
bi_sep : bi_car → bi_car → bi_car;
bi_wand : bi_car → bi_car → bi_car;
bi_persistently : bi_car → bi_car;
- bi_ofe_mixin : OfeMixin bi_car;
+ bi_ofe_mixin : OfeMixin SI bi_car;
bi_bi_mixin : BiMixin bi_entails bi_emp bi_pure bi_and bi_or bi_impl bi_forall
bi_exist bi_sep bi_wand bi_persistently;
}.
-Coercion bi_ofeO (PROP : bi) : ofeT := OfeT PROP (bi_ofe_mixin PROP).
+Coercion bi_ofeO `(PROP : bi SI) : ofeT SI := OfeT PROP (bi_ofe_mixin SI PROP).
Canonical Structure bi_ofeO.
-Instance: Params (@bi_entails) 1 := {}.
-Instance: Params (@bi_emp) 1 := {}.
-Instance: Params (@bi_pure) 1 := {}.
-Instance: Params (@bi_and) 1 := {}.
-Instance: Params (@bi_or) 1 := {}.
-Instance: Params (@bi_impl) 1 := {}.
-Instance: Params (@bi_forall) 2 := {}.
-Instance: Params (@bi_exist) 2 := {}.
-Instance: Params (@bi_sep) 1 := {}.
-Instance: Params (@bi_wand) 1 := {}.
-Instance: Params (@bi_persistently) 1 := {}.
-
-Arguments bi_car : simpl never.
-Arguments bi_dist : simpl never.
-Arguments bi_equiv : simpl never.
-Arguments bi_entails {PROP} _%I _%I : simpl never, rename.
-Arguments bi_emp {PROP} : simpl never, rename.
-Arguments bi_pure {PROP} _%stdpp : simpl never, rename.
-Arguments bi_and {PROP} _%I _%I : simpl never, rename.
-Arguments bi_or {PROP} _%I _%I : simpl never, rename.
-Arguments bi_impl {PROP} _%I _%I : simpl never, rename.
-Arguments bi_forall {PROP _} _%I : simpl never, rename.
-Arguments bi_exist {PROP _} _%I : simpl never, rename.
-Arguments bi_sep {PROP} _%I _%I : simpl never, rename.
-Arguments bi_wand {PROP} _%I _%I : simpl never, rename.
-Arguments bi_persistently {PROP} _%I : simpl never, rename.
-
-Structure sbi := Sbi {
+Instance: Params (@bi_entails) 2 := {}.
+Instance: Params (@bi_emp) 2 := {}.
+Instance: Params (@bi_pure) 2 := {}.
+Instance: Params (@bi_and) 2 := {}.
+Instance: Params (@bi_or) 2 := {}.
+Instance: Params (@bi_impl) 2 := {}.
+Instance: Params (@bi_forall) 3 := {}.
+Instance: Params (@bi_exist) 3 := {}.
+Instance: Params (@bi_sep) 2 := {}.
+Instance: Params (@bi_wand) 2 := {}.
+Instance: Params (@bi_persistently) 2 := {}.
+
+Arguments bi_car {_}: simpl never.
+Arguments bi_dist {_}: simpl never.
+Arguments bi_equiv {_}: simpl never.
+Arguments bi_entails {_ PROP} _%I _%I : simpl never, rename.
+Arguments bi_emp {_ PROP} : simpl never, rename.
+Arguments bi_pure {_ PROP} _%stdpp : simpl never, rename.
+Arguments bi_and {_ PROP} _%I _%I : simpl never, rename.
+Arguments bi_or {_ PROP} _%I _%I : simpl never, rename.
+Arguments bi_impl {_ PROP} _%I _%I : simpl never, rename.
+Arguments bi_forall {_ PROP _} _%I : simpl never, rename.
+Arguments bi_exist {_ PROP _} _%I : simpl never, rename.
+Arguments bi_sep {_ PROP} _%I _%I : simpl never, rename.
+Arguments bi_wand {_ PROP} _%I _%I : simpl never, rename.
+Arguments bi_persistently {_ PROP} _%I : simpl never, rename.
+
+Structure sbi (I: indexT) := Sbi {
sbi_car :> Type;
- sbi_dist : Dist sbi_car;
+ sbi_dist : Dist I sbi_car;
sbi_equiv : Equiv sbi_car;
sbi_entails : sbi_car → sbi_car → Prop;
sbi_emp : sbi_car;
@@ -213,9 +215,9 @@ Structure sbi := Sbi {
sbi_sep : sbi_car → sbi_car → sbi_car;
sbi_wand : sbi_car → sbi_car → sbi_car;
sbi_persistently : sbi_car → sbi_car;
- sbi_internal_eq : ∀ A : ofeT, A → A → sbi_car;
+ sbi_internal_eq : ∀ A : ofeT I, A → A → sbi_car;
sbi_later : sbi_car → sbi_car;
- sbi_ofe_mixin : OfeMixin sbi_car;
+ sbi_ofe_mixin : OfeMixin I sbi_car;
sbi_cofe : Cofe (OfeT sbi_car sbi_ofe_mixin);
sbi_bi_mixin : BiMixin sbi_entails sbi_emp sbi_pure sbi_and sbi_or sbi_impl
sbi_forall sbi_exist sbi_sep sbi_wand sbi_persistently;
@@ -224,40 +226,40 @@ Structure sbi := Sbi {
sbi_persistently sbi_internal_eq sbi_later;
}.
-Instance: Params (@sbi_later) 1 := {}.
-Instance: Params (@sbi_internal_eq) 1 := {}.
+Instance: Params (@sbi_later) 2 := {}.
+Instance: Params (@sbi_internal_eq) 2 := {}.
-Arguments sbi_later {PROP} _%I : simpl never, rename.
-Arguments sbi_internal_eq {PROP _} _ _ : simpl never, rename.
+Arguments sbi_later {_ PROP} _%I : simpl never, rename.
+Arguments sbi_internal_eq {_ PROP _} _ _ : simpl never, rename.
-Coercion sbi_ofeO (PROP : sbi) : ofeT := OfeT PROP (sbi_ofe_mixin PROP).
+Coercion sbi_ofeO {I: indexT} (PROP : sbi I) : ofeT I := OfeT PROP (sbi_ofe_mixin I PROP).
Canonical Structure sbi_ofeO.
-Coercion sbi_bi (PROP : sbi) : bi :=
- {| bi_ofe_mixin := sbi_ofe_mixin PROP; bi_bi_mixin := sbi_bi_mixin PROP |}.
+Coercion sbi_bi `(PROP : sbi SI) : bi SI :=
+ {| bi_ofe_mixin := sbi_ofe_mixin SI PROP; bi_bi_mixin := sbi_bi_mixin SI PROP |}.
Canonical Structure sbi_bi.
-Global Instance sbi_cofe' (PROP : sbi) : Cofe PROP.
+Global Instance sbi_cofe' `(PROP : sbi SI) : Cofe PROP.
Proof. apply sbi_cofe. Qed.
-Arguments sbi_car : simpl never.
-Arguments sbi_dist : simpl never.
-Arguments sbi_equiv : simpl never.
-Arguments sbi_entails {PROP} _%I _%I : simpl never, rename.
-Arguments sbi_emp {PROP} : simpl never, rename.
-Arguments sbi_pure {PROP} _%stdpp : simpl never, rename.
-Arguments sbi_and {PROP} _%I _%I : simpl never, rename.
-Arguments sbi_or {PROP} _%I _%I : simpl never, rename.
-Arguments sbi_impl {PROP} _%I _%I : simpl never, rename.
-Arguments sbi_forall {PROP _} _%I : simpl never, rename.
-Arguments sbi_exist {PROP _} _%I : simpl never, rename.
-Arguments sbi_sep {PROP} _%I _%I : simpl never, rename.
-Arguments sbi_wand {PROP} _%I _%I : simpl never, rename.
-Arguments sbi_persistently {PROP} _%I : simpl never, rename.
-Arguments sbi_internal_eq {PROP _} _ _ : simpl never, rename.
-Arguments sbi_later {PROP} _%I : simpl never, rename.
+Arguments sbi_car {_} : simpl never.
+Arguments sbi_dist {_} : simpl never.
+Arguments sbi_equiv {_} : simpl never.
+Arguments sbi_entails {_ PROP} _%I _%I : simpl never, rename.
+Arguments sbi_emp {_ PROP} : simpl never, rename.
+Arguments sbi_pure {_ PROP} _%stdpp : simpl never, rename.
+Arguments sbi_and {_ PROP} _%I _%I : simpl never, rename.
+Arguments sbi_or {_ PROP} _%I _%I : simpl never, rename.
+Arguments sbi_impl {_ PROP} _%I _%I : simpl never, rename.
+Arguments sbi_forall {_ PROP _} _%I : simpl never, rename.
+Arguments sbi_exist {_ PROP _} _%I : simpl never, rename.
+Arguments sbi_sep {_ PROP} _%I _%I : simpl never, rename.
+Arguments sbi_wand {_ PROP} _%I _%I : simpl never, rename.
+Arguments sbi_persistently {_ PROP} _%I : simpl never, rename.
+Arguments sbi_internal_eq {_ PROP _} _ _ : simpl never, rename.
+Arguments sbi_later {_ PROP} _%I : simpl never, rename.
Hint Extern 0 (bi_entails _ _) => reflexivity : core.
-Instance bi_rewrite_relation (PROP : bi) : RewriteRelation (@bi_entails PROP) := {}.
-Instance bi_inhabited {PROP : bi} : Inhabited PROP := populate (bi_pure True).
+Instance bi_rewrite_relation `(PROP : bi SI) : RewriteRelation (@bi_entails SI PROP) := {}.
+Instance bi_inhabited `{PROP : bi SI} : Inhabited PROP := populate (bi_pure True).
Notation "P ⊢ Q" := (bi_entails P%I Q%I) : stdpp_scope.
Notation "P ⊢@{ PROP } Q" := (bi_entails (PROP:=PROP) P%I Q%I) (only parsing) : stdpp_scope.
@@ -291,46 +293,53 @@ Notation "'<pers>' P" := (bi_persistently P) : bi_scope.
Infix "≡" := sbi_internal_eq : bi_scope.
Notation "â–· P" := (sbi_later P) : bi_scope.
-
-Coercion bi_emp_valid {PROP : bi} (P : PROP) : Prop := emp ⊢ P.
-Coercion sbi_emp_valid {PROP : sbi} : PROP → Prop := bi_emp_valid.
-
-Arguments bi_emp_valid {_} _%I : simpl never.
+Notation "â–·^ n P" := (Nat.iter n sbi_later P) : bi_scope.
+Notation "â–·? p P" := (Nat.iter (Nat.b2n p) sbi_later P) : bi_scope.
+Notation "⧠P" := (∃ n, ▷^n P)%I.
+Notation "â§^ n P" := (Nat.iter n (λ Q, ⧠Q) P)%I.
+
+Definition bi_emp_valid {SI: indexT} {PROP : bi SI} (P : PROP) : Prop := emp ⊢ P.
+Definition sbi_emp_valid `{PROP : sbi SI} : PROP → Prop := bi_emp_valid.
+Arguments bi_emp_valid {_ _} _%I : simpl never.
Typeclasses Opaque bi_emp_valid.
+(*NOTE: backported from current iris *)
+Notation "⊢ Q" := (bi_emp_valid Q%I) : stdpp_scope.
+Notation "'⊢@{' PROP } Q" := (bi_emp_valid (PROP:=PROP) Q%I) (only parsing) : stdpp_scope.
+
Module bi.
Section bi_laws.
-Context {PROP : bi}.
+Context `{PROP : bi SI}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types A : Type.
(* About the entailment *)
-Global Instance entails_po : PreOrder (@bi_entails PROP).
+Global Instance entails_po : PreOrder (@bi_entails SI PROP).
Proof. eapply bi_mixin_entails_po, bi_bi_mixin. Qed.
Lemma equiv_spec P Q : P ≡ Q ↔ (P ⊢ Q) ∧ (Q ⊢ P).
Proof. eapply bi_mixin_equiv_spec, bi_bi_mixin. Qed.
(* Non-expansiveness *)
-Global Instance pure_ne n : Proper (iff ==> dist n) (@bi_pure PROP).
+Global Instance pure_ne n : Proper (iff ==> dist n) (@bi_pure SI PROP).
Proof. eapply bi_mixin_pure_ne, bi_bi_mixin. Qed.
-Global Instance and_ne : NonExpansive2 (@bi_and PROP).
+Global Instance and_ne : NonExpansive2 (@bi_and SI PROP).
Proof. eapply bi_mixin_and_ne, bi_bi_mixin. Qed.
-Global Instance or_ne : NonExpansive2 (@bi_or PROP).
+Global Instance or_ne : NonExpansive2 (@bi_or SI PROP).
Proof. eapply bi_mixin_or_ne, bi_bi_mixin. Qed.
-Global Instance impl_ne : NonExpansive2 (@bi_impl PROP).
+Global Instance impl_ne : NonExpansive2 (@bi_impl SI PROP).
Proof. eapply bi_mixin_impl_ne, bi_bi_mixin. Qed.
Global Instance forall_ne A n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_forall PROP A).
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_forall SI PROP A).
Proof. eapply bi_mixin_forall_ne, bi_bi_mixin. Qed.
Global Instance exist_ne A n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_exist PROP A).
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_exist SI PROP A).
Proof. eapply bi_mixin_exist_ne, bi_bi_mixin. Qed.
-Global Instance sep_ne : NonExpansive2 (@bi_sep PROP).
+Global Instance sep_ne : NonExpansive2 (@bi_sep SI PROP).
Proof. eapply bi_mixin_sep_ne, bi_bi_mixin. Qed.
-Global Instance wand_ne : NonExpansive2 (@bi_wand PROP).
+Global Instance wand_ne : NonExpansive2 (@bi_wand SI PROP).
Proof. eapply bi_mixin_wand_ne, bi_bi_mixin. Qed.
-Global Instance persistently_ne : NonExpansive (@bi_persistently PROP).
+Global Instance persistently_ne : NonExpansive (@bi_persistently SI PROP).
Proof. eapply bi_mixin_persistently_ne, bi_bi_mixin. Qed.
(* Higher-order logic *)
@@ -409,37 +418,37 @@ Proof. eapply (bi_mixin_persistently_and_sep_elim bi_entails), bi_bi_mixin. Qed.
End bi_laws.
Section sbi_laws.
-Context {PROP : sbi}.
+Context `{PROP : sbi SI}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
(* Equality *)
-Global Instance internal_eq_ne (A : ofeT) : NonExpansive2 (@sbi_internal_eq PROP A).
+Global Instance internal_eq_ne (A : ofeT SI) : NonExpansive2 (@sbi_internal_eq SI PROP A).
Proof. eapply sbi_mixin_internal_eq_ne, sbi_sbi_mixin. Qed.
-Lemma internal_eq_refl {A : ofeT} P (a : A) : P ⊢ a ≡ a.
+Lemma internal_eq_refl {A : ofeT SI} P (a : A) : P ⊢ a ≡ a.
Proof. eapply sbi_mixin_internal_eq_refl, sbi_sbi_mixin. Qed.
-Lemma internal_eq_rewrite {A : ofeT} a b (Ψ : A → PROP) :
+Lemma internal_eq_rewrite {A : ofeT SI} a b (Ψ : A → PROP) :
NonExpansive Ψ → a ≡ b ⊢ Ψ a → Ψ b.
Proof. eapply sbi_mixin_internal_eq_rewrite, sbi_sbi_mixin. Qed.
-Lemma fun_ext {A} {B : A → ofeT} (f g : discrete_fun B) :
+Lemma fun_ext {A} {B : A → ofeT SI} (f g : discrete_fun B) :
(∀ x, f x ≡ g x) ⊢@{PROP} f ≡ g.
Proof. eapply sbi_mixin_fun_ext, sbi_sbi_mixin. Qed.
-Lemma sig_eq {A : ofeT} (P : A → Prop) (x y : sig P) :
+Lemma sig_eq {A : ofeT SI} (P : A → Prop) (x y : sig P) :
`x ≡ `y ⊢@{PROP} x ≡ y.
Proof. eapply sbi_mixin_sig_eq, sbi_sbi_mixin. Qed.
-Lemma discrete_eq_1 {A : ofeT} (a b : A) :
+Lemma discrete_eq_1 {A : ofeT SI} (a b : A) :
Discrete a → a ≡ b ⊢@{PROP} ⌜a ≡ bâŒ.
Proof. eapply sbi_mixin_discrete_eq_1, sbi_sbi_mixin. Qed.
(* Later *)
-Global Instance later_contractive : Contractive (@sbi_later PROP).
+Global Instance later_contractive : Contractive (@sbi_later SI PROP).
Proof. eapply sbi_mixin_later_contractive, sbi_sbi_mixin. Qed.
-Lemma later_eq_1 {A : ofeT} (x y : A) : Next x ≡ Next y ⊢@{PROP} ▷ (x ≡ y).
+Lemma later_eq_1 {A : ofeT SI} (x y : A) : Next x ≡ Next y ⊢@{PROP} ▷ (x ≡ y).
Proof. eapply sbi_mixin_later_eq_1, sbi_sbi_mixin. Qed.
-Lemma later_eq_2 {A : ofeT} (x y : A) : ▷ (x ≡ y) ⊢@{PROP} Next x ≡ Next y.
+Lemma later_eq_2 {A : ofeT SI} (x y : A) : ▷ (x ≡ y) ⊢@{PROP} Next x ≡ Next y.
Proof. eapply sbi_mixin_later_eq_2, sbi_sbi_mixin. Qed.
Lemma later_mono P Q : (P ⊢ Q) → ▷ P ⊢ ▷ Q.
@@ -449,11 +458,14 @@ Proof. eapply sbi_mixin_later_intro, sbi_sbi_mixin. Qed.
Lemma later_forall_2 {A} (Φ : A → PROP) : (∀ a, ▷ Φ a) ⊢ ▷ ∀ a, Φ a.
Proof. eapply sbi_mixin_later_forall_2, sbi_sbi_mixin. Qed.
-Lemma later_exist_false {A} (Φ : A → PROP) :
+Lemma later_exist_false `{FiniteIndex SI} {A} (Φ : A → PROP) :
(▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a).
-Proof. eapply sbi_mixin_later_exist_false, sbi_sbi_mixin. Qed.
-Lemma later_sep_1 P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q.
-Proof. eapply sbi_mixin_later_sep_1, sbi_sbi_mixin. Qed.
+Proof. eapply sbi_mixin_later_exist_false; eauto; eapply sbi_sbi_mixin. Qed.
+Lemma later_finite_exist_false `{FiniteBoundedExistential SI} {A} (Φ : A → PROP) (Q: A → Prop):
+ pred_finite Q → (∀ a, Φ a ⊢ ⌜Q aâŒ) → (â–· ∃ a, Φ a) ⊢ â–· False ∨ (∃ a, â–· Φ a).
+Proof. eapply sbi_mixin_later_finite_exist_false; eauto; eapply sbi_sbi_mixin. Qed.
+Lemma later_sep_1 `{FiniteIndex SI} P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q.
+Proof. eapply sbi_mixin_later_sep_1; eauto; eapply sbi_sbi_mixin. Qed.
Lemma later_sep_2 P Q : ▷ P ∗ ▷ Q ⊢ ▷ (P ∗ Q).
Proof. eapply sbi_mixin_later_sep_2, sbi_sbi_mixin. Qed.
Lemma later_persistently_1 P : ▷ <pers> P ⊢ <pers> ▷ P.
diff --git a/theories/bi/lib/atomic.v b/theories/bi/lib/atomic.v
deleted file mode 100644
index bcfc613bc11b66dbe7ba73c3a08c3e23d57d5f16..0000000000000000000000000000000000000000
--- a/theories/bi/lib/atomic.v
+++ /dev/null
@@ -1,461 +0,0 @@
-From iris.bi Require Export bi updates laterable.
-From iris.bi.lib Require Import fixpoint.
-From stdpp Require Import coPset namespaces.
-From iris.proofmode Require Import coq_tactics tactics reduction.
-Set Default Proof Using "Type".
-
-(** Conveniently split a conjunction on both assumption and conclusion. *)
-Local Tactic Notation "iSplitWith" constr(H) :=
- iApply (bi.and_parallel with H); iSplit; iIntros H.
-
-Section definition.
- Context `{BiFUpd PROP} {TA TB : tele}.
- Implicit Types
- (Eo Ei : coPset) (* outer/inner masks *)
- (α : TA → PROP) (* atomic pre-condition *)
- (P : PROP) (* abortion condition *)
- (β : TA → TB → PROP) (* atomic post-condition *)
- (Φ : TA → TB → PROP) (* post-condition *)
- .
-
- (** atomic_acc as the "introduction form" of atomic updates: An accessor
- that can be aborted back to [P]. *)
- Definition atomic_acc Eo Ei α P β Φ : PROP :=
- (|={Eo, Ei}=> ∃.. x, α x ∗
- ((α x ={Ei, Eo}=∗ P) ∧ (∀.. y, β x y ={Ei, Eo}=∗ Φ x y))
- )%I.
-
- Lemma atomic_acc_wand Eo Ei α P1 P2 β Φ1 Φ2 :
- ((P1 -∗ P2) ∧ (∀.. x y, Φ1 x y -∗ Φ2 x y)) -∗
- (atomic_acc Eo Ei α P1 β Φ1 -∗ atomic_acc Eo Ei α P2 β Φ2).
- Proof.
- iIntros "HP12 AS". iMod "AS" as (x) "[Hα Hclose]".
- iModIntro. iExists x. iFrame "Hα". iSplit.
- - iIntros "Hα". iDestruct "Hclose" as "[Hclose _]".
- iApply "HP12". iApply "Hclose". done.
- - iIntros (y) "Hβ". iDestruct "Hclose" as "[_ Hclose]".
- iApply "HP12". iApply "Hclose". done.
- Qed.
-
- Lemma atomic_acc_mask Eo Ed α P β Φ :
- atomic_acc Eo (Eo∖Ed) α P β Φ ⊣⊢ ∀ E, ⌜Eo ⊆ E⌠→ atomic_acc E (E∖Ed) α P β Φ.
- Proof.
- iSplit; last first.
- { iIntros "Hstep". iApply ("Hstep" with "[% //]"). }
- iIntros "Hstep" (E HE).
- iApply (fupd_mask_frame_acc with "Hstep"); first done.
- iIntros "Hstep". iDestruct "Hstep" as (x) "[Hα Hclose]".
- iIntros "!> Hclose'".
- iExists x. iFrame. iSplitWith "Hclose".
- - iIntros "Hα". iApply "Hclose'". iApply "Hclose". done.
- - iIntros (y) "Hβ". iApply "Hclose'". iApply "Hclose". done.
- Qed.
-
- Lemma atomic_acc_mask_weaken Eo1 Eo2 Ei α P β Φ :
- Eo1 ⊆ Eo2 →
- atomic_acc Eo1 Ei α P β Φ -∗ atomic_acc Eo2 Ei α P β Φ.
- Proof.
- iIntros (HE) "Hstep".
- iMod fupd_intro_mask' as "Hclose1"; first done.
- iMod "Hstep" as (x) "[Hα Hclose2]". iIntros "!>". iExists x.
- iFrame. iSplitWith "Hclose2".
- - iIntros "Hα". iMod ("Hclose2" with "Hα") as "$". done.
- - iIntros (y) "Hβ". iMod ("Hclose2" with "Hβ") as "$". done.
- Qed.
-
- (** atomic_update as a fixed-point of the equation
- AU = make_laterable $ atomic_acc α AU β Q
- *)
- Context Eo Ei α β Φ.
-
- Definition atomic_update_pre (Ψ : () → PROP) (_ : ()) : PROP :=
- make_laterable $ atomic_acc Eo Ei α (Ψ ()) β Φ.
-
- Local Instance atomic_update_pre_mono : BiMonoPred atomic_update_pre.
- Proof.
- constructor.
- - iIntros (P1 P2) "#HP12". iIntros ([]) "AU".
- iApply (make_laterable_wand with "[] AU").
- iIntros "!# AA". iApply (atomic_acc_wand with "[HP12] AA").
- iSplit; last by eauto. iApply "HP12".
- - intros ??. solve_proper.
- Qed.
-
- Definition atomic_update_def :=
- bi_greatest_fixpoint atomic_update_pre ().
-
-End definition.
-
-(** Seal it *)
-Definition atomic_update_aux : seal (@atomic_update_def). by eexists. Qed.
-Definition atomic_update `{BiFUpd PROP} {TA TB : tele} := atomic_update_aux.(unseal) PROP _ TA TB.
-Definition atomic_update_eq :
- @atomic_update = @atomic_update_def := atomic_update_aux.(seal_eq).
-
-Arguments atomic_acc {PROP _ TA TB} Eo Ei _ _ _ _ : simpl never.
-Arguments atomic_update {PROP _ TA TB} Eo Ei _ _ _ : simpl never.
-
-(** Notation: Atomic updates *)
-Notation "'AU' '<<' ∀ x1 .. xn , α '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
- (atomic_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
- (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- Eo Ei
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, α%I) ..)
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, β%I) .. )
- ) .. )
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, Φ%I) .. )
- ) .. )
- )
- (at level 20, Eo, Ei, α, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder,
- format "'[ ' 'AU' '<<' ∀ x1 .. xn , α '>>' '/' @ Eo , Ei '/' '[ ' '<<' ∃ y1 .. yn , β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-Notation "'AU' '<<' ∀ x1 .. xn , α '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
- (atomic_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
- (TB:=TeleO)
- Eo Ei
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, α%I) ..)
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, tele_app (TT:=TeleO) β%I) .. )
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, tele_app (TT:=TeleO) Φ%I) .. )
- )
- (at level 20, Eo, Ei, α, β, Φ at level 200, x1 binder, xn binder,
- format "'[ ' 'AU' '<<' ∀ x1 .. xn , α '>>' '/' @ Eo , Ei '/' '[ ' '<<' β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-Notation "'AU' '<<' α '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
- (atomic_update (TA:=TeleO)
- (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- Eo Ei
- (tele_app (TT:=TeleO) α%I)
- (tele_app (TT:=TeleO) $
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, β%I) ..))
- (tele_app (TT:=TeleO) $
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, Φ%I) ..))
- )
- (at level 20, Eo, Ei, α, β, Φ at level 200, y1 binder, yn binder,
- format "'[ ' 'AU' '<<' α '>>' '/' @ Eo , Ei '/' '[ ' '<<' ∃ y1 .. yn , β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-Notation "'AU' '<<' α '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
- (atomic_update (TA:=TeleO) (TB:=TeleO) Eo Ei
- (tele_app (TT:=TeleO) α%I)
- (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) β%I)
- (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) Φ%I)
- )
- (at level 20, Eo, Ei, α, β, Φ at level 200,
- format "'[ ' 'AU' '<<' α '>>' '/' @ Eo , Ei '/' '[ ' '<<' β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-(** Notation: Atomic accessors *)
-Notation "'AACC' '<<' ∀ x1 .. xn , α 'ABORT' P '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
- (atomic_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
- (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- Eo Ei
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, α%I) ..)
- P%I
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, β%I) .. )
- ) .. )
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, Φ%I) .. )
- ) .. )
- )
- (at level 20, Eo, Ei, α, P, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder,
- format "'[ ' 'AACC' '[ ' '<<' ∀ x1 .. xn , α '/' ABORT P '>>' ']' '/' @ Eo , Ei '/' '[ ' '<<' ∃ y1 .. yn , β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-Notation "'AACC' '<<' ∀ x1 .. xn , α 'ABORT' P '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
- (atomic_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
- (TB:=TeleO)
- Eo Ei
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, α%I) ..)
- P%I
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, tele_app (TT:=TeleO) β%I) .. )
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, tele_app (TT:=TeleO) Φ%I) .. )
- )
- (at level 20, Eo, Ei, α, P, β, Φ at level 200, x1 binder, xn binder,
- format "'[ ' 'AACC' '[ ' '<<' ∀ x1 .. xn , α '/' ABORT P '>>' ']' '/' @ Eo , Ei '/' '[ ' '<<' β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-Notation "'AACC' '<<' α 'ABORT' P '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
- (atomic_acc (TA:=TeleO)
- (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- Eo Ei
- (tele_app (TT:=TeleO) α%I)
- P%I
- (tele_app (TT:=TeleO) $
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, β%I) ..))
- (tele_app (TT:=TeleO) $
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, Φ%I) ..))
- )
- (at level 20, Eo, Ei, α, P, β, Φ at level 200, y1 binder, yn binder,
- format "'[ ' 'AACC' '[ ' '<<' α '/' ABORT P '>>' ']' '/' @ Eo , Ei '/' '[ ' '<<' ∃ y1 .. yn , β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-Notation "'AACC' '<<' α 'ABORT' P '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
- (atomic_acc (TA:=TeleO)
- (TB:=TeleO)
- Eo Ei
- (tele_app (TT:=TeleO) α%I)
- P%I
- (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) β%I)
- (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) Φ%I)
- )
- (at level 20, Eo, Ei, α, P, β, Φ at level 200,
- format "'[ ' 'AACC' '[ ' '<<' α '/' ABORT P '>>' ']' '/' @ Eo , Ei '/' '[ ' '<<' β , '/' COMM Φ '>>' ']' ']'") : bi_scope.
-
-(** Lemmas about AU *)
-Section lemmas.
- Context `{BiFUpd PROP} {TA TB : tele}.
- Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP) (P : PROP).
-
- Local Existing Instance atomic_update_pre_mono.
-
- Global Instance atomic_acc_ne Eo Ei n :
- Proper (
- pointwise_relation TA (dist n) ==>
- dist n ==>
- pointwise_relation TA (pointwise_relation TB (dist n)) ==>
- pointwise_relation TA (pointwise_relation TB (dist n)) ==>
- dist n
- ) (atomic_acc (PROP:=PROP) Eo Ei).
- Proof. solve_proper. Qed.
-
- Global Instance atomic_update_ne Eo Ei n :
- Proper (
- pointwise_relation TA (dist n) ==>
- pointwise_relation TA (pointwise_relation TB (dist n)) ==>
- pointwise_relation TA (pointwise_relation TB (dist n)) ==>
- dist n
- ) (atomic_update (PROP:=PROP) Eo Ei).
- Proof.
- rewrite atomic_update_eq /atomic_update_def /atomic_update_pre. solve_proper.
- Qed.
-
- (** The ellimination form: an atomic accessor *)
- Lemma aupd_aacc Eo Ei α β Φ :
- atomic_update Eo Ei α β Φ -∗
- atomic_acc Eo Ei α (atomic_update Eo Ei α β Φ) β Φ.
- Proof using Type*.
- rewrite atomic_update_eq {1}/atomic_update_def /=. iIntros "HUpd".
- iPoseProof (greatest_fixpoint_unfold_1 with "HUpd") as "HUpd".
- iApply make_laterable_elim. done.
- Qed.
-
- (* This lets you eliminate atomic updates with iMod. *)
- Global Instance elim_mod_aupd φ Eo Ei E α β Φ Q Q' :
- (∀ R, ElimModal φ false false (|={E,Ei}=> R) R Q Q') →
- ElimModal (φ ∧ Eo ⊆ E) false false
- (atomic_update Eo Ei α β Φ)
- (∃.. x, α x ∗
- (α x ={Ei,E}=∗ atomic_update Eo Ei α β Φ) ∧
- (∀.. y, β x y ={Ei,E}=∗ Φ x y))
- Q Q'.
- Proof.
- intros ?. rewrite /ElimModal /= =>-[??]. iIntros "[AU Hcont]".
- iPoseProof (aupd_aacc with "AU") as "AC".
- iMod (atomic_acc_mask_weaken with "AC"); first done.
- iApply "Hcont". done.
- Qed.
-
- Global Instance aupd_laterable Eo Ei α β Φ :
- Laterable (atomic_update Eo Ei α β Φ).
- Proof.
- rewrite atomic_update_eq {1}/atomic_update_def greatest_fixpoint_unfold.
- apply _.
- Qed.
-
- Lemma aupd_intro P Q α β Eo Ei Φ :
- Affine P → Persistent P → Laterable Q →
- (P ∗ Q -∗ atomic_acc Eo Ei α Q β Φ) →
- P ∗ Q -∗ atomic_update Eo Ei α β Φ.
- Proof.
- rewrite atomic_update_eq {1}/atomic_update_def /=.
- iIntros (??? HAU) "[#HP HQ]".
- iApply (greatest_fixpoint_coind _ (λ _, Q)); last done. iIntros "!#" ([]) "HQ".
- iApply (make_laterable_intro Q with "[] HQ"). iIntros "!# >HQ".
- iApply HAU. by iFrame.
- Qed.
-
- Lemma aacc_intro Eo Ei α P β Φ :
- Ei ⊆ Eo → (∀.. x, α x -∗
- ((α x ={Eo}=∗ P) ∧ (∀.. y, β x y ={Eo}=∗ Φ x y)) -∗
- atomic_acc Eo Ei α P β Φ)%I.
- Proof.
- iIntros (? x) "Hα Hclose".
- iMod fupd_intro_mask' as "Hclose'"; last iModIntro; first set_solver.
- iExists x. iFrame. iSplitWith "Hclose".
- - iIntros "Hα". iMod "Hclose'" as "_". iApply "Hclose". done.
- - iIntros (y) "Hβ". iMod "Hclose'" as "_". iApply "Hclose". done.
- Qed.
-
- (* This lets you open invariants etc. when the goal is an atomic accessor. *)
- Global Instance elim_acc_aacc {X} E1 E2 Ei (α' β' : X → PROP) γ' α β Pas Φ :
- ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1) α' β' γ'
- (atomic_acc E1 Ei α Pas β Φ)
- (λ x', atomic_acc E2 Ei α (β' x' ∗ (γ' x' -∗? Pas))%I β
- (λ.. x y, β' x' ∗ (γ' x' -∗? Φ x y))
- )%I.
- Proof.
- rewrite /ElimAcc.
- (* FIXME: Is there any way to prevent maybe_wand from unfolding?
- It gets unfolded by env_cbv in the proofmode, ideally we'd like that
- to happen only if one argument is a constructor. *)
- iIntros "Hinner >Hacc". iDestruct "Hacc" as (x') "[Hα' Hclose]".
- iMod ("Hinner" with "Hα'") as (x) "[Hα Hclose']".
- iMod (fupd_intro_mask') as "Hclose''"; last iModIntro; first done.
- iExists x. iFrame. iSplitWith "Hclose'".
- - iIntros "Hα". iMod "Hclose''" as "_".
- iMod ("Hclose'" with "Hα") as "[Hβ' HPas]".
- iMod ("Hclose" with "Hβ'") as "Hγ'".
- iModIntro. destruct (γ' x'); iApply "HPas"; done.
- - iIntros (y) "Hβ". iMod "Hclose''" as "_".
- iMod ("Hclose'" with "Hβ") as "Hβ'".
- (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
- rewrite ->!tele_app_bind. iDestruct "Hβ'" as "[Hβ' HΦ]".
- iMod ("Hclose" with "Hβ'") as "Hγ'".
- iModIntro. destruct (γ' x'); iApply "HΦ"; done.
- Qed.
-
- (* Everything that fancy updates can eliminate without changing, atomic
- accessors can eliminate as well. This is a forwarding instance needed becuase
- atomic_acc is becoming opaque. *)
- Global Instance elim_modal_acc p q φ P P' Eo Ei α Pas β Φ :
- (∀ Q, ElimModal φ p q P P' (|={Eo,Ei}=> Q) (|={Eo,Ei}=> Q)) →
- ElimModal φ p q P P'
- (atomic_acc Eo Ei α Pas β Φ)
- (atomic_acc Eo Ei α Pas β Φ).
- Proof. intros Helim. apply Helim. Qed.
-
- Lemma aacc_aacc {TA' TB' : tele} E1 E1' E2 E3
- α P β Φ
- (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
- E1' ⊆ E1 →
- atomic_acc E1' E2 α P β Φ -∗
- (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (P ={E1}=∗ P')) β'
- (λ.. x' y', (α x ∗ (P ={E1}=∗ Φ' x' y'))
- ∨ ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
- atomic_acc E1 E3 α' P' β' Φ'.
- Proof.
- iIntros (?) "Hupd Hstep".
- iMod (atomic_acc_mask_weaken with "Hupd") as (x) "[Hα Hclose]"; first done.
- iMod ("Hstep" with "Hα") as (x') "[Hα' Hclose']".
- iModIntro. iExists x'. iFrame "Hα'". iSplit.
- - iIntros "Hα'". iDestruct "Hclose'" as "[Hclose' _]".
- iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
- iDestruct "Hclose" as "[Hclose _]".
- iMod ("Hclose" with "Hα"). iApply "Hupd". auto.
- - iIntros (y') "Hβ'". iDestruct "Hclose'" as "[_ Hclose']".
- iMod ("Hclose'" with "Hβ'") as "Hres".
- (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
- rewrite ->!tele_app_bind. iDestruct "Hres" as "[[Hα HΦ']|Hcont]".
- + (* Abort the step we are eliminating *)
- iDestruct "Hclose" as "[Hclose _]".
- iMod ("Hclose" with "Hα") as "HP".
- iApply "HΦ'". done.
- + (* Complete the step we are eliminating *)
- iDestruct "Hclose" as "[_ Hclose]".
- iDestruct "Hcont" as (y) "[Hβ HΦ']".
- iMod ("Hclose" with "Hβ") as "HΦ".
- iApply "HΦ'". done.
- Qed.
-
- Lemma aacc_aupd {TA' TB' : tele} E1 E1' E2 E3
- α β Φ
- (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
- E1' ⊆ E1 →
- atomic_update E1' E2 α β Φ -∗
- (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ P')) β'
- (λ.. x' y', (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ Φ' x' y'))
- ∨ ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
- atomic_acc E1 E3 α' P' β' Φ'.
- Proof.
- iIntros (?) "Hupd Hstep". iApply (aacc_aacc with "[Hupd] Hstep"); first done.
- iApply aupd_aacc; done.
- Qed.
-
- Lemma aacc_aupd_commit {TA' TB' : tele} E1 E1' E2 E3
- α β Φ
- (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
- E1' ⊆ E1 →
- atomic_update E1' E2 α β Φ -∗
- (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ P')) β'
- (λ.. x' y', ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
- atomic_acc E1 E3 α' P' β' Φ'.
- Proof.
- iIntros (?) "Hupd Hstep". iApply (aacc_aupd with "Hupd"); first done.
- iIntros (x) "Hα". iApply atomic_acc_wand; last first.
- { iApply "Hstep". done. }
- (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
- iSplit; first by eauto. iIntros (??) "?". rewrite ->!tele_app_bind. by iRight.
- Qed.
-
- Lemma aacc_aupd_abort {TA' TB' : tele} E1 E1' E2 E3
- α β Φ
- (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
- E1' ⊆ E1 →
- atomic_update E1' E2 α β Φ -∗
- (∀.. x, α x -∗ atomic_acc E2 E3 α' (α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ P')) β'
- (λ.. x' y', α x ∗ (atomic_update E1' E2 α β Φ ={E1}=∗ Φ' x' y'))) -∗
- atomic_acc E1 E3 α' P' β' Φ'.
- Proof.
- iIntros (?) "Hupd Hstep". iApply (aacc_aupd with "Hupd"); first done.
- iIntros (x) "Hα". iApply atomic_acc_wand; last first.
- { iApply "Hstep". done. }
- (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
- iSplit; first by eauto. iIntros (??) "?". rewrite ->!tele_app_bind. by iLeft.
- Qed.
-
-End lemmas.
-
-(** ProofMode support for atomic updates *)
-Section proof_mode.
- Context `{BiFUpd PROP} {TA TB : tele}.
- Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP) (P : PROP).
-
- Lemma tac_aupd_intro Γp Γs n α β Eo Ei Φ P :
- Timeless (PROP:=PROP) emp →
- TCForall Laterable (env_to_list Γs) →
- P = env_to_prop Γs →
- envs_entails (Envs Γp Γs n) (atomic_acc Eo Ei α P β Φ) →
- envs_entails (Envs Γp Γs n) (atomic_update Eo Ei α β Φ).
- Proof.
- intros ? HΓs ->. rewrite envs_entails_eq of_envs_eq' /atomic_acc /=.
- setoid_rewrite env_to_prop_sound =>HAU.
- apply aupd_intro; [apply _..|]. done.
- Qed.
-End proof_mode.
-
-(** Now the coq-level tactics *)
-
-Tactic Notation "iAuIntro" :=
- iStartProof; eapply tac_aupd_intro; [
- iSolveTC || fail "iAuIntro: emp is not timeless"
- | iSolveTC || fail "iAuIntro: not all spatial assumptions are laterable"
- | (* P = ...: make the P pretty *) pm_reflexivity
- | (* the new proof mode goal *) ].
-Tactic Notation "iAaccIntro" "with" constr(sel) :=
- iStartProof; lazymatch goal with
- | |- environments.envs_entails _ (@atomic_acc ?PROP ?H ?TA ?TB ?Eo ?Ei ?α ?P ?β ?Φ) =>
- iApply (@aacc_intro PROP H TA TB Eo Ei α P β Φ with sel);
- first try solve_ndisj; last iSplit
- | _ => fail "iAAccIntro: Goal is not an atomic accessor"
- end.
-
-(* From here on, prevent TC search from implicitly unfolding these. *)
-Typeclasses Opaque atomic_acc atomic_update.
diff --git a/theories/bi/lib/core.v b/theories/bi/lib/core.v
deleted file mode 100644
index 2d737e6554685c4baaa30c7805e27a272d0dc1d9..0000000000000000000000000000000000000000
--- a/theories/bi/lib/core.v
+++ /dev/null
@@ -1,57 +0,0 @@
-From iris.bi Require Export bi plainly.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-Import bi.
-
-(** The "core" of an assertion is its maximal persistent part,
- i.e. the conjunction of all persistent assertions that are weaker
- than P (as in, implied by P). *)
-Definition coreP `{!BiPlainly PROP} (P : PROP) : PROP :=
- (* TODO: Looks like we want notation for affinely-plainly; that lets us avoid
- using conjunction/implication here. *)
- (∀ Q : PROP, <affine> ■(Q -∗ <pers> Q) -∗ <affine> ■(P -∗ Q) -∗ Q)%I.
-Instance: Params (@coreP) 1 := {}.
-Typeclasses Opaque coreP.
-
-Section core.
- Context `{!BiPlainly PROP}.
- Implicit Types P Q : PROP.
-
- Lemma coreP_intro P : P -∗ coreP P.
- Proof.
- rewrite /coreP. iIntros "HP" (Q) "_ HPQ".
- (* FIXME: Cannot apply HPQ directly. This works if we move it to the
- persistent context, but why should we? *)
- iDestruct (affinely_plainly_elim with "HPQ") as "HPQ".
- by iApply "HPQ".
- Qed.
-
- Global Instance coreP_persistent P : Persistent (coreP P).
- Proof.
- rewrite /coreP /Persistent. iIntros "HC" (Q).
- iApply persistently_wand_affinely_plainly. iIntros "#HQ".
- iApply persistently_wand_affinely_plainly. iIntros "#HPQ".
- iApply "HQ". iApply "HC"; auto.
- Qed.
-
- Global Instance coreP_ne : NonExpansive (coreP (PROP:=PROP)).
- Proof. solve_proper. Qed.
- Global Instance coreP_proper : Proper ((⊣⊢) ==> (⊣⊢)) (coreP (PROP:=PROP)).
- Proof. solve_proper. Qed.
-
- Global Instance coreP_mono : Proper ((⊢) ==> (⊢)) (coreP (PROP:=PROP)).
- Proof. solve_proper. Qed.
-
- Lemma coreP_elim P : Persistent P → coreP P -∗ P.
- Proof. rewrite /coreP. iIntros (?) "HCP". iApply "HCP"; auto. Qed.
-
- (* TODO: Can we generalize this to non-affine BIs? *)
- Lemma coreP_wand `{!BiAffine PROP} P Q : (coreP P ⊢ Q) ↔ (P ⊢ <pers> Q).
- Proof.
- split.
- - iIntros (HP) "HP". iDestruct (coreP_intro with "HP") as "#HcP".
- iAlways. by iApply HP.
- - iIntros (HPQ) "HcP". iDestruct (coreP_mono _ _ HPQ with "HcP") as "HcQ".
- by iDestruct (coreP_elim with "HcQ") as "#HQ".
- Qed.
-End core.
diff --git a/theories/bi/lib/counterexamples.v b/theories/bi/lib/counterexamples.v
deleted file mode 100644
index ca5f1707f28b2d4072979c92aa2fa8bfbceaa128..0000000000000000000000000000000000000000
--- a/theories/bi/lib/counterexamples.v
+++ /dev/null
@@ -1,217 +0,0 @@
-From iris.bi Require Export bi.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type*".
-
-(** This proves that we need the â–· in a "Saved Proposition" construction with
-name-dependent allocation. *)
-Module savedprop. Section savedprop.
- Context `{BiAffine PROP}.
- Notation "¬ P" := (□ (P → False))%I : bi_scope.
- Implicit Types P : PROP.
-
- Context (bupd : PROP → PROP).
- Notation "|==> Q" := (bupd Q)
- (at level 99, Q at level 200, format "|==> Q") : bi_scope.
-
- Hypothesis bupd_intro : ∀ P, P ⊢ |==> P.
- Hypothesis bupd_mono : ∀ P Q, (P ⊢ Q) → (|==> P) ⊢ |==> Q.
- Hypothesis bupd_trans : ∀ P, (|==> |==> P) ⊢ |==> P.
- Hypothesis bupd_frame_r : ∀ P R, (|==> P) ∗ R ⊢ |==> (P ∗ R).
-
- Context (ident : Type) (saved : ident → PROP → PROP).
- Hypothesis sprop_persistent : ∀ i P, Persistent (saved i P).
- Hypothesis sprop_alloc_dep :
- ∀ (P : ident → PROP), (|==> ∃ i, saved i (P i))%I.
- Hypothesis sprop_agree : ∀ i P Q, saved i P ∧ saved i Q ⊢ □ (P ↔ Q).
-
- (** We assume that we cannot update to false. *)
- Hypothesis consistency : ¬(|==> False)%I.
-
- Instance bupd_mono' : Proper ((⊢) ==> (⊢)) bupd.
- Proof. intros P Q ?. by apply bupd_mono. Qed.
- Instance elim_modal_bupd p P Q : ElimModal True p false (|==> P) P (|==> Q) (|==> Q).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- bupd_frame_r bi.wand_elim_r bupd_trans.
- Qed.
-
- (** A bad recursive reference: "Assertion with name [i] does not hold" *)
- Definition A (i : ident) : PROP := (∃ P, ¬ P ∗ saved i P)%I.
-
- Lemma A_alloc : (|==> ∃ i, saved i (A i))%I.
- Proof. by apply sprop_alloc_dep. Qed.
-
- Lemma saved_NA i : saved i (A i) ⊢ ¬ A i.
- Proof.
- iIntros "#Hs !# #HA". iPoseProof "HA" as "HA'".
- iDestruct "HA'" as (P) "[#HNP HsP]". iApply "HNP".
- iDestruct (sprop_agree i P (A i) with "[]") as "#[_ HP]".
- { eauto. }
- iApply "HP". done.
- Qed.
-
- Lemma saved_A i : saved i (A i) ⊢ A i.
- Proof.
- iIntros "#Hs". iExists (A i). iFrame "#".
- by iApply saved_NA.
- Qed.
-
- Lemma contradiction : False.
- Proof using All.
- apply consistency.
- iMod A_alloc as (i) "#H".
- iPoseProof (saved_NA with "H") as "HN".
- iApply bupd_intro. iApply "HN". iApply saved_A. done.
- Qed.
-End savedprop. End savedprop.
-
-
-(** This proves that we need the â–· when opening invariants. *)
-Module inv. Section inv.
- Context `{BiAffine PROP}.
- Implicit Types P : PROP.
-
- (** Assumptions *)
- (** We have the update modality (two classes: empty/full mask) *)
- Inductive mask := M0 | M1.
- Context (fupd : mask → PROP → PROP).
- Arguments fupd _ _%I.
- Hypothesis fupd_intro : ∀ E P, P ⊢ fupd E P.
- Hypothesis fupd_mono : ∀ E P Q, (P ⊢ Q) → fupd E P ⊢ fupd E Q.
- Hypothesis fupd_fupd : ∀ E P, fupd E (fupd E P) ⊢ fupd E P.
- Hypothesis fupd_frame_l : ∀ E P Q, P ∗ fupd E Q ⊢ fupd E (P ∗ Q).
- Hypothesis fupd_mask_mono : ∀ P, fupd M0 P ⊢ fupd M1 P.
-
- (** We have invariants *)
- Context (name : Type) (inv : name → PROP → PROP).
- Arguments inv _ _%I.
- Hypothesis inv_persistent : ∀ i P, Persistent (inv i P).
- Hypothesis inv_alloc : ∀ P, P ⊢ fupd M1 (∃ i, inv i P).
- Hypothesis inv_open :
- ∀ i P Q R, (P ∗ Q ⊢ fupd M0 (P ∗ R)) → (inv i P ∗ Q ⊢ fupd M1 R).
-
- (* We have tokens for a little "two-state STS": [start] -> [finish].
- state. [start] also asserts the exact state; it is only ever owned by the
- invariant. [finished] is duplicable. *)
- (* Posssible implementations of these axioms:
- * Using the STS monoid of a two-state STS, where [start] is the
- authoritative saying the state is exactly [start], and [finish]
- is the "we are at least in state [finish]" typically owned by threads.
- * Ex () +_## ()
- *)
- Context (gname : Type).
- Context (start finished : gname → PROP).
-
- Hypothesis sts_alloc : fupd M0 (∃ γ, start γ).
- Hypotheses start_finish : ∀ γ, start γ ⊢ fupd M0 (finished γ).
-
- Hypothesis finished_not_start : ∀ γ, start γ ∗ finished γ ⊢ False.
-
- Hypothesis finished_dup : ∀ γ, finished γ ⊢ finished γ ∗ finished γ.
-
- (** We assume that we cannot update to false. *)
- Hypothesis consistency : ¬ (fupd M1 False).
-
- (** Some general lemmas and proof mode compatibility. *)
- Lemma inv_open' i P R : inv i P ∗ (P -∗ fupd M0 (P ∗ fupd M1 R)) ⊢ fupd M1 R.
- Proof.
- iIntros "(#HiP & HP)". iApply fupd_fupd. iApply inv_open; last first.
- { iSplit; first done. iExact "HP". }
- iIntros "(HP & HPw)". by iApply "HPw".
- Qed.
-
- Instance fupd_mono' E : Proper ((⊢) ==> (⊢)) (fupd E).
- Proof. intros P Q ?. by apply fupd_mono. Qed.
- Instance fupd_proper E : Proper ((⊣⊢) ==> (⊣⊢)) (fupd E).
- Proof.
- intros P Q; rewrite !bi.equiv_spec=> -[??]; split; by apply fupd_mono.
- Qed.
-
- Lemma fupd_frame_r E P Q : fupd E P ∗ Q ⊢ fupd E (P ∗ Q).
- Proof. by rewrite comm fupd_frame_l comm. Qed.
-
- Global Instance elim_fupd_fupd p E P Q :
- ElimModal True p false (fupd E P) P (fupd E Q) (fupd E Q).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- fupd_frame_r bi.wand_elim_r fupd_fupd.
- Qed.
-
- Global Instance elim_fupd0_fupd1 p P Q :
- ElimModal True p false (fupd M0 P) P (fupd M1 Q) (fupd M1 Q).
- Proof.
- by rewrite /ElimModal bi.intuitionistically_if_elim
- fupd_frame_r bi.wand_elim_r fupd_mask_mono fupd_fupd.
- Qed.
-
- Global Instance exists_split_fupd0 {A} E P (Φ : A → PROP) :
- FromExist P Φ → FromExist (fupd E P) (λ a, fupd E (Φ a)).
- Proof.
- rewrite /FromExist=>HP. apply bi.exist_elim=> a.
- apply fupd_mono. by rewrite -HP -(bi.exist_intro a).
- Qed.
-
- (** Now to the actual counterexample. We start with a weird form of saved propositions. *)
- Definition saved (γ : gname) (P : PROP) : PROP :=
- (∃ i, inv i (start γ ∨ (finished γ ∗ □ P)))%I.
- Global Instance saved_persistent γ P : Persistent (saved γ P) := _.
-
- Lemma saved_alloc (P : gname → PROP) : fupd M1 (∃ γ, saved γ (P γ)).
- Proof.
- iIntros "". iMod (sts_alloc) as (γ) "Hs".
- iMod (inv_alloc (start γ ∨ (finished γ ∗ □ (P γ)))%I with "[Hs]") as (i) "#Hi".
- { auto. }
- iApply fupd_intro. by iExists γ, i.
- Qed.
-
- Lemma saved_cast γ P Q : saved γ P ∗ saved γ Q ∗ □ P ⊢ fupd M1 (□ Q).
- Proof.
- iIntros "(#HsP & #HsQ & #HP)". iDestruct "HsP" as (i) "HiP".
- iApply (inv_open' i). iSplit; first done.
- iIntros "HaP". iAssert (fupd M0 (finished γ)) with "[HaP]" as "> Hf".
- { iDestruct "HaP" as "[Hs | [Hf _]]".
- - by iApply start_finish.
- - by iApply fupd_intro. }
- iDestruct (finished_dup with "Hf") as "[Hf Hf']".
- iApply fupd_intro. iSplitL "Hf'"; first by eauto.
- (* Step 2: Open the Q-invariant. *)
- iClear (i) "HiP ". iDestruct "HsQ" as (i) "HiQ".
- iApply (inv_open' i). iSplit; first done.
- iIntros "[HaQ | [_ #HQ]]".
- { iExFalso. iApply finished_not_start. by iFrame. }
- iApply fupd_intro. iSplitL "Hf".
- { iRight. by iFrame. }
- by iApply fupd_intro.
- Qed.
-
- (** And now we tie a bad knot. *)
- Notation "¬ P" := (□ (P -∗ fupd M1 False))%I : bi_scope.
- Definition A i : PROP := (∃ P, ¬P ∗ saved i P)%I.
- Global Instance A_persistent i : Persistent (A i) := _.
-
- Lemma A_alloc : fupd M1 (∃ i, saved i (A i)).
- Proof. by apply saved_alloc. Qed.
-
- Lemma saved_NA i : saved i (A i) ⊢ ¬A i.
- Proof.
- iIntros "#Hi !# #HA". iPoseProof "HA" as "HA'".
- iDestruct "HA'" as (P) "#[HNP Hi']".
- iMod (saved_cast i (A i) P with "[]") as "HP".
- { eauto. }
- by iApply "HNP".
- Qed.
-
- Lemma saved_A i : saved i (A i) ⊢ A i.
- Proof.
- iIntros "#Hi". iExists (A i). iFrame "#".
- by iApply saved_NA.
- Qed.
-
- Lemma contradiction : False.
- Proof using All.
- apply consistency. iIntros "".
- iMod A_alloc as (i) "#H".
- iPoseProof (saved_NA with "H") as "HN".
- iApply "HN". iApply saved_A. done.
- Qed.
-End inv. End inv.
diff --git a/theories/bi/lib/fixpoint.v b/theories/bi/lib/fixpoint.v
index 1423040d92826018c0680a2ca337180a353e6299..03b0943aac54502d270c5f262a5869e7da9c661f 100644
--- a/theories/bi/lib/fixpoint.v
+++ b/theories/bi/lib/fixpoint.v
@@ -5,34 +5,34 @@ Import bi.
(** Least and greatest fixpoint of a monotone function, defined entirely inside
the logic. *)
-Class BiMonoPred {PROP : bi} {A : ofeT} (F : (A → PROP) → (A → PROP)) := {
- bi_mono_pred Φ Ψ : (<pers> (∀ x, Φ x -∗ Ψ x) → ∀ x, F Φ x -∗ F Ψ x)%I;
+Class BiMonoPred {SI} {PROP : bi SI} {A : ofeT SI} (F : (A → PROP) → (A → PROP)) := {
+ bi_mono_pred Φ Ψ : bi_emp_valid (<pers> (∀ x, Φ x -∗ Ψ x) → ∀ x, F Φ x -∗ F Ψ x)%I;
bi_mono_pred_ne Φ : NonExpansive Φ → NonExpansive (F Φ)
}.
-Arguments bi_mono_pred {_ _ _ _} _ _.
+Arguments bi_mono_pred {_ _ _ _ _} _ _.
Local Existing Instance bi_mono_pred_ne.
-Definition bi_least_fixpoint {PROP : bi} {A : ofeT}
+Definition bi_least_fixpoint {SI} {PROP : bi SI} {A : ofeT SI}
(F : (A → PROP) → (A → PROP)) (x : A) : PROP :=
tc_opaque (∀ Φ : A -n> PROP, <pers> (∀ x, F Φ x -∗ Φ x) → Φ x)%I.
Arguments bi_least_fixpoint : simpl never.
-Definition bi_greatest_fixpoint {PROP : bi} {A : ofeT}
+Definition bi_greatest_fixpoint {SI} {PROP : bi SI} {A : ofeT SI}
(F : (A → PROP) → (A → PROP)) (x : A) : PROP :=
tc_opaque (∃ Φ : A -n> PROP, <pers> (∀ x, Φ x -∗ F Φ x) ∧ Φ x)%I.
Arguments bi_greatest_fixpoint : simpl never.
-Global Instance least_fixpoint_ne {PROP : bi} {A : ofeT} n :
+Global Instance least_fixpoint_ne {SI} {PROP : bi SI} {A : ofeT SI} n :
Proper (pointwise_relation (A → PROP) (pointwise_relation A (dist n)) ==>
dist n ==> dist n) bi_least_fixpoint.
Proof. solve_proper. Qed.
-Global Instance least_fixpoint_proper {PROP : bi} {A : ofeT} :
+Global Instance least_fixpoint_proper {SI} {PROP : bi SI} {A : ofeT SI} :
Proper (pointwise_relation (A → PROP) (pointwise_relation A (≡)) ==>
(≡) ==> (≡)) bi_least_fixpoint.
Proof. solve_proper. Qed.
Section least.
- Context {PROP : bi} {A : ofeT} (F : (A → PROP) → (A → PROP)) `{!BiMonoPred F}.
+ Context {SI} {PROP : bi SI} {A : ofeT SI} (F : (A → PROP) → (A → PROP)) `{!BiMonoPred F}.
Lemma least_fixpoint_unfold_2 x : F (bi_least_fixpoint F) x ⊢ bi_least_fixpoint F x.
Proof.
@@ -74,7 +74,7 @@ Section least.
Qed.
End least.
-Lemma greatest_fixpoint_ne_outer {PROP : bi} {A : ofeT}
+Lemma greatest_fixpoint_ne_outer {SI} {PROP : bi SI} {A : ofeT SI}
(F1 : (A → PROP) → (A → PROP)) (F2 : (A → PROP) → (A → PROP)):
(∀ Φ x n, F1 Φ x ≡{n}≡ F2 Φ x) → ∀ x1 x2 n,
x1 ≡{n}≡ x2 → bi_greatest_fixpoint F1 x1 ≡{n}≡ bi_greatest_fixpoint F2 x2.
@@ -83,17 +83,17 @@ Proof.
do 3 f_equiv; last solve_proper. repeat f_equiv. apply HF.
Qed.
-Global Instance greatest_fixpoint_ne {PROP : bi} {A : ofeT} n :
+Global Instance greatest_fixpoint_ne {SI} {PROP : bi SI} {A : ofeT SI} n :
Proper (pointwise_relation (A → PROP) (pointwise_relation A (dist n)) ==>
dist n ==> dist n) bi_greatest_fixpoint.
Proof. solve_proper. Qed.
-Global Instance greatest_fixpoint_proper {PROP : bi} {A : ofeT} :
+Global Instance greatest_fixpoint_proper {SI} {PROP : bi SI} {A : ofeT SI} :
Proper (pointwise_relation (A → PROP) (pointwise_relation A (≡)) ==>
(≡) ==> (≡)) bi_greatest_fixpoint.
Proof. solve_proper. Qed.
Section greatest.
- Context {PROP : bi} {A : ofeT} (F : (A → PROP) → (A → PROP)) `{!BiMonoPred F}.
+ Context {SI} {PROP : bi SI} {A : ofeT SI} (F : (A → PROP) → (A → PROP)) `{!BiMonoPred F}.
Lemma greatest_fixpoint_unfold_1 x :
bi_greatest_fixpoint F x ⊢ F (bi_greatest_fixpoint F) x.
diff --git a/theories/bi/lib/fractional.v b/theories/bi/lib/fractional.v
index ec7b4666ac4e3ba9b1dc67ff1908d1eca9301c72..7a1bc00c6a5bbee40b54186f6a78501d4e7caab4 100644
--- a/theories/bi/lib/fractional.v
+++ b/theories/bi/lib/fractional.v
@@ -2,25 +2,25 @@ From iris.bi Require Export bi.
From iris.proofmode Require Import classes class_instances_bi.
Set Default Proof Using "Type".
-Class Fractional {PROP : bi} (Φ : Qp → PROP) :=
+Class Fractional {SI} {PROP : bi SI} (Φ : Qp → PROP) :=
fractional p q : Φ (p + q)%Qp ⊣⊢ Φ p ∗ Φ q.
-Arguments Fractional {_} _%I : simpl never.
+Arguments Fractional {_ _} _%I : simpl never.
-Class AsFractional {PROP : bi} (P : PROP) (Φ : Qp → PROP) (q : Qp) := {
+Class AsFractional {SI} {PROP : bi SI} (P : PROP) (Φ : Qp → PROP) (q : Qp) := {
as_fractional : P ⊣⊢ Φ q;
as_fractional_fractional :> Fractional Φ
}.
-Arguments AsFractional {_} _%I _%I _%Qp.
+Arguments AsFractional {_ _} _%I _%I _%Qp.
-Arguments fractional {_ _ _} _ _.
+Arguments fractional {_ _ _ _} _ _.
-Hint Mode AsFractional - + - - : typeclass_instances.
+Hint Mode AsFractional - - + - - : typeclass_instances.
(* To make [as_fractional_fractional] a useful instance, we have to
allow [q] to be an evar. *)
-Hint Mode AsFractional - - + - : typeclass_instances.
+Hint Mode AsFractional - - - + - : typeclass_instances.
Section fractional.
- Context {PROP : bi}.
+ Context {SI} {PROP : bi SI}.
Implicit Types P Q : PROP.
Implicit Types Φ : Qp → PROP.
Implicit Types q : Qp.
diff --git a/theories/bi/lib/laterable.v b/theories/bi/lib/laterable.v
deleted file mode 100644
index 155df72d47662abedd09a87cd84e585ab4f2aff8..0000000000000000000000000000000000000000
--- a/theories/bi/lib/laterable.v
+++ /dev/null
@@ -1,103 +0,0 @@
-From iris.bi Require Export bi.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-(** The class of laterable assertions *)
-Class Laterable {PROP : sbi} (P : PROP) := laterable :
- P -∗ ∃ Q, ▷ Q ∗ □ (▷ Q -∗ ◇ P).
-Arguments Laterable {_} _%I : simpl never.
-Arguments laterable {_} _%I {_}.
-Hint Mode Laterable + ! : typeclass_instances.
-
-Section instances.
- Context {PROP : sbi}.
- Implicit Types P : PROP.
- Implicit Types Ps : list PROP.
-
- Global Instance laterable_proper : Proper ((⊣⊢) ==> (↔)) (@Laterable PROP).
- Proof. solve_proper. Qed.
-
- Global Instance later_laterable P : Laterable (â–· P).
- Proof.
- rewrite /Laterable. iIntros "HP". iExists P. iFrame.
- iIntros "!# HP !>". done.
- Qed.
-
- Global Instance timeless_laterable P :
- Timeless P → Laterable P.
- Proof.
- rewrite /Laterable. iIntros (?) "HP". iExists P%I. iFrame.
- iSplitR; first by iNext. iIntros "!# >HP !>". done.
- Qed.
-
- (** This lemma is not very useful: It needs a strange assumption about
- emp, and most of the time intuitionistic propositions can be just kept
- around anyway and don't need to be "latered". The lemma exists
- because the fact that it needs the side-condition is interesting;
- it is not an instance because it won't usually get used. *)
- Lemma intuitionistic_laterable P :
- Timeless (PROP:=PROP) emp → Affine P → Persistent P → Laterable P.
- Proof.
- rewrite /Laterable. iIntros (???) "#HP".
- iExists emp%I. iSplitL; first by iNext.
- iIntros "!# >_". done.
- Qed.
-
- Global Instance sep_laterable P Q :
- Laterable P → Laterable Q → Laterable (P ∗ Q).
- Proof.
- rewrite /Laterable. iIntros (LP LQ) "[HP HQ]".
- iDestruct (LP with "HP") as (P') "[HP' #HP]".
- iDestruct (LQ with "HQ") as (Q') "[HQ' #HQ]".
- iExists (P' ∗ Q')%I. iSplitL; first by iFrame.
- iIntros "!# [HP' HQ']". iSplitL "HP'".
- - iApply "HP". done.
- - iApply "HQ". done.
- Qed.
-
- Global Instance big_sepL_laterable Ps :
- Timeless (PROP:=PROP) emp →
- TCForall Laterable Ps →
- Laterable ([∗] Ps).
- Proof. induction 2; simpl; apply _. Qed.
-
- (* A wrapper to obtain a weaker, laterable form of any assertion. *)
- Definition make_laterable (Q : PROP) : PROP :=
- (∃ P, ▷ P ∗ □ (▷ P -∗ Q))%I.
-
- Global Instance make_laterable_ne : NonExpansive make_laterable.
- Proof. solve_proper. Qed.
- Global Instance make_laterable_proper : Proper ((≡) ==> (≡)) make_laterable := ne_proper _.
-
- Lemma make_laterable_wand Q1 Q2 :
- □ (Q1 -∗ Q2) -∗ (make_laterable Q1 -∗ make_laterable Q2).
- Proof.
- iIntros "#HQ HQ1". iDestruct "HQ1" as (P) "[HP #HQ1]".
- iExists P. iFrame. iIntros "!# HP". iApply "HQ". iApply "HQ1". done.
- Qed.
-
- Global Instance make_laterable_laterable Q :
- Laterable (make_laterable Q).
- Proof.
- rewrite /Laterable. iIntros "HQ". iDestruct "HQ" as (P) "[HP #HQ]".
- iExists P. iFrame. iIntros "!# HP !>". iExists P. by iFrame.
- Qed.
-
- Lemma make_laterable_elim Q :
- make_laterable Q -∗ Q.
- Proof.
- iIntros "HQ". iDestruct "HQ" as (P) "[HP #HQ]". by iApply "HQ".
- Qed.
-
- Lemma make_laterable_intro P Q :
- Laterable P →
- □ (◇ P -∗ Q) -∗ P -∗ make_laterable Q.
- Proof.
- iIntros (?) "#HQ HP".
- iDestruct (laterable with "HP") as (P') "[HP' #HPi]". iExists P'.
- iFrame. iIntros "!# HP'". iApply "HQ". iApply "HPi". done.
- Qed.
-
-End instances.
-
-Typeclasses Opaque make_laterable.
diff --git a/theories/bi/monpred.v b/theories/bi/monpred.v
deleted file mode 100644
index 9e9fe6a05908dac779199b51d81746b852a1383c..0000000000000000000000000000000000000000
--- a/theories/bi/monpred.v
+++ /dev/null
@@ -1,986 +0,0 @@
-From stdpp Require Import coPset.
-From iris.bi Require Import bi.
-
-(** Definitions. *)
-Structure biIndex :=
- BiIndex
- { bi_index_type :> Type;
- bi_index_inhabited : Inhabited bi_index_type;
- bi_index_rel : SqSubsetEq bi_index_type;
- bi_index_rel_preorder : PreOrder (⊑@{bi_index_type}) }.
-Existing Instances bi_index_inhabited bi_index_rel bi_index_rel_preorder.
-
-(* We may want to instantiate monPred with the reflexivity relation in
- the case where there is no relevent order. In that case, there is
- no bottom element, so that we do not want to force any BI index to
- have one. *)
-Class BiIndexBottom {I : biIndex} (bot : I) :=
- bi_index_bot i : bot ⊑ i.
-
-Section Ofe_Cofe.
-Context {I : biIndex} {PROP : bi}.
-Implicit Types i : I.
-
-Record monPred :=
- MonPred { monPred_at :> I → PROP;
- monPred_mono : Proper ((⊑) ==> (⊢)) monPred_at }.
-Local Existing Instance monPred_mono.
-
-Bind Scope monPred with bi.
-
-Implicit Types P Q : monPred.
-
-(** Ofe + Cofe instances *)
-
-Section Ofe_Cofe_def.
- Inductive monPred_equiv' P Q : Prop :=
- { monPred_in_equiv i : P i ≡ Q i } .
- Instance monPred_equiv : Equiv monPred := monPred_equiv'.
- Inductive monPred_dist' (n : nat) (P Q : monPred) : Prop :=
- { monPred_in_dist i : P i ≡{n}≡ Q i }.
- Instance monPred_dist : Dist monPred := monPred_dist'.
-
- Definition monPred_sig P : { f : I -d> PROP | Proper ((⊑) ==> (⊢)) f } :=
- exist _ (monPred_at P) (monPred_mono P).
-
- Definition sig_monPred (P' : { f : I -d> PROP | Proper ((⊑) ==> (⊢)) f })
- : monPred :=
- MonPred (proj1_sig P') (proj2_sig P').
-
- (* These two lemma use the wrong Equiv and Dist instance for
- monPred. so we make sure they are not accessible outside of the
- section by using Let. *)
- Let monPred_sig_equiv:
- ∀ P Q, P ≡ Q ↔ monPred_sig P ≡ monPred_sig Q.
- Proof. by split; [intros []|]. Qed.
- Let monPred_sig_dist:
- ∀ n, ∀ P Q : monPred, P ≡{n}≡ Q ↔ monPred_sig P ≡{n}≡ monPred_sig Q.
- Proof. by split; [intros []|]. Qed.
-
- Definition monPred_ofe_mixin : OfeMixin monPred.
- Proof. by apply (iso_ofe_mixin monPred_sig monPred_sig_equiv monPred_sig_dist). Qed.
-
- Canonical Structure monPredO := OfeT monPred monPred_ofe_mixin.
-
- Global Instance monPred_cofe `{Cofe PROP} : Cofe monPredO.
- Proof.
- unshelve refine (iso_cofe_subtype (A:=I-d>PROP) _ MonPred monPred_at _ _ _);
- [apply _|by apply monPred_sig_dist|done|].
- intros c i j Hij. apply @limit_preserving;
- [by apply bi.limit_preserving_entails; intros ??|]=>n. by rewrite Hij.
- Qed.
-End Ofe_Cofe_def.
-
-Lemma monPred_sig_monPred (P' : { f : I -d> PROP | Proper ((⊑) ==> (⊢)) f }) :
- monPred_sig (sig_monPred P') ≡ P'.
-Proof. by change (P' ≡ P'). Qed.
-Lemma sig_monPred_sig P : sig_monPred (monPred_sig P) ≡ P.
-Proof. done. Qed.
-
-Global Instance monPred_sig_ne : NonExpansive monPred_sig.
-Proof. move=> ??? [?] ? //=. Qed.
-Global Instance monPred_sig_proper : Proper ((≡) ==> (≡)) monPred_sig.
-Proof. eapply (ne_proper _). Qed.
-Global Instance sig_monPred_ne : NonExpansive (@sig_monPred).
-Proof. split=>? //=. Qed.
-Global Instance sig_monPred_proper : Proper ((≡) ==> (≡)) sig_monPred.
-Proof. eapply (ne_proper _). Qed.
-
-(* We generalize over the relation R which is morally the equivalence
- relation over B. That way, the BI index can use equality as an
- equivalence relation (and Coq is able to infer the Proper and
- Reflexive instances properly), or any other equivalence relation,
- provided it is compatible with (⊑). *)
-Global Instance monPred_at_ne (R : relation I) :
- Proper (R ==> R ==> iff) (⊑) → Reflexive R →
- ∀ n, Proper (dist n ==> R ==> dist n) monPred_at.
-Proof.
- intros ????? [Hd] ?? HR. rewrite Hd.
- apply equiv_dist, bi.equiv_spec; split; f_equiv; rewrite ->HR; done.
-Qed.
-Global Instance monPred_at_proper (R : relation I) :
- Proper (R ==> R ==> iff) (⊑) → Reflexive R →
- Proper ((≡) ==> R ==> (≡)) monPred_at.
-Proof. repeat intro. apply equiv_dist=>?. f_equiv=>//. by apply equiv_dist. Qed.
-End Ofe_Cofe.
-
-Arguments monPred _ _ : clear implicits.
-Arguments monPred_at {_ _} _%I _.
-Local Existing Instance monPred_mono.
-Arguments monPredO _ _ : clear implicits.
-
-(** BI and SBI structures. *)
-
-Section Bi.
-Context {I : biIndex} {PROP : bi}.
-Implicit Types i : I.
-Notation monPred := (monPred I PROP).
-Implicit Types P Q : monPred.
-
-Inductive monPred_entails (P1 P2 : monPred) : Prop :=
- { monPred_in_entails i : P1 i ⊢ P2 i }.
-Hint Immediate monPred_in_entails : core.
-
-Program Definition monPred_upclosed (Φ : I → PROP) : monPred :=
- MonPred (λ i, (∀ j, ⌜i ⊑ j⌠→ Φ j)%I) _.
-Next Obligation. solve_proper. Qed.
-
-Definition monPred_embed_def (P : PROP) : monPred := MonPred (λ _, P) _.
-Definition monPred_embed_aux : seal (@monPred_embed_def). by eexists. Qed.
-Definition monPred_embed : Embed PROP monPred := monPred_embed_aux.(unseal).
-Definition monPred_embed_eq : @embed _ _ monPred_embed = _ := monPred_embed_aux.(seal_eq).
-
-Definition monPred_emp_def : monPred := MonPred (λ _, emp)%I _.
-Definition monPred_emp_aux : seal (@monPred_emp_def). by eexists. Qed.
-Definition monPred_emp := monPred_emp_aux.(unseal).
-Definition monPred_emp_eq : @monPred_emp = _ := monPred_emp_aux.(seal_eq).
-
-Definition monPred_pure_def (φ : Prop) : monPred := MonPred (λ _, ⌜φâŒ)%I _.
-Definition monPred_pure_aux : seal (@monPred_pure_def). by eexists. Qed.
-Definition monPred_pure := monPred_pure_aux.(unseal).
-Definition monPred_pure_eq : @monPred_pure = _ := monPred_pure_aux.(seal_eq).
-
-Definition monPred_objectively_def P : monPred := MonPred (λ _, ∀ i, P i)%I _.
-Definition monPred_objectively_aux : seal (@monPred_objectively_def). by eexists. Qed.
-Definition monPred_objectively := monPred_objectively_aux.(unseal).
-Definition monPred_objectively_eq : @monPred_objectively = _ := monPred_objectively_aux.(seal_eq).
-
-Definition monPred_subjectively_def P : monPred := MonPred (λ _, ∃ i, P i)%I _.
-Definition monPred_subjectively_aux : seal (@monPred_subjectively_def). by eexists. Qed.
-Definition monPred_subjectively := monPred_subjectively_aux.(unseal).
-Definition monPred_subjectively_eq : @monPred_subjectively = _ := monPred_subjectively_aux.(seal_eq).
-
-Program Definition monPred_and_def P Q : monPred :=
- MonPred (λ i, P i ∧ Q i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_and_aux : seal (@monPred_and_def). by eexists. Qed.
-Definition monPred_and := monPred_and_aux.(unseal).
-Definition monPred_and_eq : @monPred_and = _ := monPred_and_aux.(seal_eq).
-
-Program Definition monPred_or_def P Q : monPred :=
- MonPred (λ i, P i ∨ Q i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_or_aux : seal (@monPred_or_def). by eexists. Qed.
-Definition monPred_or := monPred_or_aux.(unseal).
-Definition monPred_or_eq : @monPred_or = _ := monPred_or_aux.(seal_eq).
-
-Definition monPred_impl_def P Q : monPred :=
- monPred_upclosed (λ i, P i → Q i)%I.
-Definition monPred_impl_aux : seal (@monPred_impl_def). by eexists. Qed.
-Definition monPred_impl := monPred_impl_aux.(unseal).
-Definition monPred_impl_eq : @monPred_impl = _ := monPred_impl_aux.(seal_eq).
-
-Program Definition monPred_forall_def A (Φ : A → monPred) : monPred :=
- MonPred (λ i, ∀ x : A, Φ x i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_forall_aux : seal (@monPred_forall_def). by eexists. Qed.
-Definition monPred_forall := monPred_forall_aux.(unseal).
-Definition monPred_forall_eq : @monPred_forall = _ := monPred_forall_aux.(seal_eq).
-
-Program Definition monPred_exist_def A (Φ : A → monPred) : monPred :=
- MonPred (λ i, ∃ x : A, Φ x i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_exist_aux : seal (@monPred_exist_def). by eexists. Qed.
-Definition monPred_exist := monPred_exist_aux.(unseal).
-Definition monPred_exist_eq : @monPred_exist = _ := monPred_exist_aux.(seal_eq).
-
-Program Definition monPred_sep_def P Q : monPred :=
- MonPred (λ i, P i ∗ Q i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_sep_aux : seal (@monPred_sep_def). by eexists. Qed.
-Definition monPred_sep := monPred_sep_aux.(unseal).
-Definition monPred_sep_eq : @monPred_sep = _ := monPred_sep_aux.(seal_eq).
-
-Definition monPred_wand_def P Q : monPred :=
- monPred_upclosed (λ i, P i -∗ Q i)%I.
-Definition monPred_wand_aux : seal (@monPred_wand_def). by eexists. Qed.
-Definition monPred_wand := monPred_wand_aux.(unseal).
-Definition monPred_wand_eq : @monPred_wand = _ := monPred_wand_aux.(seal_eq).
-
-Program Definition monPred_persistently_def P : monPred :=
- MonPred (λ i, <pers> (P i))%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_persistently_aux : seal (@monPred_persistently_def). by eexists. Qed.
-Definition monPred_persistently := monPred_persistently_aux.(unseal).
-Definition monPred_persistently_eq : @monPred_persistently = _ := monPred_persistently_aux.(seal_eq).
-
-Program Definition monPred_in_def (i0 : I) : monPred :=
- MonPred (λ i : I, ⌜i0 ⊑ iâŒ%I) _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_in_aux : seal (@monPred_in_def). by eexists. Qed.
-Definition monPred_in := monPred_in_aux.(unseal).
-Definition monPred_in_eq : @monPred_in = _ := monPred_in_aux.(seal_eq).
-End Bi.
-
-Arguments monPred_objectively {_ _} _%I.
-Arguments monPred_subjectively {_ _} _%I.
-Notation "'<obj>' P" := (monPred_objectively P) : bi_scope.
-Notation "'<subj>' P" := (monPred_subjectively P) : bi_scope.
-
-Section Sbi.
-Context {I : biIndex} {PROP : sbi}.
-Implicit Types i : I.
-Notation monPred := (monPred I PROP).
-Implicit Types P Q : monPred.
-
-Definition monPred_internal_eq_def (A : ofeT) (a b : A) : monPred :=
- MonPred (λ _, a ≡ b)%I _.
-Definition monPred_internal_eq_aux : seal (@monPred_internal_eq_def). by eexists. Qed.
-Definition monPred_internal_eq := monPred_internal_eq_aux.(unseal).
-Definition monPred_internal_eq_eq : @monPred_internal_eq = _ :=
- monPred_internal_eq_aux.(seal_eq).
-
-Program Definition monPred_later_def P : monPred := MonPred (λ i, ▷ (P i))%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_later_aux : seal monPred_later_def. by eexists. Qed.
-Definition monPred_later := monPred_later_aux.(unseal).
-Definition monPred_later_eq : monPred_later = _ := monPred_later_aux.(seal_eq).
-End Sbi.
-
-Module MonPred.
-Definition unseal_eqs :=
- (@monPred_and_eq, @monPred_or_eq, @monPred_impl_eq,
- @monPred_forall_eq, @monPred_exist_eq, @monPred_sep_eq, @monPred_wand_eq,
- @monPred_persistently_eq, @monPred_later_eq, @monPred_internal_eq_eq, @monPred_in_eq,
- @monPred_embed_eq, @monPred_emp_eq, @monPred_pure_eq,
- @monPred_objectively_eq, @monPred_subjectively_eq).
-Ltac unseal :=
- unfold bi_affinely, bi_absorbingly, sbi_except_0, bi_pure, bi_emp,
- monPred_upclosed, bi_and, bi_or,
- bi_impl, bi_forall, bi_exist, sbi_internal_eq, bi_sep, bi_wand,
- bi_persistently, bi_affinely, sbi_later;
- simpl;
- unfold sbi_emp, sbi_pure, sbi_and, sbi_or, sbi_impl, sbi_forall, sbi_exist,
- sbi_internal_eq, sbi_sep, sbi_wand, sbi_persistently;
- simpl;
- rewrite !unseal_eqs /=.
-End MonPred.
-Import MonPred.
-
-Section canonical_bi.
-Context (I : biIndex) (PROP : bi).
-
-Lemma monPred_bi_mixin : BiMixin (PROP:=monPred I PROP)
- monPred_entails monPred_emp monPred_pure monPred_and monPred_or
- monPred_impl monPred_forall monPred_exist monPred_sep monPred_wand
- monPred_persistently.
-Proof.
- split; try unseal; try by (split=> ? /=; repeat f_equiv).
- - split.
- + intros P. by split.
- + intros P Q R [H1] [H2]. split => ?. by rewrite H1 H2.
- - split.
- + intros [HPQ]. split; split => i; move: (HPQ i); by apply bi.equiv_spec.
- + intros [[] []]. split=>i. by apply bi.equiv_spec.
- - intros P φ ?. split=> i. by apply bi.pure_intro.
- - intros φ P HP. split=> i. apply bi.pure_elim'=> ?. by apply HP.
- - intros A φ. split=> i. by apply bi.pure_forall_2.
- - intros P Q. split=> i. by apply bi.and_elim_l.
- - intros P Q. split=> i. by apply bi.and_elim_r.
- - intros P Q R [?] [?]. split=> i. by apply bi.and_intro.
- - intros P Q. split=> i. by apply bi.or_intro_l.
- - intros P Q. split=> i. by apply bi.or_intro_r.
- - intros P Q R [?] [?]. split=> i. by apply bi.or_elim.
- - intros P Q R [HR]. split=> i /=. setoid_rewrite bi.pure_impl_forall.
- apply bi.forall_intro=> j. apply bi.forall_intro=> Hij.
- apply bi.impl_intro_r. by rewrite -HR /= !Hij.
- - intros P Q R [HR]. split=> i /=.
- rewrite HR /= bi.forall_elim bi.pure_impl_forall bi.forall_elim //.
- apply bi.impl_elim_l.
- - intros A P Ψ HΨ. split=> i. apply bi.forall_intro => ?. by apply HΨ.
- - intros A Ψ. split=> i. by apply: bi.forall_elim.
- - intros A Ψ a. split=> i. by rewrite /= -bi.exist_intro.
- - intros A Ψ Q HΨ. split=> i. apply bi.exist_elim => a. by apply HΨ.
- - intros P P' Q Q' [?] [?]. split=> i. by apply bi.sep_mono.
- - intros P. split=> i. by apply bi.emp_sep_1.
- - intros P. split=> i. by apply bi.emp_sep_2.
- - intros P Q. split=> i. by apply bi.sep_comm'.
- - intros P Q R. split=> i. by apply bi.sep_assoc'.
- - intros P Q R [HR]. split=> i /=. setoid_rewrite bi.pure_impl_forall.
- apply bi.forall_intro=> j. apply bi.forall_intro=> Hij.
- apply bi.wand_intro_r. by rewrite -HR /= !Hij.
- - intros P Q R [HP]. split=> i. apply bi.wand_elim_l'.
- rewrite HP /= bi.forall_elim bi.pure_impl_forall bi.forall_elim //.
- - intros P Q [?]. split=> i /=. by f_equiv.
- - intros P. split=> i. by apply bi.persistently_idemp_2.
- - split=> i. by apply bi.persistently_emp_intro.
- - intros A Ψ. split=> i. by apply bi.persistently_forall_2.
- - intros A Ψ. split=> i. by apply bi.persistently_exist_1.
- - intros P Q. split=> i. apply bi.sep_elim_l, _.
- - intros P Q. split=> i. by apply bi.persistently_and_sep_elim.
-Qed.
-
-Canonical Structure monPredI : bi :=
- {| bi_ofe_mixin := monPred_ofe_mixin; bi_bi_mixin := monPred_bi_mixin |}.
-End canonical_bi.
-
-Section canonical_sbi.
-Context (I : biIndex) (PROP : sbi).
-
-Lemma monPred_sbi_mixin :
- SbiMixin (PROP:=monPred I PROP) monPred_entails monPred_pure
- monPred_or monPred_impl monPred_forall monPred_exist
- monPred_sep monPred_persistently monPred_internal_eq monPred_later.
-Proof.
- split; unseal.
- - intros n P Q HPQ. split=> i /=.
- apply bi.later_contractive. destruct n as [|n]=> //. by apply HPQ.
- - by split=> ? /=; repeat f_equiv.
- - intros A P a. split=> i. by apply bi.internal_eq_refl.
- - intros A a b Ψ ?. split=> i /=.
- setoid_rewrite bi.pure_impl_forall. do 2 apply bi.forall_intro => ?.
- erewrite (bi.internal_eq_rewrite _ _ (flip Ψ _)) => //=. solve_proper.
- - intros A1 A2 f g. split=> i. by apply bi.fun_ext.
- - intros A P x y. split=> i. by apply bi.sig_eq.
- - intros A a b ?. split=> i. by apply bi.discrete_eq_1.
- - intros A x y. split=> i. by apply bi.later_eq_1.
- - intros A x y. split=> i. by apply bi.later_eq_2.
- - intros P Q [?]. split=> i. by apply bi.later_mono.
- - intros P. split=> i /=. by apply bi.later_intro.
- - intros A Ψ. split=> i. by apply bi.later_forall_2.
- - intros A Ψ. split=> i. by apply bi.later_exist_false.
- - intros P Q. split=> i. by apply bi.later_sep_1.
- - intros P Q. split=> i. by apply bi.later_sep_2.
- - intros P. split=> i. by apply bi.later_persistently_1.
- - intros P. split=> i. by apply bi.later_persistently_2.
- - intros P. split=> i /=. rewrite -bi.forall_intro. apply bi.later_false_em.
- intros j. rewrite bi.pure_impl_forall. apply bi.forall_intro=> Hij. by rewrite Hij.
-Qed.
-
-Canonical Structure monPredSI : sbi :=
- {| sbi_ofe_mixin := monPred_ofe_mixin; sbi_bi_mixin := monPred_bi_mixin I PROP;
- sbi_sbi_mixin := monPred_sbi_mixin |}.
-End canonical_sbi.
-
-Class Objective {I : biIndex} {PROP : bi} (P : monPred I PROP) :=
- objective_at i j : P i -∗ P j.
-Arguments Objective {_ _} _%I.
-Arguments objective_at {_ _} _%I {_}.
-Hint Mode Objective + + ! : typeclass_instances.
-Instance: Params (@Objective) 2 := {}.
-
-(** Primitive facts that cannot be deduced from the BI structure. *)
-
-Section bi_facts.
-Context {I : biIndex} {PROP : bi}.
-Local Notation monPred := (monPred I PROP).
-Local Notation monPredI := (monPredI I PROP).
-Local Notation monPred_at := (@monPred_at I PROP).
-Local Notation BiIndexBottom := (@BiIndexBottom I).
-Implicit Types i : I.
-Implicit Types P Q : monPred.
-
-(** Instances *)
-Global Instance monPred_at_mono :
- Proper ((⊢) ==> (⊑) ==> (⊢)) monPred_at.
-Proof. by move=> ?? [?] ?? ->. Qed.
-Global Instance monPred_at_flip_mono :
- Proper (flip (⊢) ==> flip (⊑) ==> flip (⊢)) monPred_at.
-Proof. solve_proper. Qed.
-
-Global Instance monPred_in_proper (R : relation I) :
- Proper (R ==> R ==> iff) (⊑) → Reflexive R →
- Proper (R ==> (≡)) (@monPred_in I PROP).
-Proof. unseal. split. solve_proper. Qed.
-Global Instance monPred_in_mono : Proper (flip (⊑) ==> (⊢)) (@monPred_in I PROP).
-Proof. unseal. split. solve_proper. Qed.
-Global Instance monPred_in_flip_mono : Proper ((⊑) ==> flip (⊢)) (@monPred_in I PROP).
-Proof. solve_proper. Qed.
-
-Global Instance monPred_positive : BiPositive PROP → BiPositive monPredI.
-Proof. split => ?. unseal. apply bi_positive. Qed.
-Global Instance monPred_affine : BiAffine PROP → BiAffine monPredI.
-Proof. split => ?. unseal. by apply affine. Qed.
-
-Global Instance monPred_at_persistent P i : Persistent P → Persistent (P i).
-Proof. move => [] /(_ i). by unseal. Qed.
-Global Instance monPred_at_absorbing P i : Absorbing P → Absorbing (P i).
-Proof. move => [] /(_ i). unfold Absorbing. by unseal. Qed.
-Global Instance monPred_at_affine P i : Affine P → Affine (P i).
-Proof. move => [] /(_ i). unfold Affine. by unseal. Qed.
-
-(* Note that monPred_in is *not* Plain, because it does depend on the
- index. *)
-Global Instance monPred_in_persistent i :
- Persistent (@monPred_in I PROP i).
-Proof. unfold Persistent. unseal; split => ?. by apply bi.pure_persistent. Qed.
-Global Instance monPred_in_absorbing i :
- Absorbing (@monPred_in I PROP i).
-Proof. unfold Absorbing. unseal. split=> ? /=. apply absorbing, _. Qed.
-
-Definition monPred_embedding_mixin : BiEmbedMixin PROP monPredI monPred_embed.
-Proof.
- split; try apply _; rewrite /bi_emp_valid; unseal; try done.
- - move=> P /= [/(_ inhabitant) ?] //.
- - intros P Q. split=> i /=.
- by rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim.
- - intros P Q. split=> i /=.
- by rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim.
-Qed.
-Global Instance monPred_bi_embed : BiEmbed PROP monPredI :=
- {| bi_embed_mixin := monPred_embedding_mixin |}.
-Global Instance monPred_bi_embed_emp : BiEmbedEmp PROP monPredI.
-Proof. split. by unseal. Qed.
-
-Lemma monPred_emp_unfold : emp%I = ⎡emp : PROP⎤%I.
-Proof. by unseal. Qed.
-Lemma monPred_pure_unfold : bi_pure = λ φ, ⎡ ⌜ φ ⌠: PROP⎤%I.
-Proof. by unseal. Qed.
-Lemma monPred_objectively_unfold : monPred_objectively = λ P, ⎡∀ i, P i⎤%I.
-Proof. by unseal. Qed.
-Lemma monPred_subjectively_unfold : monPred_subjectively = λ P, ⎡∃ i, P i⎤%I.
-Proof. by unseal. Qed.
-
-Global Instance monPred_objectively_ne : NonExpansive (@monPred_objectively I PROP).
-Proof. rewrite monPred_objectively_unfold. solve_proper. Qed.
-Global Instance monPred_objectively_proper : Proper ((≡) ==> (≡)) (@monPred_objectively I PROP).
-Proof. apply (ne_proper _). Qed.
-Lemma monPred_objectively_mono P Q : (P ⊢ Q) → (<obj> P ⊢ <obj> Q).
-Proof. rewrite monPred_objectively_unfold. solve_proper. Qed.
-Global Instance monPred_objectively_mono' : Proper ((⊢) ==> (⊢)) (@monPred_objectively I PROP).
-Proof. intros ???. by apply monPred_objectively_mono. Qed.
-Global Instance monPred_objectively_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@monPred_objectively I PROP).
-Proof. intros ???. by apply monPred_objectively_mono. Qed.
-
-Global Instance monPred_objectively_persistent P : Persistent P → Persistent (<obj> P).
-Proof. rewrite monPred_objectively_unfold. apply _. Qed.
-Global Instance monPred_objectively_absorbing P : Absorbing P → Absorbing (<obj> P).
-Proof. rewrite monPred_objectively_unfold. apply _. Qed.
-Global Instance monPred_objectively_affine P : Affine P → Affine (<obj> P).
-Proof. rewrite monPred_objectively_unfold. apply _. Qed.
-
-Global Instance monPred_subjectively_ne : NonExpansive (@monPred_subjectively I PROP).
-Proof. rewrite monPred_subjectively_unfold. solve_proper. Qed.
-Global Instance monPred_subjectively_proper : Proper ((≡) ==> (≡)) (@monPred_subjectively I PROP).
-Proof. apply (ne_proper _). Qed.
-Lemma monPred_subjectively_mono P Q : (P ⊢ Q) → <subj> P ⊢ <subj> Q.
-Proof. rewrite monPred_subjectively_unfold. solve_proper. Qed.
-Global Instance monPred_subjectively_mono' : Proper ((⊢) ==> (⊢)) (@monPred_subjectively I PROP).
-Proof. intros ???. by apply monPred_subjectively_mono. Qed.
-Global Instance monPred_subjectively_flip_mono' :
- Proper (flip (⊢) ==> flip (⊢)) (@monPred_subjectively I PROP).
-Proof. intros ???. by apply monPred_subjectively_mono. Qed.
-
-Global Instance monPred_subjectively_persistent P : Persistent P → Persistent (<subj> P).
-Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
-Global Instance monPred_subjectively_absorbing P : Absorbing P → Absorbing (<subj> P).
-Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
-Global Instance monPred_subjectively_affine P : Affine P → Affine (<subj> P).
-Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
-
-(** monPred_at unfolding laws *)
-Lemma monPred_at_embed i (P : PROP) : monPred_at ⎡P⎤ i ⊣⊢ P.
-Proof. by unseal. Qed.
-Lemma monPred_at_pure i (φ : Prop) : monPred_at ⌜φ⌠i ⊣⊢ ⌜φâŒ.
-Proof. by unseal. Qed.
-Lemma monPred_at_emp i : monPred_at emp i ⊣⊢ emp.
-Proof. by unseal. Qed.
-Lemma monPred_at_and i P Q : (P ∧ Q) i ⊣⊢ P i ∧ Q i.
-Proof. by unseal. Qed.
-Lemma monPred_at_or i P Q : (P ∨ Q) i ⊣⊢ P i ∨ Q i.
-Proof. by unseal. Qed.
-Lemma monPred_at_impl i P Q : (P → Q) i ⊣⊢ ∀ j, ⌜i ⊑ j⌠→ P j → Q j.
-Proof. by unseal. Qed.
-Lemma monPred_at_forall {A} i (Φ : A → monPred) : (∀ x, Φ x) i ⊣⊢ ∀ x, Φ x i.
-Proof. by unseal. Qed.
-Lemma monPred_at_exist {A} i (Φ : A → monPred) : (∃ x, Φ x) i ⊣⊢ ∃ x, Φ x i.
-Proof. by unseal. Qed.
-Lemma monPred_at_sep i P Q : (P ∗ Q) i ⊣⊢ P i ∗ Q i.
-Proof. by unseal. Qed.
-Lemma monPred_at_wand i P Q : (P -∗ Q) i ⊣⊢ ∀ j, ⌜i ⊑ j⌠→ P j -∗ Q j.
-Proof. by unseal. Qed.
-Lemma monPred_at_persistently i P : (<pers> P) i ⊣⊢ <pers> (P i).
-Proof. by unseal. Qed.
-Lemma monPred_at_in i j : monPred_at (monPred_in j) i ⊣⊢ ⌜j ⊑ iâŒ.
-Proof. by unseal. Qed.
-Lemma monPred_at_objectively i P : (<obj> P) i ⊣⊢ ∀ j, P j.
-Proof. by unseal. Qed.
-Lemma monPred_at_subjectively i P : (<subj> P) i ⊣⊢ ∃ j, P j.
-Proof. by unseal. Qed.
-Lemma monPred_at_persistently_if i p P : (<pers>?p P) i ⊣⊢ <pers>?p (P i).
-Proof. destruct p=>//=. apply monPred_at_persistently. Qed.
-Lemma monPred_at_affinely i P : (<affine> P) i ⊣⊢ <affine> (P i).
-Proof. by rewrite /bi_affinely monPred_at_and monPred_at_emp. Qed.
-Lemma monPred_at_affinely_if i p P : (<affine>?p P) i ⊣⊢ <affine>?p (P i).
-Proof. destruct p=>//=. apply monPred_at_affinely. Qed.
-Lemma monPred_at_intuitionistically i P : (□ P) i ⊣⊢ □ (P i).
-Proof. by rewrite /bi_intuitionistically monPred_at_affinely monPred_at_persistently. Qed.
-Lemma monPred_at_intuitionistically_if i p P : (□?p P) i ⊣⊢ □?p (P i).
-Proof. destruct p=>//=. apply monPred_at_intuitionistically. Qed.
-
-Lemma monPred_at_absorbingly i P : (<absorb> P) i ⊣⊢ <absorb> (P i).
-Proof. by rewrite /bi_absorbingly monPred_at_sep monPred_at_pure. Qed.
-Lemma monPred_at_absorbingly_if i p P : (<absorb>?p P) i ⊣⊢ <absorb>?p (P i).
-Proof. destruct p=>//=. apply monPred_at_absorbingly. Qed.
-
-Lemma monPred_wand_force i P Q : (P -∗ Q) i -∗ (P i -∗ Q i).
-Proof. unseal. rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim //. Qed.
-Lemma monPred_impl_force i P Q : (P → Q) i -∗ (P i → Q i).
-Proof. unseal. rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim //. Qed.
-
-(* Laws for monPred_objectively and of Objective. *)
-Lemma monPred_objectively_elim P : <obj> P ⊢ P.
-Proof. rewrite monPred_objectively_unfold. unseal. split=>?. apply bi.forall_elim. Qed.
-Lemma monPred_objectively_idemp P : <obj> <obj> P ⊣⊢ <obj> P.
-Proof.
- apply bi.equiv_spec; split; [by apply monPred_objectively_elim|].
- unseal. split=>i /=. by apply bi.forall_intro=>_.
-Qed.
-
-Lemma monPred_objectively_forall {A} (Φ : A → monPred) : <obj> (∀ x, Φ x) ⊣⊢ ∀ x, <obj> (Φ x).
-Proof.
- unseal. split=>i. apply bi.equiv_spec; split=>/=;
- do 2 apply bi.forall_intro=>?; by do 2 rewrite bi.forall_elim.
-Qed.
-Lemma monPred_objectively_and P Q : <obj> (P ∧ Q) ⊣⊢ <obj> P ∧ <obj> Q.
-Proof.
- unseal. split=>i. apply bi.equiv_spec; split=>/=.
- - apply bi.and_intro; do 2 f_equiv. apply bi.and_elim_l. apply bi.and_elim_r.
- - apply bi.forall_intro=>?. by rewrite !bi.forall_elim.
-Qed.
-Lemma monPred_objectively_exist {A} (Φ : A → monPred) :
- (∃ x, <obj> (Φ x)) ⊢ <obj> (∃ x, (Φ x)).
-Proof. apply bi.exist_elim=>?. f_equiv. apply bi.exist_intro. Qed.
-Lemma monPred_objectively_or P Q : <obj> P ∨ <obj> Q ⊢ <obj> (P ∨ Q).
-Proof. apply bi.or_elim; f_equiv. apply bi.or_intro_l. apply bi.or_intro_r. Qed.
-
-Lemma monPred_objectively_sep_2 P Q : <obj> P ∗ <obj> Q ⊢ <obj> (P ∗ Q).
-Proof. unseal. split=>i /=. apply bi.forall_intro=>?. by rewrite !bi.forall_elim. Qed.
-Lemma monPred_objectively_sep `{BiIndexBottom bot} P Q : <obj> (P ∗ Q) ⊣⊢ <obj> P ∗ <obj> Q.
-Proof.
- apply bi.equiv_spec, conj, monPred_objectively_sep_2. unseal. split=>i /=.
- rewrite (bi.forall_elim bot). by f_equiv; apply bi.forall_intro=>j; f_equiv.
-Qed.
-Lemma monPred_objectively_embed (P : PROP) : <obj> ⎡P⎤ ⊣⊢ ⎡P⎤.
-Proof.
- apply bi.equiv_spec; split; unseal; split=>i /=.
- by rewrite (bi.forall_elim inhabitant). by apply bi.forall_intro.
-Qed.
-Lemma monPred_objectively_emp : <obj> (emp : monPred) ⊣⊢ emp.
-Proof. rewrite monPred_emp_unfold. apply monPred_objectively_embed. Qed.
-Lemma monPred_objectively_pure φ : <obj> (⌜ φ ⌠: monPred) ⊣⊢ ⌜ φ âŒ.
-Proof. rewrite monPred_pure_unfold. apply monPred_objectively_embed. Qed.
-
-Lemma monPred_subjectively_intro P : P ⊢ <subj> P.
-Proof. unseal. split=>?. apply bi.exist_intro. Qed.
-
-Lemma monPred_subjectively_forall {A} (Φ : A → monPred) :
- (<subj> (∀ x, Φ x)) ⊢ ∀ x, <subj> (Φ x).
-Proof. apply bi.forall_intro=>?. f_equiv. apply bi.forall_elim. Qed.
-Lemma monPred_subjectively_and P Q : <subj> (P ∧ Q) ⊢ <subj> P ∧ <subj> Q.
-Proof. apply bi.and_intro; f_equiv. apply bi.and_elim_l. apply bi.and_elim_r. Qed.
-Lemma monPred_subjectively_exist {A} (Φ : A → monPred) : <subj> (∃ x, Φ x) ⊣⊢ ∃ x, <subj> (Φ x).
-Proof.
- unseal. split=>i. apply bi.equiv_spec; split=>/=;
- do 2 apply bi.exist_elim=>?; by do 2 rewrite -bi.exist_intro.
-Qed.
-Lemma monPred_subjectively_or P Q : <subj> (P ∨ Q) ⊣⊢ <subj> P ∨ <subj> Q.
-Proof.
- unseal. split=>i. apply bi.equiv_spec; split=>/=.
- - apply bi.exist_elim=>?. by rewrite -!bi.exist_intro.
- - apply bi.or_elim; do 2 f_equiv. apply bi.or_intro_l. apply bi.or_intro_r.
-Qed.
-
-Lemma monPred_subjectively_sep P Q : <subj> (P ∗ Q) ⊢ <subj> P ∗ <subj> Q.
-Proof. unseal. split=>i /=. apply bi.exist_elim=>?. by rewrite -!bi.exist_intro. Qed.
-
-Lemma monPred_subjectively_idemp P : <subj> <subj> P ⊣⊢ <subj> P.
-Proof.
- apply bi.equiv_spec; split; [|by apply monPred_subjectively_intro].
- unseal. split=>i /=. by apply bi.exist_elim=>_.
-Qed.
-
-Lemma objective_objectively P `{!Objective P} : P ⊢ <obj> P.
-Proof.
- rewrite monPred_objectively_unfold /= embed_forall. apply bi.forall_intro=>?.
- split=>?. unseal. apply objective_at, _.
-Qed.
-Lemma objective_subjectively P `{!Objective P} : <subj> P ⊢ P.
-Proof.
- rewrite monPred_subjectively_unfold /= embed_exist. apply bi.exist_elim=>?.
- split=>?. unseal. apply objective_at, _.
-Qed.
-
-Global Instance embed_objective (P : PROP) : @Objective I PROP ⎡P⎤.
-Proof. intros ??. by unseal. Qed.
-Global Instance pure_objective φ : @Objective I PROP ⌜φâŒ.
-Proof. intros ??. by unseal. Qed.
-Global Instance emp_objective : @Objective I PROP emp.
-Proof. intros ??. by unseal. Qed.
-Global Instance objectively_objective P : Objective (<obj> P).
-Proof. intros ??. by unseal. Qed.
-Global Instance subjectively_objective P : Objective (<subj> P).
-Proof. intros ??. by unseal. Qed.
-
-Global Instance and_objective P Q `{!Objective P, !Objective Q} : Objective (P ∧ Q).
-Proof. intros i j. unseal. by rewrite !(objective_at _ i j). Qed.
-Global Instance or_objective P Q `{!Objective P, !Objective Q} : Objective (P ∨ Q).
-Proof. intros i j. by rewrite !monPred_at_or !(objective_at _ i j). Qed.
-Global Instance impl_objective P Q `{!Objective P, !Objective Q} : Objective (P → Q).
-Proof.
- intros i j. unseal. rewrite (bi.forall_elim i) bi.pure_impl_forall.
- rewrite bi.forall_elim //. apply bi.forall_intro=> k.
- rewrite bi.pure_impl_forall. apply bi.forall_intro=>_.
- rewrite (objective_at Q i). by rewrite (objective_at P k).
-Qed.
-Global Instance forall_objective {A} Φ {H : ∀ x : A, Objective (Φ x)} :
- @Objective I PROP (∀ x, Φ x)%I.
-Proof. intros i j. unseal. do 2 f_equiv. by apply objective_at. Qed.
-Global Instance exists_objective {A} Φ {H : ∀ x : A, Objective (Φ x)} :
- @Objective I PROP (∃ x, Φ x)%I.
-Proof. intros i j. unseal. do 2 f_equiv. by apply objective_at. Qed.
-
-Global Instance sep_objective P Q `{!Objective P, !Objective Q} : Objective (P ∗ Q).
-Proof. intros i j. unseal. by rewrite !(objective_at _ i j). Qed.
-Global Instance wand_objective P Q `{!Objective P, !Objective Q} : Objective (P -∗ Q).
-Proof.
- intros i j. unseal. rewrite (bi.forall_elim i) bi.pure_impl_forall.
- rewrite bi.forall_elim //. apply bi.forall_intro=> k.
- rewrite bi.pure_impl_forall. apply bi.forall_intro=>_.
- rewrite (objective_at Q i). by rewrite (objective_at P k).
-Qed.
-Global Instance persistently_objective P `{!Objective P} : Objective (<pers> P).
-Proof. intros i j. unseal. by rewrite objective_at. Qed.
-
-Global Instance affinely_objective P `{!Objective P} : Objective (<affine> P).
-Proof. rewrite /bi_affinely. apply _. Qed.
-Global Instance intuitionistically_objective P `{!Objective P} : Objective (â–¡ P).
-Proof. rewrite /bi_intuitionistically. apply _. Qed.
-Global Instance absorbingly_objective P `{!Objective P} : Objective (<absorb> P).
-Proof. rewrite /bi_absorbingly. apply _. Qed.
-Global Instance persistently_if_objective P p `{!Objective P} : Objective (<pers>?p P).
-Proof. rewrite /bi_persistently_if. destruct p; apply _. Qed.
-Global Instance affinely_if_objective P p `{!Objective P} : Objective (<affine>?p P).
-Proof. rewrite /bi_affinely_if. destruct p; apply _. Qed.
-Global Instance absorbingly_if_objective P p `{!Objective P} : Objective (<absorb>?p P).
-Proof. rewrite /bi_absorbingly_if. destruct p; apply _. Qed.
-Global Instance intuitionistically_if_objective P p `{!Objective P} : Objective (â–¡?p P).
-Proof. rewrite /bi_intuitionistically_if. destruct p; apply _. Qed.
-
-(** monPred_in *)
-Lemma monPred_in_intro P : P ⊢ ∃ i, monPred_in i ∧ ⎡P i⎤.
-Proof.
- unseal. split=>i /=.
- rewrite /= -(bi.exist_intro i). apply bi.and_intro=>//. by apply bi.pure_intro.
-Qed.
-Lemma monPred_in_elim P i : monPred_in i -∗ ⎡P i⎤ → P .
-Proof.
- apply bi.impl_intro_r. unseal. split=>i' /=.
- eapply bi.pure_elim; [apply bi.and_elim_l|]=>?. rewrite bi.and_elim_r. by f_equiv.
-Qed.
-
-(** Big op *)
-Global Instance monPred_at_monoid_and_homomorphism i :
- MonoidHomomorphism bi_and bi_and (≡) (flip monPred_at i).
-Proof. split; [split|]; try apply _. apply monPred_at_and. apply monPred_at_pure. Qed.
-Global Instance monPred_at_monoid_or_homomorphism i :
- MonoidHomomorphism bi_or bi_or (≡) (flip monPred_at i).
-Proof. split; [split|]; try apply _. apply monPred_at_or. apply monPred_at_pure. Qed.
-Global Instance monPred_at_monoid_sep_homomorphism i :
- MonoidHomomorphism bi_sep bi_sep (≡) (flip monPred_at i).
-Proof. split; [split|]; try apply _. apply monPred_at_sep. apply monPred_at_emp. Qed.
-
-Lemma monPred_at_big_sepL {A} i (Φ : nat → A → monPred) l :
- ([∗ list] k↦x ∈ l, Φ k x) i ⊣⊢ [∗ list] k↦x ∈ l, Φ k x i.
-Proof. apply (big_opL_commute (flip monPred_at i)). Qed.
-Lemma monPred_at_big_sepM `{Countable K} {A} i (Φ : K → A → monPred) (m : gmap K A) :
- ([∗ map] k↦x ∈ m, Φ k x) i ⊣⊢ [∗ map] k↦x ∈ m, Φ k x i.
-Proof. apply (big_opM_commute (flip monPred_at i)). Qed.
-Lemma monPred_at_big_sepS `{Countable A} i (Φ : A → monPred) (X : gset A) :
- ([∗ set] y ∈ X, Φ y) i ⊣⊢ [∗ set] y ∈ X, Φ y i.
-Proof. apply (big_opS_commute (flip monPred_at i)). Qed.
-Lemma monPred_at_big_sepMS `{Countable A} i (Φ : A → monPred) (X : gmultiset A) :
- ([∗ mset] y ∈ X, Φ y) i ⊣⊢ ([∗ mset] y ∈ X, Φ y i).
-Proof. apply (big_opMS_commute (flip monPred_at i)). Qed.
-
-Global Instance monPred_objectively_monoid_and_homomorphism :
- MonoidHomomorphism bi_and bi_and (≡) (@monPred_objectively I PROP).
-Proof.
- split; [split|]; try apply _. apply monPred_objectively_and.
- apply monPred_objectively_pure.
-Qed.
-Global Instance monPred_objectively_monoid_sep_entails_homomorphism :
- MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@monPred_objectively I PROP).
-Proof.
- split; [split|]; try apply _. apply monPred_objectively_sep_2.
- by rewrite monPred_objectively_emp.
-Qed.
-Global Instance monPred_objectively_monoid_sep_homomorphism `{BiIndexBottom bot} :
- MonoidHomomorphism bi_sep bi_sep (≡) (@monPred_objectively I PROP).
-Proof.
- split; [split|]; try apply _. apply monPred_objectively_sep.
- by rewrite monPred_objectively_emp.
-Qed.
-
-Lemma monPred_objectively_big_sepL_entails {A} (Φ : nat → A → monPred) l :
- ([∗ list] k↦x ∈ l, <obj> (Φ k x)) ⊢ <obj> ([∗ list] k↦x ∈ l, Φ k x).
-Proof. apply (big_opL_commute monPred_objectively (R:=flip (⊢))). Qed.
-Lemma monPred_objectively_big_sepM_entails
- `{Countable K} {A} (Φ : K → A → monPred) (m : gmap K A) :
- ([∗ map] k↦x ∈ m, <obj> (Φ k x)) ⊢ <obj> ([∗ map] k↦x ∈ m, Φ k x).
-Proof. apply (big_opM_commute monPred_objectively (R:=flip (⊢))). Qed.
-Lemma monPred_objectively_big_sepS_entails `{Countable A} (Φ : A → monPred) (X : gset A) :
- ([∗ set] y ∈ X, <obj> (Φ y)) ⊢ <obj> ([∗ set] y ∈ X, Φ y).
-Proof. apply (big_opS_commute monPred_objectively (R:=flip (⊢))). Qed.
-Lemma monPred_objectively_big_sepMS_entails `{Countable A} (Φ : A → monPred) (X : gmultiset A) :
- ([∗ mset] y ∈ X, <obj> (Φ y)) ⊢ <obj> ([∗ mset] y ∈ X, Φ y).
-Proof. apply (big_opMS_commute monPred_objectively (R:=flip (⊢))). Qed.
-
-Lemma monPred_objectively_big_sepL `{BiIndexBottom bot} {A} (Φ : nat → A → monPred) l :
- <obj> ([∗ list] k↦x ∈ l, Φ k x) ⊣⊢ ([∗ list] k↦x ∈ l, <obj> (Φ k x)).
-Proof. apply (big_opL_commute _). Qed.
-Lemma monPred_objectively_big_sepM `{BiIndexBottom bot} `{Countable K} {A}
- (Φ : K → A → monPred) (m : gmap K A) :
- <obj> ([∗ map] k↦x ∈ m, Φ k x) ⊣⊢ ([∗ map] k↦x ∈ m, <obj> (Φ k x)).
-Proof. apply (big_opM_commute _). Qed.
-Lemma monPred_objectively_big_sepS `{BiIndexBottom bot} `{Countable A}
- (Φ : A → monPred) (X : gset A) :
- <obj> ([∗ set] y ∈ X, Φ y) ⊣⊢ ([∗ set] y ∈ X, <obj> (Φ y)).
-Proof. apply (big_opS_commute _). Qed.
-Lemma monPred_objectively_big_sepMS `{BiIndexBottom bot} `{Countable A}
- (Φ : A → monPred) (X : gmultiset A) :
- <obj> ([∗ mset] y ∈ X, Φ y) ⊣⊢ ([∗ mset] y ∈ X, <obj> (Φ y)).
-Proof. apply (big_opMS_commute _). Qed.
-
-Global Instance big_sepL_objective {A} (l : list A) Φ `{∀ n x, Objective (Φ n x)} :
- @Objective I PROP ([∗ list] n↦x ∈ l, Φ n x)%I.
-Proof. generalize dependent Φ. induction l=>/=; apply _. Qed.
-Global Instance big_sepM_objective `{Countable K} {A}
- (Φ : K → A → monPred) (m : gmap K A) `{∀ k x, Objective (Φ k x)} :
- Objective ([∗ map] k↦x ∈ m, Φ k x)%I.
-Proof. intros ??. rewrite !monPred_at_big_sepM. do 3 f_equiv. by apply objective_at. Qed.
-Global Instance big_sepS_objective `{Countable A} (Φ : A → monPred)
- (X : gset A) `{∀ y, Objective (Φ y)} :
- Objective ([∗ set] y ∈ X, Φ y)%I.
-Proof. intros ??. rewrite !monPred_at_big_sepS. do 2 f_equiv. by apply objective_at. Qed.
-Global Instance big_sepMS_objective `{Countable A} (Φ : A → monPred)
- (X : gmultiset A) `{∀ y, Objective (Φ y)} :
- Objective ([∗ mset] y ∈ X, Φ y)%I.
-Proof. intros ??. rewrite !monPred_at_big_sepMS. do 2 f_equiv. by apply objective_at. Qed.
-
-(** BUpd *)
-Program Definition monPred_bupd_def `{BiBUpd PROP} (P : monPred) : monPred :=
- MonPred (λ i, |==> P i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_bupd_aux `{BiBUpd PROP} : seal monPred_bupd_def. by eexists. Qed.
-Definition monPred_bupd `{BiBUpd PROP} : BUpd _ := monPred_bupd_aux.(unseal).
-Definition monPred_bupd_eq `{BiBUpd PROP} : @bupd _ monPred_bupd = _ :=
- monPred_bupd_aux.(seal_eq).
-
-Lemma monPred_bupd_mixin `{BiBUpd PROP} : BiBUpdMixin monPredI monPred_bupd.
-Proof.
- split; rewrite monPred_bupd_eq.
- - split=>/= i. solve_proper.
- - intros P. split=>/= i. apply bupd_intro.
- - intros P Q HPQ. split=>/= i. by rewrite HPQ.
- - intros P. split=>/= i. apply bupd_trans.
- - intros P Q. split=>/= i. rewrite !monPred_at_sep /=. apply bupd_frame_r.
-Qed.
-Global Instance monPred_bi_bupd `{BiBUpd PROP} : BiBUpd monPredI :=
- {| bi_bupd_mixin := monPred_bupd_mixin |}.
-
-Lemma monPred_at_bupd `{BiBUpd PROP} i P : (|==> P) i ⊣⊢ |==> P i.
-Proof. by rewrite monPred_bupd_eq. Qed.
-
-Global Instance bupd_objective `{BiBUpd PROP} P `{!Objective P} :
- Objective (|==> P)%I.
-Proof. intros ??. by rewrite !monPred_at_bupd objective_at. Qed.
-
-Global Instance monPred_bi_embed_bupd `{BiBUpd PROP} :
- BiEmbedBUpd PROP monPredI.
-Proof. split. split=>i /=. by rewrite monPred_at_bupd !monPred_at_embed. Qed.
-End bi_facts.
-
-Section sbi_facts.
-Context {I : biIndex} {PROP : sbi}.
-Local Notation monPred := (monPred I PROP).
-Local Notation monPredSI := (monPredSI I PROP).
-Implicit Types i : I.
-Implicit Types P Q : monPred.
-
-Global Instance monPred_at_timeless P i : Timeless P → Timeless (P i).
-Proof. move => [] /(_ i). unfold Timeless. by unseal. Qed.
-Global Instance monPred_in_timeless i0 : Timeless (@monPred_in I PROP i0).
-Proof. split => ? /=. unseal. apply timeless, _. Qed.
-Global Instance monPred_objectively_timeless P : Timeless P → Timeless (<obj> P).
-Proof.
- move=>[]. unfold Timeless. unseal=>Hti. split=> ? /=.
- by apply timeless, bi.forall_timeless.
-Qed.
-Global Instance monPred_subjectively_timeless P : Timeless P → Timeless (<subj> P).
-Proof.
- move=>[]. unfold Timeless. unseal=>Hti. split=> ? /=.
- by apply timeless, bi.exist_timeless.
-Qed.
-
-Global Instance monPred_sbi_embed : SbiEmbed PROP monPredSI.
-Proof.
- split; unseal=> //. intros ? P Q.
- apply (@bi.f_equiv _ _ _ (λ P, monPred_at P inhabitant)); solve_proper.
-Qed.
-
-Lemma monPred_internal_eq_unfold : @sbi_internal_eq monPredSI = λ A x y, ⎡ x ≡ y ⎤%I.
-Proof. by unseal. Qed.
-
-(** Unfolding lemmas *)
-Lemma monPred_at_internal_eq {A : ofeT} i (a b : A) :
- @monPred_at I PROP (a ≡ b) i ⊣⊢ a ≡ b.
-Proof. rewrite monPred_internal_eq_unfold. by apply monPred_at_embed. Qed.
-Lemma monPred_at_later i P : (▷ P) i ⊣⊢ ▷ P i.
-Proof. by unseal. Qed.
-Lemma monPred_at_laterN n i P : (▷^n P) i ⊣⊢ ▷^n P i.
-Proof. induction n; first done. rewrite /= monPred_at_later IHn //. Qed.
-Lemma monPred_at_except_0 i P : (◇ P) i ⊣⊢ ◇ P i.
-Proof. by unseal. Qed.
-
-Lemma monPred_equivI {PROP' : sbi} P Q :
- P ≡ Q ⊣⊢@{PROP'} ∀ i, P i ≡ Q i.
-Proof.
- apply bi.equiv_spec. split.
- - apply bi.forall_intro=>?. apply (bi.f_equiv (flip monPred_at _)).
- - by rewrite -{2}(sig_monPred_sig P) -{2}(sig_monPred_sig Q)
- -bi.f_equiv -bi.sig_equivI !bi.discrete_fun_equivI.
-Qed.
-
-(** Objective *)
-Global Instance internal_eq_objective {A : ofeT} (x y : A) :
- @Objective I PROP (x ≡ y).
-Proof. intros ??. by unseal. Qed.
-
-Global Instance later_objective P `{!Objective P} : Objective (â–· P).
-Proof. intros ??. unseal. by rewrite objective_at. Qed.
-Global Instance laterN_objective P `{!Objective P} n : Objective (â–·^n P).
-Proof. induction n; apply _. Qed.
-Global Instance except0_objective P `{!Objective P} : Objective (â—‡ P).
-Proof. rewrite /sbi_except_0. apply _. Qed.
-
-(** FUpd *)
-Program Definition monPred_fupd_def `{BiFUpd PROP} (E1 E2 : coPset)
- (P : monPred) : monPred :=
- MonPred (λ i, |={E1,E2}=> P i)%I _.
-Next Obligation. solve_proper. Qed.
-Definition monPred_fupd_aux `{BiFUpd PROP} : seal monPred_fupd_def. by eexists. Qed.
-Definition monPred_fupd `{BiFUpd PROP} : FUpd _ := monPred_fupd_aux.(unseal).
-Definition monPred_fupd_eq `{BiFUpd PROP} : @fupd _ monPred_fupd = _ :=
- monPred_fupd_aux.(seal_eq).
-
-Lemma monPred_fupd_mixin `{BiFUpd PROP} : BiFUpdMixin monPredSI monPred_fupd.
-Proof.
- split; rewrite monPred_fupd_eq.
- - split=>/= i. solve_proper.
- - intros E1 E2 P HE12. split=>/= i. by apply fupd_intro_mask.
- - intros E1 E2 P. split=>/= i. by rewrite monPred_at_except_0 except_0_fupd.
- - intros E1 E2 P Q HPQ. split=>/= i. by rewrite HPQ.
- - intros E1 E2 E3 P. split=>/= i. apply fupd_trans.
- - intros E1 E2 Ef P HE1f. split=>/= i.
- rewrite monPred_impl_force monPred_at_pure -fupd_mask_frame_r' //.
- - intros E1 E2 P Q. split=>/= i. by rewrite !monPred_at_sep /= fupd_frame_r.
-Qed.
-Global Instance monPred_bi_fupd `{BiFUpd PROP} : BiFUpd monPredSI :=
- {| bi_fupd_mixin := monPred_fupd_mixin |}.
-Global Instance monPred_bi_bupd_fupd `{BiBUpdFUpd PROP} : BiBUpdFUpd monPredSI.
-Proof.
- intros E P. split=>/= i. rewrite monPred_at_bupd monPred_fupd_eq bupd_fupd //=.
-Qed.
-Global Instance monPred_bi_embed_fupd `{BiFUpd PROP} : BiEmbedFUpd PROP monPredSI.
-Proof. split. split=>i /=. by rewrite monPred_fupd_eq /= !monPred_at_embed. Qed.
-
-Lemma monPred_at_fupd `{BiFUpd PROP} i E1 E2 P :
- (|={E1,E2}=> P) i ⊣⊢ |={E1,E2}=> P i.
-Proof. by rewrite monPred_fupd_eq. Qed.
-
-Global Instance fupd_objective E1 E2 P `{!Objective P} `{BiFUpd PROP} :
- Objective (|={E1,E2}=> P)%I.
-Proof. intros ??. by rewrite !monPred_at_fupd objective_at. Qed.
-
-(** Plainly *)
-Definition monPred_plainly_def `{BiPlainly PROP} P : monPred :=
- MonPred (λ _, ∀ i, ■(P i))%I _.
-Definition monPred_plainly_aux `{BiPlainly PROP} : seal monPred_plainly_def. by eexists. Qed.
-Definition monPred_plainly `{BiPlainly PROP} : Plainly _ := monPred_plainly_aux.(unseal).
-Definition monPred_plainly_eq `{BiPlainly PROP} : @plainly _ monPred_plainly = _ := monPred_plainly_aux.(seal_eq).
-
-Lemma monPred_plainly_mixin `{BiPlainly PROP} : BiPlainlyMixin monPredSI monPred_plainly.
-Proof.
- split; rewrite monPred_plainly_eq; try unseal.
- - by (split=> ? /=; repeat f_equiv).
- - intros P Q [?]. split=> i /=. by do 3 f_equiv.
- - intros P. split=> i /=. by rewrite bi.forall_elim plainly_elim_persistently.
- - intros P. split=> i /=. repeat setoid_rewrite <-plainly_forall.
- rewrite -plainly_idemp_2. f_equiv. by apply bi.forall_intro=>_.
- - intros A Ψ. split=> i /=. apply bi.forall_intro=> j.
- rewrite plainly_forall. apply bi.forall_intro=> a. by rewrite !bi.forall_elim.
- - intros P Q. split=> i /=. repeat setoid_rewrite bi.pure_impl_forall.
- repeat setoid_rewrite <-plainly_forall.
- repeat setoid_rewrite bi.persistently_forall. do 4 f_equiv.
- apply persistently_impl_plainly.
- - intros P Q. split=> i /=.
- repeat setoid_rewrite bi.pure_impl_forall. rewrite 2!bi.forall_elim //.
- repeat setoid_rewrite <-plainly_forall.
- setoid_rewrite plainly_impl_plainly. f_equiv.
- do 3 apply bi.forall_intro => ?. f_equiv. rewrite bi.forall_elim //.
- - intros P. split=> i /=. apply bi.forall_intro=>_. by apply plainly_emp_intro.
- - intros P Q. split=> i. apply bi.sep_elim_l, _.
- - intros P Q. split=> i /=. rewrite (monPred_equivI P Q). f_equiv=> j.
- by rewrite -prop_ext !(bi.forall_elim j) !bi.pure_True // !bi.True_impl.
- - intros P. split=> i /=.
- rewrite bi.later_forall. f_equiv=> j. by rewrite -later_plainly_1.
- - intros P. split=> i /=.
- rewrite bi.later_forall. f_equiv=> j. by rewrite -later_plainly_2.
-Qed.
-Global Instance monPred_bi_plainly `{BiPlainly PROP} : BiPlainly monPredSI :=
- {| bi_plainly_mixin := monPred_plainly_mixin |}.
-
-Global Instance monPred_bi_plainly_exist `{BiPlainly PROP} `{@BiIndexBottom I bot} :
- BiPlainlyExist PROP → BiPlainlyExist monPredSI.
-Proof.
- split=>?/=. rewrite monPred_plainly_eq /=. repeat setoid_rewrite monPred_at_exist.
- rewrite (bi.forall_elim bot) plainly_exist_1. do 2 f_equiv.
- apply bi.forall_intro=>?. by do 2 f_equiv.
-Qed.
-
-Global Instance monPred_bi_embed_plainly `{BiPlainly PROP} :
- BiEmbedPlainly PROP monPredSI.
-Proof. apply bi_embed_plainly_emp, _. Qed.
-
-Lemma monPred_plainly_unfold `{BiPlainly PROP} : plainly = λ P, ⎡ ∀ i, ■(P i) ⎤%I.
-Proof. by rewrite monPred_plainly_eq monPred_embed_eq. Qed.
-Lemma monPred_at_plainly `{BiPlainly PROP} i P : (■P) i ⊣⊢ ∀ j, ■(P j).
-Proof. by rewrite monPred_plainly_eq. Qed.
-
-Global Instance monPred_bi_bupd_plainly `{BiBUpdPlainly PROP} : BiBUpdPlainly monPredSI.
-Proof.
- intros P. split=> /= i.
- rewrite monPred_at_bupd monPred_at_plainly bi.forall_elim. apply bupd_plainly.
-Qed.
-
-Global Instance monPred_at_plain `{BiPlainly PROP} P i : Plain P → Plain (P i).
-Proof. move => [] /(_ i). rewrite /Plain monPred_at_plainly bi.forall_elim //. Qed.
-
-Global Instance monPred_bi_fupd_plainly `{BiFUpdPlainly PROP} : BiFUpdPlainly monPredSI.
-Proof.
- split; rewrite !monPred_fupd_eq; try unseal.
- - intros E P. split=>/= i.
- by rewrite monPred_at_plainly (bi.forall_elim i) fupd_plainly_mask_empty.
- - intros E P R. split=>/= i.
- rewrite (bi.forall_elim i) bi.pure_True // bi.True_impl.
- by rewrite monPred_at_plainly (bi.forall_elim i) fupd_plainly_keep_l.
- - intros E P. split=>/= i.
- by rewrite monPred_at_plainly (bi.forall_elim i) fupd_plainly_later.
- - intros E A Φ. split=>/= i.
- rewrite -fupd_plainly_forall_2. apply bi.forall_mono=> x.
- by rewrite monPred_at_plainly (bi.forall_elim i).
-Qed.
-
-Global Instance plainly_objective `{BiPlainly PROP} P : Objective (â– P).
-Proof. rewrite monPred_plainly_unfold. apply _. Qed.
-Global Instance plainly_if_objective `{BiPlainly PROP} P p `{!Objective P} :
- Objective (â– ?p P).
-Proof. rewrite /plainly_if. destruct p; apply _. Qed.
-
-Global Instance monPred_objectively_plain `{BiPlainly PROP} P : Plain P → Plain (<obj> P).
-Proof. rewrite monPred_objectively_unfold. apply _. Qed.
-Global Instance monPred_subjectively_plain `{BiPlainly PROP} P : Plain P → Plain (<subj> P).
-Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
-End sbi_facts.
diff --git a/theories/bi/notation.v b/theories/bi/notation.v
index 9534481981ed54127029c7da3b46d06d01bdb884..afc390fc0a8d25dfc58d2bfec4f30e04b7d4e6c0 100644
--- a/theories/bi/notation.v
+++ b/theories/bi/notation.v
@@ -8,6 +8,10 @@ Reserved Notation "P ⊣⊢ Q" (at level 95, no associativity).
Reserved Notation "P '⊣⊢@{' PROP } Q" (at level 95, no associativity).
Reserved Notation "('⊣⊢@{' PROP } )" (at level 95).
+(*NOTE: backported from current iris *)
+Reserved Notation "⊢ Q" (at level 20, Q at level 200).
+Reserved Notation "'⊢@{' PROP } Q" (at level 20, Q at level 200).
+
(** BI connectives *)
Reserved Notation "'emp'".
Reserved Notation "'⌜' φ 'âŒ'" (at level 1, φ at level 200, format "⌜ φ âŒ").
@@ -28,6 +32,10 @@ Reserved Notation "â–·? p P" (at level 20, p at level 9, P at level 20,
format "â–·? p P").
Reserved Notation "â–·^ n P" (at level 20, n at level 9, P at level 20,
format "â–·^ n P").
+Reserved Notation "⧠P" (at level 20, right associativity).
+Reserved Notation "â§^ n P" (at level 20, n at level 9, P at level 20,
+ format "â§^ n P").
+
Reserved Infix "∗-∗" (at level 95, no associativity).
diff --git a/theories/bi/plainly.v b/theories/bi/plainly.v
index b28934bcb2ee6d1e4d2bbbd40f675c5b4579b482..0ce3c50013a45027337b0f3ea60e7e4a5638bee6 100644
--- a/theories/bi/plainly.v
+++ b/theories/bi/plainly.v
@@ -8,7 +8,7 @@ Instance: Params (@plainly) 2 := {}.
Notation "â– P" := (plainly P) : bi_scope.
(* Mixins allow us to create instances easily without having to use Program *)
-Record BiPlainlyMixin (PROP : sbi) `(Plainly PROP) := {
+Record BiPlainlyMixin {SI: indexT} (PROP : sbi SI) `(Plainly PROP) := {
bi_plainly_mixin_plainly_ne : NonExpansive (plainly (A:=PROP));
bi_plainly_mixin_plainly_mono (P Q : PROP) : (P ⊢ Q) → ■P ⊢ ■Q;
@@ -35,23 +35,23 @@ Record BiPlainlyMixin (PROP : sbi) `(Plainly PROP) := {
bi_plainly_mixin_later_plainly_2 (P : PROP) : ■▷ P ⊢ ▷ ■P;
}.
-Class BiPlainly (PROP : sbi) := {
+Class BiPlainly {SI: indexT} (PROP : sbi SI) := {
bi_plainly_plainly :> Plainly PROP;
bi_plainly_mixin : BiPlainlyMixin PROP bi_plainly_plainly;
}.
-Hint Mode BiPlainly ! : typeclass_instances.
-Arguments bi_plainly_plainly : simpl never.
+Hint Mode BiPlainly - ! : typeclass_instances.
+Arguments bi_plainly_plainly {_} _ : simpl never.
-Class BiPlainlyExist `{!BiPlainly PROP} :=
+Class BiPlainlyExist `{BiPlainly SI PROP} :=
plainly_exist_1 A (Ψ : A → PROP) :
■(∃ a, Ψ a) ⊢ ∃ a, ■(Ψ a).
Arguments BiPlainlyExist : clear implicits.
-Arguments BiPlainlyExist _ {_}.
-Arguments plainly_exist_1 _ {_ _} _.
-Hint Mode BiPlainlyExist ! - : typeclass_instances.
+Arguments BiPlainlyExist {_} _ {_}.
+Arguments plainly_exist_1 {_} _ {_ _} _.
+Hint Mode BiPlainlyExist - ! - : typeclass_instances.
Section plainly_laws.
- Context `{BiPlainly PROP}.
+ Context `{BiPlainly SI PROP}.
Implicit Types P Q : PROP.
Global Instance plainly_ne : NonExpansive (@plainly PROP _).
@@ -84,23 +84,23 @@ Section plainly_laws.
End plainly_laws.
(* Derived properties and connectives *)
-Class Plain `{BiPlainly PROP} (P : PROP) := plain : P ⊢ ■P.
-Arguments Plain {_ _} _%I : simpl never.
-Arguments plain {_ _} _%I {_}.
-Hint Mode Plain + - ! : typeclass_instances.
-Instance: Params (@Plain) 1 := {}.
+Class Plain `{BiPlainly SI PROP} (P : PROP) := plain : P ⊢ ■P.
+Arguments Plain {_ _ _} _%I : simpl never.
+Arguments plain {_ _ _} _%I {_}.
+Hint Mode Plain - + - ! : typeclass_instances.
+Instance: Params (@Plain) 2 := {}.
-Definition plainly_if `{!BiPlainly PROP} (p : bool) (P : PROP) : PROP :=
+Definition plainly_if `{BiPlainly SI PROP} (p : bool) (P : PROP) : PROP :=
(if p then â– P else P)%I.
-Arguments plainly_if {_ _} !_ _%I /.
-Instance: Params (@plainly_if) 2 := {}.
+Arguments plainly_if {_ _ _} !_ _%I /.
+Instance: Params (@plainly_if) 3 := {}.
Typeclasses Opaque plainly_if.
Notation "â– ? p P" := (plainly_if p P) : bi_scope.
(* Derived laws *)
Section plainly_derived.
-Context `{BiPlainly PROP}.
+Context `{BiPlainly SI PROP}.
Implicit Types P : PROP.
Hint Resolve pure_intro forall_intro : core.
@@ -234,7 +234,7 @@ Proof.
Qed.
Lemma plainly_sep_2 P Q : ■P ∗ ■Q ⊢ ■(P ∗ Q).
Proof. by rewrite -plainly_and_sep plainly_and -and_sep_plainly. Qed.
-Lemma plainly_sep `{BiPositive PROP} P Q : ■(P ∗ Q) ⊣⊢ ■P ∗ ■Q.
+Lemma plainly_sep `{BiPositive SI PROP} P Q : ■(P ∗ Q) ⊣⊢ ■P ∗ ■Q.
Proof.
apply (anti_symm _); auto using plainly_sep_2.
rewrite -(plainly_affinely_elim (_ ∗ _)%I) affinely_sep -and_sep_plainly. apply and_intro.
@@ -272,7 +272,7 @@ Lemma plainly_wand_affinely_plainly P Q :
Proof. rewrite -!impl_wand_affinely_plainly. apply plainly_impl_plainly. Qed.
Section plainly_affine_bi.
- Context `{BiAffine PROP}.
+ Context `{BiAffine SI PROP}.
Lemma plainly_emp : ■emp ⊣⊢@{PROP} emp.
Proof. by rewrite -!True_emp plainly_pure. Qed.
@@ -295,18 +295,18 @@ Section plainly_affine_bi.
Lemma impl_wand_plainly P Q : (■P → Q) ⊣⊢ (■P -∗ Q).
Proof.
apply (anti_symm (⊢)). by rewrite -impl_wand_1. by rewrite impl_wand_plainly_2.
- Qed.
+ Qed.
End plainly_affine_bi.
(* Conditional plainly *)
-Global Instance plainly_if_ne p : NonExpansive (@plainly_if PROP _ p).
+Global Instance plainly_if_ne p : NonExpansive (@plainly_if SI PROP _ p).
Proof. solve_proper. Qed.
-Global Instance plainly_if_proper p : Proper ((⊣⊢) ==> (⊣⊢)) (@plainly_if PROP _ p).
+Global Instance plainly_if_proper p : Proper ((⊣⊢) ==> (⊣⊢)) (@plainly_if SI PROP _ p).
Proof. solve_proper. Qed.
-Global Instance plainly_if_mono' p : Proper ((⊢) ==> (⊢)) (@plainly_if PROP _ p).
+Global Instance plainly_if_mono' p : Proper ((⊢) ==> (⊢)) (@plainly_if SI PROP _ p).
Proof. solve_proper. Qed.
Global Instance plainly_if_flip_mono' p :
- Proper (flip (⊢) ==> flip (⊢)) (@plainly_if PROP _ p).
+ Proper (flip (⊢) ==> flip (⊢)) (@plainly_if SI PROP _ p).
Proof. solve_proper. Qed.
Lemma plainly_if_mono p P Q : (P ⊢ Q) → ■?p P ⊢ ■?p Q.
@@ -332,7 +332,7 @@ Lemma plainly_if_idemp p P : ■?p ■?p P ⊣⊢ ■?p P.
Proof. destruct p; simpl; auto using plainly_idemp. Qed.
(* Properties of plain propositions *)
-Global Instance Plain_proper : Proper ((≡) ==> iff) (@Plain PROP _).
+Global Instance Plain_proper : Proper ((≡) ==> iff) (@Plain SI PROP _).
Proof. solve_proper. Qed.
Lemma plain_plainly_2 P `{!Plain P} : P ⊢ ■P.
@@ -390,7 +390,7 @@ Global Instance plainly_sep_weak_homomorphism `{!BiPositive PROP, !BiAffine PROP
WeakMonoidHomomorphism bi_sep bi_sep (≡) (@plainly PROP _).
Proof. split; try apply _. apply plainly_sep. Qed.
-Global Instance plainly_sep_homomorphism `{BiAffine PROP} :
+Global Instance plainly_sep_homomorphism `{BiAffine SI PROP} :
MonoidHomomorphism bi_sep bi_sep (≡) (@plainly PROP _).
Proof. split. apply _. apply plainly_emp. Qed.
@@ -402,7 +402,7 @@ Global Instance plainly_sep_entails_homomorphism `{!BiAffine PROP} :
MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@plainly PROP _).
Proof. split. apply _. simpl. rewrite plainly_emp. done. Qed.
-Global Instance limit_preserving_Plain {A:ofeT} `{Cofe A} (Φ : A → PROP) :
+Global Instance limit_preserving_Plain {A: ofeT SI} `{Cofe SI A} (Φ : A → PROP) :
NonExpansive Φ → LimitPreserving (λ x, Plain (Φ x)).
Proof. intros. apply limit_preserving_entails; solve_proper. Qed.
@@ -459,7 +459,7 @@ Global Instance from_option_plain {A} P (Ψ : A → PROP) (mx : option A) :
Proof. destruct mx; apply _. Qed.
(* Interaction with equality *)
-Lemma plainly_internal_eq {A:ofeT} (a b : A) : ■(a ≡ b) ⊣⊢@{PROP} a ≡ b.
+Lemma plainly_internal_eq {A:ofeT SI} (a b : A) : ■(a ≡ b) ⊣⊢@{PROP} a ≡ b.
Proof.
apply (anti_symm (⊢)).
{ by rewrite plainly_elim. }
@@ -511,7 +511,7 @@ Proof. by rewrite /sbi_except_0 -plainly_or_2 -later_plainly plainly_pure. Qed.
Lemma except_0_plainly `{!BiPlainlyExist PROP} P : ◇ ■P ⊣⊢ ■◇ P.
Proof. by rewrite /sbi_except_0 plainly_or -later_plainly plainly_pure. Qed.
-Global Instance internal_eq_plain {A : ofeT} (a b : A) :
+Global Instance internal_eq_plain {A : ofeT SI} (a b : A) :
Plain (PROP:=PROP) (a ≡ b).
Proof. by intros; rewrite /Plain plainly_internal_eq. Qed.
@@ -522,7 +522,8 @@ Proof. induction n; apply _. Qed.
Global Instance except_0_plain P : Plain P → Plain (◇ P).
Proof. rewrite /sbi_except_0; apply _. Qed.
-Global Instance plainly_timeless P `{!BiPlainlyExist PROP} :
+(* TODO: depends on some stuff in derived_laws_sbi, therefore affine *)
+Global Instance plainly_timeless P `{BiAffine SI PROP} `{!BiPlainlyExist PROP} :
Timeless P → Timeless (■P).
Proof.
intros. rewrite /Timeless /sbi_except_0 later_plainly_1.
diff --git a/theories/bi/satisfiable.v b/theories/bi/satisfiable.v
new file mode 100644
index 0000000000000000000000000000000000000000..9c08a5d5598a25d754ddbe97a4cc1c5191aad8e2
--- /dev/null
+++ b/theories/bi/satisfiable.v
@@ -0,0 +1,99 @@
+From iris.bi Require Import
+ derived_connectives derived_laws_bi
+ derived_laws_sbi notation interface
+ plainly updates.
+
+
+Section satisfiable.
+ Context {SI: indexT} {PROP: sbi SI} `{BiPlainly SI PROP} `{BUpd PROP}.
+
+
+ Structure satisfiable_mixin (satisfiable: PROP → Prop) := {
+ satisfiable_mixin_intro P: (True ⊢ P) → satisfiable P;
+ satisfiable_mixin_mono P Q: satisfiable P → (P ⊢ Q) → satisfiable Q;
+ satisfiable_mixin_elim P: satisfiable P → Plain P → True ⊢ P;
+ satisfiable_mixin_later P: satisfiable (▷ P)%I → satisfiable P;
+ satisfiable_mixin_finite_exists `{FiniteExistential SI} (X: Type) P Q: satisfiable (∃ x: X, P x)%I → pred_finite Q → (∀ x, P x ⊢ ⌜Q xâŒ) → ∃ x: X, satisfiable (P x);
+ satisfiable_mixin_exists `{LargeIndex SI} (X: Type) P: satisfiable (∃ x: X, P x)%I → ∃ x: X, satisfiable (P x);
+ satisfiable_mixin_bupd P: satisfiable (|==> P)%I → satisfiable P
+ }.
+
+
+ Class Satisfiable := {
+ satisfiable: PROP → Prop;
+ satisfiable_satisfiable_mixin: satisfiable_mixin satisfiable
+ }.
+
+
+ Section satisfiable_lemmas.
+ Context `{Satisfiable}.
+
+ Lemma satisfiable_intro P: (True ⊢ P) → satisfiable P.
+ Proof. apply satisfiable_mixin_intro, satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_mono P Q: satisfiable P → (P ⊢ Q) → satisfiable Q.
+ Proof. apply satisfiable_mixin_mono, satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_elim P: satisfiable P → Plain P → True ⊢ P.
+ Proof. apply satisfiable_mixin_elim, satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_later P: satisfiable (▷ P)%I → satisfiable P.
+ Proof. apply satisfiable_mixin_later, satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_finite_exists `{FiniteExistential SI} (X: Type) P Q: satisfiable (∃ x: X, P x)%I → pred_finite Q → (∀ x, P x ⊢ ⌜Q xâŒ) → ∃ x: X, satisfiable (P x).
+ Proof. apply satisfiable_mixin_finite_exists; auto. apply satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_exists `{LargeIndex SI} (X: Type) P: satisfiable (∃ x: X, P x)%I → ∃ x: X, satisfiable (P x).
+ Proof. apply satisfiable_mixin_exists; auto. apply satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_bupd P: satisfiable (|==> P)%I → satisfiable P.
+ Proof. apply satisfiable_mixin_bupd; auto. apply satisfiable_satisfiable_mixin. Qed.
+
+ Lemma satisfiable_forall {X} (x: X) P: satisfiable (∀ x, P x)%I → satisfiable (P x).
+ Proof. intros Hs; eapply (satisfiable_mono _ _ Hs), bi.forall_elim. Qed.
+
+ Lemma satisfiable_impl P Q: satisfiable (P → Q)%I → (True ⊢ P) → satisfiable Q.
+ Proof.
+ intros Hs Hent; apply (satisfiable_mono _ _ Hs).
+ etrans; last apply derived_laws_bi.bi.impl_elim_r.
+ apply bi.and_intro; last reflexivity.
+ etrans; last apply Hent. by eapply bi.pure_intro.
+ Qed.
+
+ Lemma satisfiable_wand P Q: satisfiable (P -∗ Q)%I → (True ⊢ P) → satisfiable Q.
+ Proof.
+ intros Hs Hent; apply (satisfiable_mono _ _ Hs).
+ erewrite derived_laws_bi.bi.True_sep_2.
+ rewrite Hent. apply derived_laws_bi.bi.wand_elim_r.
+ Qed.
+
+ Lemma satisfiable_pers `{BiAffine SI PROP} P: satisfiable (<pers> P)%I → satisfiable P.
+ Proof.
+ intros Hs; apply (satisfiable_mono _ _ Hs).
+ apply bi.persistently_elim. apply _.
+ Qed.
+
+ Lemma satisfiable_intuitionistically P: satisfiable (□ P)%I → satisfiable P.
+ Proof.
+ intros Hs; apply (satisfiable_mono _ _ Hs).
+ apply bi.intuitionistically_elim.
+ Qed.
+
+ Lemma satisfiable_or `{FiniteExistential SI} P Q: satisfiable (P ∨ Q)%I → satisfiable P ∨ satisfiable Q.
+ Proof.
+ intros Hs. assert (satisfiable (∃ b: bool, if b then P else Q)%I) as Hex.
+ - apply (satisfiable_mono _ _ Hs). by rewrite bi.or_alt.
+ - apply satisfiable_finite_exists with (Q := λ b, True) in Hex as [[] Hex]; auto.
+ + exists [true;false]; intros [] _; rewrite !elem_of_cons; eauto.
+ + intros x. eapply bi.True_intro.
+ Qed.
+
+ Global Instance satisfiable_equiv: Proper (equiv ==> iff) satisfiable.
+ Proof.
+ intros P Q HPQ. split; intros H'; eapply satisfiable_mono; eauto; by rewrite HPQ.
+ Qed.
+ End satisfiable_lemmas.
+
+End satisfiable.
+Arguments Satisfiable {_} _ {_} {_}.
+
diff --git a/theories/bi/tactics.v b/theories/bi/tactics.v
index 983a5d8d4ef1ccbef431983c414e43863f925c58..8ddec3c0d5b7e95669fdc0e0e55f0aaa40548fd2 100644
--- a/theories/bi/tactics.v
+++ b/theories/bi/tactics.v
@@ -4,7 +4,7 @@ Set Default Proof Using "Type".
Import bi.
Module bi_reflection. Section bi_reflection.
- Context {PROP : bi}.
+ Context {SI} {PROP : bi SI}.
Inductive expr :=
| EEmp : expr
@@ -32,7 +32,7 @@ Module bi_reflection. Section bi_reflection.
Qed.
(* Can be related to the RHS being affine *)
- Lemma flatten_entails `{BiAffine PROP} Σ e1 e2 :
+ Lemma flatten_entails `{BiAffine SI PROP} Σ e1 e2 :
flatten e2 ⊆+ flatten e1 → eval Σ e1 ⊢ eval Σ e2.
Proof. intros. rewrite !eval_flatten. by apply big_sepL_submseteq. Qed.
Lemma flatten_equiv Σ e1 e2 :
diff --git a/theories/bi/telescopes.v b/theories/bi/telescopes.v
index d54533929a945c82d8872083527dacbaaff6251c..662539f5bd1c1d47ba75ef97cabb6c626b0b2f6a 100644
--- a/theories/bi/telescopes.v
+++ b/theories/bi/telescopes.v
@@ -6,12 +6,12 @@ Import bi.
(* This cannot import the proofmode because it is imported by the proofmode! *)
(** Telescopic quantifiers *)
-Definition bi_texist {PROP : bi} {TT : tele} (Ψ : TT → PROP) : PROP :=
- tele_fold (@bi_exist PROP) (λ x, x) (tele_bind Ψ).
-Arguments bi_texist {_ !_} _ /.
-Definition bi_tforall {PROP : bi} {TT : tele} (Ψ : TT → PROP) : PROP :=
- tele_fold (@bi_forall PROP) (λ x, x) (tele_bind Ψ).
-Arguments bi_tforall {_ !_} _ /.
+Definition bi_texist {SI} {PROP : bi SI} {TT : tele} (Ψ : TT → PROP) : PROP :=
+ tele_fold (@bi_exist SI PROP) (λ x, x) (tele_bind Ψ).
+Arguments bi_texist {_ _ !_} _ /.
+Definition bi_tforall {SI} {PROP : bi SI} {TT : tele} (Ψ : TT → PROP) : PROP :=
+ tele_fold (@bi_forall SI PROP) (λ x, x) (tele_bind Ψ).
+Arguments bi_tforall {_ _ !_} _ /.
Notation "'∃..' x .. y , P" := (bi_texist (λ x, .. (bi_texist (λ y, P)) .. )%I)
(at level 200, x binder, y binder, right associativity,
@@ -21,7 +21,7 @@ Notation "'∀..' x .. y , P" := (bi_tforall (λ x, .. (bi_tforall (λ y, P)) ..
format "∀.. x .. y , P") : bi_scope.
Section telescope_quantifiers.
- Context {PROP : bi} {TT : tele}.
+ Context {SI} {PROP : bi SI} {TT : tele}.
Lemma bi_tforall_forall (Ψ : TT → PROP) :
bi_tforall Ψ ⊣⊢ bi_forall Ψ.
@@ -56,25 +56,25 @@ Section telescope_quantifiers.
Qed.
Global Instance bi_tforall_ne n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_tforall PROP TT).
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_tforall SI PROP TT).
Proof.
intros ?? EQ. rewrite !bi_tforall_forall. rewrite EQ //.
Qed.
Global Instance bi_tforall_proper :
- Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_tforall PROP TT).
+ Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_tforall SI PROP TT).
Proof.
intros ?? EQ. rewrite !bi_tforall_forall. rewrite EQ //.
Qed.
Global Instance bi_texist_ne n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_texist PROP TT).
+ Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_texist SI PROP TT).
Proof.
intros ?? EQ. rewrite !bi_texist_exist. rewrite EQ //.
Qed.
Global Instance bi_texist_proper :
- Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_texist PROP TT).
+ Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (@bi_texist SI PROP TT).
Proof.
intros ?? EQ. rewrite !bi_texist_exist. rewrite EQ //.
Qed.
diff --git a/theories/bi/updates.v b/theories/bi/updates.v
index 5fd78269ad2b3c1a930638531007f5c4d609ef38..c74353aaa896f14a2c65ecca9a5bc5f88d976d32 100644
--- a/theories/bi/updates.v
+++ b/theories/bi/updates.v
@@ -1,5 +1,5 @@
From stdpp Require Import coPset.
-From iris.bi Require Import interface derived_laws_sbi big_op plainly.
+From iris.bi Require Import interface derived_laws_bi derived_laws_sbi plainly big_op.
Import interface.bi derived_laws_bi.bi derived_laws_sbi.bi.
(* We first define operational type classes for the notations, and then later
@@ -38,7 +38,7 @@ Notation "P ={ E1 , E2 }▷=∗^ n Q" := (P -∗ |={E1,E2}▷=>^n Q)%I : bi_scop
(** Bundled versions *)
(* Mixins allow us to create instances easily without having to use Program *)
-Record BiBUpdMixin (PROP : bi) `(BUpd PROP) := {
+Record BiBUpdMixin {SI: indexT} (PROP : bi SI) `(BUpd PROP) := {
bi_bupd_mixin_bupd_ne : NonExpansive (bupd (PROP:=PROP));
bi_bupd_mixin_bupd_intro (P : PROP) : P ==∗ P;
bi_bupd_mixin_bupd_mono (P Q : PROP) : (P ⊢ Q) → (|==> P) ==∗ Q;
@@ -46,7 +46,7 @@ Record BiBUpdMixin (PROP : bi) `(BUpd PROP) := {
bi_bupd_mixin_bupd_frame_r (P R : PROP) : (|==> P) ∗ R ==∗ P ∗ R;
}.
-Record BiFUpdMixin (PROP : sbi) `(FUpd PROP) := {
+Record BiFUpdMixin {SI: indexT} (PROP : sbi SI) `(FUpd PROP) := {
bi_fupd_mixin_fupd_ne E1 E2 : NonExpansive (fupd (PROP:=PROP) E1 E2);
bi_fupd_mixin_fupd_intro_mask E1 E2 (P : PROP) : E2 ⊆ E1 → P ⊢ |={E1,E2}=> |={E2,E1}=> P;
bi_fupd_mixin_except_0_fupd E1 E2 (P : PROP) : ◇ (|={E1,E2}=> P) ={E1,E2}=∗ P;
@@ -57,33 +57,33 @@ Record BiFUpdMixin (PROP : sbi) `(FUpd PROP) := {
bi_fupd_mixin_fupd_frame_r E1 E2 (P R : PROP) : (|={E1,E2}=> P) ∗ R ={E1,E2}=∗ P ∗ R;
}.
-Class BiBUpd (PROP : bi) := {
+Class BiBUpd {SI: indexT} (PROP : bi SI) := {
bi_bupd_bupd :> BUpd PROP;
bi_bupd_mixin : BiBUpdMixin PROP bi_bupd_bupd;
}.
-Hint Mode BiBUpd ! : typeclass_instances.
-Arguments bi_bupd_bupd : simpl never.
+Hint Mode BiBUpd - ! : typeclass_instances.
+Arguments bi_bupd_bupd {_} : simpl never.
-Class BiFUpd (PROP : sbi) := {
+Class BiFUpd {SI: indexT} (PROP : sbi SI) := {
bi_fupd_fupd :> FUpd PROP;
bi_fupd_mixin : BiFUpdMixin PROP bi_fupd_fupd;
}.
-Hint Mode BiFUpd ! : typeclass_instances.
+Hint Mode BiFUpd - ! : typeclass_instances.
Arguments bi_fupd_fupd : simpl never.
-Class BiBUpdFUpd (PROP : sbi) `{BiBUpd PROP, BiFUpd PROP} :=
+Class BiBUpdFUpd {SI: indexT} (PROP : sbi SI) `{BiBUpd SI PROP, BiFUpd SI PROP} :=
bupd_fupd E (P : PROP) : (|==> P) ={E}=∗ P.
-Hint Mode BiBUpdFUpd ! - - : typeclass_instances.
+Hint Mode BiBUpdFUpd - ! - - : typeclass_instances.
-Class BiBUpdPlainly (PROP : sbi) `{!BiBUpd PROP, !BiPlainly PROP} :=
+Class BiBUpdPlainly {SI: indexT} (PROP : sbi SI) `{!BiBUpd PROP, !BiPlainly PROP} :=
bupd_plainly (P : PROP) : (|==> ■P) -∗ P.
-Hint Mode BiBUpdPlainly ! - - : typeclass_instances.
+Hint Mode BiBUpdPlainly - ! - - : typeclass_instances.
(** These rules for the interaction between the [â– ] and [|={E1,E2=>] modalities
only make sense for affine logics. From the axioms below, one could derive
[■P ={E}=∗ P] (see the lemma [fupd_plainly_elim]), which in turn gives
[True ={E}=∗ emp]. *)
-Class BiFUpdPlainly (PROP : sbi) `{!BiFUpd PROP, !BiPlainly PROP} := {
+Class BiFUpdPlainly {SI: indexT} (PROP : sbi SI) `{!BiFUpd PROP, !BiPlainly PROP} := {
(** When proving a fancy update of a plain proposition, you can also prove it
while being allowed to open all invariants. *)
fupd_plainly_mask_empty E (P : PROP) :
@@ -102,10 +102,10 @@ Class BiFUpdPlainly (PROP : sbi) `{!BiFUpd PROP, !BiPlainly PROP} := {
fupd_plainly_forall_2 E {A} (Φ : A → PROP) :
(∀ x, |={E}=> ■Φ x) ⊢ |={E}=> ∀ x, Φ x
}.
-Hint Mode BiBUpdFUpd ! - - : typeclass_instances.
+Hint Mode BiBUpdFUpd - ! - - : typeclass_instances.
Section bupd_laws.
- Context `{BiBUpd PROP}.
+ Context `{BiBUpd SI PROP}.
Implicit Types P : PROP.
Global Instance bupd_ne : NonExpansive (@bupd PROP _).
@@ -121,7 +121,7 @@ Section bupd_laws.
End bupd_laws.
Section fupd_laws.
- Context `{BiFUpd PROP}.
+ Context `{BiFUpd SI PROP}.
Implicit Types P : PROP.
Global Instance fupd_ne E1 E2 : NonExpansive (@fupd PROP _ E1 E2).
@@ -142,7 +142,7 @@ Section fupd_laws.
End fupd_laws.
Section bupd_derived.
- Context `{BiBUpd PROP}.
+ Context `{BiBUpd SI PROP}.
Implicit Types P Q R : PROP.
(* FIXME: Removing the `PROP:=` diverges. *)
@@ -166,7 +166,7 @@ Section bupd_derived.
End bupd_derived.
Section bupd_derived_sbi.
- Context {PROP : sbi} `{BiBUpd PROP}.
+ Context `{PROP : sbi SI} `{BiBUpd SI PROP}.
Implicit Types P Q R : PROP.
Lemma except_0_bupd P : ◇ (|==> P) ⊢ (|==> ◇ P).
@@ -176,7 +176,7 @@ Section bupd_derived_sbi.
Qed.
Section bupd_plainly.
- Context `{BiBUpdPlainly PROP}.
+ Context `{BiBUpdPlainly SI PROP}.
Lemma bupd_plain P `{!Plain P} : (|==> P) ⊢ P.
Proof. by rewrite {1}(plain P) bupd_plainly. Qed.
@@ -193,7 +193,7 @@ Section bupd_derived_sbi.
End bupd_derived_sbi.
Section fupd_derived.
- Context `{BiFUpd PROP}.
+ Context `{BiFUpd SI PROP}.
Implicit Types P Q R : PROP.
Global Instance fupd_proper E1 E2 :
@@ -208,7 +208,7 @@ Section fupd_derived.
Lemma fupd_intro E P : P ={E}=∗ P.
Proof. by rewrite {1}(fupd_intro_mask E E P) // fupd_trans. Qed.
- Lemma fupd_intro_mask' E1 E2 : E2 ⊆ E1 → (|={E1,E2}=> |={E2,E1}=> bi_emp (PROP:=PROP))%I.
+ Lemma fupd_intro_mask' E1 E2 : E2 ⊆ E1 → bi_emp_valid (|={E1,E2}=> |={E2,E1}=> bi_emp (PROP:=PROP))%I.
Proof. exact: fupd_intro_mask. Qed.
Lemma fupd_except_0 E1 E2 P : (|={E1,E2}=> ◇ P) ={E1,E2}=∗ P.
Proof. by rewrite {1}(fupd_intro E2 P) except_0_fupd fupd_trans. Qed.
@@ -291,6 +291,7 @@ Section fupd_derived.
Lemma fupd_sep E P Q : (|={E}=> P) ∗ (|={E}=> Q) ={E}=∗ P ∗ Q.
Proof. by rewrite fupd_frame_r fupd_frame_l fupd_trans. Qed.
+
Lemma fupd_big_sepL {A} E (Φ : nat → A → PROP) (l : list A) :
([∗ list] k↦x ∈ l, |={E}=> Φ k x) ={E}=∗ [∗ list] k↦x ∈ l, Φ k x.
Proof.
@@ -308,13 +309,13 @@ Section fupd_derived.
Proof.
apply (big_opS_forall (λ P Q, P ={E}=∗ Q)); auto using fupd_intro.
intros P1 P2 HP Q1 Q2 HQ. by rewrite HP HQ -fupd_sep.
- Qed.
+ Qed.
(** Fancy updates that take a step derived rules. *)
Lemma step_fupd_wand E1 E2 E3 P Q : (|={E1,E2,E3}▷=> P) -∗ (P -∗ Q) -∗ |={E1,E2,E3}▷=> Q.
Proof.
apply wand_intro_l.
- by rewrite (later_intro (P -∗ Q)%I) fupd_frame_l -later_sep fupd_frame_l
+ by rewrite (later_intro (P -∗ Q)%I) fupd_frame_l later_sep_2 fupd_frame_l
wand_elim_l.
Qed.
@@ -333,7 +334,7 @@ Section fupd_derived.
rewrite fupd_frame_l -(fupd_trans E1 F2 F1). f_equiv.
rewrite (fupd_intro_mask F2 F1 (|={_,_}=> emp)%I) //.
rewrite fupd_frame_r. f_equiv.
- rewrite [X in (X ∗ _)%I]later_intro -later_sep. f_equiv.
+ rewrite [X in (X ∗ _)%I]later_intro later_sep_2. f_equiv.
rewrite fupd_frame_r -(fupd_trans F1 F2 E2). f_equiv.
rewrite fupd_frame_l -(fupd_trans F2 E1 E2). f_equiv.
by rewrite fupd_frame_r left_id.
@@ -347,7 +348,7 @@ Section fupd_derived.
Proof.
rewrite fupd_frame_l.
apply fupd_mono.
- rewrite [P in P ∗ _ ⊢ _](later_intro R) -later_sep fupd_frame_l.
+ rewrite [P in P ∗ _ ⊢ _](later_intro R) later_sep_2 fupd_frame_l.
by apply later_mono, fupd_mono.
Qed.
@@ -364,13 +365,13 @@ Section fupd_derived.
intros HPQ. induction n as [|n IH]=> //=. rewrite IH //.
Qed.
- Lemma step_fupdN_wand E1 E2 n P Q :
+ Lemma step_fupdN_wand E1 E2 n P Q :
(|={E1,E2}▷=>^n P) -∗ (P -∗ Q) -∗ (|={E1,E2}▷=>^n Q).
Proof.
apply wand_intro_l. induction n as [|n IH]=> /=.
- { by rewrite wand_elim_l. }
- rewrite -IH -fupd_frame_l later_sep -fupd_frame_l.
- by apply sep_mono; first apply later_intro.
+ { by rewrite wand_elim_l. } etransitivity.
+ rewrite (later_intro (P -∗ Q)%I). eapply fupd_frame_l.
+ by rewrite later_sep_2 fupd_frame_l IH.
Qed.
Lemma step_fupdN_S_fupd n E P:
@@ -387,8 +388,27 @@ Section fupd_derived.
rewrite step_fupd_frame_l IH //=.
Qed.
+ Global Instance step_fupdN_ne k E1 E2: NonExpansive (λ P: PROP, |={E1, E2}▷=>^k P)%I.
+ Proof.
+ induction k; simpl; solve_proper.
+ Qed.
+
+ Lemma step_fupdN_steps_mono n m E1 E2 (P: PROP):
+ n ≤ m → E2 ⊆ E1 → (|={E1,E2}▷=>^n P)%I ⊢ |={E1, E2}▷=>^m P.
+ Proof.
+ intros H0 H'. induction H0 as [| ? ? IH]; eauto.
+ rewrite IH; simpl. rewrite -step_fupd_intro; eauto using later_intro.
+ Qed.
+
+ Lemma step_fupdN_intro n E1 E2 (P: PROP):
+ E2 ⊆ E1 → ▷^n P ⊢ |={E1, E2}▷=>^n P.
+ Proof.
+ intros H'. induction n as [|n IH]; eauto.
+ simpl. by rewrite IH -step_fupd_intro.
+ Qed.
+
Section fupd_plainly_derived.
- Context `{BiPlainly PROP, !BiFUpdPlainly PROP}.
+ Context `{BiPlainly SI PROP, !BiFUpdPlainly PROP}.
Lemma fupd_plainly_mask E E' P : (|={E,E'}=> ■P) ⊢ |={E}=> P.
Proof.
@@ -476,3 +496,4 @@ Section fupd_derived.
Qed.
End fupd_plainly_derived.
End fupd_derived.
+
diff --git a/theories/bi/weakestpre.v b/theories/bi/weakestpre.v
index 387b24bf8d789e3f0d09910a85b943dcc9333e24..3b9052fa3e9718f7d9ce5cb61a03f772217e8df8 100644
--- a/theories/bi/weakestpre.v
+++ b/theories/bi/weakestpre.v
@@ -32,11 +32,26 @@ Class Wp (Λ : language) (PROP A : Type) :=
Arguments wp {_ _ _ _} _ _ _%E _%I.
Instance: Params (@wp) 7 := {}.
+Class Swp (Λ : language) (PROP A : Type) :=
+ swp : nat → A → coPset → expr Λ → (val Λ → PROP) → PROP.
+Arguments swp {_ _ _ _} _ _ _%E _%I.
+Instance: Params (@swp) 8 := {}.
+
Class Twp (Λ : language) (PROP A : Type) :=
twp : A → coPset → expr Λ → (val Λ → PROP) → PROP.
Arguments twp {_ _ _ _} _ _ _%E _%I.
Instance: Params (@twp) 7 := {}.
+Class Rwp (Λ : language) (PROP A : Type) :=
+ rwp : A → coPset → expr Λ → (val Λ → PROP) → PROP.
+Arguments rwp {_ _ _ _} _ _ _%E _%I.
+Instance: Params (@rwp) 7 := {}.
+
+Class Rswp (Λ : language) (PROP A : Type) :=
+ rswp : nat → A → coPset → expr Λ → (val Λ → PROP) → PROP.
+Arguments rswp {_ _ _ _} _ _ _ _%E _%I.
+Instance: Params (@rswp) 8 := {}.
+
(** Notations for partial weakest preconditions *)
(** Notations without binder -- only parsing because they overlap with the
notations with binder. *)
@@ -242,3 +257,318 @@ Notation "'[[{' P } ] ] e [[{ 'RET' pat ; Q } ] ]" :=
(∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ WP e [{ Φ }]) : stdpp_scope.
Notation "'[[{' P } ] ] e ? [[{ 'RET' pat ; Q } ] ]" :=
(∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ WP e ?[{ Φ }]) : stdpp_scope.
+
+
+(** Notations for stronger weakest preconditions *)
+(** Notations without binder -- only parsing because they overlap with the
+notations with binder. *)
+Notation "'SWP' e 'at' k @ s ; E {{ Φ } }" := (swp k s E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'SWP' e 'at' k @ E {{ Φ } }" := (swp k NotStuck E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'SWP' e 'at' k @ E ? {{ Φ } }" := (swp k MaybeStuck E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'SWP' e 'at' k {{ Φ } }" := (swp k NotStuck ⊤ e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'SWP' e 'at' k ? {{ Φ } }" := (swp k MaybeStuck ⊤ e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+
+(** Notations with binder. The indentation for the inner format block is chosen
+such that *if* one has a single-character mask (e.g. [E]), the second line
+should align with the binder(s) on the first line. *)
+Notation "'SWP' e 'at' k @ s ; E {{ v , Q } }" := (swp k s E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'SWP' e 'at' k '/' '[ ' @ s ; E {{ v , Q } } ']' ']'") : bi_scope.
+Notation "'SWP' e 'at' k @ E {{ v , Q } }" := (swp k NotStuck E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'SWP' e 'at' k '/' '[ ' @ E {{ v , Q } } ']' ']'") : bi_scope.
+Notation "'SWP' e 'at' k @ E ? {{ v , Q } }" := (swp k MaybeStuck E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'SWP' e 'at' k '/' '[ ' @ E ? {{ v , Q } } ']' ']'") : bi_scope.
+Notation "'SWP' e 'at' k {{ v , Q } }" := (swp k NotStuck ⊤ e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'SWP' e 'at' k '/' '[ ' {{ v , Q } } ']' ']'") : bi_scope.
+Notation "'SWP' e 'at' k ? {{ v , Q } }" := (swp k MaybeStuck ⊤ e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'SWP' e 'at' k '/' '[ ' ? {{ v , Q } } ']' ']'") : bi_scope.
+
+
+(* Texan triples *)
+Notation "'{{{' P } } } e 'at' k @ s ; E {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ,
+ P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k @ s; E {{ Φ }})%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' @ s ; E {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k @ E {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ,
+ P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k @ E {{ Φ }})%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' @ E {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k @ E ? {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ,
+ P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k @ E ?{{ Φ }})%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' @ E ? {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ,
+ P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k {{ Φ }})%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k ? {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ,
+ P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k ?{{ Φ }})%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' ? {{{ x .. y , RET pat ; Q } } } ']'") : bi_scope.
+
+Notation "'{{{' P } } } e 'at' k @ s ; E {{{ 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k @ s; E {{ Φ }})%I
+ (at level 20,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' @ s ; E {{{ RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k @ E {{{ 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k @ E {{ Φ }})%I
+ (at level 20,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' @ E {{{ RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k @ E ? {{{ 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k @ E ?{{ Φ }})%I
+ (at level 20,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' @ E ? {{{ RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k {{{ 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k {{ Φ }})%I
+ (at level 20,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' {{{ RET pat ; Q } } } ']'") : bi_scope.
+Notation "'{{{' P } } } e 'at' k ? {{{ 'RET' pat ; Q } } }" :=
+ (□ ∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k ?{{ Φ }})%I
+ (at level 20,
+ format "'[hv' {{{ P } } } '/ ' e 'at' k '/' ? {{{ RET pat ; Q } } } ']'") : bi_scope.
+
+(** Aliases for stdpp scope -- they inherit the levels and format from above. *)
+Notation "'{{{' P } } } e 'at' k @ s ; E {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k @ s; E {{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k @ E {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k @ E {{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k @ E ? {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k @ E ?{{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k {{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k ? {{{ x .. y , 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ SWP e at k ?{{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k @ s ; E {{{ 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k @ s; E {{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k @ E {{{ 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k @ E {{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k @ E ? {{{ 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k @ E ?{{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k {{{ 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k {{ Φ }}) : stdpp_scope.
+Notation "'{{{' P } } } e 'at' k ? {{{ 'RET' pat ; Q } } }" :=
+ (∀ Φ, P -∗ ▷ (Q -∗ Φ pat%V) -∗ SWP e at k ?{{ Φ }}) : stdpp_scope.
+
+
+(** Notations for stronger weakest preconditions *)
+(** Notations without binder -- only parsing because they overlap with the
+notations with binder. *)
+Notation "'RSWP' e 'at' k @ s ; E ⟨⟨ Φ ⟩ ⟩" := (rswp k%nat s E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RSWP' e 'at' k @ E ⟨⟨ Φ ⟩ ⟩" := (rswp k%nat NotStuck E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RSWP' e 'at' k @ E ? ⟨⟨ Φ ⟩ ⟩" := (rswp k%nat MaybeStuck E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RSWP' e 'at' k ⟨⟨ Φ ⟩ ⟩" := (rswp k%nat NotStuck ⊤ e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RSWP' e 'at' k ? ⟨⟨ Φ ⟩ ⟩" := (rswp k%nat MaybeStuck ⊤ e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+
+(** Notations with binder. The indentation for the inner format block is chosen
+such that *if* one has a single-character mask (e.g. [E]), the second line
+should align with the binder(s) on the first line. *)
+Notation "'RSWP' e 'at' k @ s ; E ⟨⟨ v , Q ⟩ ⟩" := (rswp k%nat s E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RSWP' e 'at' k '/' '[ ' @ s ; E ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RSWP' e 'at' k @ E ⟨⟨ v , Q ⟩ ⟩" := (rswp k%nat NotStuck E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RSWP' e 'at' k '/' '[ ' @ E ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RSWP' e 'at' k @ E ? ⟨⟨ v , Q ⟩ ⟩" := (rswp k%nat MaybeStuck E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RSWP' e 'at' k '/' '[ ' @ E ? ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RSWP' e 'at' k ⟨⟨ v , Q ⟩ ⟩" := (rswp k%nat NotStuck ⊤ e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RSWP' e 'at' k '/' '[ ' ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RSWP' e 'at' k ? ⟨⟨ v , Q ⟩ ⟩" := (rswp k%nat MaybeStuck ⊤ e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RSWP' e 'at' k '/' '[ ' ? ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+
+
+(* Texan triples *)
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ s ; E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' @ s ; E ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k @ E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' @ E ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k @ E ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' @ E ? ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k ⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' ? ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ s ; E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' @ s ; E ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k @ E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' @ E ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k @ E ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' @ E ? ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ ▷^k(Q -∗ Φ pat%V) -∗ RSWP e at k ⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e 'at' k '/' ? ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+
+(** Aliases for stdpp scope -- they inherit the levels and format from above. *)
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ s ; E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k @ E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k @ E ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RSWP e at k ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ s ; E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k @ E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k @ E ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k @ E ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e 'at' k ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ ▷^k (Q -∗ Φ pat%V) -∗ RSWP e at k ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+
+
+(** Notations for refinement weakest preconditions *)
+(** Notations without binder -- only parsing because they overlap with the
+notations with binder. *)
+Notation "'RWP' e @ s ; E ⟨⟨ Φ ⟩ ⟩" := (rwp s E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RWP' e @ E ⟨⟨ Φ ⟩ ⟩" := (rwp NotStuck E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RWP' e @ E ? ⟨⟨ Φ ⟩ ⟩" := (rwp MaybeStuck E e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RWP' e ⟨⟨ Φ ⟩ ⟩" := (rwp NotStuck ⊤ e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+Notation "'RWP' e ? ⟨⟨ Φ ⟩ ⟩" := (rwp MaybeStuck ⊤ e%E Φ)
+ (at level 20, e, Φ at level 200, only parsing) : bi_scope.
+
+(** Notations with binder. The indentation for the inner format block is chosen
+such that *if* one has a single-character mask (e.g. [E]), the second line
+should align with the binder(s) on the first line. *)
+Notation "'RWP' e @ s ; E ⟨⟨ v , Q ⟩ ⟩" := (rwp s E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RWP' e '/' '[ ' @ s ; E ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RWP' e @ E ⟨⟨ v , Q ⟩ ⟩" := (rwp NotStuck E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RWP' e '/' '[ ' @ E ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RWP' e @ E ? ⟨⟨ v , Q ⟩ ⟩" := (rwp MaybeStuck E e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RWP' e '/' '[ ' @ E ? ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RWP' e ⟨⟨ v , Q ⟩ ⟩" := (rwp NotStuck ⊤ e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RWP' e '/' '[ ' ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'RWP' e ? ⟨⟨ v , Q ⟩ ⟩" := (rwp MaybeStuck ⊤ e%E (λ v, Q))
+ (at level 20, e, Q at level 200,
+ format "'[' 'RWP' e '/' '[ ' ? ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+
+
+(* Texan triples *)
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ s ; E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' @ s ; E ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e @ E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' @ E ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e @ E ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' @ E ? ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e ⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ,
+ P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20, x closed binder, y closed binder,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' ? ⟨⟨⟨ x .. y , RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ s ; E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' @ s ; E ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e @ E ⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' @ E ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e @ E ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' @ E ? ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e ⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (□ ∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e ?⟨⟨ Φ ⟩⟩)%I
+ (at level 20,
+ format "'[hv' ⟨⟨⟨ P ⟩ ⟩ ⟩ '/ ' e '/' ? ⟨⟨⟨ RET pat ; Q ⟩ ⟩ ⟩ ']'") : bi_scope.
+
+(** Aliases for stdpp scope -- they inherit the levels and format from above. *)
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ s ; E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e @ E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e @ E ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ? ⟨⟨⟨ x .. y , 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat%V) .. ) -∗ RWP e ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ s ; E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e @ E ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e @ E ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e @ E ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e ⟨⟨ Φ ⟩⟩) : stdpp_scope.
+Notation "'⟨⟨⟨' P ⟩ ⟩ ⟩ e ? ⟨⟨⟨ 'RET' pat ; Q ⟩ ⟩ ⟩" :=
+ (∀ Φ, P -∗ (Q -∗ Φ pat%V) -∗ RWP e ?⟨⟨ Φ ⟩⟩) : stdpp_scope.
diff --git a/theories/examples/counterexamples.v b/theories/examples/counterexamples.v
new file mode 100644
index 0000000000000000000000000000000000000000..9003e3f1f3024d5657c44ee4dcc957a3b9384e9e
--- /dev/null
+++ b/theories/examples/counterexamples.v
@@ -0,0 +1,227 @@
+From iris.algebra Require Import base stepindex.
+
+(** counter-examples for existential properties *)
+Section existential_negative.
+ (* Transfinite step-index types cannot validate the bounded existential property. *)
+ Context {SI : indexT}.
+ Record sProp :=
+ {
+ prop : SI → Prop;
+ prop_downclosed : ∀ α β, α ≺ β → prop β → prop α
+ }.
+ Program Definition sProp_later (P : sProp) := Build_sProp (λ γ, ∀ γ', γ' ≺ γ → prop P γ') _.
+ Next Obligation.
+ intros [P Pdown] α β Hα. cbn. eauto with index.
+ Qed.
+ Program Definition sProp_false := Build_sProp (λ _, False) _.
+ Next Obligation. intros. assumption. Qed.
+
+ Program Definition sProp_ex {X} (Φ : X → sProp) := Build_sProp (λ α, ∃ x, prop (Φ x) α) _.
+ Next Obligation.
+ intros X Φ α β Hα. cbn. intros [x H]. exists x. by eapply prop_downclosed.
+ Qed.
+
+ Definition bounded_existential (X : Type) (Φ : X → sProp) α:=
+ (∀ β, β ≺ α → ∃ x : X, prop (Φ x) β)
+ → ∃ x : X, ∀ β, β ≺ α → prop (Φ x) β.
+ Definition existential (X : Type) (Φ : X → sProp) :=
+ (∀ α, ∃ x : X, prop (Φ x) α)
+ → ∃ x : X, ∀ α, prop (Φ x) α.
+
+ Section transfinite.
+ Hypothesis (ω: SI).
+ Hypothesis (is_limit_of_nat: ∀ n, Nat.iter n (index_succ SI) zero ≺ ω).
+ Hypothesis (is_smallest: ∀ α, α ≺ ω → ∃ n, α = Nat.iter n (index_succ SI) zero).
+
+ Lemma transfinite_no_bounded_existential :
+ bounded_existential nat (λ n, Nat.iter n sProp_later sProp_false) ω → False.
+ Proof.
+ intros H. unfold bounded_existential in H. edestruct H as [n H'].
+ { intros β Hβ. apply is_smallest in Hβ as (n & ->). exists (S n).
+ induction n as [ | n IH].
+ - intros ? []%index_lt_zero_is_normal.
+ - intros α Hα. apply index_succ_iff in Hα as [ -> | Hα]. now apply IH.
+ intros β Hβ. apply IH. eauto with index.
+ }
+ specialize (H' (Nat.iter n (index_succ SI) zero) ltac:(apply is_limit_of_nat)).
+ induction n as [ | n IH]; cbn in H'. exact H'.
+ apply IH. apply H'. apply index_succ_greater.
+ Qed.
+ End transfinite.
+End existential_negative.
+
+Section no_later_exists.
+(** A step-indexed logic cannot have
+ * a sound later-operation,
+ * Löb induction
+ * Commutation of later with existentials: ▷ (∃ x. P) ⊢ ▷ False ∨ ∃ x. ▷ P
+ * the existential property for countable types, if ⊢ ∃ n : nat. P n, then there is n : nat such that ⊢ P n.
+*)
+
+ Context
+ (PROP : Type) (* the type of propositions *)
+ (entail : PROP → PROP → Prop) (* the entailment relation *)
+ (TRUE : PROP) (* the true proposition *)
+ (FALSE : PROP) (* the false proposition *)
+ (later : PROP → PROP) (* the later modality *)
+ (ex : (nat → PROP) → PROP). (* for simplicity, we restrict to predicates over nat here since we don't need more for the proof *)
+
+ Implicit Types (P Q: PROP).
+
+ Notation "â–· P" := (later P) (at level 20).
+ Notation "P ⊢ Q" := (entail P Q) (at level 60).
+ Notation "⊢ P" := (entail TRUE P) (at level 60).
+
+ (* standard structural rules *)
+ Context
+ (cut : ∀ P Q R, P ⊢ Q → Q ⊢ R → P ⊢ R)
+ (assumption : ∀ P, P ⊢ P)
+ (ex_intro : ∀ P Φ, (∃ n, P ⊢ Φ n) → P ⊢ ex Φ)
+ (ex_elim : ∀ P Φ, (∀ n, Φ n ⊢ P) → ex Φ ⊢ P).
+
+
+ (* relevant assumptions about our step-indexed logic *)
+ Context
+ (logic_sound: ¬ ⊢ FALSE)
+ (later_sound: ∀ P, ⊢ ▷ P → ⊢ P) (* later is sound *)
+ (existential : ∀ (Φ : nat → PROP), (⊢ ex Φ) → ∃ n, ⊢ (Φ n)) (* the existential property for nat *)
+ (Löb : ∀ P, (▷ P ⊢ P) → ⊢ P). (* Löb induction *)
+
+ (* now later commuting with existentials is contradictory *)
+ Lemma no_later_existential_commuting :
+ (∀ Φ, ▷ (ex Φ) ⊢ (ex (λ n, ▷ (Φ n))) )
+ → False.
+ Proof.
+ intros Hcomm. apply logic_sound.
+ assert (∃ n, ⊢ Nat.iter n later FALSE) as [ n Hf].
+ { apply existential.
+ apply Löb.
+ eapply cut. apply Hcomm.
+ apply ex_elim.
+ intros n. apply ex_intro. exists (S n). apply assumption.
+ }
+ induction n as [ | n IH].
+ exact Hf.
+ apply IH. apply later_sound, Hf.
+ Qed.
+End no_later_exists.
+
+
+From iris.algebra Require Export cmra updates.
+From iris.base_logic Require Import upred.
+From iris.bi Require Import notation.
+Section more_counterexamples.
+ Context {I: indexT} {M : ucmraT I}.
+ Implicit Types φ : Prop.
+ Implicit Types P Q : uPred M.
+ Implicit Types A : Type.
+ Arguments uPred_holds {_ _} !_ _ _ /.
+ Hint Immediate uPred_in_entails : core.
+
+ Notation "P ⊢ Q" := (@uPred_entails I M P%I Q%I) : stdpp_scope.
+ Notation "(⊢)" := (@uPred_entails I M) (only parsing) : stdpp_scope.
+ Notation "P ⊣⊢ Q" := (@uPred_equiv I M P%I Q%I) : stdpp_scope.
+ Notation "(⊣⊢)" := (@uPred_equiv I M) (only parsing) : stdpp_scope.
+
+ Notation "'True'" := (uPred_pure True) : bi_scope.
+ Notation "'False'" := (uPred_pure False) : bi_scope.
+ Notation "'⌜' φ 'âŒ'" := (uPred_pure φ%type%stdpp) : bi_scope.
+ Infix "∧" := uPred_and : bi_scope.
+ Infix "∨" := uPred_or : bi_scope.
+ Infix "→" := uPred_impl : bi_scope.
+ Notation "∀ x .. y , P" :=
+ (uPred_forall (λ x, .. (uPred_forall (λ y, P)) ..)) : bi_scope.
+ Notation "∃ x .. y , P" :=
+ (uPred_exist (λ x, .. (uPred_exist (λ y, P)) ..)) : bi_scope.
+ Infix "∗" := uPred_sep : bi_scope.
+ Infix "-∗" := uPred_wand : bi_scope.
+ Notation "â–¡ P" := (uPred_persistently P) : bi_scope.
+ Notation "â– P" := (uPred_plainly P) : bi_scope.
+ Notation "x ≡ y" := (uPred_internal_eq x y) : bi_scope.
+ Notation "â–· P" := (uPred_later P) : bi_scope.
+ Notation "|==> P" := (uPred_bupd P) : bi_scope.
+ Notation "â–·^ n P" := (Nat.iter n uPred_later P) : bi_scope.
+ Notation "â–·? p P" := (Nat.iter (Nat.b2n p) uPred_later P) : bi_scope.
+ Notation "⧠P" := (∃ n, ▷^n P)%I : bi_scope.
+ Notation "â§^ n P" := (Nat.iter n (λ Q, ⧠Q) P)%I : bi_scope.
+
+ Import uPred_primitive.
+
+ Section bounded_limit_preserving_counterexample.
+
+ Definition F (P: uPred M) : uPred M := P.
+ Definition G (P: uPred M) : uPred M := (∃ n, ▷^n False)%I.
+ Definition c {α: I} : bchain (uPredO M) α := bchain_const (∃ n, ▷^n False)%I α.
+
+ Hypothesis (omega: I).
+ Hypothesis (is_limit_of_nat: ∀ n, Nat.iter n (index_succ I) zero ≺ omega).
+ Hypothesis (is_smallest: ∀ α, α ≺ omega → ∃ n, α = Nat.iter n (index_succ I) zero).
+
+ Notation "'ω'" := omega.
+ Lemma zero_omega: zero ≺ ω.
+ Proof using I is_limit_of_nat omega. eapply (is_limit_of_nat 0). Qed.
+
+ Lemma bounded_limit_preserving_entails_counterexample:
+ ¬ BoundedLimitPreserving (λ P, F P ⊢ G P).
+ Proof using I M is_limit_of_nat is_smallest omega.
+ intros H. specialize (H ω zero_omega c); simpl in H.
+ assert (∀ β : I, β ≺ ω → F (⧠⌜FalseâŒ) ⊢ G (⧠⌜FalseâŒ)) as H'.
+ { intros ??. destruct (entails_po (I:=I) (M:=M)) as [R _]. apply R. }
+ specialize (H H'). destruct H as [H].
+ specialize (H ω ε (ucmra_unit_validN ω)).
+ unfold F in *. assert (bcompl zero_omega c ω ε) as H''.
+ { eapply bcompl_unfold. unfold c; simpl.
+ intros n' Hn' _ Hv. eapply is_smallest in Hn'.
+ destruct Hn' as [m ->]. unseal.
+ exists (S m). clear Hv H' H. induction m; cbn.
+ - intros ? [] % index_lt_zero_is_normal.
+ - intros n' Hn' n'' Hn''. eapply uPred_mono.
+ eapply IHm; eauto.
+ eapply index_lt_le_trans. eapply Hn''.
+ eapply index_succ_iff, Hn'.
+ all: eauto.
+ }
+ specialize (H H''). unfold G in *.
+ revert H; unseal. intros [n].
+ eapply uPred_mono with (n2 := (Nat.iter (S n) (index_succ I) zero)) in H; eauto.
+ clear H' H''. induction n; simpl in *; eauto.
+ Qed.
+
+ End bounded_limit_preserving_counterexample.
+
+ Section ne_does_not_preserve_limits.
+ (* we show that, in general, non-expansive maps do not preserve limits. *)
+
+ Program Definition f : uPredO M -n> uPredO M := λne P, (P ∧ ∃ n, ▷^n False)%I.
+ Next Obligation.
+ intros α x y Heq. apply and_ne. apply Heq. reflexivity.
+ Qed.
+ Definition c0 {α: I} : bchain (uPredO M) α := bchain_const (True)%I α.
+
+ Hypothesis (omega: I).
+ Hypothesis (is_limit_of_nat: ∀ n, Nat.iter n (index_succ I) zero ≺ omega).
+ Hypothesis (is_smallest: ∀ α, α ≺ omega → ∃ n, α = Nat.iter n (index_succ I) zero).
+
+
+ Notation "'ω'" := omega.
+ Lemma zero_omega': zero ≺ ω.
+ Proof using I is_limit_of_nat omega. eapply (is_limit_of_nat 0). Qed.
+
+ Lemma test : ¬ (f (bcompl zero_omega' c0) ≡ bcompl zero_omega' (bchain_map f c0)).
+ Proof using is_smallest.
+ intros Heq. destruct Heq as [Heq]. specialize (Heq omega ε (ucmra_unit_validN _)).
+ cbn in Heq. destruct Heq as [_ H1].
+ revert H1. rewrite !bcompl_unfold; cbn. unseal. intros H. destruct H as [ _ H].
+ 2: { destruct H as [n H]. eapply uPred_mono with (n2 := Nat.iter (S n) (index_succ I) zero) in H; eauto.
+ induction n as [ | n IH]; cbn in H; [tauto | ].
+ eapply IH. apply H. eapply index_succ_greater.
+ }
+ intros. split; [easy | ]. apply is_smallest in Hn' as [nn ->]. exists (S nn).
+ clear H0 H. induction nn as [ | n IH]; cbn.
+ - intros ? []%index_lt_zero_is_normal.
+ - intros n' Hn' n'' Hn''. apply IH. eapply index_lt_le_trans.
+ exact Hn''. apply index_succ_iff, Hn'.
+ Qed.
+ End ne_does_not_preserve_limits.
+
+End more_counterexamples.
diff --git a/theories/examples/keyideas/generalized_simulations.v b/theories/examples/keyideas/generalized_simulations.v
new file mode 100644
index 0000000000000000000000000000000000000000..623475e5acf4f7a89c2842dc123616efb4d6f6da
--- /dev/null
+++ b/theories/examples/keyideas/generalized_simulations.v
@@ -0,0 +1,147 @@
+From iris.base_logic Require Export iprop satisfiable.
+From iris.bi Require Export fixpoint.
+From iris.proofmode Require Import tactics.
+
+
+Section simulations.
+
+ Context {SI} `{LargeIndex SI} {Σ: gFunctors SI}.
+
+
+ (* We assume a source and a target language *)
+ Variable (S T: Type) (src_step: S → S → Prop) (tgt_step: T → T → Prop).
+ Variable (V: Type) (val_to_tgt: V → T) (φ: V → S → Prop).
+ Variable (val_irred: ∀ v, ¬ ∃ t', tgt_step (val_to_tgt v) t') (val_inj: Inj eq eq val_to_tgt).
+
+
+ (* refinements *)
+ Definition gtpr (t: T) (s: S) :=
+ (∀ v, rtc tgt_step t (val_to_tgt v) → ∃ s', rtc src_step s s' ∧ φ v s') ∧
+ (ex_loop tgt_step t → ex_loop src_step s).
+
+
+ Notation "S *d T" := (prodO (leibnizO SI T) (leibnizO SI S)) (at level 60).
+ Definition gsim_pre (sim: ((S *d T) → iProp Σ)) : (S *d T) → iProp Σ :=
+ (λ '(t, s),
+ (∃ v, ⌜φ v s⌠∧ ⌜val_to_tgt v = tâŒ) ∨
+ (∃ t', ⌜tgt_step t t'âŒ) ∧
+ (∀ t', ⌜tgt_step t t'⌠→ sim (t', s) ∨ ∃ s', ⌜src_step s s'⌠∧ ▷ sim (t', s'))
+ )%I.
+
+ Instance gsim_pre_mono: BiMonoPred gsim_pre.
+ Proof.
+ split.
+ - intros Φ Ψ. iIntros "#H" ([t s]).
+ rewrite /gsim_pre.
+ iIntros "[Hsim|Hsim]"; eauto.
+ iRight. iDestruct "Hsim" as "[Hsteps Hsim]".
+ iSplit; eauto.
+ iIntros (t' Htgt). iDestruct ("Hsim" $! t' Htgt) as "[Hsim|Hsim]".
+ + iLeft. by iApply "H".
+ + iRight. iDestruct "Hsim" as (s' Hsrc) "Hsim".
+ iExists s'. iSplit; eauto. iNext. by iApply "H".
+ - intros Φ Hdist α [t s] [t' s'] [Heq1 Heq2]; simpl in *.
+ repeat f_equiv; eauto.
+ Qed.
+
+ Definition gsim := bi_least_fixpoint gsim_pre.
+
+ Lemma sim_unfold t s:
+ (gsim (t, s) ⊣⊢ (∃ v, ⌜φ v s⌠∧ ⌜val_to_tgt v = tâŒ) ∨
+ (∃ t', ⌜tgt_step t t'âŒ) ∧
+ (∀ t', ⌜tgt_step t t'⌠→ gsim (t', s) ∨ ∃ s', ⌜src_step s s'⌠∧ ▷ gsim (t', s')))%I.
+ Proof.
+ fold (gsim_pre gsim (t, s)). iSplit.
+ - iApply least_fixpoint_unfold_1.
+ - iApply least_fixpoint_unfold_2.
+ Qed.
+
+
+ Lemma satisfiable_pure ψ: satisfiable (⌜ψâŒ: iProp Σ)%I → ψ.
+ Proof.
+ intros Hsat. apply satisfiable_elim in Hsat; last apply _.
+ by apply uPred.pure_soundness in Hsat.
+ Qed.
+
+ (* result preserving *)
+ Lemma gsim_execute_tgt_step t s t':
+ tgt_step t t' → satisfiable (gsim (t, s)) → ∃ s', rtc src_step s s' ∧ satisfiable (gsim (t', s')).
+ Proof.
+ intros Hstep Hsat.
+ eapply satisfiable_mono with (Q := (∃ s', ⌜rtc src_step s s'⌠∧ ▷ gsim (t', s'))%I) in Hsat.
+ - eapply satisfiable_exists in Hsat as [s' Hsat].
+ exists s'. split.
+ + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "[$ _]".
+ + eapply satisfiable_later, satisfiable_mono; eauto. iIntros "[_ $]".
+ - iIntros "Hsim". rewrite sim_unfold. iDestruct "Hsim" as "[Hsim|[_ Hsim]]".
+ + iDestruct "Hsim" as (v) "[_ <-]". exfalso. naive_solver.
+ + iDestruct ("Hsim" $! t' Hstep) as "[Hsim|Hsim]".
+ * iExists s. iSplit; first by iPureIntro. by iNext.
+ * iDestruct "Hsim" as (s' Hstep') "Hsim". iExists s'. iSplit; eauto.
+ iPureIntro. by eapply rtc_l.
+ Qed.
+
+ Lemma sim_execute_tgt t s t':
+ rtc tgt_step t t' → satisfiable (gsim (t, s)) → ∃ s', rtc src_step s s' ∧ satisfiable (gsim (t', s')).
+ Proof.
+ induction 1 in s.
+ - intros Hsim. exists s. by split.
+ - intros Hsim. eapply gsim_execute_tgt_step in Hsim; last eauto.
+ destruct Hsim as [s' [Hsrc Hsat]].
+ destruct (IHrtc _ Hsat) as [s'' [Hsrc' Hsat']].
+ exists s''. split; auto. by transitivity s'.
+ Qed.
+
+
+ (* termination preserving *)
+ Lemma sim_execute_tgt_step t s:
+ ex_loop tgt_step t → satisfiable (gsim (t, s)) → ∃ t' s', src_step s s' ∧ ex_loop tgt_step t' ∧ satisfiable (gsim (t', s')).
+ Proof.
+ intros Hsteps Hsat.
+ eapply satisfiable_mono with (Q := (∃ t' s', ⌜src_step s s'⌠∧ ⌜ex_loop tgt_step t'⌠∧ ▷ gsim (t', s'))%I) in Hsat; last first.
+ iPoseProof (@least_fixpoint_strong_ind _ _ _ gsim_pre _ (λ '(t, s), ⌜ex_loop tgt_step t⌠→ ∃ (t' : T) (s' : S), ⌜src_step s s'⌠∧ ⌜ex_loop tgt_step t'⌠∧ ▷ gsim (t', s'))%I) as "Hind".
+ { intros ? [t'' s''] [t' s'] [Heq1 Heq2]; repeat f_equiv; eauto. }
+ - iIntros "Hsim". iRevert (Hsteps). iRevert "Hsim". iSpecialize ("Hind" with "[]"); last iApply ("Hind" $! (t, s)).
+ clear Hsat t s. iModIntro. iIntros ([t s]). iIntros "Hsim" (Hloop).
+ rewrite /gsim_pre. iDestruct "Hsim" as "[Hsim|Hsim]".
+ + iDestruct "Hsim" as (v) "[_ %]".
+ destruct Hloop as [t t']; subst t. naive_solver.
+ + iDestruct "Hsim" as "[_ Hsim]".
+ inversion Hloop as [t'' t' Hstep Hloop']; subst t''.
+ iDestruct ("Hsim" $! t' Hstep) as "[Hsim|Hsim]".
+ * iDestruct "Hsim" as "[Hsim _]". by iSpecialize ("Hsim" $! Hloop').
+ * iDestruct "Hsim" as (s' Hstep') "Hsim".
+ iExists t', s'. repeat iSplit; eauto.
+ iNext. iDestruct "Hsim" as "[_ $]".
+ - eapply satisfiable_exists in Hsat as [t' Hsat].
+ eapply satisfiable_exists in Hsat as [s' Hsat].
+ exists t', s'. repeat split.
+ + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "($ & _ & _)".
+ + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "(_ & $ & _)".
+ + eapply satisfiable_later, satisfiable_mono; eauto. iIntros "(_ & _ & $)".
+ Qed.
+
+ Lemma sim_divergence t s:
+ ex_loop tgt_step t → satisfiable (gsim (t, s)) → ex_loop src_step s.
+ Proof.
+ revert t s. cofix IH. intros t s Hloop Hsat.
+ edestruct sim_execute_tgt_step as (t' & s' & Hsrc & Hloop' & Hsim); [eauto..|].
+ econstructor; eauto.
+ Qed.
+
+ Lemma sim_is_tpr t s: (⊢ gsim (t, s)) → gtpr t s.
+ Proof.
+ intros Hsim. split.
+ - apply satisfiable_intro in Hsim. intros v Hsteps.
+ eapply sim_execute_tgt in Hsteps as [s' [Hsteps' Hsat]]; eauto.
+ enough (φ v s') by eauto.
+ eapply satisfiable_pure, satisfiable_mono; eauto.
+ rewrite sim_unfold. iIntros "[H|[H _]]".
+ + iDestruct "H" as (v') "[% H]". by iDestruct "H" as %->%val_inj.
+ + iDestruct "H" as (t') "%". exfalso. naive_solver.
+ - intros Hloop. eapply sim_divergence; eauto.
+ apply satisfiable_intro, Hsim.
+ Qed.
+
+End simulations.
+
diff --git a/theories/examples/keyideas/simulations.v b/theories/examples/keyideas/simulations.v
new file mode 100644
index 0000000000000000000000000000000000000000..35f5f9e38d923e01386577c392a7a57127dc25c7
--- /dev/null
+++ b/theories/examples/keyideas/simulations.v
@@ -0,0 +1,129 @@
+From iris.base_logic Require Export iprop satisfiable.
+From iris.bi Require Export fixpoint.
+From iris.proofmode Require Import tactics.
+
+
+Section simulations.
+
+ Context {SI} `{LargeIndex SI} {Σ: gFunctors SI}.
+
+
+ (* We assume a source and a target language *)
+ Variable (S T: Type) (src_step: S → S → Prop) (tgt_step: T → T → Prop).
+ Variable (V: Type) (val_to_src: V → S) (val_to_tgt: V → T).
+ Variable (val_irred: ∀ v, ¬ ∃ t', tgt_step (val_to_tgt v) t') (val_inj: Inj eq eq val_to_tgt).
+
+
+ (* refinements *)
+ Definition rpr (t: T) (s: S) :=
+ (∀ v, rtc tgt_step t (val_to_tgt v) → rtc src_step s (val_to_src v)).
+
+ Definition tpr (t: T) (s: S) :=
+ (∀ v, rtc tgt_step t (val_to_tgt v) → rtc src_step s (val_to_src v)) ∧
+ (ex_loop tgt_step t → ex_loop src_step s).
+
+ Definition sim_pre (sim: (T -d> S -d> iProp Σ)) : T -d> S -d> iProp Σ :=
+ (λ t s,
+ (∃ v, ⌜val_to_src v = s⌠∧ ⌜val_to_tgt v = tâŒ) ∨
+ (∃ t', ⌜tgt_step t t'âŒ) ∧
+ (∀ t', ⌜tgt_step t t'⌠→ ∃ s', ⌜src_step s s'⌠∧ ▷ sim t' s')
+ )%I.
+
+ Instance sim_pre_contr: Contractive sim_pre.
+ Proof.
+ intros a sim sim' Heq. unfold sim_pre.
+ intros t s. do 8 f_equiv. apply bi.later_contractive.
+ intros ??. by apply Heq.
+ Qed.
+
+
+ Definition sim := fixpoint sim_pre.
+
+ Lemma sim_unfold':
+ sim ≡ sim_pre sim.
+ Proof. by rewrite {1}/sim fixpoint_unfold. Qed.
+
+ Lemma sim_unfold t s:
+ (sim t s ⊣⊢ ((∃ v, ⌜val_to_src v = s⌠∧ ⌜val_to_tgt v = tâŒ) ∨
+ (∃ t', ⌜tgt_step t t'âŒ) ∧
+ (∀ t', ⌜tgt_step t t'⌠→ ∃ s', ⌜src_step s s'⌠∧ ▷ sim t' s')))%I.
+ Proof. apply sim_unfold'. Qed.
+
+ Instance sim_plain t s: Plain (sim t s).
+ Proof.
+ unfold Plain. iRevert (t s). iLöb as "IH".
+ iIntros (t s); rewrite sim_unfold.
+ iIntros "[H1|[H1 H2]]".
+ - iLeft. iApply (plain with "H1").
+ - iRight. iSplit; first iApply (plain with "H1").
+ iIntros (t' Hstep). iDestruct ("H2" $! t' Hstep) as (s' Hstep') "Hsim".
+ iExists s'; iSplit; first (iApply plain; by iPureIntro).
+ iApply later_plainly_1. iNext. by iApply "IH".
+ Qed.
+
+ Lemma sim_valid_satisfiable t s: satisfiable (sim t s) ↔ ⊢ sim t s.
+ Proof.
+ split.
+ - intros ? % satisfiable_elim; eauto. apply _.
+ - by intros ? % satisfiable_intro.
+ Qed.
+
+
+ Lemma satisfiable_pure φ: satisfiable (⌜φâŒ: iProp Σ)%I → φ.
+ Proof.
+ intros Hsat. apply satisfiable_elim in Hsat; last apply _.
+ by apply uPred.pure_soundness in Hsat.
+ Qed.
+
+ (* result preserving *)
+ Lemma sim_execute_tgt_step t s t':
+ tgt_step t t' → satisfiable (sim t s) → ∃ s', src_step s s' ∧ satisfiable (sim t' s').
+ Proof.
+ intros Hstep Hsat.
+ eapply satisfiable_mono with (Q := (∃ s', ⌜src_step s s'⌠∧ ▷ sim t' s')%I) in Hsat.
+ - eapply satisfiable_exists in Hsat as [s' Hsat].
+ exists s'. split.
+ + eapply satisfiable_pure, satisfiable_mono; eauto. iIntros "[$ _]".
+ + eapply satisfiable_later, satisfiable_mono; eauto. iIntros "[_ $]".
+ - iIntros "Hsim". rewrite sim_unfold. iDestruct "Hsim" as "[Hsim|[_ Hsim]]".
+ + iDestruct "Hsim" as (v) "[<- <-]". exfalso. naive_solver.
+ + iApply ("Hsim" $! t' Hstep).
+ Qed.
+
+ Lemma sim_execute_tgt t s t':
+ rtc tgt_step t t' → satisfiable (sim t s)
+ → ∃ s', rtc src_step s s' ∧ satisfiable (sim t' s').
+ Proof.
+ induction 1 in s.
+ - intros Hsim. exists s. by split.
+ - intros Hsim. eapply sim_execute_tgt_step in Hsim; eauto.
+ destruct Hsim as [s' [Hsrc Hsat]].
+ destruct (IHrtc _ Hsat) as [s'' [Hsrc' Hsat']].
+ exists s''. split; auto. by eapply rtc_l.
+ Qed.
+
+ (* Lemma 2.1 *)
+ Lemma sim_is_rpr t s: (⊢ sim t s) → rpr t s.
+ Proof.
+ intros Hsim % sim_valid_satisfiable v Hsteps.
+ eapply sim_execute_tgt in Hsteps as [s' [Hsteps' Hsat]]; eauto.
+ enough (s' = (val_to_src v)) as -> by eauto.
+ eapply satisfiable_pure, satisfiable_mono; eauto.
+ rewrite sim_unfold. iIntros "[H|[H _]]".
+ - iDestruct "H" as (v') "[<- H]". by iDestruct "H" as %->%val_inj.
+ - iDestruct "H" as (t') "%". exfalso. naive_solver.
+ Qed.
+
+
+ (* Lemma 2.2 *)
+ Lemma sim_is_tpr t s: (⊢ sim t s) → tpr t s.
+ Proof.
+ intros Hsim. split.
+ - by apply sim_is_rpr.
+ - apply sim_valid_satisfiable in Hsim. revert t s Hsim.
+ cofix IH. intros t s Hsat. inversion 1 as [t'' t' Hstep Hloop]; subst t''.
+ destruct (sim_execute_tgt_step _ _ _ Hstep Hsat) as [s' [Hstep' Hsat']].
+ econstructor; eauto.
+ Qed.
+End simulations.
+
diff --git a/theories/examples/refinements/derived.v b/theories/examples/refinements/derived.v
new file mode 100644
index 0000000000000000000000000000000000000000..931dfa3b6a8dce9d7d5f056e69e205367b5a8e0d
--- /dev/null
+++ b/theories/examples/refinements/derived.v
@@ -0,0 +1,124 @@
+
+From iris.program_logic.refinement Require Export ref_weakestpre ref_adequacy seq_weakestpre.
+From iris.examples.refinements Require Export refinement.
+From iris.algebra Require Import auth.
+From iris.heap_lang Require Import proofmode notation.
+From iris.proofmode Require Import tactics.
+Set Default Proof Using "Type".
+
+
+(* We illustrate here how to derive the rules shown in the paper *)
+
+
+Section derived.
+ Context {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)} `{!seqG Σ}.
+
+ Definition seq_rswp E e φ : iProp Σ := (na_own seqG_name E -∗ RSWP e at 0 ⟨⟨ v, na_own seqG_name E ∗ φ v ⟩⟩)%I.
+ Notation "⟨⟨ P ⟩ ⟩ e ⟨⟨ v , Q ⟩ ⟩" := (□ (P -∗ (seq_rswp ⊤ e (λ v, Q))))%I
+ (at level 20, P, e, Q at level 200, format "⟨⟨ P ⟩ ⟩ e ⟨⟨ v , Q ⟩ ⟩") : stdpp_scope.
+ Notation "{{ P } } e {{ v , Q } }" := (□ (P -∗ SEQ e ⟨⟨ v, Q ⟩⟩))%I
+ (at level 20, P, e, Q at level 200, format "{{ P } } e {{ v , Q } }") : stdpp_scope.
+
+
+ Lemma Value (v: val): (⊢ {{True}} v {{w, ⌜v = wâŒ}})%I.
+ Proof.
+ iIntros "!> _ $". by iApply rwp_value.
+ Qed.
+
+ Lemma Frame (e: expr) P R Q: ({{P}} e {{v, Q v}} ⊢ {{P ∗ R}} e {{v, Q v ∗ R}})%I.
+ Proof.
+ iIntros "#H !> [P $]". by iApply "H".
+ Qed.
+
+ Lemma Bind (e: expr) K P Q R:
+ ({{P}} e {{v, Q v}} ∗ (∀ v: val, ({{Q v}} fill K (Val v) {{w, R w}}))
+ ⊢ {{P}} fill K e {{v, R v}})%I.
+ Proof.
+ iIntros "[#H1 #H2] !> P Hna".
+ iApply rwp_bind. iSpecialize ("H1" with "P Hna").
+ iApply (rwp_strong_mono with "H1 []"); auto.
+ iIntros (v) "[Hna Q] !>". iApply ("H2" with "Q Hna").
+ Qed.
+
+ Lemma Löb (P : iPropI Σ) : (▷ P → P) ⊢ P.
+ Proof. iApply bi.löb. Qed.
+
+ Lemma TPPureT (e e': expr) P Q: pure_step e e' → ({{P}} e' {{v, Q v}} ⊢ ⟨⟨P⟩⟩ e ⟨⟨v, Q v⟩⟩)%I.
+ Proof.
+ iIntros (Hstep) "#H !> P Hna".
+ iApply (ref_lifting.rswp_pure_step_later _ _ _ _ _ True); [|done|by iApply ("H" with "P Hna")].
+ intros _. apply nsteps_once, Hstep.
+ Qed.
+
+ Lemma TPPureS (e e' et: expr) K P Q:
+ to_val et = None
+ → pure_step e e'
+ → (⟨⟨src (fill K e') ∗ P⟩⟩ et ⟨⟨v, Q v⟩⟩ ⊢ {{src (fill K e) ∗ ▷ P}} et {{v, Q v}})%I.
+ Proof.
+ iIntros (Hexp Hstep) "#H !> [Hsrc P] Hna". iApply (rwp_take_step with "[P Hna] [Hsrc]"); first done; last first.
+ - iApply step_pure; last iApply "Hsrc". apply pure_step_ctx; last done. apply _.
+ - iIntros "Hsrc'". iApply rswp_do_step. iNext. iApply ("H" with "[$P $Hsrc'] Hna").
+ Qed.
+
+ Lemma TPStoreT l (v1 v2: val): (True ⊢ ⟨⟨l ↦ v1⟩⟩ #l <- v2 ⟨⟨w, ⌜w = #()⌠∗ l ↦ v2⟩⟩)%I.
+ Proof.
+ iIntros "_ !> Hl $". iApply (rswp_store with "[$Hl]").
+ by iIntros "$".
+ Qed.
+
+ Lemma TPStoreS (et: expr) l v1 v2 K P Q:
+ to_val et = None
+ → (⟨⟨P ∗ src (fill K (Val #())) ∗ l ↦s v2⟩⟩ et ⟨⟨v, Q v⟩⟩
+ ⊢ {{src (fill K (#l <- v2)) ∗ l ↦s v1 ∗ ▷ P}} et {{v, Q v}})%I.
+ Proof.
+ iIntros (Hexp) "#H !> [Hsrc [Hloc P]] Hna". iApply (rwp_take_step with "[P Hna] [Hsrc Hloc]"); first done; last first.
+ - iApply step_store. iFrame.
+ - iIntros "Hsrc'". iApply rswp_do_step. iNext. iApply ("H" with "[$P $Hsrc'] Hna").
+ Qed.
+
+ Lemma TPStutterT (e: expr) P Q: to_val e = None → (⟨⟨P⟩⟩ e ⟨⟨v, Q v⟩⟩ ⊢ {{P}} e {{v, Q v}})%I.
+ Proof.
+ iIntros (H) "#H !> P Hna". iApply rwp_no_step; first done.
+ by iApply ("H" with "P Hna").
+ Qed.
+
+ Lemma TPStutterSStore (et : expr) v1 v2 K l P Q :
+ to_val et = None
+ → {{P ∗ src (fill K (Val #())) ∗ l ↦s v2}} et {{v, Q v}}
+ ⊢ {{l ↦s v1 ∗ src (fill K (#l <- v2)) ∗ P}} et {{v, Q v}}.
+ Proof.
+ iIntros (Hv) "#H !> [Hloc [Hsrc P]] Hna".
+ iApply (rwp_weaken with "[H Hna] [P Hloc Hsrc]"); first done.
+ - instantiate (1 := (P ∗ src (fill K #()) ∗ l ↦s v2)%I).
+ iIntros "H1". iApply ("H" with "[H1] [Hna]"); done.
+ - iApply src_update_mono. iSplitL "Hsrc Hloc".
+ iApply step_store. by iFrame.
+ iIntros "[H0 H1]". by iFrame.
+ Qed.
+
+ Lemma TPStutterSPure (et es es' : expr) P Q :
+ to_val et = None
+ → pure_step es es'
+ → {{ P ∗ src(es') }} et {{v, Q v}}
+ ⊢ {{ P ∗ src(es)}} et {{v, Q v}}.
+ Proof.
+ iIntros (H0 H) "#H !> [P Hsrc] Hna".
+ iApply (rwp_weaken with "[H Hna] [P Hsrc]"); first done.
+ - instantiate (1 := (P ∗ src es')%I). iIntros "H1".
+ by iApply ("H" with "[H1] Hna").
+ - iApply src_update_mono. iSplitL "Hsrc".
+ by iApply step_pure. iIntros "?"; by iFrame.
+ Qed.
+
+ Lemma HoareLöb X P Q e :
+ (∀ x :X, {{P x ∗ ▷ (∀ x, {{P x}} e {{v, Q x v}})}} e {{ v, Q x v}})
+ ⊢ ∀ x, {{ P x }} e {{v, Q x v}}.
+ Proof.
+ iIntros "H". iApply bi.löb.
+ iIntros "#H1" (x).
+ (*iIntros "H0".*)
+ (*iSpecialize ("H" with x). *)
+ (*iApply ("H"). iModIntro.*)
+ Abort.
+
+End derived.
diff --git a/theories/examples/refinements/memoization.v b/theories/examples/refinements/memoization.v
new file mode 100644
index 0000000000000000000000000000000000000000..3dc4e2476deb7ab5cebbffdb56b252559aa4b4db
--- /dev/null
+++ b/theories/examples/refinements/memoization.v
@@ -0,0 +1,1914 @@
+
+From iris.program_logic.refinement Require Export ref_weakestpre ref_source seq_weakestpre.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From iris.examples.refinements Require Export refinement.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation metatheory.
+From iris.algebra Require Import auth gmap excl frac agree.
+Set Default Proof Using "Type".
+
+Definition refN := nroot .@ "ref".
+
+Lemma fill_item_injective a (e e': expr): fill_item a e = fill_item a e' → e = e'.
+Proof.
+ induction a; simpl; injection 1; eauto.
+Qed.
+
+Lemma fill_injective K (e e': expr): fill K e = fill K e' → e = e'.
+Proof.
+ revert e e'; induction K; intros e e'; simpl; eauto.
+ intros ? % IHK. by eapply fill_item_injective.
+Qed.
+
+Definition eq_heaplang : val := (λ: "n1" "n2", "n1" = "n2").
+
+Notation exec := (tc (@pure_step heap_lang)).
+
+Section map_simple.
+
+ Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A}.
+ Context (Comparable: val → iProp Σ).
+ Context `{Comparable_timeless: ∀ v, Timeless (Comparable v)}.
+
+ Fixpoint contents (kvs: list (val * val)) (l: loc) : iProp Σ :=
+ (match kvs with
+ | nil => l ↦ NONEV
+ | (k, n) :: kvs' => ∃(l': loc), Comparable k ∗ l ↦ SOMEV ((k, n), #l') ∗ contents kvs' l'
+ end)%I.
+
+ Global Instance contents_timeless kvs l: Timeless (contents kvs l).
+ Proof using Comparable_timeless.
+ revert l; induction kvs as [|[] kvs IH]; intros l; simpl; apply _.
+ Qed.
+ Definition map : val :=
+ λ: <>, ref (ref NONE).
+
+ Definition get : val :=
+ λ: "m" "eq" "a",
+ (rec: "get" "h" "a" :=
+ match: !"h" with
+ NONE => NONE
+ | SOME "p" =>
+ let: "kv" := Fst "p" in
+ let: "next" := Snd "p" in
+ if: "eq" (Fst "kv") "a" then SOME (Snd "kv") else "get" "next" "a"
+ end) (!"m") "a".
+
+ Definition set : val :=
+ λ: "h" "a" "v",
+ "h" <- ref (SOME (("a", "v"), !"h")).
+
+ Fixpoint to_map (kvs: list (val * val)) : gmap val val :=
+ match kvs with
+ | nil => ∅
+ | (k, n) :: kvs => <[k := n]> (to_map kvs)
+ end.
+
+ Definition Map v (h: gmap val val) :=
+ (∃ (l l': loc) kvs, ⌜v = #l⌠∗ ⌜h = to_map kvs⌠∗ l ↦ #l' ∗ contents kvs l')%I.
+
+ Global Instance Map_timeless v h: Timeless (Map v h).
+ Proof using Comparable_timeless. apply _. Qed.
+
+ Lemma map_spec: ⊢ ⟨⟨⟨ True ⟩⟩⟩ map #() ⟨⟨⟨ v, RET v; Map v ∅ ⟩⟩⟩.
+ Proof.
+ iModIntro; iIntros (Φ) "_ Hpost". rewrite /map. wp_pures.
+ wp_alloc r as "Hr". wp_alloc h as "Hh".
+ iApply "Hpost".
+ iExists h, r, nil; simpl; iFrame; iSplit; done.
+ Qed.
+
+ Definition embed (o: option val) :=
+ match o with
+ | None => NONEV
+ | Some k => SOMEV k
+ end.
+
+ Definition eqfun (eq : val) (Q: val → val → iProp Σ) :=
+ (∀ n1 n2,
+ ⟨⟨⟨ Comparable n1 ∗ Comparable n2 ⟩⟩⟩ eq n1 n2
+ ⟨⟨⟨ b, RET #(b: bool); Comparable n1 ∗ Comparable n2 ∗
+ match b with
+ | true => Q n1 n2
+ | _ => Q n1 n2 -∗ False
+ end ⟩⟩⟩)%I.
+
+ Lemma get_spec h eq Q m (n: val) :
+ ⊢ ⟨⟨⟨ Map m h ∗ eqfun eq Q ∗ Comparable n ⟩⟩⟩ get m eq n
+ ⟨⟨⟨ o, RET (embed o);
+ match o with
+ | Some v => ∃ n', ⌜ h !! n' = Some v ⌠∗ Q n' n ∗ Map m h
+ | None => (∀ n', ⌜ n' ∈ dom (gset val) h ⌠-∗ Q n' n -∗ False) ∗ Map m h
+ end ⟩⟩⟩.
+ Proof using Comparable_timeless.
+ iModIntro; iIntros (Φ) "(HM&#Heq&Hcompn) Hpost". rewrite /get {1}/Map.
+ wp_pures. iDestruct "HM" as (l r kvs -> ->) "[Hr Hc]".
+ wp_load.
+ (* we prepare the goal for the induction *)
+ iAssert (∀ o, contents kvs r -∗
+ match o with
+ | Some v => ∃ n' : val, ⌜to_map kvs !! n' = Some v⌠∗ Q n' n
+ | None => (∀ n', ⌜ n' ∈ dom (gset val) (to_map kvs) ⌠-∗ Q n' n -∗ False)
+ end -∗ Φ (embed o))%I with "[Hr Hpost]" as "Hpost".
+ { iIntros (o) "H1 H2". iApply "Hpost". destruct o.
+ - iDestruct "H2" as (n') "(?&?)".
+ iExists n'. iFrame. iExists l, r, kvs; iFrame; done.
+ - iFrame. iExists l, r, kvs; iFrame; done.
+ }
+ wp_pure _. iInduction kvs as [|[k n'] kvs] "IH" forall (r) "Hc"; simpl.
+ - wp_pures. wp_load. wp_pures.
+ iApply ("Hpost" $! None with "[$]").
+ iIntros (? Hin) "_". iPureIntro. set_solver.
+ - iDestruct "Hc" as (l') "[Hcompk [Hr Hc]]". wp_pures.
+ wp_load. wp_pures.
+ wp_bind (eq k n).
+ wp_apply ("Heq" with "[$Hcompk $Hcompn]").
+ iIntros (b) "(Hcompk&Hcompn&Hif)".
+ destruct b.
+ + wp_pures. subst.
+ iApply ("Hpost" $! (Some n') with "[Hcompk Hr Hc]").
+ { iExists _; iFrame. }
+ iExists k. rewrite lookup_insert.
+ eauto.
+ + wp_pure _. iApply ("IH" $! l' with "[$] [Hpost Hr Hcompk Hif] Hc").
+ iIntros (o) "Hc H". iApply ("Hpost" with "[Hr Hcompk Hc] [H Hif]").
+ { iExists _. iFrame. }
+ { destruct o.
+ * iDestruct "H" as (k') "(Heq'&HQ)".
+ iAssert (⌜k' ≠kâŒ)%I with "[-]" as %Hneq.
+ { iIntros (->). by iApply "Hif". }
+ iExists k'. rewrite lookup_insert_ne //. iFrame.
+ * iIntros (? Hin) "HQ".
+ set_unfold in Hin. destruct Hin as [->|Hin].
+ + by iApply "Hif".
+ + by iApply "H".
+ }
+ Qed.
+
+ Lemma set_spec h m (n k: val) :
+ ⊢ ⟨⟨⟨ Map m h ∗ Comparable k ⟩⟩⟩ set m k n ⟨⟨⟨ RET #(); Map m (<[k := n]> h) ⟩⟩⟩.
+ Proof.
+ iModIntro; iIntros (Φ) "(HM&Hcomp) Hpost". rewrite /set /Map.
+ wp_pures. iDestruct "HM" as (l r kvs -> ->) "[Hr Hc]".
+ wp_load. wp_alloc r' as "Hr'". wp_store.
+ iApply "Hpost". iExists l, r', ((k, n) :: kvs); simpl; iFrame; repeat iSplit; auto.
+ iExists r. iFrame.
+ Qed.
+
+End map_simple.
+
+
+Section memoization_functions.
+ Definition memoize: val :=
+ λ: "eq" "f",
+ let: "h" := map #() in
+ λ: "a",
+ match: get "h" "eq" "a" with
+ NONE => let: "y" := "f" "a" in set "h" "a" "y";; "y"
+ | SOME "y" => "y"
+ end.
+
+
+ Definition mem_rec: val :=
+ λ: "eq" "F",
+ let: "h" := map #() in
+ rec: "mem_rec" "a" :=
+ match: get "h" "eq" "a" with
+ NONE =>
+ let: "y" := "F" "mem_rec" "a" in
+ set "h" "a" "y";; "y"
+ | SOME "y" => "y"
+ end.
+End memoization_functions.
+
+
+
+
+
+Section timeless_memoization.
+ Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
+
+
+ Implicit Types (c: nat).
+ Implicit Types (f g m v: val).
+ Implicit Types (e: expr).
+ Implicit Types (h: gmap val val).
+
+
+ Variable (R: expr → val → iProp Σ).
+ Variable (Pre Post: val → val → iProp Σ).
+ Variable (Comparable: val → iProp Σ).
+ Variable (Eq: val → val → iProp Σ).
+ Context `{TL: !∀ e v, Timeless (R e v)}.
+ Context `{TLPost: !∀ v v', Timeless (Post v v')}.
+ Context `{PPre: !∀ v v', Persistent (Pre v v')}.
+ Context `{PPost: !∀ v v', Persistent (Post v v')}.
+ Context `{PEq: !∀ v v', Persistent (Eq v v')}.
+ Context `{Comparable_timeless: ∀ v, Timeless (Comparable v)}.
+ Variable (Pre_Comparable : ∀ v v', Pre v v' -∗ Comparable v).
+ Variable (Pre_Eq_Proper: ∀ v1 v1' v2, Eq v1 v1' -∗ Pre v1' v2 -∗ Pre v1 v2).
+
+ (* we allow arbitrary stutter *)
+ Definition eval e v := (∀ K, src (fill K e) -∗ src_update ⊤ (src (fill K v)))%I.
+ Definition mem_inv (m f: val) : iProp Σ :=
+ (∃ h, Map Comparable m h ∗
+ [∗ map] k ↦ v ∈ h, □ (∀ k', Pre k k' -∗ ∃ v', □ R (f (of_val k')) v' ∗ Post v v'))%I.
+
+ Definition implements (g: val) (f: val) : iProp Σ :=
+ (□ ∀ x x' K,
+ Pre x x' -∗
+ src (fill K (f x')) -∗
+ SEQ (g x) ⟨⟨v, ∃ v': val, Post v v' ∗ src (fill K v') ∗
+ □ (∀ x', Pre x x' -∗ ∃ v', □ R (f x') v' ∗ Post v v') ⟩⟩)%I.
+
+
+ Lemma memoization_core (eq: val) (f: val) e (n n' : val) m K :
+ SEQ e ⟨⟨ h, implements h f ⟩⟩ ∗
+ se_inv refN (mem_inv m f) ∗
+ □ (∀ e v, R e v -∗ eval e v) ∗
+ Pre n n' ∗
+ eqfun Comparable eq Eq ∗
+ src (fill K (f n')) ⊢
+ SEQ (match: get m eq n with
+ NONE => let: "y" := e n in set m n "y";; "y"
+ | SOME "y" => "y"
+ end) ⟨⟨v, ∃ v': val, Post v v' ∗ src (fill K v') ∗ □ (∀ n', Pre n n' -∗ ∃ v', □ R (f n') v' ∗ Post v v') ⟩⟩.
+ Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper R SI
+ Seq TL TLPost Σ.
+ iIntros "(Spec & #I & #IEval & #HPre & #Heqfun & Hsrc) Hna".
+ (* we open the timeless invariant for the get *)
+ iMod (na_inv_acc_open_timeless with "I Hna") as "(Hc & Hna & Hclose)"; auto.
+ iDestruct "Hc" as (h) "(HM & #Hupd)".
+ wp_bind (get m eq n). wp_apply (get_spec with "[$HM $Heqfun]").
+ { by iApply Pre_Comparable. }
+ iIntros (o) "HM".
+ destruct o as [k|] eqn: Heq.
+ - (* we have stored this result before *)
+ iDestruct "HM" as (n0 Hlookup) "(#Heq&HM)".
+ iDestruct (big_sepM_lookup with "Hupd") as "#Hk"; first done.
+ iDestruct (Pre_Eq_Proper with "[$] [$]") as "#HPre'".
+ iDestruct ("Hk" with "[$]") as (?) "(#HR&#HP)".
+ iApply (rwp_weaken with "[-Hsrc] [Hsrc]"); first done; last by iApply "IEval".
+ iIntros "Hsrc".
+ iApply fupd_rwp. iMod ("Hclose" with "[HM $Hna]") as "Hna".
+ { iNext. iExists h. by iFrame. }
+ iModIntro. wp_pures.
+ iFrame. iExists _. iFrame "# ∗".
+ iIntros "!>" (n'') "HPre''".
+ iApply "Hk". iApply (Pre_Eq_Proper with "[$] [$]").
+ - (* we close the invariant again for the recursive call *)
+ iDestruct "HM" as "(Hnin&HM)".
+ iMod ("Hclose" with "[HM $Hna]") as "Hna".
+ { iNext. iExists _. iFrame "# ∗". }
+ wp_pures. wp_bind e.
+ iApply (rwp_strong_mono with "[Spec Hna]");[eauto..| by iApply "Spec" |].
+ iIntros (g) "[Hna Hres] !>"; simpl.
+ iSpecialize ("Hres" with "HPre Hsrc Hna").
+ wp_bind (g _). iApply (rwp_wand with "Hres []").
+ iIntros (v) "[Hna Hres]". iDestruct "Hres" as (k) "(#HPost & Hsrc & #Hk)".
+ iMod (na_inv_acc_open_timeless with "I Hna") as "(Hc & Hna & Hclose)"; auto.
+ iDestruct "Hc" as (h2) "(HM & #Hupd')".
+ wp_pures. wp_apply (set_spec with "[$HM]").
+ { by iApply Pre_Comparable. }
+ iIntros "HM".
+ iApply fupd_rwp. iMod ("Hclose" with "[HM $Hna]") as "Hna".
+ { iNext. iExists (<[n:=_]> h2). iFrame.
+ iApply big_sepM_insert_2; simpl; auto.
+ }
+ iModIntro. wp_pures. iFrame.
+ iExists k. iFrame. iFrame "#".
+ Qed.
+
+
+ Lemma memoize_spec eq (f g: val):
+ eqfun Comparable eq Eq ∗
+ implements g f ∗
+ □ (∀ (e : expr) (v : val), R e v -∗ eval e v)
+ ⊢ SEQ (memoize eq g) ⟨⟨ h, implements h f ⟩⟩.
+ Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper R SI
+ Seq TL TLPost Σ.
+ iIntros "[#Heq [#H #R]] Hna". rewrite /memoize. wp_pures. iFrame.
+ wp_apply map_spec; first done. iIntros (m) "Hm".
+ iMod (na_inv_alloc seqG_name ⊤ refN (mem_inv m f) with "[Hm]") as "#IM".
+ { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
+ wp_pures. iFrame.
+
+ iModIntro; iIntros (n n' K) "#HPre Hsrc Hna".
+ wp_pure _.
+ iDestruct (Pre_Comparable with "HPre") as "Hcomp".
+ iApply (memoization_core with "[-Hna] [$Hna]").
+ iFrame "IM Hsrc R HPre Heq". iIntros "Hna". wp_value_head. iFrame.
+ iApply "H".
+ Qed.
+
+ Lemma mem_rec_spec eq (F f: val):
+ eqfun Comparable eq Eq ∗
+ (□ ∀ g, ▷ implements g f -∗ SEQ (F g) ⟨⟨h, implements h f⟩⟩) ∗
+ □ (∀ (e : expr) (v : val), R e v -∗ eval e v) ⊢
+ SEQ (mem_rec eq F) ⟨⟨ h, implements h f ⟩⟩.
+ Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper R SI
+ Seq TL TLPost Σ.
+ iIntros "[#Heq [#H #R]] Hna". rewrite /mem_rec. wp_pures. iFrame.
+ wp_apply map_spec; first done. iIntros (m) "Hm".
+ iMod (na_inv_alloc seqG_name ⊤ refN (mem_inv m f) with "[Hm]") as "#IM".
+ { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
+ wp_pures. iFrame.
+
+ iLöb as "IH". iModIntro. iIntros (n n' K) "#HPre Hsrc Hna".
+ wp_pure _.
+ iDestruct (Pre_Comparable with "HPre") as "Hcomp".
+ iApply (memoization_core with "[-Hna] [$Hna]").
+ iFrame "IM Hsrc R HPre Heq". iApply "H". iApply "IH".
+ Qed.
+
+End timeless_memoization.
+
+Section pure_nat_memoization.
+ Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
+
+
+ Implicit Types (c: nat).
+ Implicit Types (f g m v: val).
+ Implicit Types (e: expr).
+ Implicit Types (h: gmap val val).
+
+ Definition natRel (v1 v2: val) : iProp Σ :=
+ (∃ n : nat, ⌜ v1 = #n ∧ v2 = #n âŒ)%I.
+
+ Lemma lookup_O {X: Type} (l: list X) (x: X):
+ l !! O = Some x →
+ ∃ l', l = x :: l'.
+ Proof.
+ destruct l as [| a l']; rewrite ?lookup_nil; try congruence => //=.
+ rewrite /=. intros. exists l'. congruence.
+ Qed.
+
+ Definition execV (e: expr) (v: val) : iProp Σ := (⌜exec e vâŒ)%I.
+
+ Lemma pure_exec_exec e1 e2 n φ: PureExec φ (S n) e1 e2 → φ → exec e1 e2.
+ Proof.
+ intros HP Hφ. specialize (HP Hφ); remember (S n) as m; revert n Heqm.
+ induction HP as [|n e1 e2 e3 Hstep Hsteps]; first naive_solver.
+ injection 1 as <-. destruct n as [|n].
+ - inversion Hsteps; subst. eapply tc_once, Hstep.
+ - eapply tc_l; naive_solver.
+ Qed.
+
+ Lemma exec_frame e1 e2 K: exec e1 e2 → exec (fill K e1) (fill K e2).
+ Proof.
+ induction 1.
+ - eapply tc_once, pure_step_ctx; eauto. apply _.
+ - etrans; eauto.
+ eapply tc_once, pure_step_ctx; eauto. apply _.
+ Qed.
+
+ Lemma exec_src_update e1 e2 j E: exec e1 e2 → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
+ Proof.
+ induction 1.
+ - by apply step_pure.
+ - iIntros "H". iApply src_update_bind. iSplitL.
+ + iApply step_pure; eauto.
+ + iApply IHtc.
+ Qed.
+
+ Lemma rtc_r_or_tc {X: Type} (R: relation X) x y:
+ rtc R x y → x = y ∨ tc R x y.
+ Proof.
+ induction 1.
+ - by left.
+ - right. destruct IHrtc.
+ * subst. by apply tc_once.
+ * eapply tc_l; eauto.
+ Qed.
+
+ Definition natfun_refines (g: val) (f: val) : iProp Σ :=
+ (□ ∀ (n : nat) K,
+ src (fill K (f #n)) -∗
+ SEQ (g #n) ⟨⟨v, ∃ n': nat, ⌜ v = #n' ⌠∗ src (fill K v) ⟩⟩)%I.
+
+ Definition natfun_pure (f: val) :=
+ ∀ (n1 n2 : nat) tp1 tp2 σ1 σ2 K,
+ rtc erased_step (fill K (f #n1) :: tp1, σ1) (fill K (#n2) :: tp2, σ2) →
+ (∀ K', rtc pure_step (fill K' (f #n1)) (fill K' (#n2))).
+
+ Lemma natfun_mem_rec_spec (F f: val):
+ natfun_pure f →
+ (□ ∀ g, ▷ natfun_refines g f -∗ SEQ (F g) ⟨⟨h, natfun_refines h f⟩⟩) ⊢
+ SEQ (mem_rec eq_heaplang F) ⟨⟨ h, natfun_refines h f ⟩⟩.
+ Proof.
+ iIntros (Hpure) "#Href".
+ iIntros "Hna".
+ iPoseProof (mem_rec_spec
+ (λ e v, ∃ K (n1 n2: nat) tp1 tp2 σ1 σ2, ⌜ e = (f #n1) ∧ v = #n2 ∧
+ rtc erased_step (fill K (f #n1) :: tp1, σ1) (fill K (#n2) :: tp2, σ2)âŒ)%I
+ natRel natRel
+ (λ x, ⌜ val_is_unboxed x âŒ)%I (λ x1 x2, ⌜ x1 = x2 âŒ)%I
+ with "[] [$Hna]") as "H"; last first.
+ { iApply (rwp_mono with "H").
+ iIntros (?) "($&#H)". rewrite /implements /natfun_refines.
+ iIntros "!>" (n K) "Hsrc Hna".
+ iSpecialize ("H" $! #n with "[] [$] [$]"); first eauto.
+ iApply (rwp_mono with "H").
+ iIntros (?) "($&Hrel)".
+ iDestruct "Hrel" as (? (n'&->&->)) "(Hsrc&_)".
+ iExists n'. eauto.
+ }
+ { iSplit.
+ {
+ rewrite /eqfun. iIntros (??) "!>". iIntros (Φ) "(%&%) H".
+ rewrite /eq_heaplang. wp_pures.
+ wp_pure _; first (rewrite /vals_compare_safe; eauto).
+ iApply "H". iFrame "%". rewrite /bool_decide. destruct (decide_rel _); eauto.
+ }
+ iSplit.
+ * iModIntro.
+ iIntros (g) "Himpl Hna".
+ iSpecialize ("Href" $! g with "[Himpl] [$]").
+ {
+ iNext. iDestruct "Himpl" as "#Himpl". iIntros (n K) "!> H Hna".
+ iSpecialize ("Himpl" with "[] [$] [$]"); eauto.
+ iApply (rwp_wand with "Himpl").
+ iIntros (?) "($&H)".
+ iDestruct "H" as (? (n'&Heq1&Heq2)) "(Hsrc&_)".
+ subst; eauto.
+ }
+ iApply (rwp_wand with "Href").
+ iIntros (?) "($&#Hnatfun)".
+ rewrite /implements.
+ iIntros (?? K) "!> H Hsrc Hna".
+ iApply (rwp_weaken' with "[-Hsrc]"); first done; last first.
+ { iApply (src_log with "[$]"). }
+ iIntros "(Hsrc&Hlog)".
+ iDestruct "Hlog" as (tp σ i Hlookup) "#Hfmlist".
+ iDestruct "H" as %[n [-> ->]].
+ iSpecialize ("Hnatfun" with "[$] [$]").
+ iApply rwp_fupd'.
+ iApply (rwp_wand with "Hnatfun").
+ iIntros (?) "($&H)".
+ iIntros (???) "(Hinterp&Hstate)".
+ iDestruct "H" as (n' ?) "Hsrc".
+ iDestruct (src_get_trace' with "[$]") as "(Hsrc&Hinterp&Hin)".
+ iDestruct "Hin" as %(?&σ'&Hlookup'&Hrtc).
+ iFrame. iModIntro.
+ iExists #n'.
+ subst.
+ iSplit; first eauto.
+ iSplit; first eauto.
+ iModIntro. iIntros (?) "H".
+ iDestruct "H" as %(?&Heq1&Heq2); subst.
+ inversion Heq1 as [Heq].
+ iExists #n'. iSplit; eauto.
+ iModIntro.
+ apply lookup_O in Hlookup as (tp1'&->).
+ apply lookup_O in Hlookup' as (tp2'&->).
+ iExists _, _, _, _, _,
+ {| heap := fst σ; used_proph_id := {| mapset.mapset_car := snd σ |}|},
+ {| heap := fst σ'; used_proph_id := {| mapset.mapset_car := snd σ' |}|}.
+ iPureIntro.
+ split_and!; eauto. rewrite /to_cfg in Hrtc. destruct σ, σ'. eapply Hrtc.
+ * iModIntro. iIntros (e v) "H".
+ iDestruct "H" as (K n1 n2 tp1 tp2 σ1 σ2) "H".
+ iDestruct "H" as %(Heq1&Heq2&Hrtc).
+ rewrite /eval.
+ iIntros (K') "Hsrc".
+ iApply (exec_src_update with "[$]").
+ subst.
+ apply Hpure in Hrtc. specialize (Hrtc K').
+ apply rtc_r_or_tc in Hrtc as [Hr|Htc]; last eauto.
+ { apply fill_injective in Hr. congruence. }
+ }
+ { iIntros (??? -> Hrel). iPureIntro. destruct Hrel as (x&->&->). eauto. }
+ { iIntros (?? (n'&->&->)). eauto. }
+ Qed.
+
+End pure_nat_memoization.
+
+Section repeatable_refinements.
+ Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Sync: !inG Σ (authR (optionUR (exclR (gmapO val (valO SI)))))} `{Seq: !seqG Σ}.
+
+
+ Implicit Types (c: nat).
+ Implicit Types (f g m v: val).
+ Implicit Types (e: expr).
+ Implicit Types (h: gmap val val).
+ Variable (Pre Post: val → val → iProp Σ).
+ Variable (Comparable: val → iProp Σ).
+ Variable (Eq: val → val → iProp Σ).
+ Context `{PPre: !∀ v v', Persistent (Pre v v')}.
+ Context `{PPost: !∀ v v', Persistent (Post v v')}.
+ Context `{PEq: !∀ v v', Persistent (Eq v v')}.
+ Context `{Comparable_timeless: ∀ v, Timeless (Comparable v)}.
+ Variable (Pre_Comparable : ∀ v v', Pre v v' ={⊤}=∗ Comparable v).
+ Variable (Pre_Eq_Proper: ∀ v1 v1' v2, Eq v1 v1' -∗ Pre v1' v2 -∗ Pre v1 v2).
+
+
+ (* we allow arbitrary stutter *)
+ Definition mem_rec_tl_inv γ m : iProp Σ := (∃ h, Map Comparable m h ∗ own γ (◠Excl' h) ∗ $ (1%nat))%I.
+ Definition mem_rec_tf_inv γ (f: val) : iProp Σ :=
+ (∃ h, own γ (◯ Excl' h) ∗ [∗ map] k ↦ v ∈ h, □ (∀ k', Pre k k' -∗ ∃ v', □ eval (f k') v' ∗ Post v v'))%I.
+
+ Definition tf_implements (g: val) (f: val) : iProp Σ :=
+ (□ ∀ x x' c K,
+ Pre x x' -∗
+ src (fill K (f x')) -∗
+ SEQ (g x) ⟨⟨v, ∃ v': val, Post v v' ∗ $c ∗ src (fill K v') ∗
+ □ (∀ x', Pre x x' -∗ ∃ v', □ eval (f x') v' ∗ Post v v') ⟩⟩)%I.
+
+ Lemma tf_memoization_core `{FiniteBoundedExistential SI} (eq: val) (f: val) e c γ (n n' : val) m K :
+ SEQ e ⟨⟨ h, tf_implements h f ⟩⟩ ∗
+ se_inv (refN .@ "tl") (mem_rec_tl_inv γ m) ∗
+ se_inv (refN .@ "tf") (mem_rec_tf_inv γ f) ∗
+ Pre n n' ∗
+ eqfun Comparable eq Eq ∗
+ src (fill K (f n')) ⊢
+ SEQ (match: get m eq n with
+ NONE => let: "y" := e n in set m n "y";; "y"
+ | SOME "y" => "y"
+ end) ⟨⟨v, ∃ v': val, Post v v' ∗ $c ∗ src (fill K v') ∗ □ (∀ n', Pre n n' -∗ ∃ v', □ eval (f n') v' ∗ Post v v') ⟩⟩.
+ Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper SI
+ Seq Sync Σ.
+ iIntros "(Spec & #IM & #IC & #HPre & #Heqfun & Hsrc) Hna".
+ (* we open the timeless invariant for the get *)
+ iMod (na_inv_acc_open_timeless with "IM Hna") as "(Hc & Hna & Hclose1)"; auto.
+ iDestruct "Hc" as (h) "(HM & Hâ— & Hone)".
+ wp_bind (get m eq n).
+ iMod (Pre_Comparable with "HPre") as "HComp".
+ wp_apply (get_spec with "[$HM $Heqfun $HComp]").
+ iIntros (o) "HM".
+ destruct o as [k|] eqn: Heq.
+ - (* we have stored this result before *)
+ iDestruct "HM" as (n0 Hlookup) "(#Heq&HM)".
+ iMod (na_inv_acc_open with "IC Hna") as "Hcache"; auto; first solve_ndisj.
+ iApply (rwp_take_step with "[-Hone] [Hone]"); first done; last first.
+ { iApply step_stutter. iFrame. } iIntros "_".
+ iApply rswp_do_step. iNext; simpl. iDestruct "Hcache" as "(HsrcI & Hna & Hclose2)".
+ iDestruct "HsrcI" as (h') "[Hâ—¯ #Hupd]".
+ iDestruct (own_valid_2 with "Hâ— Hâ—¯") as % [->%Excl_included%leibniz_equiv _]%auth_both_valid.
+ wp_pure _.
+ iDestruct (big_sepM_lookup with "Hupd") as "#Hk"; first done.
+ iDestruct ("Hk" with "[]") as (?) "(#Heval&#HP)".
+ { iApply (Pre_Eq_Proper with "[$] [$]"). }
+ iApply (rwp_weaken with "[-Hsrc] [Hsrc]"); first done; last first.
+ { iApply (step_inv_alloc (S c) with "[] Hsrc"); iSplitL; first iApply "Heval".
+ iIntros "Hsrc". iExists (fill K _). iFrame. iPureIntro. intros ? % fill_injective; discriminate. }
+ rewrite nat_srcF_succ. iIntros "(Hsrc & Hone & Hc)".
+ iApply fupd_rwp. iMod ("Hclose2" with "[Hâ—¯ $Hna]") as "Hna".
+ { iNext. iExists h. iFrame. done. }
+ iMod ("Hclose1" with "[Hâ— HM $Hna Hone]") as "Hna".
+ { iNext. iExists h. iFrame. }
+ iModIntro. wp_pures.
+ iFrame. iExists _. iFrame "# ∗".
+ iIntros "!>" (n'') "HPre''".
+ iApply "Hk". iApply (Pre_Eq_Proper with "[$] [$]").
+ - (* we close the invariant again for the recursive call *)
+ iDestruct "HM" as "(Hnin&HM)".
+ iMod ("Hclose1" with "[Hâ— HM $Hna Hone]") as "Hna".
+ { iNext. iExists _. iFrame. }
+ wp_pures. wp_bind e.
+ iApply (rwp_strong_mono with "[Spec Hna]");[eauto..| by iApply "Spec" |].
+ iIntros (g) "[Hna Hres] !>"; simpl.
+ iSpecialize ("Hres" $! _ _ (S c) with "[$] Hsrc Hna").
+ wp_bind (g _). iApply (rwp_wand with "Hres []").
+ iIntros (v) "[Hna Hres]". iDestruct "Hres" as (k) "(HPost & Hcred & Hsrc & #Hk)".
+ rewrite nat_srcF_succ. iDestruct ("Hcred") as "[Hone Hcred]".
+ iMod (na_inv_acc_open_timeless with "IM Hna") as "(Hc & Hna & Hclose1)"; auto.
+ iDestruct "Hc" as (h2) "(HM & Hâ— & Hone')".
+ iMod (na_inv_acc_open with "IC Hna") as "Hcache"; auto; first solve_ndisj.
+ iApply (rwp_take_step with "[-Hone] [Hone]"); first done; last first.
+ { iApply step_stutter. iFrame. } iIntros "_".
+ iApply rswp_do_step. iNext; simpl. iDestruct "Hcache" as "(HsrcI & Hna & Hclose2)".
+ iDestruct "HsrcI" as (h2') "[Hâ—¯ #Hupd]".
+ iDestruct (own_valid_2 with "Hâ— Hâ—¯") as % [->%Excl_included%leibniz_equiv _]%auth_both_valid.
+ wp_pures.
+ iMod (Pre_Comparable with "HPre") as "HComp".
+ wp_apply (set_spec with "[$HM $HComp]").
+ iIntros "HM".
+ iMod (own_update_2 with "Hâ— Hâ—¯") as "[Hâ— Hâ—¯]".
+ { apply auth_update, option_local_update, (exclusive_local_update _ (Excl (<[n := v]> h2))); done. }
+ iApply fupd_rwp. iMod ("Hclose2" with "[Hâ—¯ $Hna]") as "Hna".
+ { iNext. iExists (<[n:=_]> h2). iFrame.
+ iApply big_sepM_insert_2; simpl; eauto. }
+ iMod ("Hclose1" with "[Hâ— HM $Hna Hone']") as "Hna".
+ { iNext. iExists _. iFrame. }
+ iModIntro. wp_pures. iFrame.
+ iExists k. iFrame. iFrame "#".
+ Qed.
+
+ Lemma tf_memoize_spec `{FiniteBoundedExistential SI} eq (f g: val):
+ eqfun Comparable eq Eq ∗
+ tf_implements g f ∗
+ $ (1%nat)
+ ⊢ SEQ (memoize eq g) ⟨⟨ h, tf_implements h f ⟩⟩.
+ Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper SI
+ Seq Sync Σ.
+ iIntros "(#Heq&#H&Hcred) Hna". rewrite /memoize. wp_pures. iFrame.
+ wp_apply map_spec; first done. iIntros (m) "Hm".
+ iMod (own_alloc (◠(Excl' ∅) ⋅ ◯ (Excl' ∅))) as (γ) "[H◠H◯]".
+ { apply auth_both_valid_2; done. }
+ iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tl") (mem_rec_tl_inv γ m) with "[H◠Hm Hcred]") as "#IM".
+ { iNext. iExists ∅. iFrame. }
+ iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tf") (mem_rec_tf_inv γ f) with "[H◯]") as "#IS".
+ { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
+ wp_pures. iFrame.
+ iIntros (n n' c K) "!> #HPre Hsrc Hna".
+ wp_pure _.
+ iDestruct (Pre_Comparable with "HPre") as "Hcomp".
+ iApply (tf_memoization_core with "[-Hna] [$Hna]").
+ iFrame "IM IS Hsrc HPre Heq". iIntros "Hna". wp_value_head. iFrame.
+ iApply "H".
+ Qed.
+
+ Lemma tf_mem_rec_spec `{FiniteBoundedExistential SI} eq (F f: val):
+ eqfun Comparable eq Eq ∗
+ (□ ∀ g, ▷ tf_implements g f -∗ SEQ (F g) ⟨⟨h, tf_implements h f⟩⟩) ∗ $ (1%nat) ⊢
+ SEQ (mem_rec eq F) ⟨⟨ h, tf_implements h f ⟩⟩.
+ Proof using Comparable Comparable_timeless Cred Eq Heap PEq PPost PPre Post Pre Pre_Comparable Pre_Eq_Proper SI
+ Seq Sync Σ.
+ iIntros "[#Heq [#HF Hcred]] Hna". rewrite /mem_rec. wp_pures. iFrame.
+ wp_apply map_spec; first done. iIntros (m) "Hm".
+ iMod (own_alloc (◠(Excl' ∅) ⋅ ◯ (Excl' ∅))) as (γ) "[H◠H◯]".
+ { apply auth_both_valid_2; done. }
+ iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tl") (mem_rec_tl_inv γ m) with "[H◠Hm Hcred]") as "#IM".
+ { iNext. iExists ∅. iFrame. }
+ iMod (na_inv_alloc seqG_name ⊤ (refN .@ "tf") (mem_rec_tf_inv γ f) with "[H◯]") as "#IS".
+ { iNext. iExists ∅. iFrame. rewrite big_sepM_empty; done. }
+ wp_pures. iFrame.
+
+ iLöb as "IH". iModIntro; iIntros (n n' c K) "#HPre Hsrc Hna".
+ wp_pure _.
+ iDestruct (Pre_Comparable with "HPre") as "Hcomp".
+ iApply (tf_memoization_core with "[-Hna] Hna").
+ iFrame "IM IS Hsrc HPre Heq". iApply "HF". iApply "IH".
+ Qed.
+
+End repeatable_refinements.
+
+
+Section fibonacci.
+ Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
+
+ (* we define the body to reduce the number of lemmas we need to prove*)
+ Definition Fib (fib : val) (n : expr): expr :=
+ if: n = #0 then #0
+ else if: n = #1 then #1
+ else
+ let: "n'" := n - #1 in
+ let: "n''" := n - #2 in
+ fib "n'" + fib "n''".
+
+
+ Lemma Fib_zero fib: exec (Fib fib #0) (#0).
+ Proof.
+ eapply pure_exec_exec.
+ - rewrite /Fib; pure_exec.
+ - repeat split; solve_vals_compare_safe.
+ Qed.
+
+ Lemma Fib_one fib: exec (Fib fib #1) (#1).
+ Proof.
+ eapply pure_exec_exec.
+ - rewrite /Fib; pure_exec.
+ - repeat split; solve_vals_compare_safe.
+ Qed.
+
+ Lemma Fib_rec fib n: exec (Fib fib #(S (S n))) ((fib #(S n)) + (fib #n))%E.
+ Proof.
+ eapply pure_exec_exec.
+ - rewrite /Fib; pure_exec.
+ rewrite bool_decide_eq_false_2; last (injection 1; lia).
+ pure_exec.
+ - repeat split; try solve_vals_compare_safe.
+ + rewrite /bin_op_eval //=. by replace (S (S n) - 1) with (S n: Z) by lia.
+ + rewrite /bin_op_eval //=. by replace (S (S n) - 2) with (n: Z) by lia.
+ Qed.
+
+ Definition fib : val :=
+ rec: "fib" "n" :=
+ if: "n" = #0 then #0
+ else if: "n" = #1 then #1
+ else
+ let: "n'" := "n" - #1 in
+ let: "n''" := "n" - #2 in
+ "fib" "n'" + "fib" "n''".
+
+ Lemma fib_Fib (v: val): exec (fib v) (Fib fib v).
+ Proof.
+ eapply pure_exec_exec.
+ - rewrite /Fib /fib; pure_exec.
+ - repeat split.
+ Qed.
+
+ Definition fib_template : val :=
+ λ: "fib" "n",
+ if: "n" = #0 then #0
+ else if: "n" = #1 then #1
+ else
+ let: "n'" := "n" - #1 in
+ let: "n''" := "n" - #2 in
+ "fib" "n'" + "fib" "n''".
+
+ Tactic Notation "exec_bind" open_constr(efoc) :=
+ match goal with
+ | [|- exec ?e1 ?e2] =>
+ src_bind_core e1 efoc ltac:(fun K e' => change (exec (fill K e') e2))
+ end.
+
+ Lemma fib_fundamental_core g K (n: nat):
+ (▷ implements execV natRel natRel g fib) ∗
+ src (fill K (fib #n)) ⊢
+ SEQ (Fib g #n) ⟨⟨v, ∃ m: nat, ⌜v = #m⌠∗ src (fill K #m) ∗ □ execV (fib #n) #m ⟩⟩.
+ Proof.
+ iIntros "[#IH Hsrc] Hna".
+ destruct n as [|[|n]]; (iApply (rwp_take_step with "[-Hsrc] [Hsrc]"); first done; last first).
+ - iApply exec_src_update; eauto. eapply exec_frame.
+ etrans; first apply fib_Fib. eapply Fib_zero.
+ - iIntros "Hsrc". iApply rswp_do_step. iNext. rewrite /Fib.
+ wp_pure _; first solve_vals_compare_safe. wp_pures. iFrame.
+ iExists 0%nat. iFrame. iSplitL; eauto.
+ iModIntro. iPureIntro. etrans; first apply fib_Fib. eapply Fib_zero.
+ - iApply exec_src_update; eauto. eapply exec_frame.
+ etrans; first apply fib_Fib. eapply Fib_one.
+ - iIntros "Hsrc". iApply rswp_do_step. iNext. rewrite /Fib.
+ wp_pure _; first solve_vals_compare_safe. wp_pures.
+ wp_pure _; first solve_vals_compare_safe. wp_pures.
+ iFrame. iExists 1%nat. iFrame. iSplitL; eauto.
+ iModIntro. iPureIntro.
+ etrans; first apply fib_Fib. eapply Fib_one.
+ - iApply exec_src_update; eauto. eapply exec_frame.
+ etrans; first apply fib_Fib. eapply Fib_rec.
+ - iIntros "Hsrc". iApply rswp_do_step. iNext. rewrite /Fib.
+ wp_pure _; first solve_vals_compare_safe. wp_pures.
+ wp_pure _; first solve_vals_compare_safe.
+ rewrite bool_decide_eq_false_2; last (injection 1; lia).
+ do 7 wp_pure _.
+ (* recursion for n *)
+ wp_bind (g _)%E. replace (S (S n) - 2) with (n: Z) by lia.
+ src_bind (fib #n) in "Hsrc".
+ iApply (rwp_wand with "[Hna Hsrc]").
+ { iApply ("IH" with "[] Hsrc Hna"); first eauto. }
+ iIntros (v) "[Hna H]". iDestruct "H" as (m) "(HPre & Hsrc & #Hev1)"; simpl.
+ iDestruct "HPre" as %[m' [Heq1 Heq2]]. subst.
+ (* recursion for (n + 1) *)
+ wp_bind (g _)%E. replace (S (S n) - 1) with (S n: Z) by lia.
+ src_bind (fib _) in "Hsrc".
+ iApply (rwp_wand with "[Hna Hsrc]").
+ { iApply ("IH" with "[] Hsrc Hna"). eauto. }
+ iIntros (v) "[Hna H]". iDestruct "H" as (v') "(HPre & Hsrc & #Hev2)"; simpl.
+ iDestruct "HPre" as %[m [Heq1 Heq2]]. subst.
+ iFrame. iApply (rwp_weaken with "[-Hsrc] [Hsrc]"); first done; last first.
+ { iApply (steps_pure_exec with "Hsrc"). reflexivity. }
+ simpl; iIntros "Hsrc"; wp_pure _.
+ replace (m + m') with ((m' + m)%nat: Z) by lia.
+ iExists (m' + m)%nat; iFrame; iSplitR; auto.
+ iModIntro.
+ iDestruct "Hev1" as % Hev1. iDestruct "Hev2" as % Hev2. iPureIntro.
+ etrans; first eapply fib_Fib.
+ etrans; first eapply Fib_rec.
+ edestruct Hev1 as (?&Hexec1&?&Heq1&?); eauto.
+ edestruct Hev2 as (?&Hexec2&?&Heq2&?); eauto; subst.
+ inversion Heq1; subst.
+ inversion Heq2; subst.
+ exec_bind (fib _); etrans; first eapply exec_frame; eauto; simpl.
+ exec_bind (fib _); etrans; first eapply exec_frame; eauto; simpl.
+ eapply pure_exec_exec. apply _.
+ rewrite /bin_op_eval. destruct (decide _) => //=.
+ repeat f_equal. lia.
+ Qed.
+
+ Lemma fib_sound:
+ ⊢ implements execV natRel natRel fib fib.
+ Proof.
+ iLöb as "IH".
+ iModIntro; iIntros (v v' K) "HPre Hsrc Hna".
+ iDestruct "HPre" as %[n [Heq1 Heq2]]. subst.
+ rewrite {4}/fib. wp_pure _.
+ fold fib. fold (Fib fib #n).
+ iApply rwp_mono; last first.
+ { iApply (fib_fundamental_core fib K n with "[$Hsrc $IH] Hna"). }
+ iIntros (v) "($&H)".
+ iDestruct "H" as (m ->) "(Hsrc&#Hexec)". iExists _. iFrame.
+ iSplitR; first eauto.
+ iModIntro. iIntros (x) "Hrel". iDestruct "Hrel" as %[? [-> ->]]. iExists _. iSplit; eauto.
+ Qed.
+
+ Lemma fib_template_sound g:
+ ▷ implements execV natRel natRel g fib ⊢ SEQ (fib_template g) ⟨⟨h, implements execV natRel natRel h fib⟩⟩.
+ Proof.
+ iIntros "#H Hna". rewrite /fib_template. wp_pures. iFrame.
+ iModIntro; iIntros (n n' K) "HPre Hsrc Hna".
+ wp_pure _. fold (Fib g n).
+ iDestruct "HPre" as %[n0 [-> ->]].
+ iApply rwp_mono; last first.
+ { by iApply (fib_fundamental_core g K n0 with "[$Hsrc] Hna"). }
+ iIntros (v) "($&H)".
+ iDestruct "H" as (m ->) "(Hsrc&#Hexec)". iExists _. iFrame.
+ iSplitR; first eauto.
+ iModIntro. iIntros (x) "Hrel". iDestruct "Hrel" as %[? [-> ->]]. iExists _. iSplit; eauto.
+ Qed.
+
+
+ (* memoized versions *)
+ Lemma fib_memoized: ⊢ SEQ (memoize eq_heaplang fib) ⟨⟨ h, implements execV natRel natRel h fib ⟩⟩.
+ Proof.
+ (* XXX: the iApply fails over typeclass resolution (?) if we don't do iStartProof *)
+ iStartProof.
+ iApply (memoize_spec _ _ _ (λ x, ⌜ val_is_unboxed x âŒ)%I (λ x1 x2, ⌜ x1 = x2 âŒ)%I);
+ [| | iSplit; [| iSplit]].
+ - iIntros (??) "H". iDestruct "H" as %[? [-> ->]]. eauto.
+ - iIntros (??? ->). auto.
+ - rewrite /eqfun. iIntros (??) "!>". iIntros (Φ) "(%&%) H".
+ rewrite /eq_heaplang. wp_pures.
+ wp_pure _; first (rewrite /vals_compare_safe; eauto).
+ iApply "H". iFrame "%". rewrite /bool_decide. destruct (decide_rel _); eauto.
+ - iApply fib_sound.
+ - iModIntro. iIntros (e v Hexec K).
+ iApply exec_src_update. apply exec_frame, Hexec.
+ Qed.
+
+ Lemma fib_deep_memoized: ⊢ SEQ (mem_rec eq_heaplang fib_template) ⟨⟨ h, implements execV natRel natRel h fib ⟩⟩.
+ Proof.
+ iStartProof.
+ iApply (mem_rec_spec _ _ _ (λ x, ⌜ val_is_unboxed x âŒ)%I (λ x1 x2, ⌜ x1 = x2 âŒ)%I);
+ [| | iSplit; [| iSplit]].
+ - iIntros (??) "H". iDestruct "H" as %[? [-> ->]]. eauto.
+ - iIntros (??? ->). auto.
+ - rewrite /eqfun. iIntros (??) "!>". iIntros (Φ) "(%&%) H".
+ rewrite /eq_heaplang. wp_pures.
+ wp_pure _; first (rewrite /vals_compare_safe; eauto).
+ iApply "H". iFrame "%". rewrite /bool_decide. destruct (decide_rel _); eauto.
+ - iModIntro. iIntros (g). iApply fib_template_sound.
+ - iModIntro. iIntros (e v Hexec K).
+ iApply exec_src_update. apply exec_frame, Hexec.
+ Qed.
+End fibonacci.
+
+Section levenshtein.
+ Context {SI: indexT} {A: Type} `{Σ: gFunctors SI} `{Heap: !rheapG Σ} `{Cred: !auth_sourceG Σ (natA SI)} `{Seq: !seqG Σ}.
+
+ Definition eqstr : val :=
+ rec: "eqstr" "s1" "s2" :=
+ let: "c1" := !"s1" in
+ let: "c2" := !"s2" in
+ if: "c1" = "c2" then
+ if: "c1" = #0 then
+ #true
+ else
+ "eqstr" ("s1" +â‚— #1) ("s2" +â‚— #1)
+ else
+ #false.
+
+ Definition Strlen (strlen : val) (l : expr): expr :=
+ let: "c" := !l in
+ if: "c" = #0 then #0
+ else
+ let: "r" := strlen (l +â‚— #1) in
+ #1 + "r".
+
+ Definition strlen_template : val :=
+ λ: "strlen" "l",
+ let: "c" := !"l" in
+ if: "c" = #0 then #0
+ else
+ let: "r" := "strlen" ("l" +â‚— #1) in
+ #1 + "r".
+
+ Definition strlen : val :=
+ rec: "strlen" "l" := strlen_template "strlen" "l".
+
+ Definition min2 : val :=
+ λ: "n1" "n2",
+ if: "n1" ≤ "n2" then "n1" else "n2".
+
+ Definition min3 : val :=
+ λ: "n1" "n2" "n3",
+ min2 (min2 "n1" "n2") ("n3").
+
+ (*
+ Fixpoint gallina_lev (s1 : list nat) (s2 : list nat) : nat :=
+ match s1 with
+ | [] => length s2
+ | c1 :: s1' =>
+ match s2 with
+ | [] => length s1
+ | c2 :: s2' =>
+ if decide (c1 = c2) then
+ gallina_lev s1' s2'
+ else
+ let r1 := gallina_lev s1 s2' in
+ let r2 := gallina_lev s1' s2 in
+ let r3 := gallina_lev s1' s2' in
+ (1 + min (min r1 r2) r3)%nat
+ end
+ end.
+ *)
+
+ Definition Lev (strlen : val) (lev : val) (s12 : expr): expr :=
+ let: "s1" := Fst s12 in
+ let: "s2" := Snd s12 in
+ let: "c1" := !"s1" in
+ if: "c1" = #0 then strlen "s2" else
+ let: "c2" := !"s2" in
+ if: "c2" = #0 then strlen "s1" else
+ if: "c1" = "c2" then lev ("s1" +â‚— #1, "s2" +â‚— #1)
+ else
+ let: "r1" := lev ("s1", "s2" +â‚— #1) in
+ let: "r2" := lev ("s1" +â‚— #1, "s2") in
+ let: "r3" := lev ("s1" +â‚— #1, "s2" +â‚— #1) in
+ #1 + min3 "r1" "r2" "r3".
+
+ Definition lev_template : val :=
+ λ: "strlen" "lev" "s12",
+ let: "s1" := Fst "s12" in
+ let: "s2" := Snd "s12" in
+ let: "c1" := !"s1" in
+ if: "c1" = #0 then "strlen" "s2" else
+ let: "c2" := !"s2" in
+ if: "c2" = #0 then "strlen" "s1" else
+ if: "c1" = "c2" then "lev" ("s1" +â‚— #1,"s2" +â‚— #1)
+ else
+ let: "r1" := "lev" ("s1", "s2" +â‚— #1) in
+ let: "r2" := "lev" ("s1" +â‚— #1, "s2") in
+ let: "r3" := "lev" ("s1" +â‚— #1, "s2" +â‚— #1) in
+ #1 + min3 "r1" "r2" "r3".
+
+ Definition lev_template' (slen : expr) : val :=
+ λ: "lev" "s12",
+ let: "s1" := Fst "s12" in
+ let: "s2" := Snd "s12" in
+ let: "c1" := !"s1" in
+ if: "c1" = #0 then slen "s2" else
+ let: "c2" := !"s2" in
+ if: "c2" = #0 then slen "s1" else
+ if: "c1" = "c2" then "lev" ("s1" +â‚— #1,"s2" +â‚— #1)
+ else
+ let: "r1" := "lev" ("s1", "s2" +â‚— #1) in
+ let: "r2" := "lev" ("s1" +â‚— #1, "s2") in
+ let: "r3" := "lev" ("s1" +â‚— #1, "s2" +â‚— #1) in
+ #1 + min3 "r1" "r2" "r3".
+
+ Definition lev : val :=
+ rec: "lev" "s12" := lev_template strlen "lev" "s12".
+
+ Notation exec := (tc (@pure_step heap_lang)).
+
+ Tactic Notation "exec_bind" open_constr(efoc) :=
+ match goal with
+ | [|- exec ?e1 ?e2] =>
+ src_bind_core e1 efoc ltac:(fun K e' => change (exec (fill K e') e2))
+ end.
+
+ Lemma strlen_Strlen (v: val): exec (strlen v) (Strlen strlen v).
+ Proof.
+ eapply pure_exec_exec.
+ - rewrite /Strlen /strlen /strlen_template; repeat pure_exec.
+ - repeat split.
+ Qed.
+
+ Lemma lev_Lev (v: val): exec (lev v) (Lev strlen lev v).
+ Proof.
+ eapply pure_exec_exec.
+ - rewrite /Lev /lev /lev_template; repeat pure_exec.
+ - repeat split.
+ Qed.
+
+ (* C-style null terminated strings *)
+
+ Fixpoint string_is (l: loc) (s: list nat) :=
+ match s with
+ | [] => (∃ q, l ↦{q} #0)
+ | n1 :: s' => ⌜ n1 ≠O ⌠∗ (∃ q, l ↦{q} #n1) ∗ string_is (l +ₗ 1) s'
+ end%I.
+
+ Fixpoint src_string_is (l: loc) (s: list nat) :=
+ match s with
+ | [] => (∃ q, l ↦s{q} #0)
+ | n1 :: s' => ⌜ n1 ≠O ⌠∗ (∃ q, l ↦s{q} #n1) ∗ src_string_is (l +ₗ 1) s'
+ end%I.
+
+ Lemma string_is_dup l s :
+ string_is l s -∗ string_is l s ∗ string_is l s.
+ Proof.
+ iInduction s as [| n s] "IH" forall (l).
+ - iDestruct 1 as (q) "H". iDestruct "H" as "(H1&H2)".
+ iSplitL "H1"; iExists _; iFrame.
+ - simpl string_is. iDestruct 1 as (Hneq) "(H&Htl)".
+ iDestruct "H" as (q) "(H1&H2)".
+ iDestruct ("IH" with "Htl") as "(Htl1&Htl2)".
+ iSplitL "H1 Htl1"; iFrame "% ∗"; iExists _; iFrame.
+ Qed.
+
+ Instance string_is_timeless l s : Timeless (string_is l s).
+ Proof. revert l. induction s; apply _. Qed.
+
+ Lemma src_string_is_dup l s :
+ src_string_is l s -∗ src_string_is l s ∗ src_string_is l s.
+ Proof.
+ iInduction s as [| n s] "IH" forall (l).
+ - iDestruct 1 as (q) "H". iDestruct "H" as "(H1&H2)".
+ iSplitL "H1"; iExists _; iFrame.
+ - simpl src_string_is. iDestruct 1 as (Hneq) "(H&Htl)".
+ iDestruct "H" as (q) "(H1&H2)".
+ iDestruct ("IH" with "Htl") as "(Htl1&Htl2)".
+ iSplitL "H1 Htl1"; iFrame "% ∗"; iExists _; iFrame.
+ Qed.
+
+ Instance src_string_is_timeless l s : Timeless (src_string_is l s).
+ Proof. revert l. induction s; apply _. Qed.
+
+ Definition stringRel_is (v1 v2: val) (s: list nat) : iProp Σ :=
+ (∃ (l1 l2 : loc), ⌜ v1 = #l1 ∧ v2 = #l2 ⌠∗ string_is l1 s ∗ src_string_is l2 s)%I.
+
+ Definition strN := nroot.@"str".
+
+ Definition imm_stringRel (v1 v2: val) : iProp Σ :=
+ (∃ s, inv strN (stringRel_is v1 v2 s))%I.
+
+ Lemma stringRel_inv_acc (v1 v2 : val) s :
+ inv strN (stringRel_is v1 v2 s) ={⊤}=∗
+ stringRel_is v1 v2 s.
+ Proof.
+ iIntros "Hinv". iInv "Hinv" as ">H" "Hclo".
+ iDestruct "H" as (?? (Heq1&Heq2)) "(His1&His2)".
+ iDestruct (string_is_dup with "His1") as "(His1&His1')".
+ iDestruct (src_string_is_dup with "His2") as "(His2&His2')".
+ iMod ("Hclo" with "[His1' His2']"); iModIntro; iExists _, _; iFrame; eauto.
+ Qed.
+
+ Definition pairRel Pa Pb (v1 v2 : val) : iProp Σ :=
+ (∃ v1a v1b v2a v2b, ⌜ v1 = PairV v1a v1b⌠∗ ⌜v2 = PairV v2a v2b ⌠∗ Pa v1a v2a ∗ Pb v1b v2b)%I.
+
+ Definition pair_imm_stringRel := pairRel imm_stringRel imm_stringRel.
+
+ Lemma rwp_strlen l s:
+ string_is l s -∗
+ RWP (strlen #l) ⟨⟨v, ⌜v = #(length s)⌠⟩⟩.
+ Proof.
+ iIntros "Hstr".
+ iInduction s as [| n s] "IH" forall (l).
+ - rewrite /strlen/strlen_template. wp_pures.
+ iDestruct "Hstr" as (?) "H".
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
+ wp_pures. iFrame. eauto.
+ - rewrite /strlen/strlen_template. wp_pures. simpl string_is.
+ iDestruct "Hstr" as (?) "(H1&Htl)".
+ iDestruct "H1" as (?) "Hl".
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
+ case_bool_decide; wp_pure _; eauto.
+ { exfalso. eapply H. inversion H1. lia. }
+
+ wp_bind ((rec: "strlen" "l" :=
+ (λ: "strlen" "l",
+ let: "c" := ! "l" in
+ if: "c" = #0 then #0 else let: "r" := "strlen" ("l" +â‚— #1) in #1 + "r")%V "strlen" "l")%V
+ (#l +â‚— #1))%E.
+ wp_pure _.
+ iApply (rwp_wand with "[Htl]").
+ { iApply ("IH" with "[$]"). }
+ iIntros (v) "%". subst. wp_pures. iFrame. iPureIntro.
+ do 2 f_equal. simpl. lia.
+ Qed.
+
+ Lemma eval_strlen l s:
+ src_string_is l s -∗
+ eval (strlen #l) #(length s).
+ Proof.
+ iIntros "Hstr" (K) "H".
+ iInduction s as [| n s] "IH" forall (K l).
+ - rewrite /strlen/strlen_template.
+ do 4 src_pure _ in "H".
+ iDestruct "Hstr" as (?) "Hstr".
+ src_load in "H". do 4 src_pure _ in "H". iApply weak_src_update_return. by iFrame.
+ - rewrite /strlen/strlen_template. do 4 src_pure _ in "H". simpl src_string_is.
+ iDestruct "Hstr" as (?) "(H1&Htl)".
+ iDestruct "H1" as (?) "Hl".
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ case_bool_decide; src_pure _ in "H"; eauto.
+ { exfalso. eapply H. inversion H1. lia. }
+ src_pure _ in "H".
+ src_bind ((rec: "strlen" "l" :=
+ (λ: "strlen" "l",
+ let: "c" := ! "l" in
+ if: "c" = #0 then #0 else let: "r" := "strlen" ("l" +â‚— #1) in #1 + "r")%V "strlen"
+ "l")%V
+ #(l +â‚— 1))%E in "H".
+ iDestruct ("IH" with "Htl H") as "H".
+ simpl fill.
+ iApply src_update_weak_src_update.
+ iApply weak_src_update_bind_r. iFrame.
+ iIntros "H".
+ do 3 src_pure _ in "H".
+ iApply weak_src_update_return.
+ replace (S (length s) : Z)%Z with (1 + length s)%Z; first by iFrame.
+ rewrite Nat2Z.inj_succ //=. lia.
+ Qed.
+
+ Lemma stringRel_is_tl (l1 l2 : loc) n s:
+ stringRel_is #l1 #l2 (n :: s) -∗
+ stringRel_is #(l1 +ₗ 1) #(l2 +ₗ 1) s ∗
+ (stringRel_is #(l1 +ₗ 1) #(l2 +ₗ 1) s -∗ stringRel_is #l1 #l2 (n :: s)).
+ Proof.
+ rewrite /stringRel_is.
+ iDestruct 1 as (?? (Heq1&Heq2)) "(H1&H2)".
+ inversion Heq1; subst.
+ inversion Heq2; subst.
+ simpl string_is. simpl src_string_is.
+ iDestruct "H1" as (?) "(H1&Htl1)".
+ iDestruct "H2" as (?) "(H2&Htl2)".
+ iSplitL "Htl1 Htl2".
+ { iExists _, _. iSplit; first eauto. iFrame. }
+ iIntros "H". iExists _, _. iSplit; first eauto.
+ iDestruct "H" as (?? (Heq1'&Heq2')) "(Htl1&Htl2)".
+ iSplitL "H1 Htl1".
+ { iSplit; eauto. iFrame. inversion Heq1'. subst. eauto. }
+ { iSplit; eauto. iFrame. inversion Heq2'. subst. eauto. }
+ Qed.
+
+ Lemma inv_stringRel_is_tl N (l1 l2 : loc) n s:
+ inv N (stringRel_is #l1 #l2 (n :: s)) -∗
+ inv N (stringRel_is #(l1 +â‚— 1) #(l2 +â‚— 1) s).
+ Proof.
+ iIntros "Hinv". iApply (inv_alter_timeless with "Hinv").
+ iIntros "!> H1".
+ iDestruct (stringRel_is_tl with "H1") as "($&$)".
+ Qed.
+
+ Lemma min2_spec (n1 n2: nat) :
+ ⊢ ⟨⟨⟨ True ⟩⟩⟩ min2 #n1 #n2 ⟨⟨⟨ RET #(min n1 n2) ; True ⟩⟩⟩.
+ Proof.
+ iIntros "!>" (Φ) "_ HΦ".
+ rewrite /min2. wp_pures.
+ case_bool_decide; wp_pures.
+ - rewrite ->min_l by lia. by iApply "HΦ".
+ - rewrite ->min_r by lia. by iApply "HΦ".
+ Qed.
+
+ Lemma min3_spec (n1 n2 n3: nat) :
+ ⊢ ⟨⟨⟨ True ⟩⟩⟩ min3 #n1 #n2 #n3 ⟨⟨⟨ RET #(min (min n1 n2) n3) ; True ⟩⟩⟩.
+ Proof.
+ iIntros "!>" (Φ) "_ HΦ".
+ rewrite /min3. wp_pures.
+ repeat (wp_apply min2_spec; auto; iIntros "_").
+ Qed.
+
+ Lemma eval_min2 (n1 n2: nat) :
+ eval (min2 #n1 #n2) #(min n1 n2).
+ Proof.
+ rewrite /eval. iIntros (K) "Hsrc".
+ rewrite /min2. do 4 src_pure _ in "Hsrc".
+ case_bool_decide; do 1 src_pure _ in "Hsrc".
+ - rewrite ->min_l by lia. by iApply weak_src_update_return.
+ - rewrite ->min_r by lia. by iApply weak_src_update_return.
+ Qed.
+
+ Lemma eval_min3 (n1 n2 n3: nat) :
+ eval (min3 #n1 #n2 #n3) #(min (min n1 n2) n3).
+ Proof.
+ rewrite /eval. iIntros (K) "Hsrc".
+ rewrite /min3/min2. do 9 src_pure _ in "Hsrc".
+ case_bool_decide; do 1 src_pure _ in "Hsrc".
+ - do 4 src_pure _ in "Hsrc".
+ case_bool_decide; do 1 src_pure _ in "Hsrc".
+ * do 2 rewrite ->min_l by lia. by iApply weak_src_update_return.
+ * rewrite ->min_r by lia. by iApply weak_src_update_return.
+ - do 4 src_pure _ in "Hsrc".
+ case_bool_decide; do 1 src_pure _ in "Hsrc".
+ * rewrite ->min_l by lia. rewrite ->min_r by lia. by iApply weak_src_update_return.
+ * rewrite ->min_r by lia. by iApply weak_src_update_return.
+ Qed.
+
+ Lemma string_is_functional va s s' :
+ string_is va s -∗
+ string_is va s' -∗
+ ⌜s = s'âŒ.
+ Proof.
+ iIntros "Hrel1 Hrel2".
+ iInduction s as [| n s] "IH" forall (va s').
+ { destruct s'; first auto.
+ simpl string_is.
+ iDestruct "Hrel1" as (?) "Hva".
+ iDestruct "Hrel2" as (Hneq) "(Hva'&?)".
+ iDestruct "Hva'" as (?) "Hva'".
+ iDestruct (mapsto_agree with "[$] [$]") as %Hfalse.
+ iPureIntro. exfalso. inversion Hfalse. lia. }
+ destruct s'; first auto.
+ - simpl string_is.
+ iDestruct "Hrel1" as (Hneq) "(Hva&?)".
+ iDestruct "Hva" as (?) "Hva".
+ iDestruct "Hrel2" as (?) "Hva'".
+ iDestruct (mapsto_agree with "[$] [$]") as %Hfalse.
+ iPureIntro. exfalso. inversion Hfalse. lia.
+ - simpl string_is.
+ iDestruct "Hrel1" as (Hneq) "(Hva&?)".
+ iDestruct "Hva" as (?) "Hva".
+ iDestruct "Hrel2" as (Hneq') "(Hva'&?)".
+ iDestruct "Hva'" as (?) "Hva'".
+ iDestruct (mapsto_agree with "[$] [$]") as %Heq1.
+ iDestruct ("IH" with "[$] [$]") as %Heq2.
+ iPureIntro. subst. inversion Heq1; subst. f_equal; lia.
+ Qed.
+
+ Lemma stringRel_is_functional va vb vb' s s' :
+ stringRel_is va vb s -∗
+ stringRel_is va vb' s' -∗
+ ⌜s = s'âŒ.
+ Proof.
+ iIntros "Hrel1 Hrel2".
+ iDestruct "Hrel1" as (?? (->&->)) "(His1&?)".
+ iDestruct "Hrel2" as (?? (Heq&?)) "(His2&?)".
+ inversion Heq; subst. iApply (string_is_functional with "His1 [$]").
+ Qed.
+
+ Lemma strlen_fundamental_core slen c K (va vb: val):
+ (▷ tf_implements imm_stringRel natRel slen strlen) ∗
+ imm_stringRel va vb ∗
+ src (fill K (strlen vb)) ⊢
+ SEQ (Strlen slen va) ⟨⟨v, ∃ m: nat, ⌜v = #m⌠∗ $ c ∗ src (fill K #m) ∗ □ (∀ vb', imm_stringRel va vb' -∗ eval (strlen vb') #m) ⟩⟩.
+ Proof.
+ iIntros "[#IH [HPre Hsrc]] Hna".
+ iDestruct "HPre" as (s) "#Hinv1".
+ iApply (rwp_take_step with "[-Hsrc] [Hsrc]"); first done; last first.
+ { iApply (step_inv_alloc c with "[] [$Hsrc]").
+ iSplitL.
+ { iApply exec_src_update; eauto. eapply exec_frame. apply strlen_Strlen. }
+ iIntros "H". iExists _. iFrame. iPureIntro.
+ rewrite /Strlen/strlen. intros Heq%fill_inj. congruence. }
+ iIntros "(Hsrc&$)". iApply rswp_do_step. iNext. rewrite /Strlen.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iDestruct "Hstr1" as (l1a l1b (->&->)) "(Hl1a&Hl1b)".
+ destruct s as [| n s].
+ {
+ iDestruct "Hl1a" as (q1a) "Hl1a".
+ iDestruct "Hl1b" as (q1b) "Hl1b".
+ wp_load.
+ src_load in "Hsrc".
+ do 4 src_pure _ in "Hsrc".
+ wp_pures. wp_pure _; first solve_vals_compare_safe. wp_pures.
+ iFrame. iExists O. iSplit; first eauto. iFrame.
+ iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
+ iDestruct "HPre" as (s') "#Hinv1'".
+ iApply fupd_src_update.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
+ iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
+ iModIntro.
+ iClear "Hstr1".
+ iRename "Hstr1'" into "Hstr1".
+ iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hl1a" as (q1a') "Hl1a".
+ iDestruct "Hl1b" as (q1b') "Hl1b".
+ rewrite /strlen/strlen_template.
+ do 4 src_pure _ in "H".
+ src_load in "H".
+ do 4 src_pure _ in "H".
+ iApply weak_src_update_return; by iFrame.
+ }
+ simpl string_is. simpl src_string_is.
+ iDestruct "Hl1a" as (H1neq0) "(Hpts1a&Hl1a)".
+ iDestruct "Hpts1a" as (?) "Hpts1a".
+ iDestruct "Hl1b" as (H1neq0') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
+ src_load in "Hsrc".
+ do 3 src_pure _ in "Hsrc".
+ rewrite bool_decide_false; last first.
+ { intros Heq. inversion Heq. lia. }
+ wp_pures.
+ do 2 src_pure _ in "Hsrc".
+ src_bind (strlen _)%E in "Hsrc".
+ iSpecialize ("IH" $! #(l1a +â‚— 1) _ O with "[] Hsrc [$]").
+ { iExists _. iApply inv_stringRel_is_tl. eauto. }
+ wp_bind (slen _).
+ iApply (rwp_wand with "[IH]").
+ { wp_apply "IH". }
+ iIntros (v) "($&H)".
+ iDestruct "H" as (? (m&Heq1&Heq2)) "(_&Hsrc&#Heval')".
+ subst. simpl fill. do 3 src_pure _ in "Hsrc". wp_pures. iExists (1 + m)%nat.
+ iSplit.
+ { iPureIntro. do 2 f_equal. lia. }
+ simpl.
+ iFrame.
+ replace (1 + Z.of_nat m) with (Z.of_nat (S m)) by lia. iFrame.
+ iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
+ iDestruct "HPre" as (s') "#Hinv1'".
+ iApply fupd_src_update.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
+ iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
+ iModIntro.
+ iClear "Hstr1".
+ iRename "Hstr1'" into "Hstr1".
+ iDestruct "Hstr1" as (?? (Heq1a&Heq1b)) "(Hl1a&Hl1b)".
+ simpl src_string_is.
+ iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ rewrite /strlen/strlen_template.
+ do 4 src_pure _ in "H".
+ rewrite Heq1b.
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ rewrite bool_decide_false; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 2 src_pure _ in "H".
+ src_bind (_ (#_)%V)%E in "H".
+ rewrite fill_cons. simpl ectxi_language.fill_item.
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval'" with "[]") as (r2') "(Heval''&Hrel)"; [|
+ iDestruct "Hrel" as %[? (Heq2&->)]; iDestruct ("Heval''" with "H") as "H"].
+ { iExists _. iApply inv_stringRel_is_tl. eauto. }
+ simpl fill.
+ iApply (src_update_bind with "[$H]").
+ iIntros "H".
+ simpl.
+ rewrite -Heq2.
+ do 3 src_pure _ in "H".
+ replace (1 + Z.of_nat m) with (Z.of_nat (S m)) by lia.
+ iApply weak_src_update_return; by iFrame.
+ Qed.
+
+ Lemma lev_fundamental_core g slen c K (va vb: val):
+ (▷ tf_implements imm_stringRel natRel slen strlen) ∗
+ (▷ tf_implements pair_imm_stringRel natRel g lev) ∗
+ pair_imm_stringRel va vb ∗
+ src (fill K (lev vb)) ⊢
+ SEQ (Lev slen g va) ⟨⟨v, ∃ m: nat, ⌜v = #m⌠∗ $ c ∗ src (fill K #m) ∗ □ (∀ vb', pair_imm_stringRel va vb' -∗ eval (lev vb') #m) ⟩⟩.
+ Proof.
+ iIntros "[#Hstrlen [#IH [HPre Hsrc]]] Hna".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ iDestruct "Hs1" as (s1) "#Hinv1".
+ iDestruct "Hs2" as (s2) "#Hinv2".
+ iApply (rwp_take_step with "[-Hsrc] [Hsrc]"); first done; last first.
+ { iApply (step_inv_alloc c with "[] [$Hsrc]").
+ iSplitL.
+ { iApply exec_src_update; eauto. eapply exec_frame. apply lev_Lev. }
+ iIntros "H". iExists _. iFrame. iPureIntro.
+ rewrite /Lev/lev. intros Heq%fill_inj. congruence. }
+ iIntros "(Hsrc&$)". iApply rswp_do_step. iNext. rewrite /Lev.
+ wp_pures.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ destruct s1 as [| n1 s1].
+ {
+ iDestruct "Hstr1" as (l1a l1b (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (l2a l2b (->&->)) "(Hl2a&Hl2b)".
+ iDestruct "Hl1a" as (q1a) "Hl1a".
+ iDestruct "Hl1b" as (q1b) "Hl1b".
+ do 6 src_pure _ in "Hsrc".
+ src_load in "Hsrc".
+ do 4 src_pure _ in "Hsrc".
+ iDestruct ("Hstrlen" $! _ _ O with "[] [$Hsrc]") as "Hstr1".
+ { rewrite /imm_stringRel. iExists _; eauto. }
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe. wp_pures.
+ iApply (rwp_wand with "[Hstr1 Hna]").
+ { wp_apply ("Hstr1" with "[$]"). }
+ iIntros (v) "(Hna&H)".
+ iDestruct "H" as (? (r1&Heq1&Heq2)) "(_&Hsrc&#Heval1)".
+ iFrame.
+ subst. wp_pures.
+ simpl fill. iExists _. iSplit; first eauto. iFrame.
+ iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ symmetry in Heq1. inversion_clear Heq1. subst.
+ iDestruct "Hs1" as (s1') "#Hinv1'".
+ iDestruct "Hs2" as (s2') "#Hinv2'".
+ iApply fupd_src_update.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
+ iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
+ iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
+ iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
+ iClear "Hstr1 Hstr2".
+ iRename "Hstr1'" into "Hstr1".
+ iRename "Hstr2'" into "Hstr2".
+ iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
+ iDestruct "Hl1a" as (q1a') "Hl1a".
+ iDestruct "Hl1b" as (q1b') "Hl1b".
+ iModIntro.
+ rewrite /Lev/lev/lev_template.
+ do 12 src_pure _ in "H".
+ src_load in "H".
+ do 4 src_pure _ in "H".
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval1" with "[]") as (v') "(Heval1'&Hrel)"; last first.
+ { iDestruct "Hrel" as %[? (->&->)]. iApply "Heval1'". eauto. }
+ rewrite /imm_stringRel. eauto.
+ }
+ iDestruct "Hstr1" as (l1a l1b (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (l2a l2b (->&->)) "(Hl2a&Hl2b)".
+ simpl string_is.
+ iDestruct "Hl1a" as (H1neq0) "(Hpts1a&Hl1a)".
+ iDestruct "Hpts1a" as (?) "Hpts1a".
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ wp_pures.
+ destruct s2 as [| n2 s2].
+ {
+ simpl src_string_is.
+ iDestruct "Hl2a" as (q2a) "Hl2a".
+ iDestruct "Hl1b" as (H1neq0') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
+ wp_pure _.
+ do 6 src_pure _ in "Hsrc".
+ src_load in "Hsrc".
+ do 3 src_pure _ in "Hsrc".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 1 src_pure _ in "Hsrc".
+ iDestruct "Hl2b" as (q2b) "Hl2b".
+ src_load in "Hsrc".
+ do 4 src_pure _ in "Hsrc".
+ iDestruct ("Hstrlen" $! _ _ O with "[] [$Hsrc]") as "Hstr2".
+ { rewrite /imm_stringRel. iExists _; eauto. }
+ iApply (rwp_wand with "[Hstr2 Hna]").
+ { wp_apply ("Hstr2" with "[$]"). }
+ iIntros (v) "(Hna&H)".
+ iDestruct "H" as (? (r1&Heq1&Heq2)) "(_&Hsrc&#Heval1)".
+ iFrame.
+ subst. wp_pures.
+ simpl fill. iExists _. iSplit; first eauto. iFrame.
+ iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ symmetry in Heq1. inversion_clear Heq1. subst.
+ iDestruct "Hs1" as (s1') "#Hinv1'".
+ iDestruct "Hs2" as (s2') "#Hinv2'".
+ iApply fupd_src_update.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
+ iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
+ iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
+ iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
+ iClear "Hstr1 Hstr2".
+ iRename "Hstr1'" into "Hstr1".
+ iRename "Hstr2'" into "Hstr2".
+ iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
+ simpl src_string_is.
+ iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ rewrite /Lev/lev/lev_template.
+ iModIntro.
+ do 12 src_pure _ in "H".
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 1 src_pure _ in "H".
+ iDestruct "Hl2b" as (q2b') "Hl2b".
+ src_load in "H".
+ do 4 src_pure _ in "H".
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval1" with "[]") as (v') "(Heval1'&Hrel)"; last first.
+ { iDestruct "Hrel" as %[? (->&->)]. iApply "Heval1'". eauto. }
+ rewrite /imm_stringRel. eauto.
+ }
+ simpl string_is.
+ iDestruct "Hl2a" as (H2neq0) "(Hpts2a&Hl2a)".
+ iDestruct "Hpts2a" as (q2a) "Hpts2a".
+ wp_load. wp_pures. wp_pure _; first solve_vals_compare_safe.
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ wp_pures. wp_pure _; first solve_vals_compare_safe.
+ rewrite /tf_implements.
+ simpl src_string_is.
+ iDestruct "Hl1b" as (H1neq0') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ iDestruct "Hl2b" as (H2neq0') "(Hpts2b&Hl2b)".
+ iDestruct "Hpts2b" as (?) "Hpts2b".
+ do 6 src_pure _ in "Hsrc".
+ src_load in "Hsrc".
+ do 3 src_pure _ in "Hsrc".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 1 src_pure _ in "Hsrc".
+ src_load in "Hsrc".
+ do 3 src_pure _ in "Hsrc".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 2 src_pure _ in "Hsrc".
+ iAssert (pair_imm_stringRel (#(l1a +â‚— 1), #(l2a +â‚— 1)) (#(l1b +â‚— 1), #(l2b +â‚— 1))) as "#Hshift_both".
+ {
+ iExists #(l1a +â‚— 1), #(l2a +â‚— 1), _, _.
+ rewrite /imm_stringRel.
+ iSplit; first eauto.
+ iSplit; first eauto.
+ iSplitL "Hinv1".
+ { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv1". }
+ { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv2". }
+ }
+ iAssert (pair_imm_stringRel ((#l1a, #(l2a +â‚— 1)))%V ((#l1b, #(l2b +â‚— 1)))%V) as "#Hshift_right".
+ {
+ iExists #(l1a), #(l2a +â‚— 1), _, _.
+ rewrite /imm_stringRel.
+ iSplit; first eauto.
+ iSplit; first eauto.
+ iSplitL "Hinv1".
+ { iExists _. iApply "Hinv1". }
+ { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv2". }
+ }
+ iAssert (pair_imm_stringRel (#(l1a +â‚— 1), #l2a) (#(l1b +â‚— 1), #l2b)) as "#Hshift_left".
+ {
+ iExists #(l1a +â‚— 1), #(l2a), _, _.
+ rewrite /imm_stringRel.
+ iSplit; first eauto.
+ iSplit; first eauto.
+ iSplitL "Hinv1".
+ { iExists _. iApply inv_stringRel_is_tl. iApply "Hinv1". }
+ { iExists _. iApply "Hinv2". }
+ }
+ case_bool_decide.
+ {
+ do 2 wp_pure _.
+ do 4 src_pure _ in "Hsrc".
+ rewrite /tf_implements.
+ iSpecialize ("IH" $! (#(l1a +â‚— 1), #(l2a +â‚— 1))%V _ O with "[$] Hsrc [$]").
+ iApply (rwp_wand with "[IH]").
+ { wp_apply "IH". }
+ iIntros (v) "($&H)".
+ iDestruct "H" as (? (m&Heq1&Heq2)) "(_&Hsrc&#Heval')".
+ subst. iExists m. iSplit; first done.
+ iFrame.
+ iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ symmetry in Heq1. inversion_clear Heq1. subst.
+ iDestruct "Hs1" as (s1') "#Hinv1'".
+ iDestruct "Hs2" as (s2') "#Hinv2'".
+ iApply fupd_src_update.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
+ iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
+ iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
+ iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
+ iClear "Hstr1 Hstr2".
+ iRename "Hstr1'" into "Hstr1".
+ iRename "Hstr2'" into "Hstr2".
+ iModIntro.
+ rewrite /Lev/lev/lev_template.
+ do 12 src_pure _ in "H".
+ iDestruct "Hstr1" as (?? (Heq1a&Heq1b)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (?? (Heq2a&Heq2b)) "(Hl2a&Hl2b)".
+ simpl src_string_is.
+ iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ rewrite ?Heq1a ?Heq1b ?Heq2a ?Heq2b.
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 1 src_pure _ in "H".
+ iDestruct "Hl2b" as (H2neq0'') "(Hpts2b&Hl2b)".
+ iDestruct "Hpts2b" as (?) "Hpts2b".
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 2 src_pure _ in "H".
+ rewrite bool_decide_true //; [].
+ do 4 src_pure _ in "H".
+ rewrite -?Heq1a -?Heq1b -?Heq2a -?Heq2b.
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval'" with "[]") as (v') "(Heval1&Hrel)"; last first.
+ { iDestruct "Hrel" as %[? (->&->)]. iApply "Heval1". eauto. }
+ {
+ iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
+ { iApply inv_stringRel_is_tl. rewrite Heq1b. eauto. }
+ { iApply inv_stringRel_is_tl. rewrite Heq2b. eauto. }
+ }
+ }
+ do 3 wp_pure _.
+ do 3 src_pure _ in "Hsrc".
+ src_bind (lev _) in "Hsrc".
+ iDestruct ("IH" $! _ _ O with "Hshift_right Hsrc [$]") as "IH1".
+ wp_bind (g _).
+ iApply (rwp_wand with "[IH1]").
+ { wp_apply "IH1". }
+ iIntros (v) "(Hna&H)".
+ iDestruct "H" as (? (r1&Heq1&Heq2)) "(_&Hsrc&#Heval1)".
+ subst. wp_pures.
+ simpl fill.
+ do 1 src_pure _ in "Hsrc".
+
+ do 3 src_pure _ in "Hsrc".
+ src_bind (lev _) in "Hsrc".
+ iDestruct ("IH" $! _ _ O with "Hshift_left Hsrc [$]") as "IH2".
+ wp_bind (g _).
+ iApply (rwp_wand with "[IH2]").
+ { wp_apply "IH2". }
+ iIntros (v) "(Hna&H)".
+ iDestruct "H" as (? (r2&Heq1&Heq2)) "(_&Hsrc&#Heval2)".
+ subst. wp_pures.
+ simpl fill.
+ do 2 src_pure _ in "Hsrc".
+
+ do 3 src_pure _ in "Hsrc".
+ src_bind (lev _) in "Hsrc".
+ iDestruct ("IH" $! _ _ O with "Hshift_both Hsrc [$]") as "IH2".
+ wp_bind (g _).
+ iApply (rwp_wand with "[IH2]").
+ { wp_apply "IH2". }
+ iIntros (v) "(Hna&H)".
+ iDestruct "H" as (? (r3&Heq1&Heq2)) "(_&Hsrc&#Heval3)".
+ subst. wp_pures.
+ simpl fill.
+ do 2 src_pure _ in "Hsrc".
+
+ wp_bind (min3 _ _ _).
+ wp_apply (min3_spec with "[//]").
+ iIntros "_".
+ src_bind (min3 _ _ _) in "Hsrc".
+ iDestruct (eval_min3 with "Hsrc") as "Hsrc".
+ iApply (rwp_weaken with "[-Hsrc] Hsrc"); first done.
+ iIntros "Hsrc".
+ simpl fill.
+ src_pure _ in "Hsrc".
+ wp_pures. iFrame. iExists (1 + (min (min r1 r2) r3)%nat)%nat.
+ iSplit.
+ { iPureIntro. do 2 f_equal. lia. }
+ assert (#(1 + (r1 `min` r2) `min` r3)%nat =
+ #(1 + ((r1 `min` r2) `min` r3)%nat)) as ->.
+ { do 2 f_equal. lia. }
+ iFrame.
+ iModIntro. rewrite /eval. iIntros (vb') "#HPre". iIntros (K') "H".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ symmetry in Heq1. inversion_clear Heq1. subst.
+ iDestruct "Hs1" as (s1') "#Hinv1'".
+ iDestruct "Hs2" as (s2') "#Hinv2'".
+ iApply fupd_src_update.
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ iMod (stringRel_inv_acc with "Hinv1'") as "Hstr1'".
+ iMod (stringRel_inv_acc with "Hinv2'") as "Hstr2'".
+ iDestruct (stringRel_is_functional with "Hstr1' Hstr1") as %->.
+ iDestruct (stringRel_is_functional with "Hstr2' Hstr2") as %->.
+ iClear "Hstr1 Hstr2".
+ iRename "Hstr1'" into "Hstr1".
+ iRename "Hstr2'" into "Hstr2".
+ iModIntro.
+ rewrite /Lev/lev/lev_template.
+ do 12 src_pure _ in "H".
+ iDestruct "Hstr1" as (?? (Heq1a&Heq1b)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (?? (Heq2a&Heq2b)) "(Hl2a&Hl2b)".
+ simpl src_string_is.
+ iDestruct "Hl1b" as (H1neq0'') "(Hpts1b&Hl1b)".
+ iDestruct "Hpts1b" as (?) "Hpts1b".
+ rewrite ?Heq1a ?Heq1b ?Heq2a ?Heq2b.
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 1 src_pure _ in "H".
+ iDestruct "Hl2b" as (H2neq0'') "(Hpts2b&Hl2b)".
+ iDestruct "Hpts2b" as (?) "Hpts2b".
+ src_load in "H".
+ do 3 src_pure _ in "H".
+ rewrite bool_decide_false //; last first.
+ { intros Heq. inversion Heq. lia. }
+ do 2 src_pure _ in "H".
+ rewrite bool_decide_false //; [].
+ do 1 src_pure _ in "H".
+ do 1 src_pure _ in "H".
+ do 1 src_pure _ in "H".
+ src_bind (_ (#_, #_)%V)%E in "H".
+ (* TODO: can't seem to bind this properly otherwise *)
+ rewrite fill_cons. simpl ectxi_language.fill_item.
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval1" with "[]") as (r1') "(Heval1'&Hrel)"; [|
+ iDestruct "Hrel" as %[? (Heq1&->)]; iDestruct ("Heval1'" with "H") as "H"].
+ {
+ iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
+ { iApply inv_stringRel_is_tl. rewrite Heq1b Heq2a. eauto. }
+ }
+ iApply (src_update_bind with "[$H]").
+ iIntros "H".
+ simpl.
+ do 2 src_pure _ in "H".
+
+ do 2 src_pure _ in "H".
+ src_bind (_ (#_, #_)%V)%E in "H".
+ (* TODO: can't seem to bind this properly otherwise *)
+ rewrite fill_cons. simpl ectxi_language.fill_item.
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval2" with "[]") as (r2') "(Heval2'&Hrel)"; [|
+ iDestruct "Hrel" as %[? (Heq2&->)]; iDestruct ("Heval2'" with "H") as "H"].
+ {
+ iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
+ { iApply inv_stringRel_is_tl. rewrite Heq1a Heq2b. eauto. }
+ }
+ iApply (src_update_bind with "[$H]").
+ iIntros "H".
+ simpl.
+ do 2 src_pure _ in "H".
+
+ do 3 src_pure _ in "H".
+ src_bind (_ (#_, #_)%V)%E in "H".
+ (* TODO: can't seem to bind this properly otherwise *)
+ rewrite fill_cons. simpl ectxi_language.fill_item.
+ iApply src_update_weak_src_update.
+ iDestruct ("Heval3" with "[]") as (r3') "(Heval3'&Hrel)"; [|
+ iDestruct "Hrel" as %[? (Heq3&->)]; iDestruct ("Heval3'" with "H") as "H"].
+ {
+ iExists _, _, _, _; repeat (iSplit; try iExists _; eauto).
+ { iApply inv_stringRel_is_tl. rewrite Heq1a Heq2b. eauto. }
+ { iApply inv_stringRel_is_tl. rewrite Heq1b Heq2a. eauto. }
+ }
+ iApply (src_update_bind with "[$H]").
+ iIntros "H".
+ simpl.
+ do 2 src_pure _ in "H".
+ rewrite -Heq1 -Heq2 -Heq3.
+
+ src_bind (min3 _ _ _) in "H".
+ iDestruct (eval_min3 with "[$]") as "H".
+ iApply src_update_weak_src_update.
+ iApply (src_update_bind with "[$H]").
+ iIntros "H". simpl.
+ do 1 src_pure _ in "H".
+ iApply weak_src_update_return.
+ iApply "H".
+ Qed.
+
+ Definition eq_pair : val := (λ: "n1" "n2", BinOp AndOp (Fst "n1" = Fst "n2") (Snd "n1" = Snd "n2")).
+
+ Lemma strlen_sound :
+ ⊢ tf_implements imm_stringRel natRel strlen strlen.
+ Proof.
+ iLöb as "IH".
+ iModIntro. iIntros (?? c K) "#HPre Hsrc Hna".
+ iDestruct "HPre" as (s) "#Hinv1".
+ rewrite {4}/strlen. wp_pure _. rewrite {1}/strlen_template. do 3 wp_pure _.
+ iPoseProof (strlen_fundamental_core strlen c K _ with "[Hsrc IH] Hna") as "H".
+ { iFrame "Hsrc IH". iExists _. eauto. }
+ iApply (rwp_wand with "H").
+ iIntros (v) "($&H)".
+ iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
+ iSplitR; first eauto.
+ iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
+ iModIntro. iApply "Hexec". eauto.
+ Qed.
+
+ Lemma strlen_template_sound g:
+ ▷ tf_implements imm_stringRel natRel g strlen ⊢
+ SEQ (strlen_template g) ⟨⟨h, tf_implements imm_stringRel natRel h strlen⟩⟩.
+ Proof.
+ iIntros "#IH Hna". rewrite /strlen_template. wp_pures. iFrame.
+ iModIntro; iIntros (? ? c K) "HPre Hsrc Hna".
+ wp_pure _.
+ iDestruct "HPre" as (s1) "#Hinv1".
+ iPoseProof (strlen_fundamental_core g c K _ with "[$Hsrc $IH] Hna") as "H".
+ { iExists _. repeat iSplit; try iExists _; eauto. }
+ rewrite /Strlen.
+ iApply (rwp_wand with "H").
+ iIntros (v) "($&H)".
+ iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
+ iSplitR; first eauto.
+ iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
+ iModIntro. iApply "Hexec". eauto.
+ Qed.
+
+ Lemma lev_sound:
+ ⊢ tf_implements pair_imm_stringRel natRel lev lev.
+ Proof.
+ iLöb as "IH".
+ iModIntro. iIntros (v v' c K) "#HPre Hsrc Hna".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ iDestruct "Hs1" as (s1) "#Hinv1".
+ iDestruct "Hs2" as (s2) "#Hinv2".
+ rewrite {4}/lev. wp_pure _. rewrite {1}/lev_template. do 3 wp_pure _.
+ iPoseProof (lev_fundamental_core lev strlen c K (v1a, v2a)%V with "[Hsrc IH] Hna") as "H".
+ { iFrame "Hsrc". iSplitL.
+ { iNext. iApply strlen_sound. }
+ iFrame "IH".
+ { iExists _, _, _, _. repeat iSplit; try iExists _; eauto. }
+ }
+ rewrite /Lev/lev.
+ do 2 wp_pure _.
+ iApply (rwp_wand with "H").
+ iIntros (v) "($&H)".
+ iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
+ iSplitR; first eauto.
+ iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
+ iModIntro. iApply "Hexec". eauto.
+ Qed.
+
+ Lemma lev_template'_sound g slen:
+ ▷ tf_implements imm_stringRel natRel slen strlen ∗
+ ▷ tf_implements pair_imm_stringRel natRel g lev ⊢
+ SEQ (lev_template' slen g) ⟨⟨h, tf_implements pair_imm_stringRel natRel h lev⟩⟩.
+ Proof.
+ iIntros "[#Hslen #IH] Hna". rewrite /lev_template'. wp_pures. iFrame.
+ iModIntro; iIntros (n n' c K) "HPre Hsrc Hna".
+ wp_pure _.
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ iDestruct "Hs1" as (s1) "#Hinv1".
+ iDestruct "Hs2" as (s2) "#Hinv2".
+ iPoseProof (lev_fundamental_core g slen c K (v1a, v2a)%V with "[$Hslen $Hsrc $IH] Hna") as "H".
+ { iExists _, _, _, _. repeat iSplit; try iExists _; eauto. }
+ rewrite /Lev.
+ iApply (rwp_wand with "H").
+ iIntros (v) "($&H)".
+ iDestruct "H" as (m ->) "(Hsrc&Hc&#Hexec)". iExists _. iFrame.
+ iSplitR; first eauto.
+ iModIntro. iIntros (x) "#Hrel". iExists #m. iSplit; last eauto.
+ iModIntro. iApply "Hexec". eauto.
+ Qed.
+
+ (* memoized versions *)
+ Context `{Sync: !inG Σ (authR (optionUR (exclR (gmapO val (valO SI)))))}.
+ Context `{Fin: FiniteBoundedExistential SI}.
+
+ Lemma lev_memoized:
+ $ (1%nat) ⊢ SEQ (memoize eq_pair lev) ⟨⟨ h, tf_implements pair_imm_stringRel natRel h lev ⟩⟩.
+ Proof using Sync Fin.
+ (* XXX: the iApply fails over typeclass resolution (?) if we don't do iStartProof *)
+ iStartProof. iIntros "Hc".
+ iApply (tf_memoize_spec _ _ (λ x, ∃ (l1 l2: loc), ⌜ x = (#l1, #l2)%V âŒ)%I (λ x1 x2, ⌜ x1 = x2 âŒ)%I);
+ [| | iSplit].
+ - iIntros (??) "HPre".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ iDestruct "Hs1" as (s1) "#Hinv1".
+ iDestruct "Hs2" as (s2) "#Hinv2".
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
+ eauto.
+ - iIntros (??? ->); auto.
+ - rewrite /eqfun. iIntros (??). iModIntro. iIntros (Φ) "(H1&H2) H".
+ iDestruct "H1" as %[l1 [l2 ->]].
+ iDestruct "H2" as %[l1' [l2' ->]].
+ rewrite /eq_pair.
+ wp_pures.
+ wp_pure _; first solve_vals_compare_safe.
+ wp_pure _.
+ case_bool_decide;
+ (wp_pures; wp_pure _; first solve_vals_compare_safe;
+ case_bool_decide; (wp_pures; iApply "H"; iSplitL; [| iSplitL]; eauto; iPureIntro; congruence)).
+ - iFrame. iApply lev_sound.
+ Qed.
+
+ Lemma lev_deep_memoized:
+ $ (1%nat) ∗ $ (1%nat) ⊢
+ SEQ (let: "strlen" := mem_rec eq_heaplang strlen_template in
+ mem_rec eq_pair (lev_template "strlen"))
+ ⟨⟨ h, tf_implements pair_imm_stringRel natRel h lev ⟩⟩.
+ Proof using Sync Fin.
+ iStartProof. iIntros "(Hc1&Hc2) Hna".
+ wp_bind (mem_rec _ _).
+ iPoseProof (tf_mem_rec_spec imm_stringRel natRel
+ (λ x, ∃ l1 : loc, ⌜ x = #l1%V âŒ)%I (λ x1 x2, ⌜ x1 = x2 âŒ)%I with "[Hc1] [$Hna]")
+ as "IH"; last (iApply (rwp_wand with "IH")).
+ { iIntros (??) "HPre". iDestruct "HPre" as (s1) "#Hinv1".
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)". eauto. }
+ { iIntros (??? ->); auto. }
+ { iSplit.
+ { rewrite /eqfun. iIntros (??). iModIntro. iIntros (Φ) "(H1&H2) H".
+ iDestruct "H1" as %[l1 ->].
+ iDestruct "H2" as %[l1' ->].
+ rewrite /eq_heaplang.
+ wp_pures.
+ wp_pure _; first solve_vals_compare_safe.
+ case_bool_decide; eauto; iApply "H"; eauto. }
+ iFrame.
+ iModIntro. iIntros.
+ iApply strlen_template_sound. eauto.
+ }
+ iIntros (h) "(Hna&#Himpl)".
+ wp_pures.
+ rewrite /lev_template. wp_pure _. wp_pure _.
+ iApply (tf_mem_rec_spec _ _ (λ x, ∃ (l1 l2: loc), ⌜ x = (#l1, #l2)%V âŒ)%I (λ x1 x2, ⌜ x1 = x2 âŒ)%I with "[Hc2] [$Hna]"); [| | iSplit].
+ - iIntros (??) "HPre".
+ iDestruct "HPre" as (v1a v2a v1b v2b Heq1 Heq2) "(Hs1&Hs2)". subst.
+ iDestruct "Hs1" as (s1) "#Hinv1".
+ iDestruct "Hs2" as (s2) "#Hinv2".
+ iMod (stringRel_inv_acc with "Hinv1") as "Hstr1".
+ iMod (stringRel_inv_acc with "Hinv2") as "Hstr2".
+ iDestruct "Hstr1" as (?? (->&->)) "(Hl1a&Hl1b)".
+ iDestruct "Hstr2" as (?? (->&->)) "(Hl2a&Hl2b)".
+ eauto.
+ - iIntros (??? ->); auto.
+ - rewrite /eqfun. iIntros (??). iModIntro. iIntros (Φ) "(H1&H2) H".
+ iDestruct "H1" as %[l1 [l2 ->]].
+ iDestruct "H2" as %[l1' [l2' ->]].
+ rewrite /eq_pair.
+ wp_pures.
+ wp_pure _; first solve_vals_compare_safe.
+ wp_pure _.
+ case_bool_decide;
+ (wp_pures; wp_pure _; first solve_vals_compare_safe;
+ case_bool_decide; (wp_pures; iApply "H"; iSplitL; [| iSplitL]; eauto; iPureIntro; congruence)).
+ - iFrame. iModIntro. iIntros (g) "H".
+ iPoseProof (lev_template'_sound with "[H]") as "H".
+ { iSplitR.
+ * iApply "Himpl".
+ * iApply "H".
+ }
+ iApply "H".
+ Qed.
+End levenshtein.
+
diff --git a/theories/examples/refinements/refinement.v b/theories/examples/refinements/refinement.v
new file mode 100644
index 0000000000000000000000000000000000000000..9adc3df8fea11a88347b6184bf1bf954fb321297
--- /dev/null
+++ b/theories/examples/refinements/refinement.v
@@ -0,0 +1,842 @@
+From iris.program_logic.refinement Require Export ref_weakestpre ref_source seq_weakestpre.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From iris.heap_lang Require Export lang lifting.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation metatheory.
+From iris.algebra Require Import auth gmap excl frac agree mlist.
+Set Default Proof Using "Type".
+
+Inductive rtc_list {A : Type} (R : relation A) : list A → Prop :=
+| rtc_list_nil : rtc_list R nil
+| rtc_list_once : ∀ x, rtc_list R [x]
+| rtc_list_l : ∀ x y l, R x y → rtc_list R (y :: l) → rtc_list R (x :: y :: l).
+
+Lemma rtc_list_r {A : Type} (R : relation A) (x y: A) (l: list A) :
+ R x y →
+ rtc_list R (l ++ [x]) →
+ rtc_list R (l ++ [x] ++ [y]).
+Proof.
+ rewrite app_assoc.
+ intros HR Hrtc.
+ remember (l ++ [x]) as l' eqn:Heql. revert x y HR l Heql; induction Hrtc; intros.
+ - apply rtc_list_once.
+ - symmetry in Heql. apply app_singleton in Heql as [(?&Heq)|(?&?)]; last by congruence.
+ apply rtc_list_l; last apply rtc_list_once.
+ inversion Heq; subst; eauto.
+ - destruct l0; first by (simpl in Heql; congruence).
+ inversion Heql; subst.
+ simpl; apply rtc_list_l; first done.
+ rewrite app_comm_cons. eapply IHHrtc; eauto.
+Qed.
+
+Lemma rtc_list_app_r {A: Type} (R: relation A) l1 l2:
+ rtc_list R (l1 ++ l2) → rtc_list R l2.
+Proof.
+ revert l2. induction l1; first done.
+ intros l2 Hrtc. inversion Hrtc as [| | ???? Hrtc' [Heq1 Heq2]].
+ - assert (l2 = []) as -> by (eapply app_eq_nil; eauto).
+ constructor.
+ - apply IHl1. rewrite -Heq2; eauto.
+Qed.
+
+Lemma rtc_list_rtc {A: Type} (R: relation A) (x y : A) (l : list A):
+ rtc_list R ([x] ++ l ++ [y]) →
+ rtc R x y.
+Proof.
+ revert x y.
+ induction l as [| a l IHl]; intros x y Hrtc.
+ - inversion Hrtc; subst; eauto using rtc_l, rtc_refl.
+ - inversion Hrtc; subst.
+ apply (rtc_l _ _ a); auto.
+Qed.
+
+Lemma rtc_list_lookup_last_rtc {A: Type} (R: relation A) (x y : A) (l : list A) (i: nat) :
+ (l ++ [y]) !! i = Some x →
+ rtc_list R (l ++ [y]) →
+ rtc R x y.
+Proof.
+ rewrite lookup_app_Some.
+ intros [Hl|Hr].
+ * apply elem_of_list_split_length in Hl.
+ destruct Hl as (l1&l2&Heq&Hlen). subst.
+ rewrite -app_assoc => Hrtc. apply rtc_list_app_r in Hrtc.
+ rewrite -app_comm_cons in Hrtc. eapply rtc_list_rtc; eauto.
+ simpl; eauto.
+ * destruct Hr as (_&Hlookup). intros.
+ destruct (i - length l)%nat.
+ ** rewrite /= in Hlookup. inversion Hlookup. apply rtc_refl.
+ ** exfalso. rewrite /= lookup_nil in Hlookup. congruence.
+Qed.
+
+(* HeapLang <={log} HeapLang *)
+Definition tpoolUR SI : ucmraT SI := gmapUR nat (exclR (exprO SI)).
+Definition cfgUR SI := prodUR (tpoolUR SI) (gen_heapUR SI loc val).
+
+Class rheapPreG {SI} (Σ: gFunctors SI) := RHeapPreG {
+ rheapPreG_heapG :> heapPreG Σ;
+ rheapPreG_ghost_repr :> inG Σ (authR (cfgUR SI)); (* the source ghost state *)
+ rheapPreG_fmlistG :> fmlistG (cfg heap_lang) Σ;
+}.
+
+Class rheapG {SI} (Σ: gFunctors SI) := RHeapG {
+ rheapG_heapG :> heapG Σ;
+ rheapG_ghost_repr :> inG Σ (authR (cfgUR SI)); (* the source ghost state *)
+ rheapG_ghost_name: gname;
+ rheapG_fmlistG :> fmlistG (cfg heap_lang) Σ;
+ rheapG_fmlist_name: gname;
+}.
+
+Section source_ghost_state.
+ Context {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ}.
+
+ Fixpoint to_tpool_go (i : nat) (tp : list expr) : tpoolUR SI :=
+ match tp with
+ | [] => ∅
+ | e :: tp => <[i:=Excl e]>(to_tpool_go (S i) tp)
+ end.
+ Definition to_tpool : list expr → tpoolUR SI := to_tpool_go 0.
+
+ Definition heapS_mapsto (l : loc) (q : Qp) (v: val) : iProp Σ :=
+ own rheapG_ghost_name (◯ (∅, {[ l := (q, to_agree v) ]})).
+
+ Definition tpool_mapsto (j : nat) (e: expr) : iProp Σ :=
+ own rheapG_ghost_name (◯ ({[ j := Excl e ]}, ∅)).
+
+ Global Instance heapS_mapsto_timeless l q v : Timeless (heapS_mapsto l q v).
+ Proof. apply _. Qed.
+
+ Typeclasses Opaque heapS_mapsto tpool_mapsto.
+
+
+ Section thread_pool_conversion.
+ Open Scope nat.
+ (** Conversion to tpools and back *)
+ Lemma to_tpool_valid es : ✓ to_tpool es.
+ Proof.
+ rewrite /to_tpool. move: 0.
+ induction es as [|e es]=> n //; simpl. by apply insert_valid.
+ Qed.
+
+ Lemma tpool_lookup tp j : to_tpool tp !! j = Excl <$> tp !! j.
+ Proof.
+ cut (∀ i, to_tpool_go i tp !! (i + j) = Excl <$> tp !! j).
+ { intros help. apply (help 0). }
+ revert j. induction tp as [|e tp IH]=> //= -[|j] i /=.
+ - by rewrite Nat.add_0_r lookup_insert.
+ - by rewrite -Nat.add_succ_comm lookup_insert_ne; last lia.
+ Qed.
+ Lemma tpool_lookup_Some tp j e : to_tpool tp !! j = Excl' e → tp !! j = Some e.
+ Proof. rewrite tpool_lookup fmap_Some. naive_solver. Qed.
+ Hint Resolve tpool_lookup_Some : core.
+
+ Lemma to_tpool_insert tp j e :
+ j < length tp →
+ to_tpool (<[j:=e]> tp) = <[j:=Excl e]> (to_tpool tp).
+ Proof.
+ intros. apply: map_eq=> i. destruct (decide (i = j)) as [->|].
+ - by rewrite tpool_lookup lookup_insert list_lookup_insert.
+ - rewrite tpool_lookup lookup_insert_ne // list_lookup_insert_ne //.
+ by rewrite tpool_lookup.
+ Qed.
+ Lemma to_tpool_insert' tp j e :
+ is_Some (to_tpool tp !! j) →
+ to_tpool (<[j:=e]> tp) = <[j:=Excl e]> (to_tpool tp).
+ Proof.
+ rewrite tpool_lookup fmap_is_Some lookup_lt_is_Some. apply to_tpool_insert.
+ Qed.
+
+ Lemma to_tpool_snoc tp e :
+ to_tpool (tp ++ [e]) = <[length tp:=Excl e]>(to_tpool tp).
+ Proof.
+ intros. apply: map_eq=> i.
+ destruct (lt_eq_lt_dec i (length tp)) as [[?| ->]|?].
+ - rewrite lookup_insert_ne; last lia. by rewrite !tpool_lookup lookup_app_l.
+ - by rewrite lookup_insert tpool_lookup lookup_app_r // Nat.sub_diag.
+ - rewrite lookup_insert_ne; last lia.
+ rewrite !tpool_lookup ?lookup_ge_None_2 ?app_length //=;
+ change (ofe_car _ (exprO SI)) with expr; lia.
+ Qed.
+
+ Lemma tpool_singleton_included tp j e :
+ {[j := Excl e]} ≼ to_tpool tp → tp !! j = Some e.
+ Proof.
+ move=> /singleton_included [ex [/leibniz_equiv_iff]].
+ rewrite tpool_lookup fmap_Some=> [[e' [-> ->]] /Excl_included ?]. by f_equal.
+ Qed.
+ Lemma tpool_singleton_included' tp j e :
+ {[j := Excl e]} ≼ to_tpool tp → to_tpool tp !! j = Excl' e.
+ Proof. rewrite tpool_lookup. by move=> /tpool_singleton_included=> ->. Qed.
+
+End thread_pool_conversion.
+
+End source_ghost_state.
+Notation "l '↦s{' q } v" := (heapS_mapsto l q v) (at level 20, q at level 50, format "l '↦s{' q } v") : bi_scope.
+Notation "l '↦s' v" := (heapS_mapsto l 1 v) (at level 20) : bi_scope.
+Notation "j ⤇ e" := (tpool_mapsto j e) (at level 20) : bi_scope.
+Notation src e := (0 ⤇ e)%I.
+
+
+Definition heap_srcT : Set := (list expr * (gmap loc val * gmap proph_id unit)).
+Definition to_cfg '(es, (h, m)): cfg heap_lang := (es, {| heap := h; used_proph_id := {| mapset.mapset_car := m |} |}).
+Global Instance heap_lang_source {SI} {Σ: gFunctors SI} `{!rheapG Σ}: source Σ heap_srcT := {|
+ source_rel := λ s s', erased_step (to_cfg s) (to_cfg s');
+ source_interp := (λ '(tp, (h, proph)), own rheapG_ghost_name (◠((to_tpool tp, to_gen_heap SI h): cfgUR SI)) ∗
+ ∃ l, let l' := (l ++ [to_cfg (tp, (h, proph))]) in
+ ⌜rtc_list (erased_step) l'⌠∗
+ fmlist rheapG_fmlist_name 1 l')%I
+|}.
+
+
+Section heap_lang_source_steps.
+
+ Context {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}.
+
+ (* we use stuttering heap lang as a source *)
+ Global Instance: source Σ (heap_srcT * nat) | 0 := _.
+
+ Lemma step_insert tp j (e: expr) σ e' σ' efs κ:
+ tp !! j = Some e → prim_step e σ κ e' σ' efs →
+ erased_step (tp, σ) (<[j:= e']> tp ++ efs, σ').
+ Proof.
+ intros. rewrite -(take_drop_middle tp j e) //.
+ rewrite insert_app_r_alt take_length_le ?Nat.sub_diag /=;
+ eauto using lookup_lt_Some, Nat.lt_le_incl.
+ rewrite -(assoc_L (++)) /=. exists κ.
+ eapply step_atomic; eauto.
+ Qed.
+
+
+ Lemma pure_step_prim_step (e1 e2: expr) σ:
+ pure_step e1 e2 → prim_step e1 σ [] e2 σ [].
+ Proof.
+ destruct 1 as [safe det]. destruct (safe σ) as (e' & σ' & efs & step).
+ by specialize (det σ [] e' σ' efs step) as (_ & -> & -> & ->).
+ Qed.
+
+
+ (* allocate stuttering budget post-hoc *)
+ Lemma step_frame (c1 c2: heap_srcT) (n m k: nat):
+ (c1, n) ↪ (c2, m) → (c1, (n + k)%nat) ↪ (c2, (m + k)%nat).
+ Proof.
+ inversion 1; subst.
+ - by apply lex_left.
+ - apply lex_right, auth_source_step_frame; eauto; done.
+ Qed.
+
+ Lemma steps_frame (c1 c2: heap_srcT) (n m k: nat):
+ (c1, n) ↪⺠(c2, m) → (c1, (n + k)%nat) ↪⺠(c2, (m + k)%nat).
+ Proof.
+ intros Hsteps.
+ remember (c1, n) as p. revert n c1 Heqp.
+ remember (c2, m) as q. revert m c2 Heqq.
+ induction Hsteps as [? ? Hstep|p [c' m'] q Hstep Hsteps]; intros n c2 -> m c1 ->.
+ - apply tc_once, step_frame, Hstep.
+ - eapply tc_l; first eapply step_frame, Hstep.
+ by eapply IHHsteps.
+ Qed.
+
+ Lemma step_add_stutter (c1 c2: heap_srcT) (n m: nat) c:
+ (c1, n) ↪⺠(c2, m) → c1 ≠c2 → (c1, n) ↪⺠(c2, (m + c)%nat).
+ Proof.
+ intros Hsteps.
+ remember (c1, n) as p. revert n c1 Heqp.
+ remember (c2, m) as q. revert m c2 Heqq.
+ induction Hsteps as [? ? Hstep|p [c2 m] q Hstep Hsteps]; intros k c3 -> n c1 -> Hneq.
+ - inversion Hstep; subst.
+ + by eapply tc_once, lex_left.
+ + naive_solver.
+ - inversion Hstep; subst.
+ + eapply tc_l; first apply lex_left; eauto.
+ eapply steps_frame, Hsteps.
+ + eapply tc_l; first apply lex_right; eauto.
+ Qed.
+
+
+ Lemma step_inv_alloc c E P j e1:
+ (j ⤇ e1 -∗ src_update E P) ∗ (P -∗ ∃ e2, j ⤇ e2 ∗ ⌜e2 ≠e1âŒ)
+ ⊢ j ⤇ e1 -∗ src_update E (P ∗ $ c).
+ Proof.
+ rewrite /src_update. iIntros "[Hupd HP] Hj".
+ iIntros ([[tp [h m]] n]) "[Hsrc Hcred]".
+ iDestruct "Hsrc" as "(Hsrc&Hl)".
+ iDestruct (own_valid_2 with "Hsrc Hj") as %[[Htp%tpool_singleton_included'%tpool_lookup_Some _]%prod_included _]%auth_both_valid.
+ iSpecialize ("Hupd" with "Hj"). iMod ("Hupd" $! (tp, (h, m), n) with "[$Hsrc $Hl $Hcred]") as ([[tp' [h' m']] m''] Hsteps) "[[[Hsrc Hsrcl] Hcred] P]".
+ iAssert (⌜∃ e2, tp' !! j = Some e2 ∧ e2 ≠e1âŒ)%I as %Htp'; last destruct Htp' as [e2 [Htp' Hneq]].
+ { iDestruct ("HP" with "P") as (e2) "[Hj %]".
+ iDestruct (own_valid_2 with "Hsrc Hj") as %[[Htp'%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iPureIntro; exists e2. split; first eapply tpool_lookup_Some, Htp'. done.
+ }
+ iMod (own_update _ (â— m'') (â— (m'' + c)%nat â‹… â—¯ c) with "Hcred") as "[Hnat Hc]".
+ { eapply auth_update_alloc, nat_local_update. rewrite /ε //= /nat_unit. }
+ iModIntro. iExists (tp', (h', m'), (m'' + c)%nat). iFrame.
+ iPureIntro. apply step_add_stutter; eauto.
+ injection 1 as -> ->.
+ eapply Hneq. eapply Some_inj. rewrite -Htp -Htp' //=.
+ Qed.
+
+
+ (* stuttering rule *)
+ Lemma step_stutter E c:
+ srcF (natA SI) (S c) ⊢ src_update E (srcF (natA SI) c).
+ Proof.
+ rewrite /src_update.
+ iIntros "Hf" ([[tp σ] n]) "[H◠Hnat]".
+ iDestruct (own_valid_2 with "Hnat Hf") as %[Hle%nat_included _]%auth_both_valid.
+ destruct n as [|n]; first lia.
+ iMod (own_update_2 _ (â— (S n)) (â—¯ (S c)) (â— n â‹… â—¯ c) with "Hnat Hf") as "[Hnat Hc]".
+ { eapply auth_update, nat_local_update. lia. }
+ iModIntro. iExists (tp, σ, n); iFrame.
+ iPureIntro. apply tc_once, lex_right; simpl; lia.
+ Qed.
+
+ Lemma src_log E j (e: expr) :
+ j ⤇ e ⊢ weak_src_update E (j ⤇ e ∗
+ ∃ tp σ i, ⌜ tp !! j = Some e ⌠∗ fmlist_idx rheapG_fmlist_name i (to_cfg (tp, σ))).
+ Proof.
+ iIntros "Hj".
+ rewrite /weak_src_update /tpool_mapsto /source_interp //=.
+ iIntros ([[tp [h m]] n]) "[[Hâ— Hl] Hnat]".
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iDestruct "Hl" as (l Htrace) "Hfmlist".
+ iMod (fmlist_get_lb with "Hfmlist") as "(Hfmlist&Hlb)".
+ iDestruct (fmlist_lb_to_idx _ _ (length l) with "Hlb") as "Hidx".
+ { rewrite lookup_app_r; last lia. replace (length l - length l)%nat with O by lia. rewrite //. }
+ iModIntro. iExists (tp, (h, m), n). iFrame.
+ iSplit; first eauto. iSplit.
+ { iExists _. iFrame. eauto. }
+ iExists tp, (h, m), (length l).
+ iSplit; eauto.
+ iPureIntro. eapply (tpool_lookup_Some (SI:=SI)); auto.
+ Qed.
+
+ Lemma src_get_trace' j (e: expr) i cfg σ :
+ j ⤇ e ∗ fmlist_idx rheapG_fmlist_name i cfg ∗ source_interp σ -∗
+ j ⤇ e ∗
+ source_interp σ ∗
+ ∃ tp σ, ⌜ tp !! j = Some e ∧ rtc erased_step cfg (to_cfg (tp, σ)) âŒ.
+ Proof.
+ iIntros "(Hj&Hidx&Hinterp)".
+ rewrite /tpool_mapsto /source_interp //=.
+ destruct σ as [[tp [h m]] n].
+ iDestruct "Hinterp" as "[[Hâ— Hl] Hnat]".
+ iDestruct "Hl" as (l Htrace) "Hfmlist".
+ iDestruct (fmlist_idx_agree_2 with "[$] [$]") as %Hlookup.
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iFrame.
+ iSplit; first eauto.
+ iExists tp, (h, m).
+ iPureIntro. split.
+ * eapply (tpool_lookup_Some (SI:=SI)); auto.
+ * eapply rtc_list_lookup_last_rtc; eauto.
+ Qed.
+
+ Lemma src_get_trace E j (e: expr) i cfg :
+ j ⤇ e ∗ fmlist_idx rheapG_fmlist_name i cfg ⊢ weak_src_update E (j ⤇ e ∗
+ ∃ tp σ, ⌜ tp !! j = Some e ∧ rtc erased_step cfg (to_cfg (tp, σ)) âŒ).
+ Proof.
+ iIntros "(Hj&Hidx)".
+ rewrite /weak_src_update /tpool_mapsto /source_interp //=.
+ iIntros ([[tp [h m]] n]) "[[Hâ— Hl] Hnat]".
+ iDestruct "Hl" as (l Htrace) "Hfmlist".
+ iDestruct (fmlist_idx_agree_2 with "[$] [$]") as %Hlookup.
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iModIntro. iExists (tp, (h, m), n). iFrame.
+ iSplit; first eauto. iSplit.
+ { iExists _. iFrame. eauto. }
+ iExists tp, (h, m).
+ iPureIntro. split.
+ * eapply (tpool_lookup_Some (SI:=SI)); auto.
+ * eapply rtc_list_lookup_last_rtc; eauto.
+ Qed.
+
+ (* operational rules *)
+ Lemma step_pure E j (e1 e2: expr):
+ pure_step e1 e2 → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
+ Proof.
+ iIntros (Hp) "Hj"; rewrite /src_update /tpool_mapsto /source_interp //=.
+ iIntros ([[tp [h m]] n]) "[[Hâ— Hl] Hnat]".
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iMod (own_update_2 with "Hâ— Hj") as "[Hâ— Hj]".
+ { eapply auth_update, prod_local_update_1, singleton_local_update; eauto.
+ by eapply (exclusive_local_update) with (x' := Excl e2). }
+ iDestruct "Hl" as (l Htrace) "Hfmlist".
+ iMod (fmlist_update_snoc (to_cfg (<[j:= e2]> tp, (h, m))) with "[$]") as "(Hfmlist&_)".
+ iFrame "Hj". iModIntro. iExists (((<[j:= e2]> tp), (h, m)), n).
+ rewrite to_tpool_insert'; eauto; iFrame.
+ iSplit.
+ - iPureIntro.
+ replace (<[j:=e2]> tp) with (<[j:=e2]> tp ++ []) by rewrite right_id_L //=.
+ eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
+ apply pure_step_prim_step, Hp.
+ - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
+ replace (<[j:=e2]> tp) with (<[j:=e2]> tp ++ []) by rewrite right_id_L //=.
+ eapply step_insert; first by eapply tpool_lookup_Some.
+ apply pure_step_prim_step, Hp.
+ Qed.
+
+ Lemma steps_pure n E j (e1 e2: expr):
+ nsteps pure_step (S n) e1 e2 → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
+ Proof.
+ remember (S n) as m. intros H; revert n Heqm; induction H as [|? e1 e2 e3 Hstep Hsteps]; intros m.
+ - discriminate 1.
+ - injection 1 as ->. destruct m.
+ + inversion Hsteps; subst. by apply step_pure.
+ + iIntros "P". iApply src_update_bind; iSplitL.
+ * iApply step_pure; eauto.
+ * by iApply IHHsteps.
+ Qed.
+
+ Lemma steps_pure_exec E j e1 e2 φ n:
+ PureExec φ (S n) e1 e2 → φ → j ⤇ e1 ⊢ src_update E (j ⤇ e2).
+ Proof.
+ intros Hp Hφ. specialize (pure_exec Hφ); eapply steps_pure.
+ Qed.
+
+ Lemma step_load E j K (l: loc) q v:
+ j ⤇ fill K (Load #l) ∗ l ↦s{q} v ⊢ src_update E (j ⤇ fill K (of_val v) ∗ l ↦s{q} v).
+ Proof.
+ iIntros "[Hj Hl]"; rewrite /src_update /tpool_mapsto /source_interp //=.
+ iIntros ([[tp [h m]] n]) "[[Hâ— Hfmlist] Hnat]".
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iDestruct (own_valid_2 with "Hâ— Hl") as %[[_ ?%gen_heap_singleton_included]%prod_included ?]%auth_both_valid.
+ iMod (own_update_2 with "Hâ— Hj") as "[Hâ— Hj]".
+ { by eapply auth_update, prod_local_update_1, singleton_local_update,
+ (exclusive_local_update _ (Excl (fill K (of_val v)))). }
+ iDestruct "Hfmlist" as (tr Htrace) "Hfmlist".
+ iMod (fmlist_update_snoc (to_cfg (<[j:= fill K (of_val v)]> tp, (h, m))) with "[$]") as "(Hfmlist&_)".
+ iFrame "Hj Hl". iModIntro. iExists (((<[j:=fill K (of_val v)]> tp), (h, m)), n).
+ rewrite to_tpool_insert'; last eauto. iFrame. iSplit.
+ - iPureIntro.
+ replace (<[j:=fill K v]> tp) with (<[j:=fill K v]> tp ++ []) by rewrite right_id_L //=.
+ eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
+ apply fill_prim_step, head_prim_step.
+ econstructor; eauto.
+ - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
+ replace (<[j:=fill K v]> tp) with (<[j:=fill K v]> tp ++ []) by rewrite right_id_L //=.
+ eapply step_insert; first by eapply tpool_lookup_Some.
+ apply fill_prim_step, head_prim_step.
+ econstructor; eauto.
+ Qed.
+
+ Lemma step_store E j K (l: loc) (v v': val):
+ j ⤇ fill K (Store #l v) ∗ l ↦s v' ⊢ src_update E (j ⤇ fill K #() ∗ l ↦s v).
+ Proof.
+ iIntros "[Hj Hl]"; rewrite /src_update /tpool_mapsto /heapS_mapsto /source_interp //=.
+ iIntros ([[tp [h m]] n]) "[[Hâ— Hfmlist] Hnat]".
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iDestruct (own_valid_2 with "Hâ— Hl") as %[[_ Hl%gen_heap_singleton_included]%prod_included ?]%auth_both_valid.
+ iMod (own_update_2 with "Hâ— Hj") as "[Hâ— Hj]".
+ { by eapply auth_update, prod_local_update_1, singleton_local_update,
+ (exclusive_local_update _ (Excl (fill K (of_val #())))). }
+ iMod (own_update_2 with "Hâ— Hl") as "[Hâ— Hl]".
+ { eapply auth_update, prod_local_update_2, singleton_local_update,
+ (exclusive_local_update _ (1%Qp, to_agree v)); last done.
+ by rewrite /to_gen_heap lookup_fmap Hl. }
+ iDestruct "Hfmlist" as (tr Htrace) "Hfmlist".
+ iMod (fmlist_update_snoc (to_cfg (<[j:= fill K (of_val #())]> tp, (<[l:=v]>h, m))) with "[$]") as
+ "(Hfmlist&_)".
+ iFrame "Hj Hl". iExists (((<[j:=fill K (of_val #())]> tp), (<[l:=v]> h, m)), n).
+ rewrite -to_gen_heap_insert -to_tpool_insert' //=; eauto.
+ iModIntro. iFrame. iSplit.
+ - iPureIntro.
+ replace (<[j:=fill K #()]> tp) with (<[j:=fill K #()]> tp ++ []) by rewrite right_id_L //=.
+ eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
+ apply fill_prim_step, head_prim_step.
+ econstructor; eauto.
+ - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
+ replace (<[j:=fill K #()]> tp) with (<[j:=fill K #()]> tp ++ []) by rewrite right_id_L //=.
+ eapply step_insert; first by eapply tpool_lookup_Some.
+ apply fill_prim_step, head_prim_step.
+ econstructor; eauto.
+ Qed.
+
+ Lemma step_alloc E j K (v : val):
+ j ⤇ fill K (Alloc v) ⊢ src_update E (∃ l: loc, j ⤇ fill K #l ∗ l ↦s v).
+ Proof.
+ iIntros "Hj"; rewrite /src_update /tpool_mapsto /heapS_mapsto /source_interp //=.
+ iIntros ([[tp [h m]] n]) "[[Hâ— Hfmlist] Hnat]".
+ destruct (exist_fresh (dom (gset loc) h)) as [l Hl%not_elem_of_dom].
+ iDestruct (own_valid_2 with "Hâ— Hj") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ iMod (own_update_2 with "Hâ— Hj") as "[Hâ— Hj]".
+ { by eapply auth_update, prod_local_update_1, singleton_local_update,
+ (exclusive_local_update _ (Excl (fill K (of_val #l)))). }
+ iMod (own_update with "Hâ—") as "[Hâ— Hl]".
+ { eapply auth_update_alloc, prod_local_update_2, (alloc_singleton_local_update _ l (1%Qp,to_agree v)); last done.
+ by apply lookup_to_gen_heap_None. }
+ iDestruct "Hfmlist" as (tr Htrace) "Hfmlist".
+ iMod (fmlist_update_snoc (to_cfg (<[j:= fill K (of_val #l)]> tp, (<[l:=v]>h, m))) with "[$]") as
+ "(Hfmlist&_)".
+ iModIntro. iExists (((<[j:=fill K (of_val #l)]> tp), (<[l:=v]> h, m)), n).
+ rewrite -to_gen_heap_insert to_tpool_insert' //=; eauto. iFrame.
+ iSplitR; [| iSplitL "Hfmlist"]; last by iExists l; iFrame.
+ - iPureIntro.
+ replace (<[j:=fill K #l]> tp) with (<[j:=fill K #l]> tp ++ []) by rewrite right_id_L //=.
+ eapply tc_once, lex_left, step_insert; first by eapply tpool_lookup_Some.
+ apply fill_prim_step, head_prim_step.
+ pose proof (AllocNS 1 v {| heap := h; used_proph_id := {| mapset.mapset_car := m |} |} l) as H.
+ rewrite state_init_heap_singleton in H; simpl in H. apply H; first lia.
+ intros i ??; assert (i = 0) as -> by lia; simpl; rewrite loc_add_0 //=.
+ - iExists _. iFrame. iPureIntro. rewrite -app_assoc. apply rtc_list_r; auto.
+ replace (<[j:=fill K #l]> tp) with (<[j:=fill K #l]> tp ++ []) by rewrite right_id_L //=.
+ eapply step_insert; first by eapply tpool_lookup_Some.
+ apply fill_prim_step, head_prim_step.
+ pose proof (AllocNS 1 v {| heap := h; used_proph_id := {| mapset.mapset_car := m |} |} l) as H.
+ rewrite state_init_heap_singleton in H; simpl in H. apply H; first lia.
+ intros i ??; assert (i = 0) as -> by lia; simpl; rewrite loc_add_0 //=.
+ Qed.
+
+End heap_lang_source_steps.
+
+
+(* some proof automation for source languages *)
+From iris.proofmode Require Import tactics coq_tactics reduction.
+Ltac strip_ectx e cb :=
+ match e with
+ | fill ?K ?e' => strip_ectx e' ltac:(fun K' e'' => match K' with nil => cb K e'' | _ => cb (K ++ K') e'' end)
+ | _ => cb (@nil ectx_item) e
+ end.
+
+Ltac src_bind_core e efoc cb :=
+ strip_ectx e ltac:(fun K e' => reshape_expr e' ltac:(fun K' e'' => unify e'' efoc; cb (K' ++ K) e'')).
+
+Ltac src_bind_core' e cb :=
+ strip_ectx e ltac:(fun K e' => reshape_expr e' ltac:(fun K' e'' => cb (K' ++ K) e'')).
+
+Lemma src_change e1 e2 {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)} j Δ (G: iProp Σ):
+ e1 = e2 →
+ envs_entails Δ (j ⤇ e2 -∗ G) →
+ envs_entails Δ (j ⤇ e1 -∗ G).
+Proof. by intros ->. Qed.
+
+Tactic Notation "src_bind" open_constr(efoc) :=
+ match goal with
+ | [|- envs_entails ?Δ (?j ⤇ ?e -∗ ?G)] =>
+ src_bind_core e efoc ltac:(fun K e' => apply (src_change e (fill K e')); first reflexivity)
+ end.
+
+Tactic Notation "src_bind" open_constr(efoc) "in" constr(H) :=
+ iRevert H;
+ src_bind efoc;
+ last iIntros H.
+
+Lemma tac_src_pures_rwp e1 e2 {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
+ φ e Δ j E s Φ:
+ PureExec φ 1 e1 e2 →
+ to_val e = None →
+ φ →
+ envs_entails Δ (j ⤇ e2 -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (j ⤇ e1 -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ? ? ? ->.
+ iIntros "H Hj". iApply (rwp_weaken with "H"); auto.
+ by iApply @steps_pure_exec.
+Qed.
+
+Lemma tac_src_pures e1 e2 {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
+ φ Δ j E P:
+ PureExec φ 1 e1 e2 →
+ φ →
+ envs_entails Δ (j ⤇ e2 -∗ weak_src_update E P) →
+ envs_entails Δ (j ⤇ e1 -∗ src_update E P).
+Proof.
+ rewrite envs_entails_eq=> ? ? ->.
+ iIntros "H Hj".
+ iApply (weak_src_update_bind_r with "[$H Hj]").
+ by iApply @steps_pure_exec.
+Qed.
+
+Lemma tac_src_load_rwp {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
+ e s Φ Δ E i j K l q v:
+ to_val e = None →
+ envs_lookup i Δ = Some (false, l ↦s{q} v)%I →
+ envs_entails Δ (j ⤇ fill K (Val v) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (j ⤇ fill K (Load (LitV l)) -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ?? Henvs.
+ iIntros "H Hj".
+ rewrite envs_lookup_split //.
+ iDestruct "H" as "(Hl&Hw)".
+ iApply (rwp_weaken with "[Hw] [Hl Hj]"); first done; last first.
+ { iApply step_load. iFrame. }
+ iIntros "(Hj&Hl)".
+ iSpecialize ("Hw" with "[$]"). iApply (Henvs with "[$] [$]").
+Qed.
+
+Lemma tac_src_load {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
+ Δ E P i j K l q v:
+ envs_lookup i Δ = Some (false, l ↦s{q} v)%I →
+ envs_entails Δ (j ⤇ fill K (Val v) -∗ weak_src_update E P) →
+ envs_entails Δ (j ⤇ fill K (Load (LitV l)) -∗ src_update E P).
+Proof.
+ rewrite envs_entails_eq=> ? Henvs.
+ iIntros "H Hj".
+ rewrite envs_lookup_split //.
+ iDestruct "H" as "(Hl&Hw)".
+ iApply (weak_src_update_bind_r with "[-]").
+ iSplitL "Hl Hj".
+ { iApply step_load. iFrame. }
+ iIntros "(Hj&Hl)".
+ iApply (Henvs with "[Hw Hl] Hj").
+ by iApply "Hw".
+Qed.
+
+Lemma tac_src_store {SI: indexT} `{Σ: gFunctors SI} `{!rheapG Σ} `{!auth_sourceG Σ (natA SI)}
+ Δ Δ' E P i j K l v v':
+ envs_lookup i Δ = Some (false, l ↦s v)%I →
+ envs_simple_replace i false (Esnoc Enil i (l ↦s v')) Δ = Some Δ' →
+ envs_entails Δ' (j ⤇ fill K (Val $ LitV LitUnit) -∗ weak_src_update E P) →
+ envs_entails Δ (j ⤇ fill K (Store (LitV l) (Val v')) -∗ src_update E P).
+Proof.
+ rewrite envs_entails_eq=> ?? Henvs.
+ iIntros "H Hj".
+ rewrite envs_simple_replace_sound //.
+ iDestruct "H" as "(Hl&Hw)".
+ iApply (weak_src_update_bind_r with "[-]").
+ iSplitL "Hl Hj".
+ { iApply step_store. iFrame. }
+ iIntros "(Hj&Hl)".
+ iApply (Henvs with "[Hw Hl] Hj").
+ iApply "Hw". simpl. rewrite right_id. eauto.
+Qed.
+
+Ltac weak_to_src_update :=
+ lazymatch goal with
+ | [|- envs_entails ?Δ (weak_src_update _ _)] =>
+ iApply src_update_weak_src_update
+ | _ => idtac
+ end.
+
+Tactic Notation "src_pure" open_constr(efoc) :=
+ match goal with
+ | [|- envs_entails ?Δ (?j ⤇ ?e -∗ src_update _ _)] =>
+ src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_pures (fill K e'));
+ [iSolveTC|try solve_vals_compare_safe| simpl ectx_language.fill])
+ | [|- envs_entails ?Δ (?j ⤇ ?e -∗ rwp _ _ _ _)] =>
+ src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_pures_rwp (fill K e'));
+ [iSolveTC|done|try solve_vals_compare_safe|simpl])
+ end.
+
+Tactic Notation "src_pure" open_constr(efoc) "in" constr(H) :=
+ weak_to_src_update;
+ iRevert H;
+ src_pure efoc;
+ last iIntros H.
+
+Tactic Notation "src_load" open_constr (efoc) :=
+ lazymatch goal with
+ | [|- envs_entails ?Δ (?j ⤇ ?e -∗ rwp _ _ _ _)] =>
+ src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_load_rwp _ _ _ _ _ _ _ K);
+ [done|iAssumptionCore| simpl fill])
+ | [|- envs_entails ?Δ (?j ⤇ ?e -∗ weak_src_update _ _)] =>
+ iApply src_update_weak_src_update;
+ src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_load _ _ _ _ _ K);
+ [iAssumptionCore| simpl fill])
+ | [|- envs_entails ?Δ (?j ⤇ ?e -∗ src_update _ _)] =>
+ src_bind_core e efoc ltac:(fun K e' => eapply (tac_src_load _ _ _ _ _ K);
+ [iAssumptionCore| simpl fill])
+ end.
+
+Tactic Notation "src_load" "in" constr(H) :=
+ weak_to_src_update;
+ iRevert H;
+ src_bind (! _)%E;
+ src_load _;
+ last iIntros H.
+
+Tactic Notation "pattern" open_constr(e) "in" tactic(f) := f e.
+
+Ltac single_pure_exec :=
+ match goal with
+ | [|- PureExec ?φ 1 ?e1 ?e2] => apply _
+ | [|- PureExec ?φ 1 (fill ?K1 ?e1) (fill ?K2 ?e2)] =>
+ unify K1 K2; eapply pure_exec_fill; single_pure_exec
+ | [|- PureExec ?φ 1 ?e1 ?e2 ] =>
+ reshape_expr e1 ltac:(fun K e1 =>
+ pattern (_: expr) in ltac:(fun e2' =>
+ unify e2 (fill K e2');
+ change (PureExec φ 1 (fill K e1) (fill K e2'));
+ apply pure_exec_fill, _
+ ))
+ end.
+
+
+Lemma pure_exec_cons φ ψ n (e1 e2 e3: expr):
+ PureExec φ 1 e1 e2 → PureExec ψ n e2 e3 → PureExec (φ ∧ ψ) (S n) e1 e3.
+Proof.
+ intros H1 H2 [Hφ Hψ]; econstructor; eauto.
+ specialize (H1 Hφ).
+ by inversion H1 as [|x y z a Hpure Hstep]; subst; inversion Hstep; subst.
+Qed.
+
+
+Lemma pure_exec_zero (e: expr): PureExec True 0 e e.
+Proof.
+ intros ?. econstructor.
+Qed.
+
+Ltac pure_exec_cons :=
+ match goal with
+ | [|- PureExec ?φ 0 ?e1 ?e2] =>
+ apply pure_exec_zero
+ | [|- PureExec ?φ ?n ?e1 ?e2] =>
+ unify e1 e2; apply pure_exec_zero
+ | [|- PureExec ?φ ?n ?e1 ?e2] =>
+ (eapply pure_exec_cons; [single_pure_exec|]); simpl
+ end.
+
+Ltac pure_exec := repeat pure_exec_cons.
+
+
+
+
+Arguments satisfiable_at {_ _ _} _ _%I.
+
+Lemma satisfiable_update_alloc {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!invG Σ} {E} {P} Q:
+ satisfiable_at E P → (⊢ |==> ∃ γ: gname, Q γ) → ∃ γ, satisfiable_at E (P ∗ Q γ).
+Proof.
+ intros Hsat Hent. apply satisfiable_at_exists; first done.
+ eapply satisfiable_at_fupd with (E1 := E).
+ eapply satisfiable_at_mono; first apply Hsat.
+ iIntros "$". iMod (Hent) as "$"; eauto.
+Qed.
+
+Lemma satisfiable_update_alloc_2 {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!invG Σ} {E} {P} Φ:
+ satisfiable_at E P → (⊢ |==> ∃ γ1 γ2: gname, Φ γ1 γ2) → ∃ γ1 γ2, satisfiable_at E (P ∗ Φ γ1 γ2).
+Proof.
+ intros Hsat Hent.
+ eapply satisfiable_at_mono with (Q := (|==> ∃ γ1 γ2, P ∗ Φ γ1 γ2)%I) in Hsat.
+ - eapply satisfiable_at_bupd in Hsat as Hsat.
+ apply satisfiable_at_exists in Hsat as [γ1 Hsat]; auto.
+ apply satisfiable_at_exists in Hsat as [γ2 Hsat]; eauto.
+ - iIntros "$". by iMod Hent.
+Qed.
+
+Lemma satisfiable_at_alloc {SI A} {Σ: gFunctors SI} `{LargeIndex SI} `{!inG Σ A} `{!invG Σ} {E} {P} (a: A):
+ satisfiable_at E P → ✓ a → ∃ γ, satisfiable_at E (P ∗ own γ a).
+Proof.
+ intros Hsat Hent. apply satisfiable_update_alloc; first done.
+ by eapply own_alloc.
+Qed.
+
+Lemma satisfiable_at_add {SI} (Σ: gFunctors SI) `{!invG Σ} E P Q: satisfiable_at E P → sbi_emp_valid Q → satisfiable_at E (P ∗ Q).
+Proof.
+ intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
+ iIntros "$". iApply Hval.
+Qed.
+
+Lemma satisfiable_at_add' {SI} (Σ: gFunctors SI) `{!invG Σ} E Q: satisfiable_at E True → sbi_emp_valid Q → satisfiable_at E Q.
+Proof.
+ intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
+ iIntros "_". iApply Hval.
+Qed.
+
+Lemma satisfiable_at_gen_heap {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!heapPreG Σ} κ σ:
+ ∃ Hheap: heapG Σ, satisfiable_at ⊤ ((gen_heap_ctx (heap σ)) ∗ proph_map_ctx κ (used_proph_id σ)).
+Proof.
+ (* allocate invariants *)
+ edestruct satisfiable_at_intro as [Hinv Hsat].
+ eapply satisfiable_update_alloc_2 in Hsat as (γ_gen_heap & γ_gen_heap_meta & Hsat); last eapply (alloc_gen_heap _ _ σ.(heap)).
+ pose (Hgen := GenHeapG SI loc val _ _ _ _ _ _ γ_gen_heap γ_gen_heap_meta).
+
+ (* TODO: prophecies are not really included in the refinement version *)
+ (* allocate prophecies *)
+ eapply satisfiable_update_alloc in Hsat as (γ_proph_map & Hsat); last apply (proph_map_init' κ σ.(used_proph_id)).
+ pose (Hproph := ProphMapG SI proph_id (val * val) Σ _ _ _ γ_proph_map).
+ exists (HeapG _ _ _ _ _).
+ eapply satisfiable_at_mono; first apply Hsat.
+ by iIntros "[[_ $] $]".
+Qed.
+
+
+Lemma satisfiable_at_ref_heapG {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!heapPreG Σ} n σ:
+ ∃ Hheap: heapG Σ, satisfiable_at ⊤ (ref_state_interp n σ).
+Proof.
+ edestruct (satisfiable_at_gen_heap nil) as [Hheap Hsat].
+ exists Hheap. eapply satisfiable_at_mono; first eauto.
+ iIntros "($ & _)".
+Qed.
+
+Lemma satisfiable_at_rheapG {SI} {Σ: gFunctors SI} `{LargeIndex SI} `{!rheapPreG Σ} n σ h m tp:
+ ∃ Hheap: rheapG Σ, satisfiable_at ⊤ (ref_state_interp σ n ∗ source_interp (tp, (h, m)) ∗ own rheapG_ghost_name (◯ (to_tpool tp, to_gen_heap SI h))).
+Proof.
+ edestruct (satisfiable_at_ref_heapG) as [Hheap Hsat].
+ eapply (satisfiable_at_alloc (◠(to_tpool tp, to_gen_heap SI h) ⋅ ◯ (to_tpool tp, to_gen_heap SI h))) in Hsat as [γ Hsat]; last first.
+ { apply auth_both_valid; repeat split; eauto using to_tpool_valid, to_gen_heap_valid. }
+ eapply (satisfiable_at_alloc ((â—{1} (MList [to_cfg (tp, (h, m))])))) in Hsat as [γ' Hsat]; last first.
+ { apply auth_auth_valid.
+ cbv; auto. }
+ exists (RHeapG _ _ _ _ γ _ γ').
+ eapply satisfiable_at_mono; first apply Hsat.
+ iIntros "(($&($&$))&H3)".
+ iExists nil. simpl. rewrite /fmlist. iFrame.
+ iPureIntro. apply rtc_list_once.
+Qed.
+
+Lemma rtc_to_cfg {SI} {Σ: gFunctors SI} `{!rheapG Σ} x y: rtc source_rel x y → rtc erased_step (to_cfg x) (to_cfg y).
+Proof.
+ induction 1; first done.
+ econstructor; by eauto.
+Qed.
+
+Lemma sn_to_cfg {SI} {Σ: gFunctors SI} `{!rheapG Σ} x: sn erased_step (to_cfg x) → sn source_rel x.
+Proof.
+ remember (to_cfg x) as σ; intros Hsn; revert x Heqσ.
+ induction Hsn as [x _ IH]; intros [ts [h m]] ->.
+ constructor. intros [ts' [h' m']] Hstep.
+ eapply IH; eauto. apply Hstep.
+Qed.
+
+From iris.program_logic Require Import ref_adequacy.
+(* Adequacy Theorem *)
+Section adequacy.
+ Context {SI: indexT} `{C: Classical} `{LI: LargeIndex SI} {Σ: gFunctors SI}.
+ Context `{Hpre: !rheapPreG Σ} `{Hna: !na_invG Σ} `{Hauth: !inG Σ (authR (natA SI))}.
+
+ Theorem heap_lang_ref_adequacy (φ: val → val → Prop) (s t: expr) σ σ_src:
+ (∀ `{!rheapG Σ} `{!seqG Σ} `{!auth_sourceG Σ (natA SI)}, src s ⊢ SEQ t ⟨⟨ v, ∃ v': val, src v' ∗ ⌜φ v v'⌠⟩⟩) →
+ (∀ σ' v, rtc erased_step ([t], σ) ([Val v], σ') → ∃ v': val, ∃ σ_src' ts, rtc erased_step ([s], σ_src) (Val v' :: ts, σ_src') ∧ φ v v') ∧
+ (sn erased_step ([s], σ_src) → sn erased_step ([t], σ)).
+ Proof using SI C LI Σ Hpre Hna Hauth.
+ intros Hobj.
+ (* allocate the heap *)
+ edestruct (satisfiable_at_rheapG 0 σ (heap σ_src) (mapset.mapset_car (used_proph_id σ_src)) [s]) as [Hheap Hsat].
+ (* allocate sequential invariants *)
+ eapply satisfiable_update_alloc in Hsat as [seqG_name Hsat]; last apply na_alloc.
+ pose (seq := {| seqG_na_invG := _; seqG_name := seqG_name |}).
+ (* allocte stuttering credits *)
+ eapply (satisfiable_at_alloc (â— 0%nat â‹… â—¯ 0%nat)) in Hsat as [authG_name Hsat]; last first.
+ { apply auth_both_valid; by split. }
+ pose (stutter := {| sourceG_inG := _; sourceG_name := authG_name |}).
+ specialize (Hobj Hheap seq stutter).
+ eapply satisfiable_at_mono in Hsat as Hsat; last first; [|split].
+ - iIntros "[[(SI & Hsrc & Hsrc') Hna] [Hc Hc']]".
+ iPoseProof (Hobj with "[Hsrc'] Hna") as "Hwp".
+ + assert ((◯ (to_tpool [s], to_gen_heap SI (heap σ_src))) ≡ (◯ (to_tpool [s], ∅) ⋅ ◯ (∅, to_gen_heap SI (heap σ_src)))) as ->.
+ { by rewrite -auth_frag_op pair_op left_id right_id. }
+ iDestruct "Hsrc'" as "[$ _]".
+ + iClear "Hc'". iCombine "Hsrc Hc" as "Hsrc".
+ iCombine "Hsrc SI Hwp" as "G". iExact "G".
+ - intros σ' v Hsteps. eapply (rwp_result _ _ ([s], (heap σ_src, mapset.mapset_car (used_proph_id σ_src)), 0%nat)) in Hsteps; last apply Hsat.
+ destruct Hsteps as ([[ts [h p]] c] & m & Hsteps & Hsat').
+ eapply satisfiable_at_pure.
+ eapply satisfiable_at_mono; first apply Hsat'.
+ iIntros "(Hsrc & SI & _ & Hv)". iDestruct "Hv" as (v') "[Hsrc' %]".
+ iExists v', {| heap := h; used_proph_id := {| mapset.mapset_car := p |} |}.
+ iDestruct "Hsrc" as "[[Hsrc _] _]".
+ iDestruct (own_valid_2 with "Hsrc Hsrc'") as %[[H1%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
+ destruct ts as [|e ts]; first naive_solver.
+ iExists ts.
+ iPureIntro. split; auto.
+ rewrite tpool_lookup in H1.
+ injection H1 as ->.
+ eapply lex_rtc in Hsteps.
+ eapply rtc_to_cfg in Hsteps; simpl in Hsteps.
+ destruct σ_src as [? [?]]; apply Hsteps.
+ - intros Hsn. destruct σ_src as [h_src [p_src]]; simpl in *. eapply (rwp_sn_preservation _ ([s], (h_src, p_src), 0%nat) _ _ 0).
+ { eapply sn_lex; first apply (sn_to_cfg ([s], (h_src, p_src))); eauto.
+ intros y; apply lt_wf. }
+ eapply satisfiable_at_mono; first apply Hsat.
+ iIntros "($ & $ & $)".
+ Qed.
+
+End adequacy.
diff --git a/theories/heap_lang/lib/assert.v b/theories/examples/safety/assert.v
similarity index 90%
rename from theories/heap_lang/lib/assert.v
rename to theories/examples/safety/assert.v
index 04a6d76133fb524c6e9e99961af2524ad50bd4de..24d098c8fdf98b5882362f39252e391ea7e553a2 100644
--- a/theories/heap_lang/lib/assert.v
+++ b/theories/examples/safety/assert.v
@@ -10,15 +10,16 @@ Definition assert : val :=
Notation "'assert:' e" := (assert (λ: <>, e)%E) (at level 99) : expr_scope.
Notation "'assert:' e" := (assert (λ: <>, e)%V) (at level 99) : val_scope.
+(*
Lemma twp_assert `{!heapG Σ} E (Φ : val → iProp Σ) e :
WP e @ E [{ v, ⌜v = #true⌠∧ Φ #() }] -∗
WP (assert: e)%V @ E [{ Φ }].
Proof.
iIntros "HΦ". wp_lam.
wp_apply (twp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
-Qed.
+Qed.*)
-Lemma wp_assert `{!heapG Σ} E (Φ : val → iProp Σ) e :
+Lemma wp_assert {SI} {Σ: gFunctors SI} `{!heapG Σ} E (Φ : val → iProp Σ) e :
WP e @ E {{ v, ⌜v = #true⌠∧ ▷ Φ #() }} -∗
WP (assert: e)%V @ E {{ Φ }}.
Proof.
diff --git a/theories/examples/safety/barrier/barrier.v b/theories/examples/safety/barrier/barrier.v
new file mode 100644
index 0000000000000000000000000000000000000000..7ae83e5da15123f3fcb6dc59f83401ee1e923ac1
--- /dev/null
+++ b/theories/examples/safety/barrier/barrier.v
@@ -0,0 +1,7 @@
+From iris.heap_lang Require Export notation.
+Set Default Proof Using "Type".
+
+Definition newbarrier : val := λ: <>, ref #false.
+Definition signal : val := λ: "x", "x" <- #true.
+Definition wait : val :=
+ rec: "wait" "x" := if: !"x" then #() else "wait" "x".
diff --git a/theories/examples/safety/barrier/example_client.v b/theories/examples/safety/barrier/example_client.v
new file mode 100644
index 0000000000000000000000000000000000000000..21377276318be326fb0e8312912c60052f0e38d9
--- /dev/null
+++ b/theories/examples/safety/barrier/example_client.v
@@ -0,0 +1,73 @@
+From iris.program_logic Require Export weakestpre.
+From iris.heap_lang Require Export lang.
+From iris.heap_lang Require Import adequacy proofmode.
+From iris.examples.safety Require Import par.
+From iris.examples.safety.barrier Require Import proof.
+Set Default Proof Using "Type".
+
+Definition worker (n : Z) : val :=
+ λ: "b" "y", wait "b" ;; !"y" #n.
+Definition client : expr :=
+ let: "y" := ref #0 in
+ let: "b" := newbarrier #() in
+ ("y" <- (λ: "z", "z" + #42) ;; signal "b") |||
+ (worker 12 "b" "y" ||| worker 17 "b" "y").
+
+Section client.
+ Local Set Default Proof Using "Type*".
+ Context `{Σ : gFunctors SI} `{!heapG Σ, !barrierG Σ, !spawnG Σ}.
+
+ Definition N := nroot .@ "barrier".
+
+ Definition y_inv (q : Qp) (l : loc) : iProp Σ :=
+ (∃ f : val, l ↦{q} f ∗ □ ∀ n : Z, WP f #n {{ v, ⌜v = #(n + 42)⌠}})%I.
+
+ Lemma y_inv_split q l : y_inv q l -∗ (y_inv (q/2) l ∗ y_inv (q/2) l).
+ Proof.
+ iDestruct 1 as (f) "[[Hl1 Hl2] #Hf]".
+ iSplitL "Hl1"; iExists f; by iSplitL; try iAlways.
+ Qed.
+
+ Lemma worker_safe q (n : Z) (b y : loc) :
+ recv N b (y_inv q y) -∗ WP worker n #b #y {{ _, True }}.
+ Proof.
+ iIntros "Hrecv". wp_lam. wp_let.
+ wp_apply (wait_spec with "Hrecv"). iDestruct 1 as (f) "[Hy #Hf]".
+ wp_seq. wp_load.
+ iApply (wp_wand with "[]"). iApply "Hf". by iIntros (v) "_".
+ Qed.
+
+ Lemma client_safe : ⊢ WP client {{ _, True }}.
+ Proof.
+ iIntros ""; rewrite /client. wp_alloc y as "Hy". wp_let.
+ wp_apply (newbarrier_spec N (y_inv 1 y) with "[//]").
+ iIntros (l) "[Hr Hs]".
+ wp_apply (wp_par (λ _, True%I) (λ _, True%I) with "[Hy Hs] [Hr]"); last auto.
+ - (* The original thread, the sender. *)
+ wp_store. iApply (signal_spec with "[-]"); last by iNext; auto.
+ iSplitR "Hy"; first by eauto.
+ iExists _; iSplitL; [done|]. iIntros "!#" (n). by wp_pures.
+ - (* The two spawned threads, the waiters. *)
+ iDestruct (recv_weaken with "[] Hr") as "Hr".
+ { iIntros "Hy". by iApply (y_inv_split with "Hy"). }
+ iPoseProof (recv_split with "Hr") as "H". instantiate (1 := ⊤). done.
+ iApply swp_wp_lstep; eauto.
+ iApply (lstepN_lstep _ _ 1).
+ iMod "H". do 2 iModIntro. iNext. do 2 iModIntro. iMod "H". iModIntro. swp_finish.
+ iDestruct "H" as "[H1 H2]".
+ wp_apply (wp_par (λ _, True%I) (λ _, True%I) with "[H1] [H2]"); last auto.
+ + by iApply worker_safe.
+ + by iApply worker_safe.
+Qed.
+End client.
+
+Section ClosedProofs.
+
+Let Σ {SI} : gFunctors SI := #[ heapΣ SI ; barrierΣ ; spawnΣ SI ].
+
+Lemma client_adequate {SI : indexT} σ : adequate NotStuck client σ (λ _ _, True).
+Proof. apply (heap_adequacy Σ)=> ?. apply client_safe. Qed.
+
+End ClosedProofs.
+
+(*Print Assumptions client_adequate.*)
diff --git a/theories/examples/safety/barrier/proof.v b/theories/examples/safety/barrier/proof.v
new file mode 100644
index 0000000000000000000000000000000000000000..e40b3941109142f325ba941c6b60387312fb4804
--- /dev/null
+++ b/theories/examples/safety/barrier/proof.v
@@ -0,0 +1,187 @@
+From iris.program_logic Require Export weakestpre.
+From iris.base_logic Require Import invariants saved_prop.
+From iris.heap_lang Require Export lang.
+From iris.heap_lang Require Import proofmode.
+From iris.algebra Require Import auth gset.
+From iris.examples.safety.barrier Require Export barrier.
+Set Default Proof Using "Type".
+
+(** The CMRAs/functors we need. *)
+Class barrierG {SI} (Σ : gFunctors SI) := BarrierG {
+ barrier_inG :> inG Σ (authR (gset_disjUR gname));
+ barrier_savedPropG :> savedPropG Σ;
+}.
+Definition barrierΣ {SI} : gFunctors SI :=
+ #[ GFunctor (authRF (gset_disjUR gname)); savedPropΣ ].
+
+Instance subG_barrierΣ `{Σ : gFunctors SI} : subG barrierΣ Σ → barrierG Σ.
+Proof. solve_inG. Qed.
+
+(** Now we come to the Iris part of the proof. *)
+Section proof.
+Context `{Σ : gFunctors SI} `{!heapG Σ, !barrierG Σ} (N : namespace).
+
+(* P is the proposition that will be sent, R the one that will be received by the individual threads *)
+Definition barrier_inv (l : loc) (γ : gname) (P : iProp Σ) : iProp Σ :=
+ (∃ (b : bool) (γsps : gset gname) (oracle : gname -> iProp Σ),
+ l ↦ #b ∗
+ own γ (◠(GSet γsps)) ∗
+ ((if b then True else P) -∗ ▷ [∗ set] γsp ∈ γsps, oracle γsp) ∗
+ ([∗ set] γsp ∈ γsps, saved_prop_own γsp (oracle γsp)))%I.
+
+(*P is the proposition that will be sent, R' the one that will be received by this particular thread, and R the one we want to have *)
+Definition recv (l : loc) (R : iProp Σ) : iProp Σ :=
+ (∃ γ P R' γsp,
+ inv N (barrier_inv l γ P) ∗
+ ▷ (R' -∗ R) ∗
+ own γ (◯ GSet {[ γsp ]}) ∗
+ saved_prop_own γsp R')%I.
+
+(* P is the prop that we need to send *)
+Definition send (l : loc) (P : iProp Σ) : iProp Σ :=
+ (∃ γ, inv N (barrier_inv l γ P))%I.
+
+(** Setoids *)
+Instance barrier_inv_ne l γ : NonExpansive (barrier_inv l γ).
+Proof. solve_proper. Qed.
+Global Instance send_ne l : NonExpansive (send l).
+Proof. solve_proper. Qed.
+Global Instance recv_ne l : NonExpansive (recv l).
+Proof. solve_proper. Qed.
+
+(** Actual proofs *)
+Lemma newbarrier_spec (P : iProp Σ) :
+ {{{ True }}} newbarrier #() {{{ l, RET #l; recv l P ∗ send l P }}}.
+Proof.
+ iIntros (Φ) "_ HΦ". iApply wp_fupd. wp_lam. wp_alloc l as "Hl".
+ iApply ("HΦ" with "[> -]").
+ iMod (saved_prop_alloc P) as (γsp) "#Hsp".
+ iMod (own_alloc (◠GSet {[ γsp ]} ⋅ ◯ GSet {[ γsp ]})) as (γ) "[H◠H◯]".
+ { by apply auth_both_valid. }
+ iMod (inv_alloc N _ (barrier_inv l γ P) with "[Hl Hâ—]") as "#Hinv".
+ { iExists false, {[ γsp ]}, (fun _ => P). iIntros "{$Hl $Hâ—} !>".
+ rewrite !big_sepS_singleton; eauto. }
+ iModIntro; iSplitL "Hâ—¯".
+ - iExists γ, P, P, γsp. iFrame; auto.
+ - by iExists γ.
+Qed.
+
+Lemma signal_spec l P :
+ {{{ send l P ∗ P }}} signal #l {{{ RET #(); True }}}.
+Proof.
+ iIntros (Φ) "[Hs HP] HΦ".
+ iDestruct "Hs" as (γ) "#Hinv". wp_lam.
+ wp_swp. iInv "Hinv" as "H".
+ swp_last_step. iNext; simpl.
+ iDestruct "H" as ([] γsps oracle) "(Hl & H◠& HRs & Hsaved)".
+ { wp_store. iModIntro. iSplitR "HΦ"; last by iApply "HΦ".
+ iExists true, γsps, oracle. iFrame. }
+ wp_store. iDestruct ("HRs" with "HP") as "HRs".
+ iModIntro. iSplitR "HΦ"; last by iApply "HΦ".
+ iExists true, γsps, oracle. iFrame; eauto.
+Qed.
+
+Lemma wait_spec l P:
+ {{{ recv l P }}} wait #l {{{ RET #(); P }}}.
+Proof.
+ rename P into R.
+ iIntros (Φ) "HR HΦ".
+ iDestruct "HR" as (γ P R' γsp) "(#Hinv & HR & H◯ & #Hsp)".
+ iLöb as "IH". wp_rec. wp_bind (! _)%E.
+ iInv "Hinv" as "H". wp_swp. swp_step. iNext; simpl.
+ iDestruct "H" as ([] γsps oracle) "(Hl & H◠& HRs & Hsaved)"; last first.
+ { wp_load. iModIntro. iSplitL "Hl Hâ— HRs Hsaved".
+ { iExists false, γsps, oracle. iFrame. }
+ by wp_apply ("IH" with "[$] [$]"). }
+ iSpecialize ("HRs" with "[//]").
+ swp_last_step. iNext. wp_load.
+ iDestruct (own_valid_2 with "Hâ— Hâ—¯")
+ as %[Hvalid%gset_disj_included%elem_of_subseteq_singleton _]%auth_both_valid.
+ iDestruct (big_sepS_delete with "HRs") as "[HR'' HRs]"; first done.
+ iDestruct (big_sepS_delete with "Hsaved") as "[HRsaved Hsaved]"; first done.
+ iDestruct (saved_prop_agree with "Hsp HRsaved") as "#Heq".
+ iMod (own_update_2 with "Hâ— Hâ—¯") as "Hâ—".
+ { apply (auth_update_dealloc _ _ (GSet (γsps ∖ {[ γsp ]}))).
+ apply gset_disj_dealloc_local_update. }
+ iIntros "!>". iSplitL "Hl Hâ— HRs Hsaved".
+ { iModIntro.
+ iExists true, (γsps ∖ {[ γsp ]}), oracle. iFrame; eauto.
+ }
+ wp_if. iApply "HΦ". iApply "HR". by iRewrite "Heq".
+Qed.
+
+Lemma recv_split E l P1 P2 :
+ ↑N ⊆ E → ⊢ (recv l (P1 ∗ P2) -∗ |={E, ∅}=> ▷ |={∅, E}=> recv l P1 ∗ recv l P2)%I.
+Proof.
+ rename P1 into R1; rename P2 into R2.
+ iIntros (?). iDestruct 1 as (γ P R' γsp) "(#Hinv & HR & H◯ & #Hsp)".
+ iInv N as "H" "Hclose".
+ iMod (fupd_intro_mask' (E ∖ ↑N) ∅) as "H3". set_solver.
+ iModIntro. iNext.
+ iDestruct "H" as (b γsps oracle) "(Hl & H◠& HRs & Hsaved)". (* as later does not commute with exists, this would fail without taking a step *)
+ iDestruct (own_valid_2 with "Hâ— Hâ—¯")
+ as %[Hvalid%gset_disj_included%elem_of_subseteq_singleton _]%auth_both_valid.
+ set (γsps' := γsps ∖ {[γsp]}).
+ iMod (own_update_2 with "Hâ— Hâ—¯") as "Hâ—".
+ { apply (auth_update_dealloc _ _ (GSet γsps')).
+ apply gset_disj_dealloc_local_update. }
+ iMod (saved_prop_alloc_cofinite γsps' R1) as (γsp1 Hγsp1) "#Hsp1".
+ iMod (saved_prop_alloc_cofinite (γsps' ∪ {[ γsp1 ]}) R2)
+ as (γsp2 [? ?%not_elem_of_singleton]%not_elem_of_union) "#Hsp2".
+ iMod (own_update _ _ (◠_ ⋅ (◯ GSet {[ γsp1 ]} ⋅ ◯ (GSet {[ γsp2 ]})))
+ with "Hâ—") as "(Hâ— & Hâ—¯1 & Hâ—¯2)".
+ { rewrite -auth_frag_op gset_disj_union; last set_solver.
+ apply auth_update_alloc, (gset_disj_alloc_empty_local_update _ {[ γsp1; γsp2 ]}).
+ set_solver. }
+ iMod "H3" as "_".
+ iMod ("Hclose" with "[HR Hl HRs Hsaved Hâ—]") as "_".
+ { iModIntro. iExists b, ({[γsp1; γsp2]} ∪ γsps'),
+ (fun g => if (decide (g = γsp1)) then R1 else if (decide (g = γsp2)) then R2 else oracle g).
+ iIntros "{$Hl $Hâ—}".
+ iDestruct (big_sepS_delete with "Hsaved") as "[HRsaved Hsaved]"; first done.
+ iSplitL "HR HRs HRsaved".
+ - iIntros "HP". iSpecialize ("HRs" with "HP").
+ iDestruct (saved_prop_agree with "Hsp HRsaved") as "#Heq".
+ iNext.
+ iDestruct (big_sepS_delete with "HRs") as "[HR'' HRs]"; first done.
+ iApply big_sepS_union; [set_solver|iSplitL "HR HR'' HRsaved"]; first last.
+ {
+ subst γsps'. iApply big_opS_forall. 2: iApply "HRs". cbn. intros γ' Hin.
+ destruct (decide (γ' = γsp1)) as [-> |_]. 1: by destruct Hγsp1.
+ destruct (decide (γ' = γsp2)) as [-> |_]. 1: by destruct H0.
+ reflexivity.
+ }
+ iApply big_sepS_union; [set_solver|].
+ iAssert (R')%I with "[HR'']" as "HR'"; [by iRewrite "Heq"|].
+ iDestruct ("HR" with "HR'") as "[HR1 HR2]".
+ iSplitL "HR1".
+ + iApply big_sepS_singleton. rewrite decide_True; done.
+ + iApply big_sepS_singleton. rewrite decide_False; [by rewrite decide_True | done].
+ - iApply big_sepS_union; [set_solver| iSplitR "Hsaved"]; first last.
+ {
+ subst γsps'. iApply big_opS_forall. 2: iApply "Hsaved". cbn. intros γ' Hin.
+ destruct (decide (γ' = γsp1)) as [-> | _]. by destruct Hγsp1.
+ destruct (decide (γ' = γsp2)) as [-> | _]. by destruct H0.
+ reflexivity.
+ }
+ iApply big_sepS_union; [set_solver|]; rewrite !big_sepS_singleton.
+ iSplitL.
+ + rewrite decide_True; done.
+ + rewrite decide_False; [by rewrite decide_True | done].
+ }
+ iModIntro; iSplitL "Hâ—¯1".
+ - iExists γ, P, R1, γsp1. iFrame; auto.
+ - iExists γ, P, R2, γsp2. iFrame; auto.
+Qed.
+
+Lemma recv_weaken l P1 P2 : (P1 -∗ P2) -∗ recv l P1 -∗ recv l P2.
+Proof.
+ iIntros "HP". iDestruct 1 as (γ P R' i) "(#Hinv & HR & H◯)".
+ iExists γ, P, R', i. iIntros "{$Hinv $H◯} !> HR'". iApply "HP". by iApply "HR".
+Qed.
+
+Lemma recv_mono l P1 P2 : (P1 ⊢ P2) → recv l P1 ⊢ recv l P2.
+Proof. iIntros (HP) "H". iApply (recv_weaken with "[] H"). iApply HP. Qed.
+End proof.
+
+Typeclasses Opaque send recv.
diff --git a/theories/examples/safety/barrier/specification.v b/theories/examples/safety/barrier/specification.v
new file mode 100644
index 0000000000000000000000000000000000000000..99ff884328117d9c1b337e3c29a74810303a5648
--- /dev/null
+++ b/theories/examples/safety/barrier/specification.v
@@ -0,0 +1,30 @@
+From iris.program_logic Require Export hoare.
+From iris.heap_lang Require Import proofmode.
+From iris.examples.safety.barrier Require Export barrier.
+From iris.examples.safety.barrier Require Import proof.
+Set Default Proof Using "Type".
+Import uPred.
+
+Section spec.
+Local Set Default Proof Using "Type*".
+Context `{Σ : gFunctors SI} `{!heapG Σ, !barrierG Σ}.
+
+Lemma barrier_spec (N : namespace) :
+ ∃ recv send : loc → iProp Σ -n> iProp Σ,
+ (∀ P, ⊢ {{ True }} newbarrier #()
+ {{ v, ∃ l : loc, ⌜v = #l⌠∗ recv l P ∗ send l P }}) ∧
+ (∀ l P, ⊢ {{ send l P ∗ P }} signal #l {{ _, True }}) ∧
+ (∀ l P, ⊢ {{ recv l P }} wait #l {{ _, P }}) ∧
+ (∀ l P Q, recv l (P ∗ Q) -∗ |={↑N, ∅}=> ▷ |={∅, ↑N}=> recv l P ∗ recv l Q) ∧
+ (∀ l P Q, (P -∗ Q) -∗ recv l P -∗ recv l Q).
+Proof.
+ exists (λ l, OfeMor (recv N l)), (λ l, OfeMor (send N l)).
+ split_and?; simpl.
+ - iIntros (P) "!# _". iApply (newbarrier_spec _ P with "[]"); [done..|].
+ iNext. eauto.
+ - iIntros (l P) "!# [Hl HP]". iApply (signal_spec with "[$Hl $HP]"). by eauto.
+ - iIntros (l P) "!# Hl". iApply (wait_spec with "Hl"). eauto.
+ - iIntros (l P Q). by iApply recv_split.
+ - apply recv_weaken.
+Qed.
+End spec.
diff --git a/theories/heap_lang/lib/clairvoyant_coin.v b/theories/examples/safety/clairvoyant_coin.v
similarity index 96%
rename from theories/heap_lang/lib/clairvoyant_coin.v
rename to theories/examples/safety/clairvoyant_coin.v
index 87aa3c437ab14a599e9a3bf95eb09b75bfd17394..bdd909074fb0a1f08f95f7fbfa04fccef630298e 100644
--- a/theories/heap_lang/lib/clairvoyant_coin.v
+++ b/theories/examples/safety/clairvoyant_coin.v
@@ -1,7 +1,7 @@
From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
-From iris.heap_lang.lib Require Export nondet_bool.
+From iris.examples.safety Require Export nondet_bool.
(** The clairvoyant coin predicts all the values that it will
*non-deterministically* choose throughout the execution of the
@@ -23,7 +23,7 @@ Definition toss_coin : val :=
"c" <- "r";; resolve_proph: "p" to: "r";; #().
Section proof.
- Context `{!heapG Σ}.
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
Definition prophecy_to_list_bool (vs : list (val * val)) : list bool :=
(λ v, bool_decide (v = #true)) ∘ snd <$> vs.
diff --git a/theories/heap_lang/lib/counter.v b/theories/examples/safety/counter.v
similarity index 78%
rename from theories/heap_lang/lib/counter.v
rename to theories/examples/safety/counter.v
index 4b7058988290aa68957ca306c2dfbbf50ef5030a..27381bf55af1322ad4ac0fc409c2aff384ee75ce 100644
--- a/theories/heap_lang/lib/counter.v
+++ b/theories/examples/safety/counter.v
@@ -13,14 +13,14 @@ Definition incr : val := rec: "incr" "l" :=
Definition read : val := λ: "l", !"l".
(** Monotone counter *)
-Class mcounterG Σ := MCounterG { mcounter_inG :> inG Σ (authR mnatUR) }.
-Definition mcounterΣ : gFunctors := #[GFunctor (authR mnatUR)].
+Class mcounterG {SI} (Σ: gFunctors SI) := MCounterG { mcounter_inG :> inG Σ (authR (mnatUR SI)) }.
+Definition mcounterΣ {SI} : gFunctors SI := #[GFunctor (authR (mnatUR SI))].
-Instance subG_mcounterΣ {Σ} : subG mcounterΣ Σ → mcounterG Σ.
+Instance subG_mcounterΣ {SI} {Σ: gFunctors SI} : subG mcounterΣ Σ → mcounterG Σ.
Proof. solve_inG. Qed.
Section mono_proof.
- Context `{!heapG Σ, !mcounterG Σ} (N : namespace).
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !mcounterG Σ} (N : namespace).
Definition mcounter_inv (γ : gname) (l : loc) : iProp Σ :=
(∃ n, own γ (◠(n : mnat)) ∗ l ↦ #n)%I.
@@ -48,10 +48,11 @@ Section mono_proof.
Proof.
iIntros (Φ) "Hl HΦ". iLöb as "IH". wp_rec.
iDestruct "Hl" as (γ) "[#? Hγf]".
- wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]".
+ wp_bind (! _)%E.
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
wp_load. iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
wp_pures. wp_bind (CmpXchg _ _ _).
- iInv N as (c') ">[Hγ Hl]".
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c') "[Hγ Hl]".
destruct (decide (c' = c)) as [->|].
- iDestruct (own_valid_2 with "Hγ Hγf")
as %[?%mnat_included _]%auth_both_valid.
@@ -66,35 +67,36 @@ Section mono_proof.
- wp_cmpxchg_fail; first (by intros [= ?%Nat2Z.inj]). iModIntro.
iSplitL "Hl Hγ"; [iNext; iExists c'; by iFrame|].
wp_pures. iApply ("IH" with "[Hγf] [HΦ]"); last by auto.
- rewrite {3}/mcounter; eauto 10.
+ rewrite {3}/mcounter; simpl; eauto 10.
Qed.
Lemma read_mono_spec l j :
{{{ mcounter l j }}} read #l {{{ i, RET #i; ⌜j ≤ iâŒ%nat ∧ mcounter l i }}}.
Proof.
iIntros (ϕ) "Hc HΦ". iDestruct "Hc" as (γ) "[#Hinv Hγf]".
- rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hl]".
+ rewrite /read /=. wp_lam.
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
wp_load.
iDestruct (own_valid_2 with "Hγ Hγf")
as %[?%mnat_included _]%auth_both_valid.
iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
{ apply auth_update, (mnat_local_update _ _ c); auto. }
iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- iApply ("HΦ" with "[-]"). rewrite /mcounter; eauto 10.
+ iApply ("HΦ" with "[-]"). rewrite /mcounter; simpl; eauto 10.
Qed.
End mono_proof.
(** Counter with contributions *)
-Class ccounterG Σ :=
- CCounterG { ccounter_inG :> inG Σ (frac_authR natR) }.
-Definition ccounterΣ : gFunctors :=
- #[GFunctor (frac_authR natR)].
+Class ccounterG {SI} Σ :=
+ CCounterG { ccounter_inG :> inG Σ (frac_authR (natR SI)) }.
+Definition ccounterΣ {SI} : gFunctors SI :=
+ #[GFunctor (frac_authR (natR SI))].
-Instance subG_ccounterΣ {Σ} : subG ccounterΣ Σ → ccounterG Σ.
+Instance subG_ccounterΣ {SI} {Σ: gFunctors SI} : subG ccounterΣ Σ → ccounterG Σ.
Proof. solve_inG. Qed.
Section contrib_spec.
- Context `{!heapG Σ, !ccounterG Σ} (N : namespace).
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !ccounterG Σ} (N : namespace).
Definition ccounter_inv (γ : gname) (l : loc) : iProp Σ :=
(∃ n, own γ (â—F n) ∗ l ↦ #n)%I.
@@ -127,10 +129,11 @@ Section contrib_spec.
{{{ RET #(); ccounter γ q (S n) }}}.
Proof.
iIntros (Φ) "[#? Hγf] HΦ". iLöb as "IH". wp_rec.
- wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]".
+ wp_bind (! _)%E.
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
wp_load. iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
wp_pures. wp_bind (CmpXchg _ _ _).
- iInv N as (c') ">[Hγ Hl]".
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c') "[Hγ Hl]".
destruct (decide (c' = c)) as [->|].
- iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
{ apply frac_auth_update, (nat_local_update _ _ (S c) (S n)); lia. }
@@ -147,10 +150,12 @@ Section contrib_spec.
{{{ c, RET #c; ⌜n ≤ câŒ%nat ∧ ccounter γ q n }}}.
Proof.
iIntros (Φ) "[#? Hγf] HΦ".
- rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hl]". wp_load.
+ rewrite /read /=. wp_lam.
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
+ wp_load.
iDestruct (own_valid_2 with "Hγ Hγf") as % ?%frac_auth_included_total%nat_included.
iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
- iApply ("HΦ" with "[-]"); rewrite /ccounter; eauto 10.
+ iApply ("HΦ" with "[-]"); rewrite /ccounter; simpl; eauto 10.
Qed.
Lemma read_contrib_spec_1 γ l n :
@@ -158,7 +163,9 @@ Section contrib_spec.
{{{ n, RET #n; ccounter γ 1 n }}}.
Proof.
iIntros (Φ) "[#? Hγf] HΦ".
- rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hl]". wp_load.
+ rewrite /read /=. wp_lam.
+ wp_swp 1%nat. iInv N as "H". swp_step. iNext. iDestruct "H" as (c) "[Hγ Hl]".
+ wp_load.
iDestruct (own_valid_2 with "Hγ Hγf") as % <-%frac_auth_agreeL.
iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
by iApply "HΦ".
diff --git a/theories/heap_lang/lib/lazy_coin.v b/theories/examples/safety/lazy_coin.v
similarity index 95%
rename from theories/heap_lang/lib/lazy_coin.v
rename to theories/examples/safety/lazy_coin.v
index c1acf7ed59d9bbca07479f2a67ae4579c07872ae..adb4ee3da2f569bdc4d9041c4bf4ab08e583a7de 100644
--- a/theories/heap_lang/lib/lazy_coin.v
+++ b/theories/examples/safety/lazy_coin.v
@@ -1,7 +1,7 @@
From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
-From iris.heap_lang.lib Require Export nondet_bool.
+From iris.examples.safety Require Export nondet_bool.
Definition new_coin: val := λ: <>, (ref NONE, NewProph).
@@ -16,7 +16,7 @@ Definition read_coin : val :=
end.
Section proof.
- Context `{!heapG Σ}.
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
Definition val_to_bool (v : val) : bool := bool_decide (v = #true).
diff --git a/theories/heap_lang/lib/lock.v b/theories/examples/safety/lock.v
similarity index 79%
rename from theories/heap_lang/lib/lock.v
rename to theories/examples/safety/lock.v
index a5d9966a25060e0ffdd20dc6bc361e9bf7ee8dae..df71e47bfb2ead4c680224483056406553680142 100644
--- a/theories/heap_lang/lib/lock.v
+++ b/theories/examples/safety/lock.v
@@ -2,7 +2,7 @@ From iris.heap_lang Require Export lifting notation.
From iris.base_logic.lib Require Export invariants.
Set Default Proof Using "Type".
-Structure lock Σ `{!heapG Σ} := Lock {
+Structure lock {SI} (Σ: gFunctors SI) `{!heapG Σ} := Lock {
(* -- operations -- *)
newlock : val;
acquire : val;
@@ -26,14 +26,14 @@ Structure lock Σ `{!heapG Σ} := Lock {
{{{ is_lock N γ lk R ∗ locked γ ∗ R }}} release lk {{{ RET #(); True }}}
}.
-Arguments newlock {_ _} _.
-Arguments acquire {_ _} _.
-Arguments release {_ _} _.
-Arguments is_lock {_ _} _ _ _ _ _.
-Arguments locked {_ _} _ _.
+Arguments newlock {_ _ _} _.
+Arguments acquire {_ _ _} _.
+Arguments release {_ _ _} _.
+Arguments is_lock {_ _ _} _ _ _ _ _.
+Arguments locked {_ _ _} _ _.
Existing Instances is_lock_ne is_lock_persistent locked_timeless.
-Instance is_lock_proper Σ `{!heapG Σ} (L: lock Σ) N γ lk:
+Instance is_lock_proper {SI} (Σ: gFunctors SI) `{!heapG Σ} (L: lock Σ) N γ lk:
Proper ((≡) ==> (≡)) (is_lock L N γ lk) := ne_proper _.
diff --git a/theories/heap_lang/lib/nondet_bool.v b/theories/examples/safety/nondet_bool.v
similarity index 73%
rename from theories/heap_lang/lib/nondet_bool.v
rename to theories/examples/safety/nondet_bool.v
index fcf7f6a03a030c776df4cd306578b1b376e4dc94..f07854e399b90414dc48604345dcc841d785c21a 100644
--- a/theories/heap_lang/lib/nondet_bool.v
+++ b/theories/examples/safety/nondet_bool.v
@@ -6,7 +6,7 @@ Definition nondet_bool : val :=
λ: <>, let: "l" := ref #true in Fork ("l" <- #false);; !"l".
Section proof.
- Context `{!heapG Σ}.
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
Lemma nondet_bool_spec : {{{ True }}} nondet_bool #() {{{ (b : bool), RET #b; True }}}.
Proof.
@@ -16,8 +16,8 @@ Section proof.
iMod (inv_alloc rndN _ (∃ (b : bool), l ↦ #b)%I with "[Hl]") as "#Hinv";
first by eauto.
wp_apply wp_fork.
- - iInv rndN as (?) "?". wp_store; eauto.
- - wp_seq. iInv rndN as (?) "?". wp_load.
+ - wp_swp 1%nat. iInv rndN as "H". swp_step. iNext. iDestruct "H" as (?) "?". wp_store; eauto.
+ - wp_seq. wp_swp 1%nat. iInv rndN as "H". swp_step. iNext. iDestruct "H" as (?) "?". wp_load.
iSplitR "HΦ"; first by eauto.
by iApply "HΦ".
Qed.
diff --git a/theories/heap_lang/lib/par.v b/theories/examples/safety/par.v
similarity index 93%
rename from theories/heap_lang/lib/par.v
rename to theories/examples/safety/par.v
index 558853f4f48d15d4eae8f61cffd88981686e4abd..57c6ea6a9ec18ffc70690cc1b20505e9eba44cc1 100644
--- a/theories/heap_lang/lib/par.v
+++ b/theories/examples/safety/par.v
@@ -1,4 +1,4 @@
-From iris.heap_lang Require Export spawn.
+From iris.examples.safety Require Export spawn.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".
Import uPred.
@@ -16,7 +16,7 @@ Notation "e1 ||| e2" := (par (λ: <>, e1)%V (λ: <>, e2)%V) : val_scope.
Section proof.
Local Set Default Proof Using "Type*".
-Context `{!heapG Σ, !spawnG Σ}.
+Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !spawnG Σ}.
(* Notice that this allows us to strip a later *after* the two Ψ have been
brought together. That is strictly stronger than first stripping a later
diff --git a/theories/heap_lang/lib/spawn.v b/theories/examples/safety/spawn.v
similarity index 82%
rename from theories/heap_lang/lib/spawn.v
rename to theories/examples/safety/spawn.v
index 7e698d52bbe39eb5b94ee5c18be0986285120d36..415dcd82ffa8330427499c0ee3dc3b9af04bf678 100644
--- a/theories/heap_lang/lib/spawn.v
+++ b/theories/examples/safety/spawn.v
@@ -19,15 +19,15 @@ Definition join : val :=
(** The CMRA & functor we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
-Class spawnG Σ := SpawnG { spawn_tokG :> inG Σ (exclR unitO) }.
-Definition spawnΣ : gFunctors := #[GFunctor (exclR unitO)].
+Class spawnG {SI} (Σ: gFunctors SI) := SpawnG { spawn_tokG :> inG Σ (exclR (unitO SI)) }.
+Definition spawnΣ SI : gFunctors SI := #[GFunctor (exclR (unitO SI))].
-Instance subG_spawnΣ {Σ} : subG spawnΣ Σ → spawnG Σ.
+Instance subG_spawnΣ {SI} {Σ: gFunctors SI} : subG (spawnΣ SI) Σ → spawnG Σ.
Proof. solve_inG. Qed.
(** Now we come to the Iris part of the proof. *)
Section proof.
-Context `{!heapG Σ, !spawnG Σ} (N : namespace).
+Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !spawnG Σ} (N : namespace).
Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
(∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌠∨
@@ -54,7 +54,7 @@ Proof.
{ iNext. iExists NONEV. iFrame; eauto. }
wp_apply (wp_fork with "[Hf]").
- iNext. wp_bind (f _). iApply (wp_wand with "Hf"); iIntros (v) "Hv".
- wp_inj. iInv N as (v') "[Hl _]".
+ wp_inj. iInv N as "H". wp_swp 1%nat. swp_step. iNext. iDestruct "H" as (v') "[Hl _]".
wp_store. iSplitL; last done. iIntros "!> !>". iExists (SOMEV v). iFrame. eauto.
- wp_pures. iApply "HΦ". rewrite /join_handle. eauto.
Qed.
@@ -63,7 +63,8 @@ Lemma join_spec (Ψ : val → iProp Σ) l :
{{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
Proof.
iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
- iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]".
+ iLöb as "IH". wp_rec. wp_bind (! _)%E.
+ iInv N as "H". wp_swp 1%nat. swp_step. iNext. iDestruct "H" as (v) "[Hl Hinv]".
wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
- iModIntro. iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
wp_apply ("IH" with "Hγ [HΦ]"). auto.
diff --git a/theories/heap_lang/lib/spin_lock.v b/theories/examples/safety/spin_lock.v
similarity index 82%
rename from theories/heap_lang/lib/spin_lock.v
rename to theories/examples/safety/spin_lock.v
index 3370bdcc298b5bb75baf9bcadd318512c61d9ca1..e73573296bf24454a80e82da79ad777480c1880d 100644
--- a/theories/heap_lang/lib/spin_lock.v
+++ b/theories/examples/safety/spin_lock.v
@@ -3,7 +3,7 @@ From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl.
-From iris.heap_lang.lib Require Import lock.
+From iris.examples.safety Require Import lock.
Set Default Proof Using "Type".
Definition newlock : val := λ: <>, ref #false.
@@ -14,14 +14,14 @@ Definition release : val := λ: "l", "l" <- #false.
(** The CMRA we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
-Class lockG Σ := LockG { lock_tokG :> inG Σ (exclR unitO) }.
-Definition lockΣ : gFunctors := #[GFunctor (exclR unitO)].
+Class lockG {SI} (Σ: gFunctors SI) := LockG { lock_tokG :> inG Σ (exclR (unitO SI)) }.
+Definition lockΣ SI : gFunctors SI := #[GFunctor (exclR (unitO SI))].
-Instance subG_lockΣ {Σ} : subG lockΣ Σ → lockG Σ.
+Instance subG_lockΣ {SI} {Σ: gFunctors SI} : subG (lockΣ SI) Σ → lockG Σ.
Proof. solve_inG. Qed.
Section proof.
- Context `{!heapG Σ, !lockG Σ} (N : namespace).
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !lockG Σ} (N : namespace).
Definition lock_inv (γ : gname) (l : loc) (R : iProp Σ) : iProp Σ :=
(∃ b : bool, l ↦ #b ∗ if b then True else own γ (Excl ()) ∗ R)%I.
@@ -61,12 +61,14 @@ Section proof.
{{{ b, RET #b; if b is true then locked γ ∗ R else True }}}.
Proof.
iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l ->) "#Hinv".
- wp_rec. wp_bind (CmpXchg _ _ _). iInv N as ([]) "[Hl HR]".
+ wp_rec. wp_bind (CmpXchg _ _ _). wp_swp. iInv N as "H". swp_step. iNext.
+ iDestruct "H" as ([]) "[Hl HR]".
- wp_cmpxchg_fail. iModIntro. iSplitL "Hl"; first (iNext; iExists true; eauto).
wp_pures. iApply ("HΦ" $! false). done.
- wp_cmpxchg_suc. iDestruct "HR" as "[Hγ HR]".
iModIntro. iSplitL "Hl"; first (iNext; iExists true; eauto).
rewrite /locked. wp_pures. by iApply ("HΦ" $! true with "[$Hγ $HR]").
+ Unshelve. exact 0%nat.
Qed.
Lemma acquire_spec γ lk R :
@@ -83,14 +85,16 @@ Section proof.
Proof.
iIntros (Φ) "(Hlock & Hlocked & HR) HΦ".
iDestruct "Hlock" as (l ->) "#Hinv".
- rewrite /release /=. wp_lam. iInv N as (b) "[Hl _]".
+ rewrite /release /=. wp_lam. wp_swp. iInv N as "H". swp_step. iNext.
+ iDestruct "H" as (b) "[Hl _]".
wp_store. iSplitR "HΦ"; last by iApply "HΦ".
iModIntro. iNext. iExists false. by iFrame.
+ Unshelve. exact 0%nat.
Qed.
End proof.
Typeclasses Opaque is_lock locked.
-Canonical Structure spin_lock `{!heapG Σ, !lockG Σ} : lock Σ :=
+Canonical Structure spin_lock {SI} {Σ: gFunctors SI} `{!heapG Σ, !lockG Σ} : lock Σ :=
{| lock.locked_exclusive := locked_exclusive; lock.newlock_spec := newlock_spec;
lock.acquire_spec := acquire_spec; lock.release_spec := release_spec |}.
diff --git a/theories/heap_lang/lib/ticket_lock.v b/theories/examples/safety/ticket_lock.v
similarity index 83%
rename from theories/heap_lang/lib/ticket_lock.v
rename to theories/examples/safety/ticket_lock.v
index 5600f18d9fd5495eb91bbe97dd9723755b8dfdcf..104824ac19b9f11f4665501309e1232f62349f31 100644
--- a/theories/heap_lang/lib/ticket_lock.v
+++ b/theories/examples/safety/ticket_lock.v
@@ -3,7 +3,7 @@ From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl auth gset.
-From iris.heap_lang.lib Require Export lock.
+From iris.examples.safety Require Export lock.
Set Default Proof Using "Type".
Import uPred.
@@ -28,16 +28,16 @@ Definition release : val :=
λ: "lk", (Fst "lk") <- !(Fst "lk") + #1.
(** The CMRAs we need. *)
-Class tlockG Σ :=
- tlock_G :> inG Σ (authR (prodUR (optionUR (exclR natO)) (gset_disjUR nat))).
-Definition tlockΣ : gFunctors :=
- #[ GFunctor (authR (prodUR (optionUR (exclR natO)) (gset_disjUR nat))) ].
+Class tlockG {SI} (Σ: gFunctors SI) :=
+ tlock_G :> inG Σ (authR (prodUR (optionUR (exclR (natO SI))) (gset_disjUR nat))).
+Definition tlockΣ {SI} : gFunctors SI :=
+ #[ GFunctor (authR (prodUR (optionUR (exclR (natO SI))) (gset_disjUR nat))) ].
-Instance subG_tlockΣ {Σ} : subG tlockΣ Σ → tlockG Σ.
+Instance subG_tlockΣ {SI} {Σ: gFunctors SI} : subG tlockΣ Σ → tlockG Σ.
Proof. solve_inG. Qed.
Section proof.
- Context `{!heapG Σ, !tlockG Σ} (N : namespace).
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ, !tlockG Σ} (N : namespace).
Definition lock_inv (γ : gname) (lo ln : loc) (R : iProp Σ) : iProp Σ :=
(∃ o n : nat,
@@ -88,13 +88,13 @@ Section proof.
Proof.
iIntros (Φ) "[Hl Ht] HΦ". iDestruct "Hl" as (lo ln ->) "#Hinv".
iLöb as "IH". wp_rec. subst. wp_pures. wp_bind (! _)%E.
- iInv N as (o n) "(Hlo & Hln & Ha)".
+ wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o n) "(Hlo & Hln & Ha)".
wp_load. destruct (decide (x = o)) as [->|Hneq].
- iDestruct "Ha" as "[Hainv [[Ho HR] | Haown]]".
+ iModIntro. iSplitL "Hlo Hln Hainv Ht".
{ iNext. iExists o, n. iFrame. }
wp_pures. case_bool_decide; [|done]. wp_if.
- iApply ("HΦ" with "[-]"). rewrite /locked. iFrame. eauto.
+ iApply ("HΦ" with "[-]"). rewrite /locked. iFrame. simpl. eauto.
+ iDestruct (own_valid_2 with "Ht Haown") as % [_ ?%gset_disj_valid_op].
set_solver.
- iModIntro. iSplitL "Hlo Hln Ha".
@@ -108,11 +108,11 @@ Section proof.
Proof.
iIntros (ϕ) "Hl HΦ". iDestruct "Hl" as (lo ln ->) "#Hinv".
iLöb as "IH". wp_rec. wp_bind (! _)%E. simplify_eq/=. wp_proj.
- iInv N as (o n) "[Hlo [Hln Ha]]".
+ wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o n) "(Hlo & Hln & Ha)".
wp_load. iModIntro. iSplitL "Hlo Hln Ha".
{ iNext. iExists o, n. by iFrame. }
wp_pures. wp_bind (CmpXchg _ _ _).
- iInv N as (o' n') "(>Hlo' & >Hln' & >Hauth & Haown)".
+ wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o' n') "(Hlo' & Hln' & Hauth & Haown)".
destruct (decide (#n' = #n))%V as [[= ->%Nat2Z.inj] | Hneq].
- iMod (own_update with "Hauth") as "[Hauth Hofull]".
{ eapply auth_update_alloc, prod_local_update_2.
@@ -138,15 +138,15 @@ Section proof.
iIntros (Φ) "(Hl & Hγ & HR) HΦ". iDestruct "Hl" as (lo ln ->) "#Hinv".
iDestruct "Hγ" as (o) "Hγo".
wp_lam. wp_proj. wp_bind (! _)%E.
- iInv N as (o' n) "(>Hlo & >Hln & >Hauth & Haown)".
+ wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o' n) "(Hlo & Hln & Hauth & Haown)".
wp_load.
iDestruct (own_valid_2 with "Hauth Hγo") as
%[[<-%Excl_included%leibniz_equiv _]%prod_included _]%auth_both_valid.
iModIntro. iSplitL "Hlo Hln Hauth Haown".
{ iNext. iExists o, n. by iFrame. }
wp_pures.
- iInv N as (o' n') "(>Hlo & >Hln & >Hauth & Haown)".
- iApply wp_fupd. wp_store.
+ wp_swp 1%nat. iInv N as "Hlock". swp_step. iNext. iDestruct "Hlock" as (o' n') "(Hlo & Hln & Hauth & Haown)".
+ iApply swp_fupd. wp_store.
iDestruct (own_valid_2 with "Hauth Hγo") as
%[[<-%Excl_included%leibniz_equiv _]%prod_included _]%auth_both_valid.
iDestruct "Haown" as "[[Hγo' _]|Haown]".
@@ -162,6 +162,6 @@ End proof.
Typeclasses Opaque is_lock issued locked.
-Canonical Structure ticket_lock `{!heapG Σ, !tlockG Σ} : lock Σ :=
+Canonical Structure ticket_lock {SI} {Σ: gFunctors SI} `{!heapG Σ, !tlockG Σ} : lock Σ :=
{| lock.locked_exclusive := locked_exclusive; lock.newlock_spec := newlock_spec;
lock.acquire_spec := acquire_spec; lock.release_spec := release_spec |}.
diff --git a/theories/examples/termination/adequacy.v b/theories/examples/termination/adequacy.v
new file mode 100644
index 0000000000000000000000000000000000000000..d46c9b883d8022bd490f914dd685e645184c8aea
--- /dev/null
+++ b/theories/examples/termination/adequacy.v
@@ -0,0 +1,67 @@
+From iris.program_logic.refinement Require Export ref_weakestpre ref_source seq_weakestpre.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From iris.heap_lang Require Export lang lifting.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation metatheory.
+From iris.algebra Require Import auth gmap excl frac agree.
+From iris.program_logic Require Import ref_adequacy.
+From iris.examples Require Import refinement.
+Set Default Proof Using "Type".
+
+
+(* Adequacy Theorem *)
+Section adequacy.
+ Context {SI} `{C: Classical} {Σ: gFunctors SI} {Hlarge: LargeIndex SI}.
+ Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA SI))}.
+
+ Theorem heap_lang_ref_adequacy (e: expr) σ:
+ (∀ `{heapG SI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA SI)},
+ True ⊢ (∃ α, $α -∗ SEQ e ⟨⟨ v, True ⟩⟩)%I
+ ) →
+ sn erased_step ([e], σ).
+ Proof using C Hlarge Σ Hpre Hna Htc.
+ intros Hobj.
+ (* allocate the heap *)
+ edestruct (satisfiable_at_gen_heap nil σ) as [Hheap Hsat].
+ (* allocate sequential invariants *)
+ eapply satisfiable_update_alloc in Hsat as [seqG_name Hsat]; last apply na_alloc.
+ pose (seq := {| seqG_na_invG := _; seqG_name := seqG_name |}).
+ (* allocte stuttering credits *)
+ eapply (satisfiable_at_alloc (â— zero â‹… â—¯ zero)) in Hsat as [authG_name Hsat]; last first.
+ { apply auth_both_valid; by split. }
+ pose (stutter := {| sourceG_inG := _; sourceG_name := authG_name |}).
+ specialize (Hobj Hheap seq stutter).
+ eapply satisfiable_at_mono with (Q := (∃ α: Ord, _)%I) in Hsat; last first.
+ { iIntros "H". iPoseProof (Hobj with "[//]") as (α) "Hwp".
+ iExists α. iCombine "H Hwp" as "H". iExact "H". }
+ eapply satisfiable_at_exists in Hsat as [α Hsat]; last apply _.
+ eapply satisfiable_at_mono with (Q := (|={⊤}=> _)%I) in Hsat; last first.
+ - iIntros "[[[[SI _] Hna] [Hc Hc']] Hwp]".
+ iMod (own_update_2 _ _ _ (◠α ⋅ ◯ α) with "Hc Hc'") as "[Hc Hc']".
+ { rewrite -[α]natural_addition_zero_left_id natural_addition_comm -ord_op_plus.
+ eapply auth_update, op_local_update_discrete; done. }
+ iSpecialize ("Hwp" with "Hc' Hna").
+ iCombine "Hc SI Hwp" as "G". iExact "G".
+ - eapply satisfiable_at_fupd in Hsat as Hsat.
+ eapply (rwp_sn_preservation _ (α) _ _ 0); first apply index_lt_wf.
+ eapply satisfiable_at_mono; first apply Hsat.
+ iIntros "($ & $ & $)".
+ Qed.
+
+End adequacy.
+
+Section adequacy_ord.
+ (* result for the ordinal step-index type *)
+ Context `{C: Classical} {Σ: gFunctors ordI}.
+ Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA ordI))}.
+ Theorem heap_lang_ref_adequacy_ord (e: expr) σ:
+ (∀ `{heapG ordI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA ordI)},
+ True ⊢ (∃ α, $α -∗ SEQ e ⟨⟨ v, True ⟩⟩)%I
+ ) →
+ sn erased_step ([e], σ).
+ Proof using C Σ Hpre Hna Htc.
+ apply heap_lang_ref_adequacy.
+ Qed.
+ Print Assumptions heap_lang_ref_adequacy_ord.
+
+End adequacy_ord.
diff --git a/theories/examples/termination/eventloop.v b/theories/examples/termination/eventloop.v
new file mode 100644
index 0000000000000000000000000000000000000000..de992cf02a315d01d7ef9853d33d0689441c0a18
--- /dev/null
+++ b/theories/examples/termination/eventloop.v
@@ -0,0 +1,211 @@
+From iris.program_logic.refinement Require Export seq_weakestpre.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From iris.heap_lang Require Export lang lifting.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation metatheory.
+From iris.algebra Require Import auth.
+From iris.algebra.ordinals Require Import arithmetic.
+Set Default Proof Using "Type".
+
+Section eventloop_code.
+ Definition new_stack : val := λ: <>, ref NONEV.
+
+ Definition push : val := λ: "s", λ: "x",
+ let: "hd" := !"s" in
+ let: "p" := ("x", "hd") in
+ "s" <- SOME (ref "p").
+
+ Definition pop : val := (λ: "s",
+ let: "hd" := !"s" in
+ match: "hd" with
+ NONE => NONE
+ | SOME "l" =>
+ let: "p" := !"l" in
+ let: "x" := Fst "p" in
+ "s" <- Snd "p" ;; SOME "x"
+ end).
+
+ Definition enqueue : val := push.
+
+ Definition run : val :=
+ λ: "q", rec: "run" <> :=
+ match: pop "q" with
+ NONE => #()
+ | SOME "f" => "f" #() ;; "run" #()
+ end.
+
+ Definition mkqueue : val :=
+ λ: <>, new_stack #().
+
+End eventloop_code.
+Section eventloop_spec.
+
+ Context {SI} {Σ: gFunctors SI} `{Hheap: !heapG Σ} `{Htc: !tcG Σ} `{Hseq: !seqG Σ} (N : namespace).
+
+ Implicit Types (l: loc).
+
+ Fixpoint stack_contents (hd: val) (xs: list val) (φ: val → iProp Σ) :=
+ match xs with
+ | [] => ⌜hd = NONEVâŒ
+ | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌠∗ l ↦ (x, hd') ∗ φ x ∗ stack_contents hd' xs φ
+ end%I.
+ Definition stack (l: loc) (xs: list val) (φ: val → iProp Σ): iProp Σ := (∃ hd, l ↦ hd ∗ stack_contents hd xs φ)%I.
+ Definition queue (q: val) : iProp Σ := (∃ l, ⌜q = #l⌠∗ na_inv seqG_name (N .@ l) (∃ xs, stack l xs (λ f, $ one ∗ SEQ f #() [{_, True}])))%I.
+
+
+ Lemma new_stack_spec φ:
+ sbi_emp_valid (WP (new_stack #()) [{ v, ∃ l, ⌜v = #l⌠∗ stack l nil φ }])%I.
+ Proof.
+ rewrite /new_stack. wp_pures.
+ wp_alloc l as "Hl". iFrame.
+ rewrite /stack. iExists l; iSplit; auto.
+ Qed.
+
+ Lemma push_spec l xs φ (x : val):
+ (stack l xs φ ∗ φ x ⊢ RSWP (push #l x) at 0 ⟨⟨ v, ⌜v = #()⌠∗ stack l (x :: xs) φ ⟩⟩)%I.
+ Proof.
+ iIntros "(Hstack & Hφ)".
+ rewrite /push /stack. wp_pures.
+ iDestruct "Hstack" as (hd) "[Hl cont]".
+ wp_load. wp_pures. wp_alloc r as "Hr". rewrite -tcwp_rwp.
+ wp_store. iSplit; auto. iExists (SOMEV #r). iFrame "Hl".
+ simpl. iExists r, hd. by iFrame.
+ Qed.
+
+ Lemma pop_element_spec l xs φ (x : val):
+ (stack l (x :: xs) φ ⊢ RSWP (pop #l) at 0 ⟨⟨ v, ⌜v = SOMEV x⌠∗ φ x ∗ stack l xs φ ⟩⟩)%I.
+ Proof.
+ iIntros "Hstack".
+ rewrite /pop /stack. wp_pures.
+ iDestruct "Hstack" as (hd) "[Hl Hcont]".
+ iDestruct "Hcont" as (r hd') "(-> & Hr & Hφ & Hcont)".
+ wp_load. wp_pures. wp_load. wp_pures. wp_store. wp_pures; iFrame.
+ iSplit; eauto. iExists hd'. iFrame.
+ Qed.
+
+ Lemma pop_empty_spec l φ:
+ (stack l nil φ ⊢ RSWP (pop #l) at 0 ⟨⟨ v, ⌜v = NONEV⌠∗ stack l nil φ ⟩⟩)%I.
+ Proof.
+ iIntros "Hstack".
+ rewrite /pop /stack. wp_pures.
+ iDestruct "Hstack" as (hd) "[Hl ->]".
+ wp_load. wp_pures; iSplit; eauto.
+ Qed.
+
+ Lemma run_spec `{FiniteBoundedExistential SI} q :
+ queue q ∗ $ one ⊢ SEQ (run q #()) [{v, ⌜v = #()⌠}].
+ Proof.
+ iIntros "[#Q Hc] Hna". rewrite /run. do 2 wp_pure _.
+ iLöb as "IH". wp_pures.
+ wp_bind (pop _). iDestruct "Q" as (l) "[-> I]".
+ iMod (na_inv_acc_open _ _ _ with "I Hna") as "Hinv"; auto.
+ iApply (tcwp_burn_credit with "Hc"); first done.
+ iNext. iDestruct "Hinv" as "(Hinv & Hna & Hclose)".
+ iDestruct "Hinv" as (xs) "Hstack".
+ destruct xs as [|f xs].
+ - iPoseProof (pop_empty_spec with "Hstack") as "Hwp".
+ iApply (rswp_wand with "Hwp"). iIntros (v) "[-> Hstack]".
+ iMod ("Hclose" with "[Hstack $Hna]") as "Hna"; eauto.
+ wp_pures. by iFrame.
+ - iPoseProof (pop_element_spec with "Hstack") as "Hwp".
+ iApply (rswp_wand with "Hwp"). iIntros (v) "[-> [[Hone Hwp] Hstack]]".
+ iMod ("Hclose" with "[Hstack $Hna]") as "Hna"; eauto.
+ wp_pures. iSpecialize ("Hwp" with "Hna").
+ wp_bind (f _).
+ iApply (rwp_wand with "Hwp"). iIntros (v) "[Hna _]".
+ do 2 wp_pure _. rewrite -tcwp_rwp.
+ iApply ("IH" with "Hone Hna").
+ Qed.
+
+ Lemma enqueue_spec `{FiniteBoundedExistential SI} q (f: val) :
+ queue q ∗ $ one ∗ $ one ∗ SEQ (f #()) [{ _, True }] ⊢ SEQ (enqueue q f) [{v, ⌜v = #()⌠}].
+ Proof.
+ iIntros "[#Q [Hc Hf]] Hna". rewrite /enqueue.
+ iDestruct "Q" as (l) "[-> I]".
+ iMod (na_inv_acc_open _ _ _ with "I Hna") as "Hinv"; auto.
+ iApply (tcwp_burn_credit with "Hc"); first done.
+ iNext. iDestruct "Hinv" as "(Hinv & Hna & Hclose)".
+ iDestruct "Hinv" as (xs) "Hstack".
+ iPoseProof (push_spec with "[$Hstack $Hf]") as "Hpush".
+ iApply (rswp_strong_mono with "Hpush"); auto.
+ iIntros (v) "(-> & Hstack)". iMod ("Hclose" with "[Hstack $Hna]"); eauto.
+ Qed.
+
+ Lemma mkqueue_spec :
+ sbi_emp_valid (SEQ (mkqueue #()) [{ q, queue q}])%I.
+ Proof.
+ iIntros "Hna". rewrite /mkqueue. wp_pures.
+ iMod (new_stack_spec) as "_".
+ iIntros (v) "H". iDestruct "H" as (l) "[-> Hstack]".
+ iMod (na_inv_alloc with "[Hstack]"); last first.
+ { iModIntro. iFrame. iExists l. iSplit; eauto. }
+ iNext. by iExists nil.
+ Qed.
+
+End eventloop_spec.
+
+
+
+
+
+Section open_example.
+
+ Variable external_code: val.
+ Variable print: val.
+ Variable q: val.
+ Context {SI} {Σ: gFunctors SI} `{Hheap: !heapG Σ} `{Htc: !tcG Σ} `{Hseq: !seqG Σ} (N : namespace).
+
+
+ Definition for_loop: val :=
+ (rec: "loop" "f" "n" :=
+ if: "n" ≤ #0 then #() else let: "m" := "n" - #1 in "f" #() ;; "loop" "f" "m")%V.
+
+ Notation "'for:' n 'do' e" := (for_loop (λ: <>, e)%V n%V) (at level 200, n at level 200, e at level 200) : val_scope.
+ Notation "'for:' n 'do' e" := (for_loop (λ: <>, e)%E n%E) (at level 200, n at level 200, e at level 200) : expr_scope.
+
+ Definition example : expr :=
+ let: "n" := external_code #() in
+ for: "n" do
+ enqueue q (λ: <>, print "Hello World!").
+
+ Lemma for_zero e:
+ sbi_emp_valid (WP (for: #0 do e)%V [{ v, ⌜v = #()⌠}])%I.
+ Proof.
+ rewrite /for_loop; by wp_pures.
+ Qed.
+
+ Lemma for_val (n: nat) e φ:
+ WP (for: #n do e)%V [{v, φ v}] ⊢ WP (for: #n do e) [{ v, φ v }].
+ Proof.
+ rewrite /for_loop; iIntros "H". by wp_pure _.
+ Qed.
+
+
+ Lemma for_succ (n: nat) e φ:
+ WP e;; (for: #n do e)%V [{v, φ v}] ⊢ WP (for: #(S n) do e)%V [{ v, φ v }].
+ Proof.
+ rewrite /for_loop; iIntros "H". wp_pures.
+ by replace (S n - 1) with (n: Z) by lia.
+ Qed.
+
+ Lemma example_spec `{FiniteBoundedExistential SI}:
+ queue N q ∗ $ (omul one) ∗ SEQ external_code #() [{ v, ∃ n: nat, ⌜v = #n⌠}] ∗ (□ ∀ s: string, SEQ print s [{ _, True }]) ⊢
+ SEQ example [{ _, True }].
+ Proof.
+ iIntros "(#Q & Hc & Hwp & #Hprint) Hna". rewrite /example.
+ wp_bind (external_code _). iMod ("Hwp" with "Hna") as "_".
+ iIntros (v) "[Hna Hn] !>". iDestruct "Hn" as (n) "->".
+ do 2 wp_pure _. iApply (tc_weaken (omul one) (natmul (n * 2)%nat one)); auto; first apply (ord_stepindex.limit_upper_bound (λ n, natmul n one)).
+ iFrame "Hc". iIntros "Hc". iApply for_val.
+ iInduction n as [|n] "IH".
+ - iMod (for_zero) as "_"; iFrame; auto.
+ - simpl. rewrite !tc_split. iDestruct "Hc" as "(Ho & Ho' & Hc)".
+ iApply for_succ. wp_pures.
+ wp_bind (enqueue _ _).
+ iMod (enqueue_spec with "[$Q $Ho $Ho'] Hna") as "_".
+ + iIntros "Hna". wp_pures. iMod ("Hprint" with "Hna") as "_"; auto.
+ + iIntros (v) "[Hna _] !>". wp_pures. iApply ("IH" with "Hna Hc").
+ Qed.
+
+End open_example.
+
diff --git a/theories/examples/termination/logrel.v b/theories/examples/termination/logrel.v
new file mode 100644
index 0000000000000000000000000000000000000000..2452064b95ba3ad92547554646946ee78a83d784
--- /dev/null
+++ b/theories/examples/termination/logrel.v
@@ -0,0 +1,931 @@
+
+From iris.program_logic.refinement Require Export seq_weakestpre.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From iris.heap_lang Require Export lang lifting.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation metatheory.
+From iris.algebra Require Import auth.
+From iris.algebra.ordinals Require Import arithmetic.
+Set Default Proof Using "Type".
+
+
+
+Section token_ra.
+ Context {SI: indexT} {Σ: gFunctors SI} `{!inG Σ (authR (unitUR SI))}.
+
+ Definition tok γ := own γ (◠()).
+
+ Lemma tok_alloc: ⊢ (|==> ∃ γ, tok γ)%I.
+ Proof.
+ iStartProof. iMod (own_alloc (â— ())); auto.
+ by apply auth_auth_valid.
+ Qed.
+
+ Lemma tok_unique γ: tok γ ∗ tok γ ⊢ False.
+ Proof.
+ rewrite /tok -own_op own_valid -auth_auth_frac_op uPred.discrete_valid.
+ iIntros (Htok). apply ->(@auth_auth_frac_valid SI) in Htok.
+ destruct Htok as [Htok _]. apply ->(@frac_valid' SI) in Htok.
+ exfalso. by eapply Qp_not_plus_q_ge_1.
+ Qed.
+
+End token_ra.
+
+
+
+
+(* the heap values for empty, value, and computation *)
+Definition div : expr := (rec: "f" "x" := "f" "x") #().
+Definition E : expr := InjL #().
+Definition V (e: expr): expr := InjR (InjL e).
+Definition C (e: expr): expr := InjR (InjR e).
+Definition EV : val := InjLV #().
+Definition VV (v: val): val := InjRV (InjLV v).
+Definition CV (v: val): val := InjRV (InjRV v).
+Definition caseof : val :=
+ λ: "e" "e_empty" "e_val" "e_cont",
+ match: "e" with
+ InjL <> => "e_empty" #()
+ | InjR "x" =>
+ match: "x" with
+ InjL "v" => "e_val" "v"
+ | InjR "f" => "e_cont" "f"
+ end
+ end.
+Notation "'case' e 'of' 'E' => e1 | 'V' v => e2 | 'C' c => e3 'end'" := (caseof e (λ: <>, e1)%E (λ: v, e2)%E (λ: c, e3)%E).
+
+Definition letpair : val :=
+ λ: "p" "f", "f" (Fst "p") (Snd "p").
+
+Notation "'let:' ( x , y ) := p 'in' e" := (letpair p (λ: x y, e)%E) (at level 200, x at level 1, y at level 1, p, e at level 200, format "'[' 'let:' ( x , y ) := '[' p ']' 'in' '/' e ']'") : expr_scope.
+
+Definition iter : val :=
+ rec: "iter" "s" := λ: "n" "f", if: "n" = #0 then "s" else "iter" ("f" "s") ("n" - #1) "f".
+
+Definition chan : val :=
+ λ: <>, let: "c" := ref E in ("c", "c").
+
+Definition put : val :=
+ λ: "p",
+ let: "c" := Fst "p" in
+ let: "v" := Snd "p" in
+ case ! "c" of
+ E => "c" <- V "v"
+ | V <> => div
+ | C "f" => "c" <- E;; "f" "v"
+ end.
+
+Definition get : val :=
+ λ: "p",
+ let: "c" := Fst "p" in
+ let: "f" := Snd "p" in
+ case ! "c" of
+ E => "c" <- C "f"
+ | V "v" => "c" <- E;; "f" "v"
+ | C <> => div
+ end.
+
+Section semantic_model.
+ Context {SI} {Σ: gFunctors SI} `{Heap: !heapG Σ} `{TimeCredits: !tcG Σ} `{Sequential: !seqG Σ} `{FBI: FiniteBoundedExistential SI} `{Tok: !inG Σ (authR (unitUR SI))}.
+
+ Implicit Types (l r: loc).
+ Implicit Types (n: nat).
+ Implicit Types (b: bool).
+ Implicit Types (e : expr).
+ Implicit Types (v f: val).
+ Implicit Types (P Q: iProp Σ).
+ Implicit Types (Φ Ψ: val → iProp Σ).
+ Implicit Types (x y: string).
+
+
+ Section execution_lemmas.
+ Lemma rwp_put_empty l v:
+ l ↦ EV ⊢ WP (put (#l, v)%V)%E [{ w, ⌜w = #()⌠∗ l ↦ VV v}].
+ Proof.
+ iIntros "Hl". rewrite /put /caseof. wp_pures. wp_load. wp_pures.
+ wp_store. by iFrame.
+ Qed.
+
+ Lemma rwp_put_cont l f v Φ:
+ l ↦ CV f ∗ WP f v [{ w, Φ w }] ⊢ WP (put (#l, v)%V)%E [{ w, Φ w ∗ l ↦ EV}].
+ Proof.
+ iIntros "[Hl Hwp]". rewrite /put /caseof. wp_pures. wp_load. wp_pures.
+ wp_store. by iFrame "Hl".
+ Qed.
+
+ Lemma rwp_get_empty l f:
+ l ↦ EV ⊢ WP (get (#l, f)%V)%E [{ w, ⌜w = #()⌠∗ l ↦ CV f}].
+ Proof.
+ iIntros "Hl". rewrite /get /caseof. wp_pures. wp_load. wp_pures.
+ wp_store. by iFrame.
+ Qed.
+
+ Lemma rwp_get_val l f v Φ:
+ l ↦ VV v ∗ WP f v [{ w, Φ w }] ⊢ WP (get (#l, f)%V)%E [{ w, Φ w ∗ l ↦ EV}].
+ Proof.
+ iIntros "[Hl Hwp]". rewrite /get /caseof. wp_pures. wp_load. wp_pures.
+ wp_store. by iFrame "Hl".
+ Qed.
+
+ Lemma rwp_chan :
+ ⊢ (WP (chan #())%E [{ v, ∃ l, ⌜v = (#l, #l)%V⌠∗ l ↦ EV}])%I.
+ Proof.
+ iStartProof. rewrite /chan. wp_pures. wp_alloc l as "Hl".
+ wp_pures. eauto.
+ Qed.
+ End execution_lemmas.
+
+
+ Section closed_lemmas.
+ (* the channel invariant *)
+ Definition ch_inv γget γput l A :=
+ (l ↦ EV ∨ (∃ v, l ↦ VV v ∗ tok γput ∗ A v) ∨ (∃ f, l ↦ CV f ∗ tok γget ∗ ∀ v, A v -∗ SEQ f v [{ v, ⌜v = #()⌠}]))%I.
+
+ (* we have a linear type system *)
+ Definition lN := nroot .@ "type".
+ Definition ltype := val -d> iProp Σ.
+
+ Implicit Types (A B C: ltype).
+
+ (* type interpretations *)
+ Definition lunit : ltype := λ v, (⌜v = #()âŒ)%I.
+ Definition lbool : ltype := λ v, (∃ b, ⌜v = #bâŒ)%I.
+ Definition lnat : ltype := λ v, (∃ n, ⌜v = #nâŒ)%I.
+ Definition lget A : ltype := λ v, (∃ l γget γput, ⌜v = #l⌠∗ tok γget ∗ se_inv (lN .@ l) (ch_inv γget γput l A) ∗ $ one)%I.
+ Definition lput A : ltype := λ v, (∃ l γget γput, ⌜v = #l⌠∗ tok γput ∗ se_inv (lN .@ l) (ch_inv γget γput l A) ∗ $ one)%I.
+ Definition ltensor A B : ltype := λ v, (∃ v1 v2, ⌜v = (v1, v2)%V⌠∗ A v1 ∗ B v2)%I.
+ Definition larr A B : ltype := λ f, (∀ v, A v -∗ SEQ f v [{ v, B v }])%I.
+
+ Lemma closed_unit_intro: (SEQ #() [{ v, lunit v }])%I.
+ Proof.
+ iApply seq_value. by rewrite /lunit.
+ Qed.
+
+ Lemma closed_unit_elim e1 e2 Φ: (SEQ e1 [{ v, lunit v}] ∗ SEQ e2 [{ v, Φ v }] ⊢ SEQ e1;;e2 [{ v, Φ v }])%I.
+ Proof.
+ iIntros "[He He2] Hna". wp_bind e1.
+ iMod ("He" with "Hna") as "_". iIntros (v) "[Hna ->] !>".
+ wp_pures. by iApply "He2".
+ Qed.
+
+ Lemma closed_bool_intro (b: bool): (SEQ #b [{ v, lbool v }])%I.
+ Proof.
+ iApply seq_value. rewrite /lbool; eauto.
+ Qed.
+
+ Lemma closed_bool_elim e e_1 e_2 A P: (SEQ e [{ v, lbool v}] ∗ (P -∗ SEQ e_1 [{ v, A v}]) ∗ (P -∗ SEQ e_2 [{ v, A v}]) ∗ P) ⊢ (SEQ (if: e then e_1 else e_2) [{ v, A v}])%I.
+ Proof.
+ iIntros "(He & H1 & H2 & P) Hna". wp_bind e.
+ iMod ("He" with "Hna") as "_"; iIntros (v) "[Hna Hb] !>"; iDestruct "Hb" as ([]) "->".
+ - wp_pures. iApply ("H1" with "P Hna").
+ - wp_pures. iApply ("H2" with "P Hna").
+ Qed.
+
+ Lemma closed_nat_intro n: (SEQ #n [{ v, lnat v }])%I.
+ Proof.
+ iApply seq_value. rewrite /lnat; eauto.
+ Qed.
+
+ Lemma closed_nat_add e1 e2: (SEQ e1 [{ v, lnat v }] ∗ SEQ e2 [{ v, lnat v }] ⊢ SEQ (e1 + e2) [{ v, lnat v}])%I.
+ Proof.
+ iIntros "(H1 & H2) Hna".
+ wp_bind e2. iMod ("H2" with "Hna") as "_"; iIntros (v2) "[Hna Hv2] !>"; iDestruct "Hv2" as (n2) "->".
+ wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (v1) "[Hna Hv1] !>"; iDestruct "Hv1" as (n1) "->".
+ wp_pures. iFrame. rewrite /lnat; iExists (n1 + n2)%nat. iPureIntro. do 2 f_equal.
+ lia.
+ Qed.
+
+ Lemma closed_nat_iter_n n s f α A: (SEQ s [{ v, A v }] ∗ (□ $ α -∗ ∀ v, A v -∗ SEQ f v [{ w, A w }]) ∗ $ (natmul n α) ⊢ SEQ (iter s #n f) [{ v, A v}])%I.
+ Proof.
+ iIntros "(H1 & #H2 & Hc) Hna". iInduction n as [|n] "IH" forall (s); simpl.
+ all: wp_bind s; iMod ("H1" with "Hna") as "_"; iIntros (v) "[Hna Hv] !>".
+ - rewrite /iter. wp_pures. replace (#0%nat) with (#0) by ((do 2 f_equal); lia).
+ wp_pure _; first naive_solver. wp_pures. by iFrame.
+ - rewrite tc_split. iDestruct "Hc" as "[Hα Hc]".
+ rewrite /iter. wp_pures. wp_pure _; first naive_solver.
+ wp_pures. replace (S n - 1) with (n: Z) by lia.
+ iApply ("IH" with "[Hα Hv] Hc Hna"). iApply ("H2" with "Hα Hv").
+ Qed.
+
+
+ Lemma closed_nat_iter e1 e2 f α A: (SEQ e1 [{ v, lnat v }] ∗ SEQ e2 [{ v, A v }] ∗ (□ $ α -∗ ∀ v, A v -∗ SEQ f v [{ w, A w }]) ∗ $ (omul α) ⊢ SEQ (iter e2 e1 f) [{ v, A v}])%I.
+ Proof.
+ iIntros "(H1 & H2 & H3 & Hc) Hna".
+ wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (v) "[Hna Hv] !>"; iDestruct "Hv" as (n) "->".
+ iApply (tc_weaken (omul α) (natmul n α) with "[H2 H3 Hna $Hc]"); auto.
+ { eapply (ord_stepindex.limit_upper_bound (λ n, natmul n α)). }
+ iIntros "Hα". iApply (closed_nat_iter_n with "[$H2 $H3 $Hα] Hna").
+ Qed.
+
+ Lemma closed_fun_intro x e A B: (∀ v, A v -∗ SEQ (subst x v e) [{ w, B w}] ) ⊢ (SEQ (λ: x, e) [{ v, larr A B v}])%I.
+ Proof.
+ iIntros "H Hna". wp_pures. iFrame. iIntros (v) "Hv Hna". wp_pures.
+ by iApply ("H" with "Hv Hna").
+ Qed.
+
+ Lemma closed_fun_elim e_1 e_2 A B: (SEQ e_1 [{ v, larr A B v}] ∗ SEQ e_2 [{ v, A v }]) ⊢ (SEQ (e_1 e_2) [{ v, B v}])%I.
+ Proof.
+ iIntros "(H1 & H2) Hna".
+ wp_bind e_2. iMod ("H2" with "Hna") as "_"; iIntros (v) "[Hna HA] !>".
+ wp_bind e_1. iMod ("H1" with "Hna") as "_"; iIntros (f) "[Hna HAB] !>".
+ iApply ("HAB" with "HA Hna").
+ Qed.
+
+ Lemma closed_tensor_intro e_1 e_2 A B: (SEQ e_1 [{ v, A v}] ∗ SEQ e_2 [{ v, B v }]) ⊢ (SEQ (e_1, e_2) [{ v, ltensor A B v}])%I.
+ Proof.
+ iIntros "(H1 & H2) Hna".
+ wp_bind e_2. iMod ("H2" with "Hna") as "_"; iIntros (v2) "[Hna HB] !>".
+ wp_bind e_1. iMod ("H1" with "Hna") as "_"; iIntros (v1) "[Hna HA] !>".
+ wp_pures. iFrame. iExists v1, v2; by iFrame.
+ Qed.
+
+ Lemma closed_tensor_elim x y e1 e2 A B C: x ≠y → (SEQ e1 [{ v, ltensor A B v }]) ∗ (∀ v1 v2, A v1 -∗ B v2 -∗ SEQ (subst y v2 (subst x v1 e2)) [{ w, C w}]) ⊢ (SEQ (let: (x, y) := e1 in e2) [{ v, C v}])%I.
+ Proof.
+ iIntros (Hneq) "[H1 H2] Hna". wp_pures. wp_bind e1.
+ iMod ("H1" with "Hna") as "_". iIntros (p) "[Hna Hp] !>".
+ iDestruct "Hp" as (v1 v2) "(-> & Hv1 & Hv2)".
+ rewrite /letpair. wp_pures.
+ destruct decide as [H|H].
+ - iApply ("H2" with "Hv1 Hv2 Hna").
+ - exfalso. apply H; split; auto. by injection 1.
+ Qed.
+
+
+ Lemma closed_get e1 e2 A: SEQ e1 [{ v, lget A v}] ∗ SEQ e2 [{ f, larr A lunit f}] ⊢ SEQ (get (e1, e2)) [{ v, lunit v}].
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ iIntros "[H1 H2] Hna".
+ wp_bind e2. iMod ("H2" with "Hna") as "_"; iIntros (f) "[Hna Hf] !>".
+ wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (?) "[Hna Hloc] !>"; iDestruct "Hloc" as (l γget γput) "(-> & Hget & #I & Hone)".
+ iMod (na_inv_acc_open with "I Hna") as "P"; auto.
+ iApply (tcwp_burn_credit with "Hone"); first done. iNext. wp_pures. (* we use the step from expressions to values here conventiently *)
+ rewrite -tcwp_rwp.
+ iDestruct "P" as "([HI|[HI|HI]] & Hna & Hclose)".
+ - iMod (rwp_get_empty with "HI") as "_". iIntros (?) "(-> & Hl)".
+ iMod ("Hclose" with "[Hf Hl Hget $Hna]") as "Hna".
+ { iNext. iRight. iRight. iExists f. iFrame. }
+ iModIntro. iFrame. eauto.
+ - iDestruct "HI" as (v) "[Hl [Hput Hv]]".
+ iSpecialize ("Hf" with "Hv").
+ (* we need to close the invariant after the value has been updated before we execute f, since f assumes all invariants *)
+ rewrite /get. wp_pures. wp_load. rewrite /caseof. wp_pures.
+ wp_store. iApply fupd_rwp.
+ iMod ("Hclose" with "[Hl $Hna]") as "Hna".
+ { iNext. by iLeft. }
+ iApply ("Hf" with "Hna").
+ - iDestruct "HI" as (f') "[_ [Hget' _]]".
+ iExFalso. iApply (tok_unique with "[$Hget $Hget']").
+ Qed.
+
+ Lemma closed_put e1 e2 A: SEQ e1 [{ v, lput A v}] ∗ SEQ e2 [{ v, A v}] ⊢ SEQ (put (e1, e2)) [{ v, lunit v}].
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ iIntros "[H1 H2] Hna".
+ wp_bind e2. iMod ("H2" with "Hna") as "_"; iIntros (v) "[Hna Hv] !>".
+ wp_bind e1. iMod ("H1" with "Hna") as "_"; iIntros (?) "[Hna Hloc] !>"; iDestruct "Hloc" as (l γget γput) "(-> & Hput & #I & Hone)".
+ iMod (na_inv_acc_open with "I Hna") as "P"; auto.
+ iApply (tcwp_burn_credit with "Hone"); first done. iNext. wp_pures. (* we use the step from expressions to values here conventiently *)
+ rewrite -tcwp_rwp.
+ iDestruct "P" as "([HI|[HI|HI]] & Hna & Hclose)".
+ - iMod (rwp_put_empty with "HI") as "_". iIntros (?) "(-> & Hl)".
+ iMod ("Hclose" with "[Hv Hl Hput $Hna]") as "Hna".
+ { iNext. iRight. iLeft. iExists v. iFrame. }
+ iModIntro. by iFrame.
+ - iDestruct "HI" as (v') "[Hl [Hput' _]]".
+ iExFalso. iApply (tok_unique with "[$Hput $Hput']").
+ - iDestruct "HI" as (f) "[Hl [Hget Hf]]".
+ iSpecialize ("Hf" with "Hv").
+ (* we need to close the invariant after the value has been updated before we execute f, since f assumes all invariants *)
+ rewrite /put. wp_pures. wp_load. rewrite /caseof. wp_pures.
+ wp_store. iApply fupd_rwp.
+ iMod ("Hclose" with "[Hl $Hna]") as "Hna".
+ { iNext. by iLeft. }
+ iApply ("Hf" with "Hna").
+ Qed.
+
+ Lemma closed_chan A: $ one ∗ $ one ⊢ SEQ (chan #()) [{ v, ltensor (lget A) (lput A) v}].
+ Proof.
+ iIntros "[Hone Hone'] Hna".
+ iMod (rwp_chan) as "_". iIntros (v) "Hv". iDestruct "Hv" as (l) "[-> Hl]".
+ iMod (tok_alloc) as (γget) "Hget".
+ iMod (tok_alloc) as (γput) "Hput".
+ iMod (na_inv_alloc seqG_name _ (lN .@ l) (ch_inv γget γput l A) with "[Hl]") as "#I".
+ { iNext. by iLeft. }
+ iModIntro; rewrite /ltensor /lget /lput; iFrame.
+ iExists #l, #l; iSplit; auto.
+ iSplitL "Hget"; iExists l, γget, γput; iFrame; eauto.
+ Qed.
+
+ End closed_lemmas.
+
+ Section simple_logical_relation.
+ (* The semantic typing judgment *)
+ Implicit Types (Γ Δ: gmap string ltype).
+ Implicit Types (θ τ: gmap string val).
+
+ Definition env_ltyped Γ θ: iProp Σ := ([∗ map] x ↦ A ∈ Γ, ∃ v, ⌜θ !! x = Some v⌠∗ A v)%I.
+ Definition ltyped Γ e A := ⊢ (∃ α, $ α -∗ ∀ θ, env_ltyped Γ θ -∗ SEQ subst_map θ e [{ v, A v }])%I.
+ Notation "Γ ⊨ e : A" := (ltyped Γ e A) (at level 100, e at next level, A at level 200) : bi_scope.
+
+ Lemma env_ltyped_split Γ Δ θ: Γ ##ₘ Δ → env_ltyped (Γ ∪ Δ) θ ⊢ env_ltyped Γ θ ∗ env_ltyped Δ θ.
+ Proof.
+ intros H. rewrite /env_ltyped. by rewrite big_sepM_union.
+ Qed.
+
+ Lemma env_ltyped_empty θ: ⊢ (env_ltyped ∅ θ).
+ Proof.
+ iStartProof. by rewrite /env_ltyped big_sepM_empty.
+ Qed.
+
+ Lemma env_ltyped_insert Γ θ A v x: env_ltyped Γ θ ∗ A v ⊢ env_ltyped (<[x:=A]> Γ) (<[x:=v]> θ).
+ Proof.
+ iIntros "[HΓ HA]". destruct (Γ !! x) eqn: Hx.
+ - rewrite -[<[x:=A]> Γ]insert_delete. iApply (big_sepM_insert_2 with "[HA] [HΓ]"); simpl.
+ + iExists v. iFrame. iPureIntro. apply lookup_insert.
+ + rewrite /env_ltyped.
+ rewrite big_sepM_delete; last apply Hx.
+ iDestruct "HΓ" as "[_ HΓ]". iApply (big_sepM_mono with "HΓ").
+ iIntros (y B Hy) "Hv"; simpl. iDestruct "Hv" as (w) "[% B]".
+ iExists w. iFrame. iPureIntro.
+ rewrite lookup_insert_ne; auto.
+ intros ->. rewrite lookup_delete in Hy. discriminate.
+ - iApply (big_sepM_insert_2 with "[HA] [HΓ]"); simpl.
+ + iExists v. iFrame. iPureIntro. apply lookup_insert.
+ + rewrite /env_ltyped. iApply (big_sepM_mono with "HΓ").
+ iIntros (y B Hy) "Hv"; simpl. iDestruct "Hv" as (w) "[% B]".
+ iExists w. iFrame. iPureIntro.
+ rewrite lookup_insert_ne; auto.
+ intros ->. rewrite Hy in Hx. discriminate.
+ Qed.
+
+ Lemma env_ltyped_weaken x A Γ θ: Γ !! x = None → env_ltyped (<[x:=A]> Γ) θ ⊢ env_ltyped Γ θ.
+ Proof.
+ intros Hx. rewrite insert_union_singleton_l. iIntros "H".
+ iPoseProof (env_ltyped_split with "H") as "[_ $]".
+ apply map_disjoint_insert_l_2, map_disjoint_empty_l; auto.
+ Qed.
+
+ (* the typing rules *)
+ Lemma variable x A: ({[ x := A ]} ⊨ x : A)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (θ) "HΓ". rewrite /env_ltyped.
+ iPoseProof (big_sepM_lookup _ _ x A with "HΓ") as "Hx"; first eapply lookup_insert.
+ simpl; iDestruct "Hx" as (v) "(-> & HA)".
+ by iApply seq_value.
+ Qed.
+
+ Lemma weaken x Γ e A B: Γ !! x = None → (Γ ⊨ e : B)%I → (<[ x := A ]> Γ ⊨ e : B)%I.
+ Proof.
+ intros Hx He. iDestruct He as (α) "He".
+ iExists α. iIntros "Hα". iIntros (θ) "Hθ".
+ iApply ("He" with "Hα"). by iApply (env_ltyped_weaken with "Hθ").
+ Qed.
+
+ Lemma unit_intro: (∅ ⊨ #() : lunit)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (θ) "HΓ"; simpl. iApply closed_unit_intro.
+ Qed.
+
+ Lemma unit_elim Γ Δ e e' A: Γ ##ₘ Δ → (Γ ⊨ e : lunit)%I → (Δ ⊨ e' : A)%I → (Γ ∪ Δ ⊨ (e ;; e'): A)%I.
+ Proof.
+ intros Hdis He He'. iDestruct He as (α_e) "He". iDestruct He' as (α_e') "He'".
+ iExists (α_e ⊕ α_e'). rewrite tc_split. iIntros "[α_e α_e']".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("He" with "α_e HΓ"). iSpecialize ("He'" with "α_e' HΔ").
+ simpl; iApply (closed_unit_elim with "[$He $He']").
+ Qed.
+
+ Lemma bool_intro b: (∅ ⊨ #b : lbool)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (θ) "HΓ"; simpl. iApply closed_bool_intro.
+ Qed.
+
+ Lemma bool_elim Γ Δ e e_1 e_2 A: Γ ##ₘ Δ → (Γ ⊨ e : lbool)%I → (Δ ⊨ e_1 : A)%I → (Δ ⊨ e_2 : A)%I → (Γ ∪ Δ ⊨ (if: e then e_1 else e_2): A)%I.
+ Proof.
+ intros Hdis He H1 H2. iDestruct He as (α_e) "He". iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_e ⊕ α_1 ⊕ α_2). rewrite !tc_split. iIntros "[[α_e α_1] α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("He" with "α_e HΓ"). simpl.
+ iApply (closed_bool_elim _ _ _ _ (env_ltyped Δ θ)); iFrame.
+ iSplitL "H1 α_1".
+ - iApply ("H1" with "α_1").
+ - iApply ("H2" with "α_2").
+ Qed.
+
+ Lemma nat_intro n: (∅ ⊨ #n : lnat)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (θ) "HΓ"; simpl. iApply closed_nat_intro.
+ Qed.
+
+ Lemma nat_plus e1 e2 Γ Δ: Γ ##ₘ Δ → (Γ ⊨ e1 : lnat)%I → (Δ ⊨ e2 : lnat)%I → (Γ ∪ Δ ⊨ e1 + e2 : lnat)%I.
+ Proof.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
+ simpl; iApply (closed_nat_add with "[$H1 $H2]").
+ Qed.
+
+ Lemma nat_elim e e_0 e_S x A Γ Δ: Γ ##ₘ Δ → (Γ ⊨ e : lnat)%I → (Δ ⊨ e_0 : A)%I → ({[ x := A ]} ⊨ e_S : A)%I → (Γ ∪ Δ ⊨ iter e_0 e (λ: x, e_S)%V : A)%I.
+ Proof.
+ intros Hdis He H0 HS.
+ iDestruct He as (α_e) "He". iDestruct H0 as (α_0) "H0". iDestruct HS as (α_S) "HS".
+ iExists (α_e ⊕ α_0 ⊕ omul α_S). rewrite !tc_split. iIntros "[[α_e α_0] α_S]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]". simpl.
+ iSpecialize ("He" with "α_e HΓ"). iSpecialize ("H0" with "α_0 HΔ").
+ simpl; iApply (closed_nat_iter _ _ _ α_S with "[$He $H0 $α_S]").
+ iModIntro. iIntros "α_S". iIntros (v) "Hv".
+ iIntros "Hna". wp_pures.
+ replace e_S with (subst_map (delete x ∅) e_S) at 1; last by rewrite delete_empty subst_map_empty.
+ rewrite -subst_map_insert. iApply ("HS" with "α_S [Hv] Hna").
+ iApply env_ltyped_insert; iFrame.
+ iApply env_ltyped_empty.
+ Qed.
+
+ Lemma fun_intro Γ x e A B: ((<[x:=A]> Γ) ⊨ e : B)%I → (Γ ⊨ (λ: x, e) : larr A B)%I.
+ Proof.
+ intros He. iDestruct He as (α_e) "He". iExists α_e.
+ iIntros "α_e". iSpecialize ("He" with "α_e").
+ iIntros (θ) "HΓ". simpl. iApply (closed_fun_intro).
+ iIntros (v) "Hv". rewrite -subst_map_insert. iApply ("He" with "[HΓ Hv]").
+ iApply (env_ltyped_insert with "[$HΓ Hv]"); first done.
+ Qed.
+
+ Lemma fun_elim Γ Δ e1 e2 A B: Γ ##ₘ Δ → (Γ ⊨ e1 : larr A B)%I → (Δ ⊨ e2 : A)%I → (Γ ∪ Δ ⊨ (e1 e2): B)%I.
+ Proof.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
+ simpl; iApply (closed_fun_elim with "[$H1 $H2]").
+ Qed.
+
+ Lemma tensor_intro Γ Δ e1 e2 A B: Γ ##ₘ Δ → (Γ ⊨ e1 : A)%I → (Δ ⊨ e2 : B)%I → (Γ ∪ Δ ⊨ (e1, e2): ltensor A B)%I.
+ Proof.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
+ iApply (closed_tensor_intro with "[$H1 $H2]").
+ Qed.
+
+ Lemma tensor_elim Γ Δ x y e1 e2 A B C: x ≠y → Γ ##ₘ Δ → (Γ ⊨ e1 : ltensor A B)%I → ((<[x := A]> (<[y := B]> Δ)) ⊨ e2 : C)%I → (Γ ∪ Δ ⊨ (let: (x, y) := e1 in e2) : C)%I.
+ Proof.
+ intros Hne Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 HΓ"). simpl. iApply (closed_tensor_elim with "[$H1 HΔ α_2]"); auto.
+ iIntros (v1 v2) "Hv1 Hv2".
+ rewrite delete_commute -subst_map_insert -delete_insert_ne; auto.
+ rewrite -subst_map_insert. iApply ("H2" with "α_2").
+ rewrite insert_commute; auto.
+ do 2 (iApply env_ltyped_insert; iFrame).
+ Qed.
+
+ Lemma chan_alloc A: (∅ ⊨ chan #() : ltensor (lget A) (lput A))%I.
+ Proof.
+ iExists (one ⊕ one). rewrite tc_split. iIntros "Hcred".
+ iIntros (θ) "_"; simpl. iApply (closed_chan A with "Hcred").
+ Qed.
+
+ Lemma chan_get Γ Δ e1 e2 A: Γ ##ₘ Δ → (Γ ⊨ e1 : lget A)%I → (Δ ⊨ e2 : larr A lunit)%I → (Γ ∪ Δ ⊨ get (e1, e2)%E: lunit)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
+ simpl; iApply (closed_get with "[$H1 $H2]").
+ Qed.
+
+ Lemma chan_put Γ Δ e1 e2 A: Γ ##ₘ Δ → (Γ ⊨ e1 : lput A)%I → (Δ ⊨ e2 : A)%I → (Γ ∪ Δ ⊨ put (e1, e2)%E: lunit)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (θ). rewrite env_ltyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 HΓ"). iSpecialize ("H2" with "α_2 HΔ").
+ simpl; iApply (closed_put with "[$H1 $H2]").
+ Qed.
+
+ End simple_logical_relation.
+
+ Section polymorphic_logical_relation.
+ (* The semantic typing judgment *)
+ Implicit Types (Ω: gset string) (* the type variables *).
+ Implicit Types (δ: gmap string ltype) (* the instantiation of the type variables *).
+ Definition lptype := gmap string ltype -d> ltype.
+
+ Implicit Types (ΠΞ: gmap string lptype). (* the variables, given an instantiation of the type variables *)
+ Implicit Types (T U: lptype). (* the types *)
+ Implicit Types (θ τ: gmap string val).
+
+ Definition subst_cons δ X A := <[X := A]> δ.
+ Definition subst_ty (T: lptype) (X: string) U : lptype := λ δ, T (subst_cons δ X (U δ)).
+ Definition well_formed Ω δ : iProp Σ := (⌜Ω ≡ dom (gset string) δâŒ)%I.
+ Definition well_formed_type Ω T : Prop := (∀ δ δ', (∀ X, X ∈ Ω → δ !! X = δ' !! X) → T δ = T δ').
+ Definition well_formed_ctx Ω Π: Prop := (∀ x T, Π!! x = Some T → well_formed_type Ω T).
+ Definition env_lptyped Πδ θ : iProp Σ := (env_ltyped (fmap (λ T, T δ) Π) θ)%I.
+ Definition lptyped Ω Πe T := ⊢ (∃ α, $ α -∗ ∀ δ, well_formed Ω δ -∗ ∀ θ, env_lptyped Πδ θ -∗ SEQ subst_map θ e [{ v, (T δ) v }])%I.
+ Notation "Ω ; Π⊨ e : T" := (lptyped Ω Πe T) (at level 100, Πat next level, e at next level, T at level 200) : bi_scope.
+
+ (* Notation for well-formedness *)
+ Class is_wf (A B: Type) := Is_wf: A → B → Prop.
+ Notation "A ⊨ B" := (Is_wf A B) (at level 100, B at level 200).
+ Instance: is_wf (gset string) (lptype) := well_formed_type.
+ Instance: is_wf (gset string) (gmap string lptype) := well_formed_ctx.
+
+ Definition lpunit : lptype := λ _, lunit.
+ Definition lpbool : lptype := λ _, lbool.
+ Definition lpnat : lptype := λ _, lnat.
+ Definition lpget T : lptype := λ δ, lget (T δ).
+ Definition lpput T : lptype := λ δ, lput (T δ).
+ Definition lptensor T U : lptype := λ δ, ltensor (T δ) (U δ).
+ Definition lparr T U : lptype := λ δ, larr (T δ) (U δ).
+ Definition lpforall X (T: lptype) : lptype := λ δ f, (∀ U, SEQ (f #()) [{ u, (subst_ty T X U) δ u }])%I.
+ Definition lpexists X (T: lptype) : lptype := λ δ v, (∃ U, (subst_ty T X U) δ v)%I.
+
+ Definition tlam e : expr := λ: <>, e.
+ Definition tapp e : expr := e #().
+ Definition pack e : expr := e.
+ Definition unpack e x e' : expr := (λ: x, e') e.
+
+ Lemma well_formed_empty:
+ True ⊢ well_formed ∅ ∅.
+ Proof using SI Σ.
+ iIntros (Heq). iPureIntro.
+ by rewrite dom_empty.
+ Qed.
+
+
+ Lemma well_formed_insert Ω δ X A:
+ well_formed Ω δ ⊢ well_formed ({[X]} ∪ Ω) (subst_cons δ X A).
+ Proof using SI Σ.
+ iIntros (Heq). iPureIntro.
+ by rewrite dom_insert Heq.
+ Qed.
+
+ Lemma env_lptyped_split ΠΞ δ θ: Π##ₘ Ξ → env_lptyped (Π∪ Ξ) δ θ ⊢ env_lptyped Πδ θ ∗ env_lptyped Ξ δ θ.
+ Proof.
+ intros H. rewrite /env_lptyped /env_ltyped !big_sepM_fmap big_sepM_union; auto.
+ Qed.
+
+ Lemma env_lptyped_empty δ θ: sbi_emp_valid (env_lptyped ∅ δ θ).
+ Proof.
+ iStartProof. by rewrite /env_lptyped /env_ltyped !big_sepM_fmap big_sepM_empty.
+ Qed.
+
+ Lemma env_lptyped_insert Πδ θ T v x: env_lptyped Πδ θ ∗ T δ v ⊢ env_lptyped (<[x:=T]> Π) δ (<[x:=v]> θ).
+ Proof.
+ rewrite /env_lptyped fmap_insert. eapply env_ltyped_insert.
+ Qed.
+
+ Lemma env_lptyped_weaken x T Πθ δ: Π!! x = None → env_lptyped (<[x:=T]> Π) δ θ ⊢ env_lptyped Πδ θ.
+ Proof.
+ intros Hx. rewrite /env_lptyped fmap_insert env_ltyped_weaken //= lookup_fmap Hx //=.
+ Qed.
+
+ Lemma env_lptyped_update_type_map Ω ΠT δ X θ:
+ (Ω ⊨ Π) → (X ∉ Ω) → env_lptyped Πδ θ ⊢ env_lptyped Π(subst_cons δ X (T δ)) θ.
+ Proof using SI Σ.
+ clear FBI. intros Hwf HX. rewrite /env_lptyped /env_ltyped !big_opM_fmap.
+ iIntros "Hθ". iApply (big_sepM_mono with "Hθ").
+ iIntros (Y B HYB) "H". iDestruct "H" as (v) "[% B]".
+ iExists v; iSplit; auto.
+ feed pose proof (Hwf _ _ HYB δ (<[X:=T δ]> δ)) as HB.
+ { intros Z Hx'. assert (X ≠Z) by set_solver. by rewrite lookup_insert_ne. }
+ by erewrite HB.
+ Qed.
+
+
+ (* the typing rules *)
+ Lemma poly_variable Ω x T: (Ω; {[ x := T ]} ⊨ x : T)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (δ) "%". iIntros (θ) "HΓ". rewrite /env_lptyped /env_ltyped big_opM_fmap.
+ iPoseProof (big_sepM_lookup _ _ x T with "HΓ") as "Hx"; first eapply lookup_insert.
+ simpl; iDestruct "Hx" as (v) "(-> & HA)".
+ by iApply seq_value.
+ Qed.
+
+ Lemma poly_weaken x Ω Πe T U: Π!! x = None → (Ω; Π⊨ e : U)%I → (Ω; (<[ x := T ]> Π) ⊨ e : U)%I.
+ Proof.
+ intros Hx He. iDestruct He as (α) "He".
+ iExists α. iIntros "Hα". iIntros (δ) "Hδ". iIntros (θ) "Hθ".
+ iApply ("He" with "Hα Hδ"). by iApply (env_lptyped_weaken with "Hθ").
+ Qed.
+
+ Lemma poly_unit_intro Ω: (Ω; ∅ ⊨ #() : lpunit)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (δ) "Hδ". iIntros (θ) "HΓ"; simpl. iApply closed_unit_intro.
+ Qed.
+
+ Lemma poly_unit_elim Ω ΠΞ e e' T: Π##ₘ Ξ → (Ω; Π⊨ e : lpunit)%I → (Ω; Ξ ⊨ e' : T)%I → (Ω; Π∪ Ξ ⊨ (e ;; e'): T)%I.
+ Proof.
+ intros Hdis He He'. iDestruct He as (α_e) "He". iDestruct He' as (α_e') "He'".
+ iExists (α_e ⊕ α_e'). rewrite tc_split. iIntros "[α_e α_e']".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("He" with "α_e Hδ HΓ"). iSpecialize ("He'" with "α_e' Hδ HΔ").
+ simpl; iApply (closed_unit_elim with "[$He $He']").
+ Qed.
+
+ Lemma poly_bool_intro Ω b: (Ω; ∅ ⊨ #b : lpbool)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (δ) "#Hδ". iIntros (θ) "HΓ"; simpl. iApply closed_bool_intro.
+ Qed.
+
+ Lemma poly_bool_elim Ω ΠΞ e e_1 e_2 T:
+ Π##ₘ Ξ
+ → (Ω; Π⊨ e : lpbool)%I
+ → (Ω; Ξ ⊨ e_1 : T)%I
+ → (Ω; Ξ ⊨ e_2 : T)%I
+ → (Ω; (Π∪ Ξ) ⊨ (if: e then e_1 else e_2): T)%I.
+ Proof.
+ intros Hdis He H1 H2. iDestruct He as (α_e) "He". iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_e ⊕ α_1 ⊕ α_2). rewrite !tc_split. iIntros "[[α_e α_1] α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("He" with "α_e Hδ HΓ"). simpl.
+ iApply (closed_bool_elim _ _ _ _ (env_lptyped Ξ δ θ)); iFrame.
+ iSplitL "H1 α_1".
+ - iApply ("H1" with "α_1 Hδ").
+ - iApply ("H2" with "α_2 Hδ").
+ Qed.
+
+ Lemma poly_nat_intro Ω n: (Ω; ∅ ⊨ #n : lpnat)%I.
+ Proof.
+ iExists ord_stepindex.zero. iIntros "_".
+ iIntros (δ) "#Hδ". iIntros (θ) "HΓ"; simpl. iApply closed_nat_intro.
+ Qed.
+
+ Lemma poly_nat_plus Ω e1 e2 ΠΞ: Π##ₘ Ξ → (Ω; Π⊨ e1 : lpnat)%I → (Ω; Ξ ⊨ e2 : lpnat)%I → (Ω; Π∪ Ξ ⊨ e1 + e2 : lpnat)%I.
+ Proof.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
+ simpl; iApply (closed_nat_add with "[$H1 $H2]").
+ Qed.
+
+ Lemma poly_nat_elim Ω e e_0 e_S x T ΠΞ:
+ Π##ₘ Ξ
+ → (Ω; Π⊨ e : lpnat)%I
+ → (Ω; Ξ ⊨ e_0 : T)%I
+ → (Ω; {[ x := T ]} ⊨ e_S : T)%I
+ → (Ω; Π∪ Ξ ⊨ iter e_0 e (λ: x, e_S)%V : T)%I.
+ Proof.
+ intros Hdis He H0 HS.
+ iDestruct He as (α_e) "He". iDestruct H0 as (α_0) "H0". iDestruct HS as (α_S) "HS".
+ iExists (α_e ⊕ α_0 ⊕ omul α_S). rewrite !tc_split. iIntros "[[α_e α_0] α_S]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]". simpl.
+ iSpecialize ("He" with "α_e Hδ HΓ"). iSpecialize ("H0" with "α_0 Hδ HΔ").
+ simpl; iApply (closed_nat_iter _ _ _ α_S with "[$He $H0 $α_S]").
+ iModIntro. iIntros "α_S". iIntros (v) "Hv".
+ iIntros "Hna". wp_pures.
+ replace e_S with (subst_map (delete x ∅) e_S) at 1; last by rewrite delete_empty subst_map_empty.
+ rewrite -subst_map_insert. iApply ("HS" with "α_S Hδ [Hv] Hna").
+ iApply env_lptyped_insert; iFrame.
+ iApply env_lptyped_empty.
+ Qed.
+
+ Lemma poly_fun_intro Ω Πx e T U:
+ (Ω; (<[x:=T]> Π) ⊨ e : U)%I
+ → (Ω; Π⊨ (λ: x, e) : lparr T U)%I.
+ Proof.
+ intros He. iDestruct He as (α_e) "He". iExists α_e.
+ iIntros "α_e". iSpecialize ("He" with "α_e").
+ iIntros (δ) "#Hδ". iIntros (θ) "HΓ". simpl. iApply (closed_fun_intro).
+ iIntros (v) "Hv". rewrite -subst_map_insert. iApply ("He" with "Hδ [HΓ Hv]").
+ iApply (env_lptyped_insert with "[$HΓ Hv]"); first done.
+ Qed.
+
+ Lemma poly_fun_elim Ω ΠΞ e1 e2 T U:
+ Π##ₘ Ξ
+ → (Ω; Π⊨ e1 : lparr T U)%I
+ → (Ω; Ξ ⊨ e2 : T)%I
+ → (Ω; Π∪ Ξ ⊨ (e1 e2): U)%I.
+ Proof.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
+ simpl; iApply (closed_fun_elim with "[$H1 $H2]").
+ Qed.
+
+ Lemma poly_tensor_intro Ω ΠΞ e1 e2 T U:
+ Π##ₘ Ξ
+ → (Ω; Π⊨ e1 : T)%I
+ → (Ω; Ξ ⊨ e2 : U)%I
+ → (Ω; Π∪ Ξ ⊨ (e1, e2): lptensor T U)%I.
+ Proof.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
+ iApply (closed_tensor_intro with "[$H1 $H2]").
+ Qed.
+
+ Lemma poly_tensor_elim Ω ΠΞ x y e1 e2 T1 T2 U:
+ x ≠y
+ → Π##ₘ Ξ
+ → (Ω; Π⊨ e1 : lptensor T1 T2)%I
+ → (Ω; (<[x := T1]> (<[y := T2]> Ξ)) ⊨ e2 : U)%I
+ → (Ω; Π∪ Ξ ⊨ (let: (x, y) := e1 in e2) : U)%I.
+ Proof.
+ intros Hne Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 Hδ HΓ"). simpl. iApply (closed_tensor_elim with "[$H1 HΔ α_2]"); auto.
+ iIntros (v1 v2) "Hv1 Hv2".
+ rewrite delete_commute -subst_map_insert -delete_insert_ne; auto.
+ rewrite -subst_map_insert. iApply ("H2" with "α_2 Hδ").
+ rewrite insert_commute; auto.
+ do 2 (iApply env_lptyped_insert; iFrame).
+ Qed.
+
+ Lemma poly_chan_alloc Ω T: (Ω; ∅ ⊨ chan #() : lptensor (lpget T) (lpput T))%I.
+ Proof.
+ iExists (one ⊕ one). rewrite tc_split. iIntros "Hcred".
+ iIntros (δ) "#Hδ". iIntros (θ) "_"; simpl. iApply (closed_chan (T δ) with "Hcred").
+ Qed.
+
+ Lemma poly_chan_get Ω ΠΞ e1 e2 T:
+ Π##ₘ Ξ
+ → (Ω; Π⊨ e1 : lpget T)%I
+ → (Ω; Ξ ⊨ e2 : lparr T lpunit)%I
+ → (Ω; Π∪ Ξ ⊨ get (e1, e2)%E: lpunit)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
+ simpl; iApply (closed_get with "[$H1 $H2]").
+ Qed.
+
+ Lemma poly_chan_put Ω ΠΞ e1 e2 T:
+ Π##ₘ Ξ
+ → (Ω; Π⊨ e1 : lpput T)%I
+ → (Ω; Ξ ⊨ e2 : T)%I
+ → (Ω; Π∪ Ξ ⊨ put (e1, e2)%E: lpunit)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros Hdis H1 H2. iDestruct H1 as (α_1) "H1". iDestruct H2 as (α_2) "H2".
+ iExists (α_1 ⊕ α_2). rewrite tc_split. iIntros "[α_1 α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split; auto. iIntros "[HΓ HΔ]".
+ iSpecialize ("H1" with "α_1 Hδ HΓ"). iSpecialize ("H2" with "α_2 Hδ HΔ").
+ simpl; iApply (closed_put with "[$H1 $H2]").
+ Qed.
+
+
+ Lemma poly_forall_intro Ω X Πe T:
+ (Ω ⊨ Π) → X ∉ Ω → (({[X]} ∪ Ω); Π⊨ e : T)%I → (Ω; Π⊨ tlam e : lpforall X T)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros Hwf Hx He.
+ iDestruct He as (α_e) "He". iExists α_e.
+ iIntros "Ha". iSpecialize ("He" with "Ha").
+ iIntros (δ) "Hδ". iIntros (θ) "Hθ". simpl.
+ iIntros "Hna". wp_pures. iFrame.
+ unfold lpforall. iIntros (U) "Hna".
+ wp_pures. unfold subst_ty. iApply ("He" with "[Hδ] [Hθ] Hna").
+ - by iApply well_formed_insert.
+ - iApply (env_lptyped_update_type_map with "Hθ"); eauto.
+ Qed.
+
+ (* For the compatibility lemma, we do not need well-formedness of U. It's only needed for type preservation. *)
+ Lemma poly_forall_elim Ω X Πe T U:
+ (* Ω ⊨ U → *) (Ω; Π⊨ e : lpforall X T)%I → (Ω; Π⊨ tapp e : subst_ty T X U)%I.
+ Proof.
+ intros He.
+ iDestruct He as (α_e) "He". iExists α_e.
+ iIntros "Ha". iSpecialize ("He" with "Ha").
+ iIntros (δ) "Hδ". iIntros (θ) "Hθ". simpl.
+ iIntros "Hna". wp_bind (subst_map _ e).
+ iMod ("He" with "Hδ Hθ Hna") as "_".
+ iIntros (v) "[Hna Hf] !>". rewrite /lpforall.
+ by iApply "Hf".
+ Qed.
+
+ (* Well-formedness assumptions needed for type preservation but not for the compatibility lemma.*)
+ Lemma poly_exists_intro Ω X Πe T U:
+ (Ω; Π⊨ e : subst_ty T X U)%I → (Ω; Π⊨ pack e : lpexists X T)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros He.
+ iDestruct He as (α_e) "He". iExists α_e.
+ iIntros "Ha". iSpecialize ("He" with "Ha").
+ iIntros (δ) "Hδ". iIntros (θ) "Hθ".
+ iIntros "Hna". iMod ("He" with "Hδ Hθ Hna") as "_".
+ iIntros (v) "[$ HT] !>". by iExists U.
+ Qed.
+
+ Lemma poly_exists_elim Ω X ΠΞ x e e2 T U:
+ X ∉ Ω
+ → (Ω ⊨ Ξ)
+ → (Ω ⊨ U)
+ → Π##ₘ Ξ
+ → (Ω; Π⊨ e : lpexists X T)%I
+ → ({[X]} ∪ Ω; <[x := T ]> Ξ ⊨ e2 : U)%I
+ → (Ω; Π∪ Ξ ⊨ unpack e x e2 : U)%I.
+ Proof using FBI Heap SI Sequential TimeCredits Σ.
+ intros Hx Hwf HwfU Hdis He He2.
+ iDestruct He as (α_e) "He". iDestruct He2 as (α_2) "H2".
+ iExists (α_e ⊕ α_2). rewrite tc_split. iIntros "[α_e α_2]".
+ iIntros (δ) "#Hδ". iIntros (θ). rewrite env_lptyped_split //=.
+ iIntros "[HΓ HΞ] Hna".
+ wp_bind (subst_map _ e). iMod ("He" with "α_e Hδ HΓ Hna") as "_".
+ iIntros (v) "[Hna Hv] !>". iDestruct "Hv" as (T') "Hv".
+ wp_pures. rewrite -subst_map_insert.
+ iMod ("H2" with "α_2 [Hδ] [HΞ Hv] Hna") as "_".
+ - by iApply well_formed_insert.
+ - iApply env_lptyped_insert; iFrame.
+ iApply (env_lptyped_update_type_map with "HΞ"); eauto.
+ - feed pose proof (HwfU δ (<[X := (T' δ)]> δ)).
+ { intros Z Hx'. assert (X ≠Z) by set_solver. by rewrite lookup_insert_ne. }
+ iIntros (w) "[$ HU] !>". by rewrite -H.
+ Qed.
+
+End polymorphic_logical_relation.
+
+End semantic_model.
+
+From iris.examples.termination Require Import adequacy.
+Section adequacy.
+
+ Context {SI} `{C: Classical} {Σ: gFunctors SI} {Hlarge: LargeIndex SI}.
+ Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA SI))}.
+
+ Theorem simple_logrel_adequacy (e: expr) σ A:
+ (∀ `{heapG SI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA SI)},
+ ltyped ∅ e A
+ ) →
+ sn erased_step ([e], σ).
+ Proof using Hlarge C Σ Hpre Hna Htc.
+ intros Htyped.
+ eapply heap_lang_ref_adequacy.
+ intros ???. iIntros "_".
+ iPoseProof (Htyped) as (α) "H".
+ iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
+ iPoseProof (env_ltyped_empty ∅) as "Henv". iSpecialize ("H" with "Henv").
+ rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
+ by iIntros (v) "[$ _]".
+ Qed.
+
+ Theorem logrel_adequacy (e: expr) σ A:
+ (∀ `{heapG SI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA SI)},
+ lptyped ∅ ∅ e A
+ ) →
+ sn erased_step ([e], σ).
+ Proof using Hlarge C Σ Hpre Hna Htc.
+ intros Htyped.
+ eapply heap_lang_ref_adequacy.
+ intros ???. iIntros "_".
+ iPoseProof (Htyped) as (α) "H".
+ iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
+ iPoseProof (well_formed_empty with "[//]") as "Hctx".
+ iPoseProof (env_lptyped_empty ∅ ∅) as "Henv".
+ iSpecialize ("H" with "Hctx Henv").
+ rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
+ by iIntros (v) "[$ _]".
+ Qed.
+
+End adequacy.
+
+Section ordinals.
+ Context `{C: Classical} {Σ: gFunctors ordI}.
+ Context `{Hpre: !heapPreG Σ} `{Hna: !na_invG Σ} `{Htc: !inG Σ (authR (ordA ordI))}.
+
+ Theorem simple_logrel_adequacy_ord (e: expr) σ A:
+ (∀ `{heapG ordI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA ordI)},
+ ltyped ∅ e A
+ ) →
+ sn erased_step ([e], σ).
+ Proof using C Σ Hpre Hna Htc.
+ intros Htyped.
+ eapply heap_lang_ref_adequacy.
+ intros ???. iIntros "_".
+ iPoseProof (Htyped) as (α) "H".
+ iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
+ iPoseProof (env_ltyped_empty ∅) as "Henv". iSpecialize ("H" with "Henv").
+ rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
+ by iIntros (v) "[$ _]".
+ Qed.
+
+ Theorem logrel_adequacy_ord (e: expr) σ A:
+ (∀ `{heapG ordI Σ} `{!seqG Σ} `{!auth_sourceG Σ (ordA ordI)},
+ lptyped ∅ ∅ e A
+ ) →
+ sn erased_step ([e], σ).
+ Proof using C Σ Hpre Hna Htc.
+ intros Htyped.
+ eapply heap_lang_ref_adequacy.
+ intros ???. iIntros "_".
+ iPoseProof (Htyped) as (α) "H".
+ iExists α. iIntros "Hα". iSpecialize ("H" with "Hα").
+ iPoseProof (well_formed_empty with "[//]") as "Hctx".
+ iPoseProof (env_lptyped_empty ∅ ∅) as "Henv".
+ iSpecialize ("H" with "Hctx Henv").
+ rewrite subst_map_empty. iIntros "Hna". iMod ("H" with "Hna"); eauto.
+ by iIntros (v) "[$ _]".
+ Qed.
+
+End ordinals.
+
diff --git a/theories/examples/termination/thunk.v b/theories/examples/termination/thunk.v
new file mode 100644
index 0000000000000000000000000000000000000000..615ea79a76fbdbc4e9be2f6260e44f02c46b9c1c
--- /dev/null
+++ b/theories/examples/termination/thunk.v
@@ -0,0 +1,139 @@
+From iris.program_logic.refinement Require Export seq_weakestpre.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From iris.heap_lang Require Export lang lifting.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation metatheory.
+From iris.algebra Require Import auth.
+From iris.algebra.ordinals Require Import arithmetic.
+Set Default Proof Using "Type".
+
+
+
+Definition thunk : val :=
+ λ: "f", let: "r" := ref NONE in
+ λ: <>, match: !"r" with
+ SOME "v" => "v"
+ | NONE => (let: "y" := "f" #() in "r" <- SOME "y";; "y")
+ end.
+
+Section thunk_proof.
+ Context {SI} {Σ: gFunctors SI} `{Hheap: !heapG Σ} `{Htc: !tcG Σ} (N : namespace) `{Htok: !inG Σ (authR (unitUR SI))}.
+
+ Implicit Types (α β: ord_stepindex.Ord).
+
+ (* simplest spec - one to one correspondence *)
+ Lemma thunk_partial_spec (f: val) Φ:
+ WP f #() {{ Φ }} -∗ WP (thunk f) {{ g, WP g #() {{ Φ }} }}.
+ Proof.
+ iIntros "Hf". unfold thunk. wp_pures. wp_bind (ref _)%E.
+ wp_alloc r as "Hr"; wp_pures.
+ wp_pures. wp_load. wp_pures.
+ wp_apply (wp_wand with "Hf [Hr]").
+ iIntros (v) "Hv"; wp_pures.
+ by wp_store.
+ Qed.
+
+ Lemma thunk_spec (f: val) Φ:
+ WP f #() [{ Φ }] -∗ WP (thunk f) [{ g, WP g #() [{ Φ }] }].
+ Proof.
+ iIntros "Hf". unfold thunk. wp_pures. wp_bind (ref _)%E.
+ wp_alloc r as "Hr"; wp_pures.
+ wp_pures. wp_load. wp_pures.
+ wp_apply (rwp_wand with "Hf [Hr]").
+ iIntros (v) "Hv"; wp_pures.
+ by wp_store.
+ Qed.
+
+
+ Definition thunk_inv `{!seqG Σ} r (f: val) Φ : iProp Σ :=
+ (r ↦ NONEV ∗ SEQ (f #()) @ (⊤ ∖ ↑N) ⟨⟨ v, Φ v ⟩⟩ ∨ (∃ v, r ↦ SOMEV v ∗ Φ v))%I.
+
+ Lemma thunk_sequential_spec `{!seqG Σ} `{FiniteBoundedExistential SI} (f: val) Φ:
+ (∀ x, Persistent (Φ x)) →
+ SEQ (f #()) @ (⊤ ∖ ↑N) ⟨⟨ v, Φ v ⟩⟩ -∗
+ SEQ (thunk f) ⟨⟨ g, □ $one -∗ SEQ (g #()) ⟨⟨ v, Φ v⟩⟩⟩⟩.
+ Proof.
+ iIntros (HΦ) "Hf". rewrite /thunk. iIntros "Hna".
+ wp_pures. wp_bind (ref _)%E.
+ wp_alloc r as "Hr".
+ iMod (na_inv_alloc seqG_name _ N (thunk_inv r f Φ) with "[Hr Hf]") as "#I".
+ { iNext. iLeft. by iFrame. }
+ wp_pures. iFrame. iModIntro.
+ iIntros "Hc Hna". wp_pures.
+ wp_bind (! _)%E.
+ iMod (na_inv_acc_open with "I Hna") as "P"; eauto.
+ iApply (tcwp_burn_credit with "Hc"); auto. iNext.
+ iDestruct "P" as "([H|H] & Hna & Hclose)".
+ - iDestruct "H" as "(Hr & Hwp)".
+ wp_load. wp_pures. iSpecialize ("Hwp" with "Hna").
+ wp_bind (f #()). iApply (rwp_wand with "Hwp [Hr Hclose]").
+ iIntros (v) "[Hna #HΦ]". wp_pures.
+ wp_bind (#r <- _)%E. wp_store.
+ iMod ("Hclose" with "[Hr $Hna]") as "Hna".
+ { iNext. iRight. iExists v. by iFrame. }
+ wp_pures. by iFrame.
+ - iDestruct "H" as (v) "[Hr #HΦ]".
+ wp_load. iMod ("Hclose" with "[Hr $Hna]") as "Hna".
+ { iNext. iRight. iExists v. by iFrame. }
+ wp_pures. by iFrame.
+ Qed.
+
+
+ (* the timeless portion *)
+ Definition prepaid_inv_tl `{!seqG Σ} γ r Φ : iProp Σ :=
+ ((r ↦ NONEV ∗ $ one ∗ own γ (◠())) ∨ (∃ v, r ↦ SOMEV v ∗ Φ v))%I.
+
+ Global Instance prepaid_inv_tl_timeless `{!seqG Σ} α γ Φ r: (∀ v, Timeless (Φ v)) → Timeless (prepaid_inv_tl γ r Φ).
+ Proof.
+ intros. rewrite /prepaid_inv_tl. apply _.
+ Qed.
+
+ Definition prepaid_inv_re `{!seqG Σ} γ (f: val) Φ : iProp Σ :=
+ (SEQ (f #()) @ (⊤ ∖ ↑N.@"tl" ∖ ↑N.@"re") ⟨⟨ v, Φ v ⟩⟩ ∨ own γ (◠()))%I.
+
+
+ Lemma thunk_sequential_prepaid_spec `{!seqG Σ} `{FiniteBoundedExistential SI} (f: val) Φ:
+ (∀ x, Persistent (Φ x)) → (∀ x, Timeless (Φ x)) →
+ SEQ (f #()) @ (⊤ ∖ ↑N.@"tl" ∖ ↑N.@"re") ⟨⟨v, Φ v⟩⟩ -∗ $one -∗ SEQ (thunk f) ⟨⟨ g, □ SEQ (g #()) ⟨⟨ v, Φ v⟩⟩⟩⟩.
+ Proof using Hheap Htc Htok N SI Σ.
+ iIntros (??) "Hf Hone". rewrite /thunk. iIntros "Hna".
+ wp_pures.
+ iMod (own_alloc (â— ())) as (γ) "Hâ—"; first by apply auth_auth_valid.
+ wp_bind (ref _)%E.
+ wp_alloc r as "Hr".
+ iMod (na_inv_alloc seqG_name _ (N .@ "tl") (prepaid_inv_tl γ r Φ) with "[Hr Hone Hâ—]") as "#Itl".
+ { iNext. iLeft. by iFrame. }
+ iMod (na_inv_alloc seqG_name _ (N .@ "re") (prepaid_inv_re γ f Φ) with "[$Hf]") as "#Ire".
+ wp_pures. iFrame. iModIntro.
+ iIntros "Hna". wp_pures.
+ wp_bind (! _)%E.
+ iMod (na_inv_acc_open_timeless with "Itl Hna") as "([H|H] & Hna & Hclose)"; eauto.
+ - iDestruct "H" as "(Hr & Hone & Hâ—)".
+ iMod (na_inv_acc_open with "Ire Hna") as "P"; eauto; first solve_ndisj.
+ iApply (tcwp_burn_credit with "Hone"); auto.
+ iNext. iDestruct "P" as "(Hre & Hna & Hclose')".
+ wp_load. wp_pures.
+ wp_bind (f #()). rewrite /prepaid_inv_re.
+ iDestruct "Hre" as "[Hwp|Hâ—']".
+ + iSpecialize ("Hwp" with "Hna").
+ iApply (rwp_wand with "Hwp [Hr Hclose Hclose' Hâ—]").
+ iIntros (v) "[Hna #HΦ]". wp_pures.
+ wp_bind (#r <- _)%E. wp_store.
+ iMod ("Hclose'" with "[$Hna $Hâ—]") as "Hna".
+ iMod ("Hclose" with "[Hr $Hna]") as "Hna".
+ { iNext. iRight. iExists v. by iFrame. }
+ wp_pures. by iFrame.
+ + iCombine "Hâ— Hâ—'" as "H".
+ iPoseProof (own_valid with "H") as "H".
+ rewrite uPred.discrete_valid.
+ iDestruct "H" as "%".
+ apply ->(@auth_auth_frac_valid SI) in H2.
+ destruct H2 as [H2 _]. rewrite frac_op' in H2.
+ apply ->(@frac_valid' SI) in H2.
+ exfalso. by eapply Qp_not_plus_q_ge_1.
+ - iDestruct "H" as (v) "[Hr #HΦ]".
+ wp_load. iMod ("Hclose" with "[Hr $Hna]") as "Hna".
+ { iNext. iRight. iExists v. by iFrame. }
+ wp_pures. by iFrame.
+ Qed.
+End thunk_proof.
diff --git a/theories/examples/transfinite.v b/theories/examples/transfinite.v
new file mode 100644
index 0000000000000000000000000000000000000000..c2554f18d771c3bb739947ca6a3dc0dafcec1b78
--- /dev/null
+++ b/theories/examples/transfinite.v
@@ -0,0 +1,150 @@
+From iris.program_logic Require Export weakestpre.
+From iris.heap_lang Require Export lang.
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import proofmode notation.
+From iris.algebra Require Import auth.
+From iris.examples.safety Require Import lock.
+Set Default Proof Using "Type".
+
+
+Section how_to_handle_invariants.
+ Context {SI} {Σ: gFunctors SI} `{!heapG Σ} (N : namespace).
+
+
+
+ (* We compare how opening invariants worked previously and
+ how it can be done in the transfinite setting. *)
+ Lemma invariants_previously `{FiniteIndex SI} l Φ:
+ {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
+ Proof.
+ iIntros (Ï•) "#I Post".
+ iInv "I" as "H" "Hclose".
+ iDestruct "H" as (v) "[Hl P]".
+ wp_load. iMod ("Hclose" with "[Hl P]") as "_".
+ { iNext. iExists v. iFrame. }
+ iModIntro. by iApply "Post".
+ Qed.
+
+
+ Lemma invariants_transfinite l Φ:
+ {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
+ Proof.
+ iIntros (Ï•) "#I Post".
+ (* We move from the weakest pre to the stronger version which allows us to strip off laters.
+ The argument is the number of laters we want to strip off. *)
+ wp_swp 1%nat.
+ (* SWP supports opening up invariants *)
+ iInv "I" as "H" "Hclose".
+ (* In general, we cannot commutate later with existential quantification *)
+ Fail iDestruct "H" as (v) "[Hl P]".
+ (* To access the contents of "H", we need to get rid of the later modality.
+ We use the step property of SWP to add an additional later to our goal. *)
+ swp_step. iNext; simpl.
+ (* Afterwards the proof continues exactly the same as before. *)
+ iDestruct "H" as (v) "[Hl P]".
+ wp_load. iMod ("Hclose" with "[Hl P]") as "_".
+ { iNext. iExists v. iFrame. }
+ iModIntro. by iApply "Post".
+ Qed.
+
+
+ (* Using Coq EVars we leave the step counting to Coq: *)
+ Lemma invariants_transfinite_evars l Φ:
+ {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
+ Proof.
+ iIntros (Ï•) "#I Post".
+ (* If no argument is provided to wp_swp, then the number of
+ laters is instantiated with an evar (k in the following). *)
+ wp_swp. iInv "I" as "H" "Hclose".
+ (* In calling swp_step Coq creates a new evar, say k', and picks k := S k'.
+ The user will usually only see k' from there on. *)
+ swp_step.
+ iNext; simpl.
+ iDestruct "H" as (v) "[Hl P]".
+ wp_load. iMod ("Hclose" with "[Hl P]") as "_".
+ { iNext. iExists v. iFrame. }
+ iModIntro. by iApply "Post".
+ (* At the end we need to pick a value for the evar k'. Here 0 is always sufficient. *)
+ Unshelve. exact 0%nat.
+ (* Note that from k' := 0 automatically k := 1 follows *)
+ Qed.
+
+ (* Make the instantiation step explicit *)
+ Lemma swp_finish E e s Φ : SWP e at 0%nat @ s; E {{ Φ }} ⊢ SWP e at 0%nat @ s; E {{ Φ }}.
+ Proof. eauto. Qed.
+ Ltac swp_finish := iApply swp_finish.
+ Ltac swp_last_step := swp_step; swp_finish.
+
+
+ (* Using Coq EVars we leave the step counting to Coq: *)
+ Lemma invariants_transfinite_evars_inst l Φ:
+ {{{ inv N (∃ v, l ↦ v ∗ Φ v) }}} ! #l {{{ v, RET v; True }}}.
+ Proof.
+ iIntros (Ï•) "#I Post".
+ (* If no argument is provided to wp_swp, then the number of
+ laters is instantiated with an evar (k in the following). *)
+ wp_swp. iInv "I" as "H" "Hclose".
+ (* do 5 swp_step. swp_finish. *)
+ swp_last_step.
+ iNext; simpl.
+ iDestruct "H" as (v) "[Hl P]".
+ wp_load. iMod ("Hclose" with "[Hl P]") as "_".
+ { iNext. iExists v. iFrame. }
+ iModIntro. by iApply "Post".
+ Qed.
+
+ (* Nested invariants *)
+ (* We can nest invariants and open nested invariants in a single step of computation *)
+ Section nested_invariants.
+ Context `{inG SI Σ (authR (mnatUR SI))}.
+
+ (* invariant asserting that the value stored at l is only increasing and already positive *)
+ Definition Pos N l γ : iProp Σ := inv N (∃ n: mnat, l ↦ #n ∗ ⌜n > 0⌠∗ own γ (◯ n))%I.
+
+
+ Definition L l1 γ : iProp Σ := inv (N .@ "L") (∃ m: mnat, l1 ↦ #m ∗ own γ (◠m))%I.
+ Definition R l2 γ : iProp Σ := inv (N .@ "R") (∃ l2': loc, l2 ↦ #l2' ∗ Pos (N .@ "I") l2' γ)%I.
+
+ Lemma mnat_own (m n: mnat) γ:
+ own γ (â— m) -∗ own γ (â—¯ n) -∗ ⌜n ≤ mâŒ%nat.
+ Proof.
+ iIntros "Hγ◠Hγ◯". iDestruct (own_valid_2 with "Hγ◠Hγ◯") as "H"; iRevert "H".
+ iIntros (Hv). iPureIntro. eapply (mnat_included SI).
+ apply auth_both_valid in Hv as [Hv _]; done.
+ Qed.
+
+ Lemma invariants_transfinite_nested γ l1 l2:
+ {{{ L l1 γ ∗ R l2 γ }}} !#l1 {{{ (m: nat), RET #m; ⌜m > 0⌠}}}.
+ Proof.
+ iIntros (Ï•) "[#L #R] H".
+ (* we need to open all invariants to ensure that the value stored at l1 is positive *)
+ wp_swp 2%nat.
+ iInv "L" as "HL" "CloseL".
+ iInv "R" as "HR" "CloseR".
+ swp_step. iNext; simpl.
+ iDestruct "HL" as (m) "[Hl1 Hγâ—]". iDestruct "HR" as (l2') "[Hl2 #I]".
+ iInv "I" as "HI" "CloseI".
+ swp_step. iNext; simpl.
+ iDestruct "HI" as (n) "(Hl2' & % & #Hγ◯)".
+ iPoseProof (mnat_own with "Hγ◠Hγ◯") as "%".
+ wp_load.
+ iMod ("CloseI" with "[Hl2']") as "_".
+ { iExists n; iNext; iFrame; by iSplit. }
+ iModIntro. iMod ("CloseR" with "[Hl2]") as "_".
+ { iExists l2'; iNext; by iFrame. } iModIntro.
+ iMod ("CloseL" with "[Hl1 Hγâ—]") as "_"; first (iNext; iExists m; iFrame).
+ iModIntro. iApply "H". iPureIntro. lia.
+ Qed.
+ End nested_invariants.
+
+
+ Lemma invariants_swp k e φ P `{!Atomic StronglyAtomic e}:
+ (P ⊢ SWP e at k @ ⊤∖↑N {{v, φ v ∗ P}}) → inv N P ⊢ SWP e at (S k) {{ v, φ v}}.
+ Proof.
+ iIntros (H) "I". iInv "I" as "P". swp_step. iNext.
+ iPoseProof (H with "P") as "Q". iApply swp_wand_r.
+ iFrame. iIntros (v) "($ & $)". by iModIntro.
+ Qed.
+
+
+End how_to_handle_invariants.
diff --git a/theories/heap_lang/adequacy.v b/theories/heap_lang/adequacy.v
index d3b20324a43c4ab9fac2cb3fb95aeed67bf7be80..eb1a8e0df2e3ba3e19cbf26fcbc6d806e5a905d7 100644
--- a/theories/heap_lang/adequacy.v
+++ b/theories/heap_lang/adequacy.v
@@ -1,29 +1,38 @@
From iris.program_logic Require Export weakestpre adequacy.
+From iris.program_logic.refinement Require Export ref_weakestpre ref_adequacy tc_weakestpre.
From iris.algebra Require Import auth.
From iris.heap_lang Require Import proofmode notation.
From iris.base_logic.lib Require Import proph_map.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
-Class heapPreG Σ := HeapPreG {
- heap_preG_iris :> invPreG Σ;
- heap_preG_heap :> gen_heapPreG loc val Σ;
- heap_preG_proph :> proph_mapPreG proph_id (val * val) Σ
-}.
-
-Definition heapΣ : gFunctors := #[invΣ; gen_heapΣ loc val; proph_mapΣ proph_id (val * val)].
-Instance subG_heapPreG {Σ} : subG heapΣ Σ → heapPreG Σ.
+Definition heapΣ SI : gFunctors SI := #[invΣ SI; gen_heapΣ loc val; proph_mapΣ proph_id (val * val)].
+Instance subG_heapPreG {SI} {Σ: gFunctors SI} : subG (heapΣ SI) Σ → heapPreG Σ.
Proof. solve_inG. Qed.
-Definition heap_adequacy Σ `{!heapPreG Σ} s e σ φ :
- (∀ `{!heapG Σ}, WP e @ s; ⊤ {{ v, ⌜φ v⌠}}%I) →
+Definition heap_adequacy {SI} `{TransfiniteIndex SI} (Σ: gFunctors SI) `{!heapPreG Σ} s e σ φ :
+ (∀ `{!heapG Σ}, sbi_emp_valid (WP e @ s; ⊤ {{ v, ⌜φ v⌠}}%I)) →
adequate s e σ (λ v _, φ v).
Proof.
- intros Hwp; eapply (wp_adequacy _ _); iIntros (??) "".
+ intros Hwp; eapply (wp_adequacy _ _). iIntros (??) "".
iMod (gen_heap_init σ.(heap)) as (?) "Hh".
iMod (proph_map_init κs σ.(used_proph_id)) as (?) "Hp".
iModIntro. iExists
(λ σ κs, (gen_heap_ctx σ.(heap) ∗ proph_map_ctx κs σ.(used_proph_id))%I),
(λ _, True%I).
- iFrame. iApply (Hwp (HeapG _ _ _ _)).
+ iFrame. iApply (Hwp (HeapG _ _ _ _ _)).
+Qed.
+
+
+Arguments satisfiable_at {_ _ _} _ _%I.
+Lemma satisfiable_at_add {SI} (Σ: gFunctors SI) `{!invG Σ} E P Q: satisfiable_at E P → sbi_emp_valid Q → satisfiable_at E (P ∗ Q).
+Proof.
+ intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
+ iIntros "$". iApply Hval.
+Qed.
+
+Lemma satisfiable_at_add' {SI} (Σ: gFunctors SI) `{!invG Σ} E Q: satisfiable_at E True → sbi_emp_valid Q → satisfiable_at E Q.
+Proof.
+ intros Hsat Hval. eapply satisfiable_at_mono; first eauto.
+ iIntros "_". iApply Hval.
Qed.
diff --git a/theories/heap_lang/lang.v b/theories/heap_lang/lang.v
index 4371dc2376a72e4d96c9d61074697781eaeefe3c..723b6cbc1d0ad407b63638a9426ea98e6987fb88 100644
--- a/theories/heap_lang/lang.v
+++ b/theories/heap_lang/lang.v
@@ -254,6 +254,8 @@ Proof.
Defined.
Instance val_eq_dec : EqDecision val.
Proof. solve_decision. Defined.
+Instance state_eq_dec : EqDecision state.
+Proof. solve_decision. Defined.
Instance base_lit_countable : Countable base_lit.
Proof.
@@ -377,10 +379,10 @@ Instance state_inhabited : Inhabited state :=
Instance val_inhabited : Inhabited val := populate (LitV LitUnit).
Instance expr_inhabited : Inhabited expr := populate (Val inhabitant).
-Canonical Structure stateO := leibnizO state.
-Canonical Structure locO := leibnizO loc.
-Canonical Structure valO := leibnizO val.
-Canonical Structure exprO := leibnizO expr.
+Canonical Structure stateO SI := leibnizO SI state.
+Canonical Structure locO SI := leibnizO SI loc.
+Canonical Structure valO SI := leibnizO SI val.
+Canonical Structure exprO SI := leibnizO SI expr.
(** Evaluation contexts *)
Inductive ectx_item :=
@@ -657,7 +659,7 @@ Inductive head_step : expr → state → list observation → expr → state →
p ∉ σ.(used_proph_id) →
head_step NewProph σ
[]
- (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id ({[ p ]} ∪) σ)
+ (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id (union {[ p ]}) σ)
[]
| ResolveS p v e σ w σ' κs ts :
head_step e σ κs (Val v) σ' ts →
@@ -698,7 +700,7 @@ Qed.
Lemma new_proph_id_fresh σ :
let p := fresh σ.(used_proph_id) in
- head_step NewProph σ [] (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id ({[ p ]} ∪) σ) [].
+ head_step NewProph σ [] (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id (union {[ p ]}) σ) [].
Proof. constructor. apply is_fresh. Qed.
Lemma heap_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
@@ -713,6 +715,9 @@ Canonical Structure heap_ectxi_lang := EctxiLanguage heap_lang.heap_lang_mixin.
Canonical Structure heap_ectx_lang := EctxLanguageOfEctxi heap_ectxi_lang.
Canonical Structure heap_lang := LanguageOfEctx heap_ectx_lang.
+Global Instance cfg_eq_dec : EqDecision (cfg heap_lang).
+Proof. solve_decision. Defined.
+
(* Prefer heap_lang names over ectx_language names. *)
Export heap_lang.
@@ -733,6 +738,12 @@ Proof.
by simplify_eq.
Qed.
+Lemma to_val_fill_none e K: to_val e = None → to_val (fill K e) = None.
+Proof.
+ intros H; destruct (to_val (fill K e)) eqn: Hval; auto.
+ apply to_val_fill_some in Hval as [_ ->]. discriminate.
+Qed.
+
Lemma prim_step_to_val_is_head_step e σ1 κs w σ2 efs :
prim_step e σ1 κs (Val w) σ2 efs → head_step e σ1 κs (Val w) σ2 efs.
Proof.
diff --git a/theories/heap_lang/lib/atomic_heap.v b/theories/heap_lang/lib/atomic_heap.v
deleted file mode 100644
index 7fc424dd67486bde7a7e6c02c0eb92fb3044deb6..0000000000000000000000000000000000000000
--- a/theories/heap_lang/lib/atomic_heap.v
+++ /dev/null
@@ -1,140 +0,0 @@
-From iris.heap_lang Require Export lifting notation.
-From iris.program_logic Require Export atomic.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation.
-From iris.bi.lib Require Import fractional.
-Set Default Proof Using "Type".
-
-(** A general logically atomic interface for a heap. *)
-Class atomic_heap {Σ} `{!heapG Σ} := AtomicHeap {
- (* -- operations -- *)
- alloc : val;
- load : val;
- store : val;
- cmpxchg : val;
- (* -- predicates -- *)
- mapsto (l : loc) (q: Qp) (v : val) : iProp Σ;
- (* -- mapsto properties -- *)
- mapsto_timeless l q v :> Timeless (mapsto l q v);
- mapsto_fractional l v :> Fractional (λ q, mapsto l q v);
- mapsto_as_fractional l q v :>
- AsFractional (mapsto l q v) (λ q, mapsto l q v) q;
- mapsto_agree l q1 q2 v1 v2 : mapsto l q1 v1 -∗ mapsto l q2 v2 -∗ ⌜v1 = v2âŒ;
- (* -- operation specs -- *)
- alloc_spec (v : val) :
- {{{ True }}} alloc v {{{ l, RET #l; mapsto l 1 v }}};
- load_spec (l : loc) :
- <<< ∀ (v : val) q, mapsto l q v >>> load #l @ ⊤ <<< mapsto l q v, RET v >>>;
- store_spec (l : loc) (w : val) :
- <<< ∀ v, mapsto l 1 v >>> store #l w @ ⊤
- <<< mapsto l 1 w, RET #() >>>;
- (* This spec is slightly weaker than it could be: It is sufficient for [w1]
- *or* [v] to be unboxed. However, by writing it this way the [val_is_unboxed]
- is outside the atomic triple, which makes it much easier to use -- and the
- spec is still good enough for all our applications.
- The postcondition deliberately does not use [bool_decide] so that users can
- [destruct (decide (a = b))] and it will simplify in both places. *)
- cmpxchg_spec (l : loc) (w1 w2 : val) :
- val_is_unboxed w1 →
- <<< ∀ v, mapsto l 1 v >>> cmpxchg #l w1 w2 @ ⊤
- <<< if decide (v = w1) then mapsto l 1 w2 else mapsto l 1 v,
- RET (v, #if decide (v = w1) then true else false) >>>;
-}.
-Arguments atomic_heap _ {_}.
-
-(** Notation for heap primitives, in a module so you can import it separately. *)
-Module notation.
-Notation "l ↦{ q } v" := (mapsto l q v)
- (at level 20, q at level 50, format "l ↦{ q } v") : bi_scope.
-Notation "l ↦ v" := (mapsto l 1 v) (at level 20) : bi_scope.
-
-Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
- (at level 20, q at level 50, format "l ↦{ q } -") : bi_scope.
-Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope.
-
-Notation "'ref' e" := (alloc e) : expr_scope.
-Notation "! e" := (load e) : expr_scope.
-Notation "e1 <- e2" := (store e1 e2) : expr_scope.
-
-Notation CAS e1 e2 e3 := (Snd (cmpxchg e1 e2 e3)).
-
-End notation.
-
-Section derived.
- Context `{!heapG Σ, !atomic_heap Σ}.
-
- Import notation.
-
- Lemma cas_spec (l : loc) (w1 w2 : val) :
- val_is_unboxed w1 →
- <<< ∀ v, mapsto l 1 v >>> CAS #l w1 w2 @ ⊤
- <<< if decide (v = w1) then mapsto l 1 w2 else mapsto l 1 v,
- RET #if decide (v = w1) then true else false >>>.
- Proof.
- iIntros (? Φ) "AU". awp_apply cmpxchg_spec; first done.
- iApply (aacc_aupd_commit with "AU"); first done.
- iIntros (v) "H↦". iAaccIntro with "H↦"; first by eauto with iFrame.
- iIntros "$ !> HΦ !>". wp_pures. done.
- Qed.
-End derived.
-
-(** Proof that the primitive physical operations of heap_lang satisfy said interface. *)
-Definition primitive_alloc : val :=
- λ: "v", ref "v".
-Definition primitive_load : val :=
- λ: "l", !"l".
-Definition primitive_store : val :=
- λ: "l" "x", "l" <- "x".
-Definition primitive_cmpxchg : val :=
- λ: "l" "e1" "e2", CmpXchg "l" "e1" "e2".
-
-Section proof.
- Context `{!heapG Σ}.
-
- Lemma primitive_alloc_spec (v : val) :
- {{{ True }}} primitive_alloc v {{{ l, RET #l; l ↦ v }}}.
- Proof.
- iIntros (Φ) "_ HΦ". wp_lam. wp_alloc l. iApply "HΦ". done.
- Qed.
-
- Lemma primitive_load_spec (l : loc) :
- <<< ∀ (v : val) q, l ↦{q} v >>> primitive_load #l @ ⊤
- <<< l ↦{q} v, RET v >>>.
- Proof.
- iIntros (Φ) "AU". wp_lam.
- iMod "AU" as (v q) "[H↦ [_ Hclose]]".
- wp_load. iMod ("Hclose" with "H↦") as "HΦ". done.
- Qed.
-
- Lemma primitive_store_spec (l : loc) (w : val) :
- <<< ∀ v, l ↦ v >>> primitive_store #l w @ ⊤
- <<< l ↦ w, RET #() >>>.
- Proof.
- iIntros (Φ) "AU". wp_lam. wp_let.
- iMod "AU" as (v) "[H↦ [_ Hclose]]".
- wp_store. iMod ("Hclose" with "H↦") as "HΦ". done.
- Qed.
-
- Lemma primitive_cmpxchg_spec (l : loc) (w1 w2 : val) :
- val_is_unboxed w1 →
- <<< ∀ (v : val), l ↦ v >>>
- primitive_cmpxchg #l w1 w2 @ ⊤
- <<< if decide (v = w1) then l ↦ w2 else l ↦ v,
- RET (v, #if decide (v = w1) then true else false) >>>.
- Proof.
- iIntros (? Φ) "AU". wp_lam. wp_pures.
- iMod "AU" as (v) "[H↦ [_ Hclose]]".
- destruct (decide (v = w1)) as [Heq|Hne];
- [wp_cmpxchg_suc|wp_cmpxchg_fail];
- iMod ("Hclose" with "H↦") as "HΦ"; done.
- Qed.
-End proof.
-
-(* NOT an instance because users should choose explicitly to use it
- (using [Explicit Instance]). *)
-Definition primitive_atomic_heap `{!heapG Σ} : atomic_heap Σ :=
- {| alloc_spec := primitive_alloc_spec;
- load_spec := primitive_load_spec;
- store_spec := primitive_store_spec;
- cmpxchg_spec := primitive_cmpxchg_spec;
- mapsto_agree := gen_heap.mapsto_agree |}.
diff --git a/theories/heap_lang/lib/increment.v b/theories/heap_lang/lib/increment.v
deleted file mode 100644
index 00065aa8db13d86a5800827e900acf787c7604ef..0000000000000000000000000000000000000000
--- a/theories/heap_lang/lib/increment.v
+++ /dev/null
@@ -1,164 +0,0 @@
-From iris.base_logic.lib Require Export invariants.
-From iris.program_logic Require Export atomic.
-From iris.proofmode Require Import tactics.
-From iris.heap_lang Require Import proofmode notation atomic_heap par.
-From iris.bi.lib Require Import fractional.
-Set Default Proof Using "Type".
-
-(** Show that implementing fetch-and-add on top of CAS preserves logical
-atomicity. *)
-
-(** First: logically atomic increment directly on top of the physical heap. *)
-
-Section increment_physical.
- Context `{!heapG Σ}.
-
- Definition incr_phy : val :=
- rec: "incr" "l" :=
- let: "oldv" := !"l" in
- if: CAS "l" "oldv" ("oldv" + #1)
- then "oldv" (* return old value if success *)
- else "incr" "l".
-
- Lemma incr_phy_spec (l: loc) :
- <<< ∀ (v : Z), l ↦ #v >>> incr_phy #l @ ⊤ <<< l ↦ #(v + 1), RET #v >>>.
- Proof.
- iIntros (Φ) "AU". iLöb as "IH". wp_lam.
- wp_bind (!_)%E. iMod "AU" as (v) "[Hl [Hclose _]]".
- wp_load. iMod ("Hclose" with "Hl") as "AU". iModIntro.
- wp_pures. wp_bind (CmpXchg _ _ _)%E. iMod "AU" as (w) "[Hl Hclose]".
- destruct (decide (#v = #w)) as [[= ->]|Hx].
- - wp_cmpxchg_suc. iDestruct "Hclose" as "[_ Hclose]". iMod ("Hclose" with "Hl") as "HΦ".
- iModIntro. wp_pures. done.
- - wp_cmpxchg_fail. iDestruct "Hclose" as "[Hclose _]". iMod ("Hclose" with "Hl") as "AU".
- iModIntro. wp_pures. iApply "IH". done.
- Qed.
-End increment_physical.
-
-(** Next: logically atomic increment on top of an arbitrary logically atomic heap *)
-
-Section increment.
- Context `{!heapG Σ} {aheap: atomic_heap Σ}.
-
- Import atomic_heap.notation.
-
- Definition incr : val :=
- rec: "incr" "l" :=
- let: "oldv" := !"l" in
- if: CAS "l" "oldv" ("oldv" + #1)
- then "oldv" (* return old value if success *)
- else "incr" "l".
-
- (** A proof of the incr specification that unfolds the definition
- of atomic accessors. Useful for introducing them as a concept,
- but see below for a shorter proof. *)
- Lemma incr_spec_direct (l: loc) :
- <<< ∀ (v : Z), l ↦ #v >>> incr #l @ ⊤ <<< l ↦ #(v + 1), RET #v >>>.
- Proof.
- iIntros (Φ) "AU". iLöb as "IH". wp_lam.
- awp_apply load_spec.
- (* Prove the atomic update for load *)
- rewrite /atomic_acc /=. iMod "AU" as (v) "[Hl [Hclose _]]".
- iModIntro. iExists _, _. iFrame "Hl". iSplit.
- { (* abort case *) done. }
- iIntros "Hl". iMod ("Hclose" with "Hl") as "AU". iModIntro.
- (* Now go on *)
- awp_apply cas_spec; first done.
- (* Prove the atomic update for CAS *)
- rewrite /atomic_acc /=. iMod "AU" as (w) "[Hl Hclose]".
- iModIntro. iExists _. iFrame "Hl". iSplit.
- { (* abort case *) iDestruct "Hclose" as "[? _]". done. }
- iIntros "Hl". simpl. destruct (decide (#w = #v)) as [[= ->]|Hx].
- - iDestruct "Hclose" as "[_ Hclose]". iMod ("Hclose" with "Hl") as "HΦ".
- iIntros "!>". wp_if. by iApply "HΦ".
- - iDestruct "Hclose" as "[Hclose _]". iMod ("Hclose" with "Hl") as "AU".
- iIntros "!>". wp_if. iApply "IH". done.
- Qed.
-
- (** A proof of the incr specification that uses lemmas to avoid reasining
- with the definition of atomic accessors. *)
- Lemma incr_spec (l: loc) :
- <<< ∀ (v : Z), l ↦ #v >>> incr #l @ ⊤ <<< l ↦ #(v + 1), RET #v >>>.
- Proof.
- iIntros (Φ) "AU". iLöb as "IH". wp_lam.
- awp_apply load_spec.
- (* Prove the atomic update for load *)
- iApply (aacc_aupd_abort with "AU"); first done.
- iIntros (x) "H↦". iAaccIntro with "H↦"; first by eauto with iFrame.
- iIntros "$ !> AU !>".
- (* Now go on *)
- awp_apply cas_spec; first done.
- (* Prove the atomic update for CAS *)
- iApply (aacc_aupd with "AU"); first done.
- iIntros (x') "H↦". iAaccIntro with "H↦"; first by eauto with iFrame.
- iIntros "H↦ !>".
- simpl. destruct (decide (#x' = #x)) as [[= ->]|Hx].
- - iRight. iFrame. iIntros "HΦ !>".
- wp_if. by iApply "HΦ".
- - iLeft. iFrame. iIntros "AU !>".
- wp_if. iApply "IH". done.
- Qed.
-
- (** A "weak increment": assumes that there is no race *)
- Definition weak_incr: val :=
- rec: "weak_incr" "l" :=
- let: "oldv" := !"l" in
- "l" <- ("oldv" + #1);;
- "oldv" (* return old value *).
-
- (** Logically atomic spec for weak increment. Also an example for what TaDA
- calls "private precondition". *)
- (* TODO: Generalize to q and 1-q, based on some theory for a "maybe-mapsto"
- connective that works on [option Qp] (the type of 1-q). *)
- Lemma weak_incr_spec (l: loc) (v : Z) :
- l ↦{1/2} #v -∗
- <<< ∀ (v' : Z), l ↦{1/2} #v' >>>
- weak_incr #l @ ⊤
- <<< ⌜v = v'⌠∗ l ↦ #(v + 1), RET #v >>>.
- Proof.
- iIntros "Hl" (Φ) "AU". wp_lam.
- wp_apply (atomic_wp_seq $! (load_spec _) with "Hl").
- iIntros "Hl". awp_apply store_spec.
- (* Prove the atomic update for store *)
- iApply (aacc_aupd_commit with "AU"); first done.
- iIntros (x) "H↦".
- iDestruct (mapsto_agree with "Hl H↦") as %[= <-].
- iCombine "Hl" "H↦" as "Hl". iAaccIntro with "Hl".
- { iIntros "[$ $]"; eauto. }
- iIntros "$ !>". iSplit; first done.
- iIntros "HΦ !>". wp_seq. done.
- Qed.
-
-End increment.
-
-Section increment_client.
- Context `{!heapG Σ, !spawnG Σ}.
-
- Existing Instance primitive_atomic_heap.
-
- Definition incr_client : val :=
- λ: "x",
- let: "l" := ref "x" in
- incr "l" ||| incr "l".
-
- Lemma incr_client_safe (x: Z):
- WP incr_client #x {{ _, True }}%I.
- Proof using Type*.
- wp_lam. wp_alloc l as "Hl".
- iMod (inv_alloc nroot _ (∃x':Z, l ↦ #x')%I with "[Hl]") as "#Hinv"; first eauto.
- (* FIXME: I am only using persistent stuff, so I should be allowed
- to move this to the persisten context even without the additional â–¡. *)
- iAssert (â–¡ WP incr #l {{ _, True }})%I as "#Aupd".
- { iAlways. awp_apply incr_spec. clear x.
- iInv nroot as (x) ">H↦". iAaccIntro with "H↦"; first by eauto 10.
- iIntros "H↦ !>". iSplitL "H↦"; first by eauto 10.
- (* The continuation: From after the atomic triple to the postcondition of the WP *)
- done.
- }
- wp_apply wp_par.
- - iAssumption.
- - iAssumption.
- - iIntros (??) "_ !>". done.
- Qed.
-
-End increment_client.
diff --git a/theories/heap_lang/lifting.v b/theories/heap_lang/lifting.v
index 48b9cbe700adc485f7436bed3ee1fdba90ee75d1..40d499bbe9764fa688d7a797445a864f20ea4b7c 100644
--- a/theories/heap_lang/lifting.v
+++ b/theories/heap_lang/lifting.v
@@ -2,26 +2,41 @@ From iris.algebra Require Import auth gmap.
From iris.base_logic Require Export gen_heap.
From iris.base_logic.lib Require Export proph_map.
From iris.program_logic Require Export weakestpre.
-From iris.program_logic Require Import ectx_lifting total_ectx_lifting.
+From iris.program_logic Require Import ectx_lifting.
+From iris.program_logic.refinement Require Export ref_weakestpre.
+From iris.program_logic.refinement Require Import ref_ectx_lifting.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import tactics notation.
From iris.proofmode Require Import tactics.
From stdpp Require Import fin_maps.
Set Default Proof Using "Type".
-Class heapG Σ := HeapG {
+
+Class heapPreG {SI} (Σ: gFunctors SI) := HeapPreG {
+ heap_preG_inv :> invPreG Σ;
+ heap_preG_heap :> gen_heapPreG loc val Σ;
+ heap_preG_proph :> proph_mapPreG proph_id (val * val) Σ
+}.
+
+
+Class heapG {SI} (Σ: gFunctors SI) := HeapG {
heapG_invG : invG Σ;
heapG_gen_heapG :> gen_heapG loc val Σ;
heapG_proph_mapG :> proph_mapG proph_id (val * val) Σ
}.
-Instance heapG_irisG `{!heapG Σ} : irisG heap_lang Σ := {
+Instance heapG_irisG {SI} {Σ: gFunctors SI} `{!heapG Σ} : irisG heap_lang Σ := {
iris_invG := heapG_invG;
state_interp σ κs _ :=
(gen_heap_ctx σ.(heap) ∗ proph_map_ctx κs σ.(used_proph_id))%I;
fork_post _ := True%I;
}.
+Instance heapG_ref_irisG {SI} {Σ: gFunctors SI} `{!heapG Σ} : ref_irisG heap_lang Σ := {
+ ref_state_interp σ _ := (gen_heap_ctx σ.(heap))%I;
+ ref_fork_post _ := True%I;
+}.
+
(** Override the notations so that scopes and coercions work out *)
Notation "l ↦{ q } v" := (mapsto (L:=loc) (V:=val) l q v%V)
(at level 20, q at level 50, format "l ↦{ q } v") : bi_scope.
@@ -31,7 +46,7 @@ Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
(at level 20, q at level 50, format "l ↦{ q } -") : bi_scope.
Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope.
-Definition array `{!heapG Σ} (l : loc) (vs : list val) : iProp Σ :=
+Definition array {SI} {Σ: gFunctors SI} `{!heapG Σ} (l : loc) (vs : list val) : iProp Σ :=
([∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦ v)%I.
Notation "l ↦∗ vs" := (array l vs)
(at level 20, format "l ↦∗ vs") : bi_scope.
@@ -198,7 +213,7 @@ Instance pure_case_inr v e1 e2 :
Proof. solve_pure_exec. Qed.
Section lifting.
-Context `{!heapG Σ}.
+Context {SI} {Σ: gFunctors SI} `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types efs : list expr.
@@ -216,7 +231,14 @@ Proof.
iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto.
iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed.
-
+Lemma swp_fork k s E e Φ :
+ ▷ WP e @ s; ⊤ {{ _, True }} -∗ ▷ Φ (LitV LitUnit) -∗ SWP Fork e at k @ s; E {{ Φ }}.
+Proof.
+ iIntros "He HΦ". iApply swp_lift_atomic_head_step.
+ iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto.
+ iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. by iFrame.
+Qed.
+(*
Lemma twp_fork s E e Φ :
WP e @ s; ⊤ [{ _, True }] -∗ Φ (LitV LitUnit) -∗ WP Fork e @ s; E [{ Φ }].
Proof.
@@ -224,6 +246,7 @@ Proof.
iIntros (σ1 κs n) "Hσ !>"; iSplit; first by eauto.
iIntros (κ v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed.
+ *)
Lemma array_nil l : l ↦∗ [] ⊣⊢ emp.
Proof. by rewrite /array. Qed.
@@ -271,7 +294,7 @@ Proof.
{ apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
intros (j&?&Hjl&_)%heap_array_lookup.
rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
- rewrite loc_add_0 -fmap_seq big_sepL_fmap.
+ rewrite loc_add_0 -fmap_S_seq big_sepL_fmap.
setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
setoid_rewrite <-loc_add_assoc.
rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
@@ -279,7 +302,7 @@ Qed.
Lemma update_array l vs off v :
vs !! off = Some v →
- (l ↦∗ vs -∗ ((l +ₗ off) ↦ v ∗ ∀ v', (l +ₗ off) ↦ v' -∗ l ↦∗ <[off:=v']>vs))%I.
+ sbi_emp_valid (l ↦∗ vs -∗ ((l +ₗ off) ↦ v ∗ ∀ v', (l +ₗ off) ↦ v' -∗ l ↦∗ <[off:=v']>vs))%I.
Proof.
iIntros (Hlookup) "Hl".
rewrite -[X in (l ↦∗ X)%I](take_drop_middle _ off v); last done.
@@ -313,7 +336,24 @@ Proof.
- by iApply heap_array_to_array.
- iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed.
-Lemma twp_allocN s E v n :
+Lemma swp_allocN k s E v n :
+ 0 < n →
+ {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) at k @ s; E
+ {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
+ [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
+Proof.
+ iIntros (Hn Φ) "_ HΦ". iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs k') "[Hσ Hκs] !>"; iSplit; first by auto with lia.
+ iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
+ iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
+ { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
+ rewrite replicate_length Z2Nat.id; auto with lia. }
+ iModIntro; iSplit; first done. iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
+ - by iApply heap_array_to_array.
+ - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
+Qed.
+
+(*Lemma twp_allocN s E v n :
0 < n →
[[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
[[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
@@ -328,7 +368,7 @@ Proof.
iModIntro; do 2 (iSplit; first done). iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
- by iApply heap_array_to_array.
- iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
-Qed.
+Qed.*)
Lemma wp_alloc s E v :
{{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }}}.
@@ -337,13 +377,21 @@ Proof.
iIntros "!>" (l) "/= (? & ? & _)".
rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
Qed.
-Lemma twp_alloc s E v :
+Lemma swp_alloc k s E v :
+ {{{ True }}} Alloc (Val v) at k @ s; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }}}.
+Proof.
+ iIntros (Φ) "_ HΦ". iApply swp_allocN; auto with lia.
+ iIntros "!>" (l) "/= (? & ? & _)".
+ rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
+Qed.
+
+(*Lemma twp_alloc s E v :
[[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }]].
Proof.
iIntros (Φ) "_ HΦ". iApply twp_allocN; auto with lia.
iIntros (l) "/= (? & ? & _)".
rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
-Qed.
+Qed.*)
Lemma wp_load s E l q v :
{{{ ▷ l ↦{q} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l ↦{q} v }}}.
@@ -353,14 +401,23 @@ Proof.
iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed.
-Lemma twp_load s E l q v :
+Lemma swp_load k s E l q v :
+ {{{ ▷ l ↦{q} v }}} Load (Val $ LitV $ LitLoc l) at k @ s; E {{{ RET v; l ↦{q} v }}}.
+Proof.
+ iIntros (Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
+ iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
+Qed.
+
+(*Lemma twp_load s E l q v :
[[{ l ↦{q} v }]] Load (Val $ LitV $ LitLoc l) @ s; E [[{ RET v; l ↦{q} v }]].
Proof.
iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.
+Qed.*)
Lemma wp_store s E l v' v :
{{{ ▷ l ↦ v' }}} Store (Val $ LitV (LitLoc l)) (Val v) @ s; E
@@ -373,7 +430,19 @@ Proof.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
Qed.
-Lemma twp_store s E l v' v :
+Lemma swp_store k s E l v' v :
+ {{{ ▷ l ↦ v' }}} Store (Val $ LitV (LitLoc l)) (Val v) at k @ s; E
+ {{{ RET LitV LitUnit; l ↦ v }}}.
+Proof.
+ iIntros (Φ) ">Hl HΦ".
+ iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
+ iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
+ iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
+Qed.
+
+(*Lemma twp_store s E l v' v :
[[{ l ↦ v' }]] Store (Val $ LitV $ LitLoc l) (Val v) @ s; E
[[{ RET LitV LitUnit; l ↦ v }]].
Proof.
@@ -383,7 +452,7 @@ Proof.
iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.
+Qed.*)
Lemma wp_cmpxchg_fail s E l q v' v1 v2 :
v' ≠v1 → vals_compare_safe v' v1 →
@@ -396,7 +465,18 @@ Proof.
rewrite bool_decide_false //.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed.
-Lemma twp_cmpxchg_fail s E l q v' v1 v2 :
+Lemma swp_cmpxchg_fail k s E l q v' v1 v2 :
+ v' ≠v1 → vals_compare_safe v' v1 →
+ {{{ ▷ l ↦{q} v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
+ {{{ RET PairV v' (LitV $ LitBool false); l ↦{q} v' }}}.
+Proof.
+ iIntros (?? Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
+ rewrite bool_decide_false //.
+ iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
+Qed.
+(*Lemma twp_cmpxchg_fail s E l q v' v1 v2 :
v' ≠v1 → vals_compare_safe v' v1 →
[[{ l ↦{q} v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
[[{ RET PairV v' (LitV $ LitBool false); l ↦{q} v' }]].
@@ -406,7 +486,7 @@ Proof.
iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step.
rewrite bool_decide_false //.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.
+Qed.*)
Lemma wp_cmpxchg_suc s E l v1 v2 v' :
v' = v1 → vals_compare_safe v' v1 →
@@ -420,7 +500,19 @@ Proof.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
Qed.
-Lemma twp_cmpxchg_suc s E l v1 v2 v' :
+Lemma swp_cmpxchg_suc k s E l v1 v2 v' :
+ v' = v1 → vals_compare_safe v' v1 →
+ {{{ ▷ l ↦ v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
+ {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }}}.
+Proof.
+ iIntros (?? Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
+ rewrite bool_decide_true //.
+ iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
+ iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
+Qed.
+(*Lemma twp_cmpxchg_suc s E l v1 v2 v' :
v' = v1 → vals_compare_safe v' v1 →
[[{ l ↦ v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
[[{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }]].
@@ -431,7 +523,7 @@ Proof.
rewrite bool_decide_true //.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.
+Qed.*)
Lemma wp_faa s E l i1 i2 :
{{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
@@ -443,7 +535,17 @@ Proof.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
Qed.
-Lemma twp_faa s E l i1 i2 :
+Lemma swp_faa k s E l i1 i2 :
+ {{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) at k @ s; E
+ {{{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }}}.
+Proof.
+ iIntros (Φ) ">Hl HΦ". iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
+ iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
+ iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
+Qed.
+(*Lemma twp_faa s E l i1 i2 :
[[{ l ↦ LitV (LitInt i1) }]] FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
[[{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }]].
Proof.
@@ -452,7 +554,7 @@ Proof.
iSplit; first by eauto. iIntros (κ e2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
-Qed.
+Qed.*)
Lemma wp_new_proph s E :
{{{ True }}}
@@ -465,6 +567,17 @@ Proof.
iMod (proph_map_new_proph p with "HR") as "[HR Hp]"; first done.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed.
+Lemma swp_new_proph k s E :
+ {{{ True }}}
+ NewProph at k @ s; E
+ {{{ pvs p, RET (LitV (LitProphecy p)); proph p pvs }}}.
+Proof.
+ iIntros (Φ) "_ HΦ". iApply swp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 κ κs n) "[Hσ HR] !>". iSplit; first by eauto.
+ iNext; iIntros (v2 σ2 efs Hstep). inv_head_step.
+ iMod (proph_map_new_proph p with "HR") as "[HR Hp]"; first done.
+ iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
+Qed.
(* In the following, strong atomicity is required due to the fact that [e] must
be able to make a head step for [Resolve e _ _] not to be (head) stuck. *)
@@ -505,6 +618,9 @@ Proof.
apply to_val_fill_some in H. destruct H as [-> ->]. inversion step.
Qed.
+
+Arguments gstep : simpl never.
+Existing Instance elim_gstep.
Lemma wp_resolve s E e Φ (p : proph_id) v (pvs : list (val * val)) :
Atomic StronglyAtomic e →
to_val e = None →
@@ -516,12 +632,43 @@ Proof.
here, since this breaks the WP abstraction. *)
iIntros (A He) "Hp WPe". rewrite !wp_unfold /wp_pre /= He. simpl in *.
iIntros (σ1 κ κs n) "[Hσ Hκ]". destruct κ as [|[p' [w' v']] κ' _] using rev_ind.
- - iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]". iModIntro. iSplit.
+ - iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]".
+ iSplit.
{ iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
inversion step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
- rewrite -app_assoc.
- iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]". iModIntro. iSplit.
+ iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]".
+ iSplit.
+ { iDestruct "Hs" as %?. iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
+ iIntros (e2 σ2 efs step). apply step_resolve in step; last done.
+ inversion step; simplify_list_eq.
+ iMod ("WPe" $! (Val w') σ2 efs with "[%]") as "WPe".
+ { by eexists [] _ _. }
+ iModIntro. iNext. iMod "WPe" as "[[$ Hκ] WPe]".
+ iMod (proph_map_resolve_proph p' (w',v') κs with "[$Hκ $Hp]") as (vs' ->) "[$ HPost]".
+ iModIntro. rewrite !wp_unfold /wp_pre /=. iDestruct "WPe" as "[HΦ $]".
+ iMod "HΦ". iModIntro. by iApply "HΦ".
+Qed.
+
+Arguments gstepN : simpl never.
+Existing Instance elim_gstepN.
+Lemma swp_resolve k s E e Φ (p : proph_id) v (pvs : list (val * val)) :
+ Atomic StronglyAtomic e →
+ proph p pvs -∗
+ SWP e at k @ s; E {{ r, ∀ pvs', ⌜pvs = (r, v)::pvs'⌠-∗ proph p pvs' -∗ Φ r }} -∗
+ SWP Resolve e (Val $ LitV $ LitProphecy p) (Val v) at k @ s; E {{ Φ }}.
+Proof.
+ (* TODO we should try to use a generic lifting lemma (and avoid [wp_unfold])
+ here, since this breaks the WP abstraction. *)
+ iIntros (A) "Hp WPe". rewrite !swp_unfold /swp_def /=. simpl in *.
+ iIntros (σ1 κ κs n) "[Hσ Hκ]". destruct κ as [|[p' [w' v']] κ' _] using rev_ind.
+ - iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]". iSplit.
+ { iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
+ iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
+ inversion step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
+ - rewrite -app_assoc.
+ iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]". iSplit.
{ iDestruct "Hs" as %?. iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
iIntros (e2 σ2 efs step). apply step_resolve in step; last done.
inversion step; simplify_list_eq.
@@ -544,6 +691,16 @@ Proof.
iIntros "!>" (vs') "HEq Hp". iApply "HΦ". iFrame.
Qed.
+Lemma swp_resolve_proph k s E (p : proph_id) (pvs : list (val * val)) v :
+ {{{ proph p pvs }}}
+ ResolveProph (Val $ LitV $ LitProphecy p) (Val v) at k @ s; E
+ {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌠∗ proph p pvs' }}}.
+Proof.
+ iIntros (Φ) "Hp HΦ". iApply (swp_resolve with "Hp").
+ iApply swp_pure_step_later=> //=. iApply wp_value.
+ iIntros "!>" (vs') "HEq Hp". iApply "HΦ". iFrame.
+Qed.
+
Lemma wp_resolve_cmpxchg_suc s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
vals_compare_safe v1 v1 →
{{{ proph p pvs ∗ ▷ l ↦ v1 }}}
@@ -557,6 +714,19 @@ Proof.
iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.
+Lemma swp_resolve_cmpxchg_suc k s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
+ vals_compare_safe v1 v1 →
+ {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
+ Resolve (CmpXchg #l v1 v2) #p v at k @ s; E
+ {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌠∗ proph p pvs' ∗ l ↦ v2 }}}.
+Proof.
+ iIntros (Hcmp Φ) "[Hp Hl] HΦ".
+ iApply (swp_resolve with "Hp").
+ assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
+ iApply (swp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
+ iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
+Qed.
+
Lemma wp_resolve_cmpxchg_fail s E l (p : proph_id) (pvs : list (val * val)) q v' v1 v2 v :
v' ≠v1 → vals_compare_safe v' v1 →
{{{ proph p pvs ∗ ▷ l ↦{q} v' }}}
@@ -569,6 +739,18 @@ Proof.
iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.
+Lemma swp_resolve_cmpxchg_fail k s E l (p : proph_id) (pvs : list (val * val)) q v' v1 v2 v :
+ v' ≠v1 → vals_compare_safe v' v1 →
+ {{{ proph p pvs ∗ ▷ l ↦{q} v' }}}
+ Resolve (CmpXchg #l v1 v2) #p v at k @ s; E
+ {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌠∗ proph p pvs' ∗ l ↦{q} v' }}}.
+Proof.
+ iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
+ iApply (swp_resolve with "Hp").
+ iApply (swp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
+ iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
+Qed.
+
(** Array lemmas *)
Lemma wp_allocN_vec s E v n :
0 < n →
@@ -581,21 +763,48 @@ Proof.
iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
Qed.
+Lemma swp_allocN_vec k s E v n :
+ 0 < n →
+ {{{ True }}}
+ AllocN #n v at k @ s ; E
+ {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
+ [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
+Proof.
+ iIntros (Hzs Φ) "_ HΦ". iApply swp_allocN; [ lia | done | .. ]. iNext.
+ iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
+Qed.
+
Lemma wp_load_offset s E l off vs v :
vs !! off = Some v →
{{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) @ s; E {{{ RET v; l ↦∗ vs }}}.
Proof.
- iIntros (Hlookup Φ) "Hl HΦ".
+ iIntros (Hlookup Φ) ">Hl HΦ".
iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
iApply (wp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ".
iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
iApply "Hl2". iApply "Hl1".
Qed.
+Lemma swp_load_offset k s E l off vs v :
+ vs !! off = Some v →
+ {{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) at k @ s; E {{{ RET v; l ↦∗ vs }}}.
+Proof.
+ iIntros (Hlookup Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (swp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ".
+ iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
+ iApply "Hl2". iApply "Hl1".
+Qed.
+
Lemma wp_load_offset_vec s E l sz (off : fin sz) (vs : vec val sz) :
{{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) @ s; E {{{ RET vs !!! off; l ↦∗ vs }}}.
Proof. apply wp_load_offset. by apply vlookup_lookup. Qed.
+Lemma swp_load_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) :
+ {{{ ▷ l ↦∗ vs }}} ! #(l +ₗ off) at k @ s; E {{{ RET vs !!! off; l ↦∗ vs }}}.
+Proof. apply swp_load_offset. by apply vlookup_lookup. Qed.
+
+
Lemma wp_store_offset s E l off vs v :
is_Some (vs !! off) →
{{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
@@ -605,6 +814,15 @@ Proof.
iApply (wp_store with "Hl1"). iNext. iIntros "Hl1".
iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
+Lemma swp_store_offset k s E l off vs v :
+ is_Some (vs !! off) →
+ {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v at k @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
+Proof.
+ iIntros ([w Hlookup] Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (swp_store with "Hl1"). iNext. iIntros "Hl1".
+ iApply "HΦ". iApply "Hl2". iApply "Hl1".
+Qed.
Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
{{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
@@ -612,6 +830,13 @@ Proof.
setoid_rewrite vec_to_list_insert. apply wp_store_offset.
eexists. by apply vlookup_lookup.
Qed.
+Lemma swp_store_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v :
+ {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v at k @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
+Proof.
+ setoid_rewrite vec_to_list_insert. apply swp_store_offset.
+ eexists. by apply vlookup_lookup.
+Qed.
+
Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
vs !! off = Some v' →
@@ -621,11 +846,24 @@ Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
CmpXchg #(l +â‚— off) v1 v2 @ s; E
{{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
Proof.
- iIntros (Hlookup ?? Φ) "Hl HΦ".
+ iIntros (Hlookup ?? Φ) ">Hl HΦ".
iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
iApply (wp_cmpxchg_suc with "Hl1"); [done..|].
iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
+Lemma swp_cmpxchg_suc_offset k s E l off vs v' v1 v2 :
+ vs !! off = Some v' →
+ v' = v1 →
+ vals_compare_safe v' v1 →
+ {{{ ▷ l ↦∗ vs }}}
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
+Proof.
+ iIntros (Hlookup ?? Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (swp_cmpxchg_suc with "Hl1"); [done..|].
+ iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
+Qed.
Lemma wp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
vs !!! off = v1 →
@@ -637,6 +875,16 @@ Proof.
intros. setoid_rewrite vec_to_list_insert. eapply wp_cmpxchg_suc_offset=> //.
by apply vlookup_lookup.
Qed.
+Lemma swp_cmpxchg_suc_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
+ vs !!! off = v1 →
+ vals_compare_safe (vs !!! off) v1 →
+ {{{ ▷ l ↦∗ vs }}}
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
+Proof.
+ intros. setoid_rewrite vec_to_list_insert. eapply swp_cmpxchg_suc_offset=> //.
+ by apply vlookup_lookup.
+Qed.
Lemma wp_cmpxchg_fail_offset s E l off vs v0 v1 v2 :
vs !! off = Some v0 →
@@ -654,6 +902,22 @@ Proof.
rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
Qed.
+Lemma swp_cmpxchg_fail_offset k s E l off vs v0 v1 v2 :
+ vs !! off = Some v0 →
+ v0 ≠v1 →
+ vals_compare_safe v0 v1 →
+ {{{ ▷ l ↦∗ vs }}}
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ {{{ RET (v0, #false); l ↦∗ vs }}}.
+Proof.
+ iIntros (Hlookup HNEq Hcmp Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (swp_cmpxchg_fail with "Hl1"); first done.
+ { destruct Hcmp; by [ left | right ]. }
+ iIntros "!> Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
+ rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
+Qed.
+
Lemma wp_cmpxchg_fail_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
vs !!! off ≠v1 →
vals_compare_safe (vs !!! off) v1 →
@@ -661,17 +925,34 @@ Lemma wp_cmpxchg_fail_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2
CmpXchg #(l +â‚— off) v1 v2 @ s; E
{{{ RET (vs !!! off, #false); l ↦∗ vs }}}.
Proof. intros. eapply wp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
+Lemma swp_cmpxchg_fail_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
+ vs !!! off ≠v1 →
+ vals_compare_safe (vs !!! off) v1 →
+ {{{ ▷ l ↦∗ vs }}}
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ {{{ RET (vs !!! off, #false); l ↦∗ vs }}}.
+Proof. intros. eapply swp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
Lemma wp_faa_offset s E l off vs (i1 i2 : Z) :
vs !! off = Some #i1 →
{{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
{{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
Proof.
- iIntros (Hlookup Φ) "Hl HΦ".
+ iIntros (Hlookup Φ) ">Hl HΦ".
iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
iApply (wp_faa with "Hl1").
iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
+Lemma swp_faa_offset k s E l off vs (i1 i2 : Z) :
+ vs !! off = Some #i1 →
+ {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 at k @ s; E
+ {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
+Proof.
+ iIntros (Hlookup Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (swp_faa with "Hl1").
+ iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
+Qed.
Lemma wp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
vs !!! off = #i1 →
@@ -681,5 +962,388 @@ Proof.
intros. setoid_rewrite vec_to_list_insert. apply wp_faa_offset=> //.
by apply vlookup_lookup.
Qed.
+Lemma swp_faa_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
+ vs !!! off = #i1 →
+ {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 at k @ s; E
+ {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
+Proof.
+ intros. setoid_rewrite vec_to_list_insert. apply swp_faa_offset=> //.
+ by apply vlookup_lookup.
+Qed.
End lifting.
+
+
+
+Section refinements.
+
+ Context {SI} {Σ: gFunctors SI} {A: Type} `{!source Σ A} `{!heapG Σ}.
+ Implicit Types P Q : iProp Σ.
+ Implicit Types Φ : val → iProp Σ.
+ Implicit Types efs : list expr.
+ Implicit Types σ : state.
+ Implicit Types v : val.
+ Implicit Types vs : list val.
+ Implicit Types l : loc.
+ Implicit Types sz off : nat.
+
+ (* TODO: Uniform approch to where the refinement *)
+ Existing Instance heapG_invG.
+
+(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
+Lemma rswp_fork k s E e Φ :
+ RWP e @ s; ⊤ ⟨⟨ _, True ⟩⟩ -∗ Φ (LitV LitUnit) -∗ RSWP Fork e at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "He HΦ". iApply rswp_lift_atomic_head_step.
+ iIntros (σ1 n) "Hσ !>"; iSplit; first by eauto.
+ iNext; iIntros (v2 σ2 efs κ Hstep); inv_head_step. by iFrame.
+Qed.
+
+(** Heap *)
+Lemma rswp_allocN k s E v n :
+ 0 < n →
+ ⟨⟨⟨ True ⟩⟩⟩ AllocN (Val $ LitV $ LitInt $ n) (Val v) at k @ s; E
+ ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
+ [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
+Proof.
+ iIntros (Hn Φ) "_ HΦ". iApply rswp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 k') "Hσ !>"; iSplit; first by auto with lia.
+ iNext; iIntros (v2 σ2 efs κ Hstep); inv_head_step.
+ iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
+ { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
+ rewrite replicate_length Z2Nat.id; auto with lia. }
+ iModIntro; iSplit; first done. iFrame "Hσ". iApply "HΦ". iSplitL "Hl".
+ - by iApply heap_array_to_array.
+ - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
+Qed.
+
+Lemma rswp_alloc k s E v :
+ ⟨⟨⟨ True ⟩⟩⟩ Alloc (Val v) at k @ s; E ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ ⟩⟩⟩.
+Proof.
+ iIntros (Φ) "_ HΦ". iApply rswp_allocN; auto with lia.
+ iIntros "!>" (l) "/= (? & ? & _)".
+ rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
+Qed.
+
+(* TODO: we can always get rid of the later if the goal is a WP anyway. Having it in the rule seems unnecessary.*)
+Lemma rswp_load k s E l q v :
+ ⟨⟨⟨ ▷ l ↦{q} v ⟩⟩⟩ Load (Val $ LitV $ LitLoc l) at k @ s; E ⟨⟨⟨ RET v; l ↦{q} v ⟩⟩⟩.
+Proof.
+ iIntros (Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2 σ2 efs κ Hstep); inv_head_step.
+ iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
+Qed.
+
+(* TODO: we can always get rid of the later if the goal is a WP anyway. Having it in the rule seems unnecessary.*)
+Lemma rswp_store k s E l v' v :
+ ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ Store (Val $ LitV (LitLoc l)) (Val v) at k @ s; E
+ ⟨⟨⟨ RET LitV LitUnit; l ↦ v ⟩⟩⟩.
+Proof.
+ iIntros (Φ) ">Hl HΦ".
+ iApply rswp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2 σ2 efs κ Hstep); inv_head_step.
+ iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
+ iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
+Qed.
+
+Lemma rswp_cmpxchg_fail k s E l q v' v1 v2 :
+ v' ≠v1 → vals_compare_safe v' v1 →
+ ⟨⟨⟨ ▷ l ↦{q} v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
+ ⟨⟨⟨ RET PairV v' (LitV $ LitBool false); l ↦{q} v' ⟩⟩⟩.
+Proof.
+ iIntros (?? Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2' σ2 efs κ Hstep); inv_head_step.
+ rewrite bool_decide_false //.
+ iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
+Qed.
+
+Lemma rswp_cmpxchg_suc k s E l v1 v2 v' :
+ v' = v1 → vals_compare_safe v' v1 →
+ ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) at k @ s; E
+ ⟨⟨⟨ RET PairV v' (LitV $ LitBool true); l ↦ v2 ⟩⟩⟩.
+Proof.
+ iIntros (?? Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2' σ2 efs κ Hstep); inv_head_step.
+ rewrite bool_decide_true //.
+ iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
+ iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
+Qed.
+
+Lemma rswp_faa k s E l i1 i2 :
+ ⟨⟨⟨ ▷ l ↦ LitV (LitInt i1) ⟩⟩⟩ FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) at k @ s; E
+ ⟨⟨⟨ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) ⟩⟩⟩.
+Proof.
+ iIntros (Φ) ">Hl HΦ". iApply rswp_lift_atomic_head_step_no_fork.
+ iIntros (σ1 n) "Hσ !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
+ iSplit; first by eauto. iNext; iIntros (v2' σ2 efs κ Hstep); inv_head_step.
+ iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
+ iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
+Qed.
+
+Lemma rswp_allocN_vec k s E v n :
+ 0 < n →
+ ⟨⟨⟨ True ⟩⟩⟩
+ AllocN #n v at k @ s ; E
+ ⟨⟨⟨ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
+ [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
+Proof.
+ iIntros (Hzs Φ) "_ HΦ". iApply rswp_allocN; [ lia | done | .. ]. iNext.
+ iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
+Qed.
+
+Lemma rswp_load_offset k s E l off vs v :
+ vs !! off = Some v →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) at k @ s; E ⟨⟨⟨ RET v; l ↦∗ vs ⟩⟩⟩.
+Proof.
+ iIntros (Hlookup Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (rswp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ".
+ iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
+ iApply "Hl2". iApply "Hl1".
+Qed.
+
+Lemma rswp_load_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) :
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) at k @ s; E ⟨⟨⟨ RET vs !!! off; l ↦∗ vs ⟩⟩⟩.
+Proof. apply rswp_load_offset. by apply vlookup_lookup. Qed.
+
+Lemma rswp_store_offset k s E l off vs v :
+ is_Some (vs !! off) →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v at k @ s; E ⟨⟨⟨ RET #(); l ↦∗ <[off:=v]> vs ⟩⟩⟩.
+Proof.
+ iIntros ([w Hlookup] Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (rswp_store with "Hl1"). iNext. iIntros "Hl1".
+ iApply "HΦ". iApply "Hl2". iApply "Hl1".
+Qed.
+
+Lemma rswp_store_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v :
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v at k @ s; E ⟨⟨⟨ RET #(); l ↦∗ vinsert off v vs ⟩⟩⟩.
+Proof.
+ setoid_rewrite vec_to_list_insert. apply rswp_store_offset.
+ eexists. by apply vlookup_lookup.
+Qed.
+
+Lemma rswp_cmpxchg_suc_offset k s E l off vs v' v1 v2 :
+ vs !! off = Some v' →
+ v' = v1 →
+ vals_compare_safe v' v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ ⟨⟨⟨ RET (v', #true); l ↦∗ <[off:=v2]> vs ⟩⟩⟩.
+Proof.
+ iIntros (Hlookup ?? Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (rswp_cmpxchg_suc with "Hl1"); [done..|].
+ iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
+Qed.
+
+Lemma rswp_cmpxchg_suc_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
+ vs !!! off = v1 →
+ vals_compare_safe (vs !!! off) v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ ⟨⟨⟨ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs ⟩⟩⟩.
+Proof.
+ intros. setoid_rewrite vec_to_list_insert. eapply rswp_cmpxchg_suc_offset=> //.
+ by apply vlookup_lookup.
+Qed.
+
+Lemma rswp_cmpxchg_fail_offset k s E l off vs v0 v1 v2 :
+ vs !! off = Some v0 →
+ v0 ≠v1 →
+ vals_compare_safe v0 v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ ⟨⟨⟨ RET (v0, #false); l ↦∗ vs ⟩⟩⟩.
+Proof.
+ iIntros (Hlookup HNEq Hcmp Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (rswp_cmpxchg_fail with "Hl1"); first done.
+ { destruct Hcmp; by [ left | right ]. }
+ iIntros "!> Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
+ rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
+Qed.
+
+Lemma rswp_cmpxchg_fail_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
+ vs !!! off ≠v1 →
+ vals_compare_safe (vs !!! off) v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 at k @ s; E
+ ⟨⟨⟨ RET (vs !!! off, #false); l ↦∗ vs ⟩⟩⟩.
+Proof. intros. eapply rswp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
+
+Lemma rswp_faa_offset k s E l off vs (i1 i2 : Z) :
+ vs !! off = Some #i1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 at k @ s; E
+ ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs ⟩⟩⟩.
+Proof.
+ iIntros (Hlookup Φ) ">Hl HΦ".
+ iDestruct (update_array l _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
+ iApply (rswp_faa with "Hl1").
+ iNext. iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
+Qed.
+
+Lemma rswp_faa_offset_vec k s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
+ vs !!! off = #i1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 at k @ s; E
+ ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs ⟩⟩⟩.
+Proof.
+ intros. setoid_rewrite vec_to_list_insert. apply rswp_faa_offset=> //.
+ by apply vlookup_lookup.
+Qed.
+
+
+(* refinement weakest pre versions *)
+(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
+Lemma rwp_fork s E e Φ :
+ RWP e @ s; ⊤ ⟨⟨ _, True ⟩⟩ -∗ Φ (LitV LitUnit) -∗ RWP Fork e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_fork with "H HΦ").
+Qed.
+
+(** Heap *)
+Lemma rwp_allocN s E v n :
+ 0 < n →
+ ⟨⟨⟨ True ⟩⟩⟩ AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
+ ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
+ [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
+Proof.
+ iIntros (Hn Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_allocN _ _ _ _ _ Hn Φ with "H HΦ").
+Qed.
+
+Lemma rwp_alloc s E v :
+ ⟨⟨⟨ True ⟩⟩⟩ Alloc (Val v) @ s; E ⟨⟨⟨ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ ⟩⟩⟩.
+Proof.
+ iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_alloc with "H HΦ").
+Qed.
+
+Lemma rwp_load s E l q v :
+ ⟨⟨⟨ ▷ l ↦{q} v ⟩⟩⟩ Load (Val $ LitV $ LitLoc l) @ s; E ⟨⟨⟨ RET v; l ↦{q} v ⟩⟩⟩.
+Proof.
+ iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_load with "H HΦ").
+Qed.
+
+Lemma rwp_store s E l v' v :
+ ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ Store (Val $ LitV (LitLoc l)) (Val v) @ s; E
+ ⟨⟨⟨ RET LitV LitUnit; l ↦ v ⟩⟩⟩.
+Proof.
+ iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_store with "H HΦ").
+Qed.
+
+Lemma rwp_cmpxchg_fail s E l q v' v1 v2 :
+ v' ≠v1 → vals_compare_safe v' v1 →
+ ⟨⟨⟨ ▷ l ↦{q} v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
+ ⟨⟨⟨ RET PairV v' (LitV $ LitBool false); l ↦{q} v' ⟩⟩⟩.
+Proof.
+ iIntros (?? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_fail with "H HΦ").
+Qed.
+
+Lemma rwp_cmpxchg_suc s E l v1 v2 v' :
+ v' = v1 → vals_compare_safe v' v1 →
+ ⟨⟨⟨ ▷ l ↦ v' ⟩⟩⟩ CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
+ ⟨⟨⟨ RET PairV v' (LitV $ LitBool true); l ↦ v2 ⟩⟩⟩.
+Proof.
+ iIntros (?? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_suc with "H HΦ").
+Qed.
+
+Lemma rwp_faa s E l i1 i2 :
+ ⟨⟨⟨ ▷ l ↦ LitV (LitInt i1) ⟩⟩⟩ FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
+ ⟨⟨⟨ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) ⟩⟩⟩.
+Proof.
+ iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_faa with "H HΦ").
+Qed.
+
+Lemma rwp_allocN_vec s E v n :
+ 0 < n →
+ ⟨⟨⟨ True ⟩⟩⟩
+ AllocN #n v @ s ; E
+ ⟨⟨⟨ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
+ [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ ⟩⟩⟩.
+Proof.
+ iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_allocN_vec with "H HΦ").
+Qed.
+
+Lemma rwp_load_offset s E l off vs v :
+ vs !! off = Some v →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) @ s; E ⟨⟨⟨ RET v; l ↦∗ vs ⟩⟩⟩.
+Proof.
+ iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_load_offset with "H HΦ").
+Qed.
+
+Lemma rwp_load_offset_vec s E l sz (off : fin sz) (vs : vec val sz) :
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ ! #(l +ₗ off) @ s; E ⟨⟨⟨ RET vs !!! off; l ↦∗ vs ⟩⟩⟩.
+Proof. apply rwp_load_offset. by apply vlookup_lookup. Qed.
+
+Lemma rwp_store_offset s E l off vs v :
+ is_Some (vs !! off) →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v @ s; E ⟨⟨⟨ RET #(); l ↦∗ <[off:=v]> vs ⟩⟩⟩.
+Proof.
+ iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_store_offset with "H HΦ").
+Qed.
+
+Lemma rwp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ #(l +ₗ off) <- v @ s; E ⟨⟨⟨ RET #(); l ↦∗ vinsert off v vs ⟩⟩⟩.
+Proof.
+ iIntros (Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_store_offset_vec with "H HΦ").
+Qed.
+
+Lemma rwp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
+ vs !! off = Some v' →
+ v' = v1 →
+ vals_compare_safe v' v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 @ s; E
+ ⟨⟨⟨ RET (v', #true); l ↦∗ <[off:=v2]> vs ⟩⟩⟩.
+Proof.
+ iIntros (??? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_suc_offset with "H HΦ").
+Qed.
+
+Lemma rwp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
+ vs !!! off = v1 →
+ vals_compare_safe (vs !!! off) v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 @ s; E
+ ⟨⟨⟨ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs ⟩⟩⟩.
+Proof.
+ iIntros (?? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_suc_offset_vec with "H HΦ").
+Qed.
+
+Lemma rwp_cmpxchg_fail_offset s E l off vs v0 v1 v2 :
+ vs !! off = Some v0 →
+ v0 ≠v1 →
+ vals_compare_safe v0 v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 @ s; E
+ ⟨⟨⟨ RET (v0, #false); l ↦∗ vs ⟩⟩⟩.
+Proof.
+ iIntros (??? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_cmpxchg_fail_offset with "H HΦ").
+Qed.
+
+Lemma rwp_cmpxchg_fail_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
+ vs !!! off ≠v1 →
+ vals_compare_safe (vs !!! off) v1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩
+ CmpXchg #(l +â‚— off) v1 v2 @ s; E
+ ⟨⟨⟨ RET (vs !!! off, #false); l ↦∗ vs ⟩⟩⟩.
+Proof. intros. eapply rwp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
+
+Lemma rwp_faa_offset s E l off vs (i1 i2 : Z) :
+ vs !! off = Some #i1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 @ s; E
+ ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs ⟩⟩⟩.
+Proof.
+ iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_faa_offset with "H HΦ").
+Qed.
+
+Lemma rwp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
+ vs !!! off = #i1 →
+ ⟨⟨⟨ ▷ l ↦∗ vs ⟩⟩⟩ FAA #(l +ₗ off) #i2 @ s; E
+ ⟨⟨⟨ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs ⟩⟩⟩.
+Proof.
+ iIntros (? Φ) "H HΦ"; iApply rwp_no_step; auto; last by iApply (rswp_faa_offset_vec with "H HΦ").
+Qed.
+End refinements.
diff --git a/theories/heap_lang/proofmode.v b/theories/heap_lang/proofmode.v
index cde60d3992d04e952f7f8be2f61e4352b48349ef..a48afd52172b301ec359b1481caf65ef3b1e6849 100644
--- a/theories/heap_lang/proofmode.v
+++ b/theories/heap_lang/proofmode.v
@@ -1,5 +1,5 @@
-From iris.program_logic Require Export weakestpre total_weakestpre.
-From iris.program_logic Require Import atomic.
+From iris.program_logic Require Export weakestpre.
+From iris.program_logic.refinement Require Export ref_weakestpre tc_weakestpre.
From iris.proofmode Require Import coq_tactics reduction.
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Export tactics lifting.
@@ -7,11 +7,23 @@ From iris.heap_lang Require Import notation.
Set Default Proof Using "Type".
Import uPred.
-Lemma tac_wp_expr_eval `{!heapG Σ} Δ s E Φ e e' :
+Lemma tac_wp_expr_eval {SI} {Σ: gFunctors SI} `{!heapG Σ} Δ s E Φ e e' :
(∀ (e'':=e'), e = e'') →
envs_entails Δ (WP e' @ s; E {{ Φ }}) → envs_entails Δ (WP e @ s; E {{ Φ }}).
Proof. by intros ->. Qed.
-Lemma tac_twp_expr_eval `{!heapG Σ} Δ s E Φ e e' :
+Lemma tac_swp_expr_eval {SI} {Σ: gFunctors SI} `{!heapG Σ} k Δ s E Φ e e' :
+ (∀ (e'':=e'), e = e'') →
+ envs_entails Δ (SWP e' at k @ s; E {{ Φ }}) → envs_entails Δ (SWP e at k @ s; E {{ Φ }}).
+Proof. by intros ->. Qed.
+Lemma tac_rwp_expr_eval {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ s E Φ e e' :
+ (∀ (e'':=e'), e = e'') →
+ envs_entails Δ (RWP e' @ s; E ⟨⟨ Φ ⟩⟩) → envs_entails Δ (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+Proof. by intros ->. Qed.
+Lemma tac_rswp_expr_eval {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} k Δ s E Φ e e' :
+ (∀ (e'':=e'), e = e'') →
+ envs_entails Δ (RSWP e' at k @ s; E ⟨⟨ Φ ⟩⟩) → envs_entails Δ (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof. by intros ->. Qed.
+Lemma tac_twp_expr_eval {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} Δ s E Φ e e' :
(∀ (e'':=e'), e = e'') →
envs_entails Δ (WP e' @ s; E [{ Φ }]) → envs_entails Δ (WP e @ s; E [{ Φ }]).
Proof. by intros ->. Qed.
@@ -21,14 +33,23 @@ Tactic Notation "wp_expr_eval" tactic(t) :=
lazymatch goal with
| |- envs_entails _ (wp ?s ?E ?e ?Q) =>
eapply tac_wp_expr_eval;
- [let x := fresh in intros x; t; unfold x; reflexivity|]
+ [let x := fresh in intros x; t; unfold x; reflexivity|]
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ eapply tac_swp_expr_eval;
+ [let x := fresh in intros x; t; unfold x; reflexivity|]
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ eapply tac_rwp_expr_eval;
+ [let x := fresh in intros x; t; unfold x; reflexivity|]
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ eapply tac_rswp_expr_eval;
+ [let x := fresh in intros x; t; unfold x; reflexivity|]
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
eapply tac_twp_expr_eval;
[let x := fresh in intros x; t; unfold x; reflexivity|]
| _ => fail "wp_expr_eval: not a 'wp'"
end.
-Lemma tac_wp_pure `{!heapG Σ} Δ Δ' s E e1 e2 φ n Φ :
+Lemma tac_wp_pure {SI} {Σ: gFunctors SI} `{!heapG Σ} Δ Δ' s E e1 e2 φ n Φ :
PureExec φ n e1 e2 →
φ →
MaybeIntoLaterNEnvs n Δ Δ' →
@@ -38,26 +59,57 @@ Proof.
rewrite envs_entails_eq=> ??? HΔ'. rewrite into_laterN_env_sound /=.
rewrite HΔ' -lifting.wp_pure_step_later //.
Qed.
-Lemma tac_twp_pure `{!heapG Σ} Δ s E e1 e2 φ n Φ :
+Lemma tac_swp_pure {SI} {Σ: gFunctors SI} `{!heapG Σ} k Δ Δ' s E e1 e2 φ n Φ :
+ PureExec φ (S n) e1 e2 →
+ φ →
+ MaybeIntoLaterNEnvs (S n) Δ Δ' →
+ envs_entails Δ' (WP e2 @ s; E {{ Φ }}) →
+ envs_entails Δ (SWP e1 at k @ s; E {{ Φ }}).
+Proof.
+ rewrite envs_entails_eq=> Hsteps H ? HΔ'. rewrite into_laterN_env_sound /=.
+ rewrite HΔ'. by rewrite -lifting.swp_pure_step_later //.
+Qed.
+Lemma tac_rwp_pure {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ s E e1 e2 φ n Φ :
+ PureExec φ n e1 e2 →
+ φ →
+ envs_entails Δ (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (RWP e1 @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ??. rewrite -ref_lifting.rwp_pure_step //.
+Qed.
+Lemma tac_rswp_pure {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ Δ' s E k e1 e2 φ Φ :
+ PureExec φ 1 e1 e2 →
+ φ →
+ MaybeIntoLaterNEnvs k Δ Δ' →
+ envs_entails Δ' (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> Hsteps Hφ ? HΔ'. rewrite into_laterN_env_sound /=.
+ rewrite HΔ'. by rewrite -ref_lifting.rswp_pure_step_later //.
+Qed.
+Lemma tac_twp_pure {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} Δ s E e1 e2 φ n Φ :
PureExec φ n e1 e2 →
φ →
envs_entails Δ (WP e2 @ s; E [{ Φ }]) →
envs_entails Δ (WP e1 @ s; E [{ Φ }]).
Proof.
- rewrite envs_entails_eq=> ?? ->. rewrite -total_lifting.twp_pure_step //.
+ apply tac_rwp_pure.
Qed.
-Lemma tac_wp_value `{!heapG Σ} Δ s E Φ v :
+Lemma tac_wp_value {SI} {Σ: gFunctors SI} `{!heapG Σ} Δ s E Φ v :
envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E {{ Φ }}).
Proof. rewrite envs_entails_eq=> ->. by apply wp_value. Qed.
-Lemma tac_twp_value `{!heapG Σ} Δ s E Φ v :
+Lemma tac_rwp_value {SI} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} Δ s E Φ v :
+ envs_entails Δ (Φ v) → envs_entails Δ (RWP (Val v) @ s; E ⟨⟨ Φ ⟩⟩).
+Proof. rewrite envs_entails_eq=> ->. by apply rwp_value. Qed.
+Lemma tac_twp_value {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} Δ s E Φ v :
envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E [{ Φ }]).
-Proof. rewrite envs_entails_eq=> ->. by apply twp_value. Qed.
+Proof. apply tac_rwp_value. Qed.
Ltac wp_expr_simpl := wp_expr_eval simpl.
Ltac wp_value_head :=
- first [eapply tac_wp_value || eapply tac_twp_value].
+ first [eapply tac_wp_value || eapply tac_rwp_value || eapply tac_twp_value].
Ltac wp_finish :=
wp_expr_simpl; (* simplify occurences of subst/fill *)
@@ -92,6 +144,16 @@ Tactic Notation "wp_pure" open_constr(efoc) :=
|wp_finish (* new goal *)
])
|| fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ let e := eval simpl in e in
+ reshape_expr e ltac:(fun K e' =>
+ unify e' efoc;
+ eapply (tac_rwp_pure _ _ _ (fill K e'));
+ [iSolveTC (* PureExec *)
+ |try fast_done (* The pure condition for PureExec *)
+ |wp_finish (* new goal *)
+ ])
+ || fail "wp_pure – rwp: cannot find" efoc "in" e "or" efoc "is not a redex"
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
let e := eval simpl in e in
reshape_expr e ltac:(fun K e' =>
@@ -101,6 +163,28 @@ Tactic Notation "wp_pure" open_constr(efoc) :=
|try fast_done (* The pure condition for PureExec *)
|wp_finish (* new goal *)
])
+ || fail "wp_pure – twp: cannot find" efoc "in" e "or" efoc "is not a redex"
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ let e := eval simpl in e in
+ reshape_expr e ltac:(fun K e' =>
+ unify e' efoc;
+ eapply (tac_swp_pure _ _ _ _ _ (fill K e'));
+ [ iSolveTC (* PureExec *)
+ | try fast_done (* The pure condition for PureExec *)
+ | apply _
+ | simpl; wp_finish (* new goal *)
+ ])
+ || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ let e := eval simpl in e in
+ reshape_expr e ltac:(fun K e' =>
+ unify e' efoc;
+ eapply (tac_rswp_pure _ _ _ _ _ (fill K e'));
+ [ iSolveTC (* PureExec *)
+ | try fast_done (* The pure condition for PureExec *)
+ | apply _
+ | simpl; wp_finish (* new goal *)
+ ])
|| fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
| _ => fail "wp_pure: not a 'wp'"
end.
@@ -140,22 +224,63 @@ Tactic Notation "wp_inj" := wp_pure (InjL _) || wp_pure (InjR _).
Tactic Notation "wp_pair" := wp_pure (Pair _ _).
Tactic Notation "wp_closure" := wp_pure (Rec _ _ _).
-Lemma tac_wp_bind `{!heapG Σ} K Δ s E Φ e f :
+
+(* SWP Tactics *)
+(* TODO: figure out the right tactics here *)
+Tactic Notation "wp_swp" constr(k) := iApply (swp_wp k); first done.
+Tactic Notation "wp_swp" := iApply (swp_wp _); first done.
+Tactic Notation "swp_step" := iApply (swp_step _).
+Tactic Notation "swp_last_step" := swp_step; iApply swp_finish.
+Tactic Notation "swp_finish" := iApply swp_finish.
+
+Lemma tac_wp_bind {SI} {Σ: gFunctors SI} `{!heapG Σ} K Δ s E Φ e f :
f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
envs_entails Δ (WP e @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I →
envs_entails Δ (WP fill K e @ s; E {{ Φ }}).
Proof. rewrite envs_entails_eq=> -> ->. by apply: wp_bind. Qed.
-Lemma tac_twp_bind `{!heapG Σ} K Δ s E Φ e f :
+Lemma tac_swp_bind {SI} {Σ: gFunctors SI} `{!heapG Σ} k K Δ s E Φ e f :
+ language.to_val e = None →
+ f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
+ envs_entails Δ (SWP e at k @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I →
+ envs_entails Δ (SWP fill K e at k @ s; E {{ Φ }}).
+Proof. rewrite envs_entails_eq=> ? -> ->. by apply: swp_bind. Qed.
+Lemma tac_rwp_bind {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} K Δ s E Φ e f :
+ f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
+ envs_entails Δ (RWP e @ s; E ⟨⟨ v, RWP f (Val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩)%I →
+ envs_entails Δ (RWP fill K e @ s; E ⟨⟨ Φ ⟩⟩).
+Proof. rewrite envs_entails_eq=> -> ->. by apply: rwp_bind. Qed.
+Lemma tac_rswp_bind {SI A} {Σ: gFunctors SI} `{!heapG Σ} `{!source Σ A} k K Δ s E Φ e f :
+ language.to_val e = None →
+ f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
+ envs_entails Δ (RSWP e at k @ s; E ⟨⟨ v, RWP f (Val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩)%I →
+ envs_entails Δ (RSWP fill K e at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof. rewrite envs_entails_eq=> ? -> ->. by apply: rswp_bind. Qed.
+Lemma tac_twp_bind {SI} {Σ: gFunctors SI} `{!heapG Σ} `{tcG Σ} K Δ s E Φ e f :
f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
envs_entails Δ (WP e @ s; E [{ v, WP f (Val v) @ s; E [{ Φ }] }])%I →
envs_entails Δ (WP fill K e @ s; E [{ Φ }]).
-Proof. rewrite envs_entails_eq=> -> ->. by apply: twp_bind. Qed.
+Proof. rewrite envs_entails_eq=> -> ->. by apply: rwp_bind. Qed.
Ltac wp_bind_core K :=
lazymatch eval hnf in K with
| [] => idtac
| _ => eapply (tac_wp_bind K); [simpl; reflexivity|reduction.pm_prettify]
end.
+Ltac swp_bind_core K :=
+ lazymatch eval hnf in K with
+ | [] => idtac
+ | _ => eapply (tac_swp_bind _ K);[done| simpl; reflexivity|reduction.pm_prettify]
+ end.
+Ltac rwp_bind_core K :=
+ lazymatch eval hnf in K with
+ | [] => idtac
+ | _ => eapply (tac_rwp_bind K); [simpl; reflexivity|reduction.pm_prettify]
+ end.
+Ltac rswp_bind_core K :=
+ lazymatch eval hnf in K with
+ | [] => idtac
+ | _ => eapply (tac_rswp_bind _ K);[done| simpl; reflexivity|reduction.pm_prettify]
+ end.
Ltac twp_bind_core K :=
lazymatch eval hnf in K with
| [] => idtac
@@ -168,6 +293,15 @@ Tactic Notation "wp_bind" open_constr(efoc) :=
| |- envs_entails _ (wp ?s ?E ?e ?Q) =>
reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K)
|| fail "wp_bind: cannot find" efoc "in" e
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ reshape_expr e ltac:(fun K e' => unify e' efoc; swp_bind_core K)
+ || fail "wp_bind: cannot find" efoc "in" e
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ reshape_expr e ltac:(fun K e' => unify e' efoc; rwp_bind_core K)
+ || fail "wp_bind: cannot find" efoc "in" e
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ reshape_expr e ltac:(fun K e' => unify e' efoc; rswp_bind_core K)
+ || fail "wp_bind: cannot find" efoc "in" e
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
reshape_expr e ltac:(fun K e' => unify e' efoc; twp_bind_core K)
|| fail "wp_bind: cannot find" efoc "in" e
@@ -176,7 +310,7 @@ Tactic Notation "wp_bind" open_constr(efoc) :=
(** Heap tactics *)
Section heap.
-Context `{!heapG Σ}.
+Context {SI} {Σ: gFunctors SI} `{!heapG Σ} .
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types Δ : envs (uPredI (iResUR Σ)).
@@ -197,7 +331,48 @@ Proof.
destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
Qed.
-Lemma tac_twp_allocN Δ s E j K v n Φ :
+Lemma tac_swp_allocN k Δ Δ' s E j K v n Φ :
+ 0 < n →
+ MaybeIntoLaterNEnvs 1 Δ Δ' →
+ (∀ l, ∃ Δ'',
+ envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ' = Some Δ'' ∧
+ envs_entails Δ'' (WP fill K (Val $ LitV $ LitLoc l) @ s; E {{ Φ }})) →
+ envs_entails Δ (SWP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) at k @ s; E {{ Φ }}).
+Proof.
+ rewrite envs_entails_eq=> ? ? HΔ.
+ rewrite -swp_bind; last done. eapply wand_apply; first exact: swp_allocN.
+ rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
+ destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
+ apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
+Qed.
+Lemma tac_rwp_allocN {A} `{!source Σ A} Δ s E j K v n Φ :
+ 0 < n →
+ (∀ l, ∃ Δ'',
+ envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ = Some Δ'' ∧
+ envs_entails Δ'' (RWP fill K (Val $ LitV $ LitLoc l) @ s; E ⟨⟨ Φ ⟩⟩)) →
+ envs_entails Δ (RWP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ? HΔ.
+ rewrite -rwp_bind. eapply wand_apply; first exact: rwp_allocN.
+ rewrite left_id; apply forall_intro=> l.
+ destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
+ apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
+Qed.
+Lemma tac_rswp_allocN {A} `{!source Σ A} k Δ Δ' s E j K v n Φ :
+ 0 < n →
+ MaybeIntoLaterNEnvs k Δ Δ' →
+ (∀ l, ∃ Δ'',
+ envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ' = Some Δ'' ∧
+ envs_entails Δ'' (RWP fill K (Val $ LitV $ LitLoc l) @ s; E ⟨⟨ Φ ⟩⟩)) →
+ envs_entails Δ (RSWP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ? ? HΔ.
+ rewrite -rswp_bind; last done. eapply wand_apply; first exact: rswp_allocN.
+ rewrite left_id into_laterN_env_sound; apply laterN_mono, forall_intro=> l.
+ destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
+ apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
+Qed.
+Lemma tac_twp_allocN `{!tcG Σ} Δ s E j K v n Φ :
0 < n →
(∀ l, ∃ Δ',
envs_app false (Esnoc Enil j (array l (replicate (Z.to_nat n) v))) Δ
@@ -205,11 +380,7 @@ Lemma tac_twp_allocN Δ s E j K v n Φ :
envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])) →
envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E [{ Φ }]).
Proof.
- rewrite envs_entails_eq=> ? HΔ.
- rewrite -twp_bind. eapply wand_apply; first exact: twp_allocN.
- rewrite left_id. apply forall_intro=> l.
- destruct (HΔ l) as (Δ'&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
+ apply tac_rwp_allocN.
Qed.
Lemma tac_wp_alloc Δ Δ' s E j K v Φ :
@@ -225,17 +396,51 @@ Proof.
destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
Qed.
-Lemma tac_twp_alloc Δ s E j K v Φ :
+Lemma tac_swp_alloc k Δ Δ' s E j K v Φ :
+ MaybeIntoLaterNEnvs 1 Δ Δ' →
+ (∀ l, ∃ Δ'',
+ envs_app false (Esnoc Enil j (l ↦ v)) Δ' = Some Δ'' ∧
+ envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E {{ Φ }})) →
+ envs_entails Δ (SWP fill K (Alloc (Val v)) at k @ s; E {{ Φ }}).
+Proof.
+ rewrite envs_entails_eq=> ? HΔ.
+ rewrite -swp_bind; last done. eapply wand_apply; first exact: swp_alloc.
+ rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
+ destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
+ apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
+Qed.
+Lemma tac_rwp_alloc {A} `{!source Σ A} Δ s E j K v Φ :
+ (∀ l, ∃ Δ'',
+ envs_app false (Esnoc Enil j (l ↦ v)) Δ = Some Δ'' ∧
+ envs_entails Δ'' (RWP fill K (Val $ LitV l) @ s; E ⟨⟨ Φ ⟩⟩)) →
+ envs_entails Δ (RWP fill K (Alloc (Val v)) @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> HΔ.
+ rewrite -rwp_bind. eapply wand_apply; first exact: rwp_alloc.
+ rewrite left_id; apply forall_intro=> l.
+ destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
+ apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
+Qed.
+Lemma tac_rswp_alloc {A} `{!source Σ A} k Δ Δ' s E j K v Φ :
+ MaybeIntoLaterNEnvs k Δ Δ' →
+ (∀ l, ∃ Δ'',
+ envs_app false (Esnoc Enil j (l ↦ v)) Δ' = Some Δ'' ∧
+ envs_entails Δ'' (RWP fill K (Val $ LitV l) @ s; E ⟨⟨ Φ ⟩⟩)) →
+ envs_entails Δ (RSWP fill K (Alloc (Val v)) at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ? HΔ.
+ rewrite -rswp_bind; last done. eapply wand_apply; first exact: rswp_alloc.
+ rewrite left_id into_laterN_env_sound; apply laterN_mono, forall_intro=> l.
+ destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
+ apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
+Qed.
+Lemma tac_twp_alloc `{!tcG Σ} Δ s E j K v Φ :
(∀ l, ∃ Δ',
envs_app false (Esnoc Enil j (l ↦ v)) Δ = Some Δ' ∧
envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])) →
envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E [{ Φ }]).
Proof.
- rewrite envs_entails_eq=> HΔ.
- rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc.
- rewrite left_id. apply forall_intro=> l.
- destruct (HΔ l) as (Δ'&?&HΔ'). rewrite envs_app_sound //; simpl.
- apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
+ apply tac_rwp_alloc.
Qed.
Lemma tac_wp_load Δ Δ' s E i K l q v Φ :
@@ -245,20 +450,47 @@ Lemma tac_wp_load Δ Δ' s E i K l q v Φ :
envs_entails Δ (WP fill K (Load (LitV l)) @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ???.
- rewrite -wp_bind. eapply wand_apply; first exact: wp_load.
- rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
- by apply later_mono, sep_mono_r, wand_mono.
+ rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
+ apply later_mono.
+ eapply wand_apply; first exact: swp_load.
+ rewrite envs_lookup_split // -!later_intro; simpl.
+ by apply sep_mono_r, wand_mono.
Qed.
-Lemma tac_twp_load Δ s E i K l q v Φ :
+Lemma tac_swp_load k Δ s E i K l q v Φ :
envs_lookup i Δ = Some (false, l ↦{q} v)%I →
- envs_entails Δ (WP fill K (Val v) @ s; E [{ Φ }]) →
- envs_entails Δ (WP fill K (Load (LitV l)) @ s; E [{ Φ }]).
+ envs_entails Δ (WP fill K (Val v) @ s; E {{ Φ }}) →
+ envs_entails Δ (SWP fill K (Load (LitV l)) at k @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ??.
- rewrite -twp_bind. eapply wand_apply; first exact: twp_load.
- rewrite envs_lookup_split //; simpl.
+ rewrite -swp_bind; last done. eapply wand_apply; first exact: swp_load.
+ rewrite envs_lookup_split // -!later_intro; simpl.
by apply sep_mono_r, wand_mono.
Qed.
+Lemma tac_rswp_load {A} `{!source Σ A} k Δ s E i K l q v Φ :
+ envs_lookup i Δ = Some (false, l ↦{q} v)%I →
+ envs_entails Δ (RWP fill K (Val v) @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (RSWP fill K (Load (LitV l)) at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=> ? HΔ.
+ rewrite -rswp_bind; last done. eapply wand_apply; first exact: rswp_load.
+ rewrite envs_lookup_split//; simpl.
+ by rewrite -!later_intro -laterN_intro HΔ.
+Qed.
+Lemma tac_rwp_load {A} `{!source Σ A} Δ s E i K l q v Φ :
+ envs_lookup i Δ = Some (false, l ↦{q} v)%I →
+ envs_entails Δ (RWP fill K (Val v) @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (RWP fill K (Load (LitV l)) @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ intros ??. rewrite -rwp_no_step; first by eapply tac_rswp_load.
+ by eapply to_val_fill_none.
+Qed.
+Lemma tac_twp_load `{!tcG Σ} Δ s E i K l q v Φ :
+ envs_lookup i Δ = Some (false, l ↦{q} v)%I →
+ envs_entails Δ (WP fill K (Val v) @ s; E [{Φ}]) →
+ envs_entails Δ (WP fill K (Load (LitV l)) @ s; E [{Φ}]).
+Proof.
+ apply tac_rwp_load.
+Qed.
Lemma tac_wp_store Δ Δ' Δ'' s E i K l v v' Φ :
MaybeIntoLaterNEnvs 1 Δ Δ' →
@@ -268,22 +500,52 @@ Lemma tac_wp_store Δ Δ' Δ'' s E i K l v v' Φ :
envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ????.
- rewrite -wp_bind. eapply wand_apply; first by eapply wp_store.
- rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
+ rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
+ eapply later_mono, wand_apply; first by eapply swp_store.
+ rewrite -!later_intro envs_simple_replace_sound //; simpl.
+ rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.
-Lemma tac_twp_store Δ Δ' s E i K l v v' Φ :
+Lemma tac_swp_store k Δ Δ' s E i K l v v' Φ :
envs_lookup i Δ = Some (false, l ↦ v)%I →
envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ = Some Δ' →
- envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }]) →
- envs_entails Δ (WP fill K (Store (LitV l) v') @ s; E [{ Φ }]).
+ envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }}) →
+ envs_entails Δ (SWP fill K (Store (LitV l) v') at k @ s; E {{ Φ }}).
Proof.
- rewrite envs_entails_eq. intros. rewrite -twp_bind.
- eapply wand_apply; first by eapply twp_store.
- rewrite envs_simple_replace_sound //; simpl.
+ rewrite envs_entails_eq. intros. rewrite -swp_bind; last done.
+ eapply wand_apply; first by eapply swp_store.
+ rewrite envs_simple_replace_sound // -!later_intro; simpl.
rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.
+Lemma tac_rswp_store {A} `{!source Σ A} k Δ Δ' s E i K l v v' Φ :
+ envs_lookup i Δ = Some (false, l ↦ v')%I →
+ envs_simple_replace i false (Esnoc Enil i (l ↦ v)) Δ = Some Δ' →
+ envs_entails Δ' (RWP fill K (Val $ LitV LitUnit) @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (RSWP fill K (Store (LitV l) v) at k @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ rewrite envs_entails_eq=>?? HΔ. rewrite -rswp_bind; last done.
+ eapply wand_apply; first by exact: rswp_store.
+ rewrite envs_simple_replace_sound // -!later_intro -laterN_intro; simpl.
+ rewrite right_id HΔ. by apply sep_mono_r, wand_mono.
+Qed.
+Lemma tac_rwp_store {A} `{!source Σ A} Δ Δ' s E i K l v v' Φ :
+ envs_lookup i Δ = Some (false, l ↦ v')%I →
+ envs_simple_replace i false (Esnoc Enil i (l ↦ v)) Δ = Some Δ' →
+ envs_entails Δ' (RWP fill K (Val $ LitV LitUnit) @ s; E ⟨⟨ Φ ⟩⟩) →
+ envs_entails Δ (RWP fill K (Store (LitV l) v) @ s; E ⟨⟨ Φ ⟩⟩).
+Proof.
+ intros ???. rewrite -rwp_no_step; first by eapply tac_rswp_store.
+ by eapply to_val_fill_none.
+Qed.
+Lemma tac_twp_store `{tcG Σ} Δ Δ' s E i K l v v' Φ :
+ envs_lookup i Δ = Some (false, l ↦ v')%I →
+ envs_simple_replace i false (Esnoc Enil i (l ↦ v)) Δ = Some Δ' →
+ envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }]) →
+ envs_entails Δ (WP fill K (Store (LitV l) v) @ s; E [{ Φ }]).
+Proof.
+ apply tac_rwp_store.
+Qed.
+(* TODO: atomic operations for the refinement weakest preconditions *)
Lemma tac_wp_cmpxchg Δ Δ' Δ'' s E i K l v v1 v2 Φ :
MaybeIntoLaterNEnvs 1 Δ Δ' →
envs_lookup i Δ' = Some (false, l ↦ v)%I →
@@ -297,34 +559,34 @@ Lemma tac_wp_cmpxchg Δ Δ' Δ'' s E i K l v v1 v2 Φ :
Proof.
rewrite envs_entails_eq=> ???? Hsuc Hfail.
destruct (decide (v = v1)) as [Heq|Hne].
- - rewrite -wp_bind. eapply wand_apply.
- { eapply wp_cmpxchg_suc; eauto. }
- rewrite into_laterN_env_sound -later_sep /= {1}envs_simple_replace_sound //; simpl.
- apply later_mono, sep_mono_r. rewrite right_id. apply wand_mono; auto.
- - rewrite -wp_bind. eapply wand_apply.
- { eapply wp_cmpxchg_fail; eauto. }
- rewrite into_laterN_env_sound -later_sep /= {1}envs_lookup_split //; simpl.
- apply later_mono, sep_mono_r. apply wand_mono; auto.
-Qed.
-Lemma tac_twp_cmpxchg Δ Δ' s E i K l v v1 v2 Φ :
+ - rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound. eapply later_mono, wand_apply.
+ { eapply swp_cmpxchg_suc; eauto. }
+ rewrite -!later_intro /= {1}envs_simple_replace_sound //; simpl.
+ apply sep_mono_r. rewrite right_id. apply wand_mono; auto.
+ - rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound. eapply later_mono, wand_apply.
+ { eapply swp_cmpxchg_fail; eauto. }
+ rewrite -!later_intro /= {1}envs_lookup_split //; simpl.
+ apply sep_mono_r. apply wand_mono; auto.
+Qed.
+Lemma tac_swp_cmpxchg k Δ Δ' s E i K l v v1 v2 Φ :
envs_lookup i Δ = Some (false, l ↦ v)%I →
envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ = Some Δ' →
vals_compare_safe v v1 →
(v = v1 →
- envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }])) →
+ envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})) →
(v ≠v1 →
- envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }])) →
- envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
+ envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }})) →
+ envs_entails Δ (SWP fill K (CmpXchg (LitV l) v1 v2) at k @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ??? Hsuc Hfail.
destruct (decide (v = v1)) as [Heq|Hne].
- - rewrite -twp_bind. eapply wand_apply.
- { eapply twp_cmpxchg_suc; eauto. }
- rewrite /= {1}envs_simple_replace_sound //; simpl.
+ - rewrite -swp_bind //. eapply wand_apply.
+ { eapply swp_cmpxchg_suc; eauto. }
+ rewrite /= {1}envs_simple_replace_sound // -!later_intro; simpl.
apply sep_mono_r. rewrite right_id. apply wand_mono; auto.
- - rewrite -twp_bind. eapply wand_apply.
- { eapply twp_cmpxchg_fail; eauto. }
- rewrite /= {1}envs_lookup_split //; simpl.
+ - rewrite -swp_bind //. eapply wand_apply.
+ { eapply swp_cmpxchg_fail; eauto. }
+ rewrite /= {1}envs_lookup_split // -!later_intro; simpl.
apply sep_mono_r. apply wand_mono; auto.
Qed.
@@ -336,19 +598,20 @@ Lemma tac_wp_cmpxchg_fail Δ Δ' s E i K l q v v1 v2 Φ :
envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ?????.
- rewrite -wp_bind. eapply wand_apply; first exact: wp_cmpxchg_fail.
- rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
- by apply later_mono, sep_mono_r, wand_mono.
+ rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
+ eapply later_mono, wand_apply; first exact: swp_cmpxchg_fail.
+ rewrite -!later_intro envs_lookup_split //; simpl.
+ by apply sep_mono_r, wand_mono.
Qed.
-Lemma tac_twp_cmpxchg_fail Δ s E i K l q v v1 v2 Φ :
+Lemma tac_swp_cmpxchg_fail k Δ s E i K l q v v1 v2 Φ :
envs_lookup i Δ = Some (false, l ↦{q} v)%I →
v ≠v1 → vals_compare_safe v v1 →
- envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }]) →
- envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
+ envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }}) →
+ envs_entails Δ (SWP fill K (CmpXchg (LitV l) v1 v2) at k @ s; E {{ Φ }}).
Proof.
- rewrite envs_entails_eq. intros. rewrite -twp_bind.
- eapply wand_apply; first exact: twp_cmpxchg_fail.
- rewrite envs_lookup_split //=. by do 2 f_equiv.
+ rewrite envs_entails_eq. intros. rewrite -swp_bind //.
+ eapply wand_apply; first exact: swp_cmpxchg_fail.
+ rewrite -!later_intro envs_lookup_split //; simpl. by do 2 f_equiv.
Qed.
Lemma tac_wp_cmpxchg_suc Δ Δ' Δ'' s E i K l v v1 v2 Φ :
@@ -360,23 +623,23 @@ Lemma tac_wp_cmpxchg_suc Δ Δ' Δ'' s E i K l v v1 v2 Φ :
envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ??????; subst.
- rewrite -wp_bind. eapply wand_apply.
- { eapply wp_cmpxchg_suc; eauto. }
- rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
+ rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound. eapply later_mono, wand_apply.
+ { eapply swp_cmpxchg_suc; eauto. }
+ rewrite -!later_intro envs_simple_replace_sound //; simpl.
+ rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.
-Lemma tac_twp_cmpxchg_suc Δ Δ' s E i K l v v1 v2 Φ :
+Lemma tac_swp_cmpxchg_suc k Δ Δ' s E i K l v v1 v2 Φ :
envs_lookup i Δ = Some (false, l ↦ v)%I →
envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ = Some Δ' →
v = v1 → vals_compare_safe v v1 →
- envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }]) →
- envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
+ envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }}) →
+ envs_entails Δ (SWP fill K (CmpXchg (LitV l) v1 v2) at k @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=>?????; subst.
- rewrite -twp_bind. eapply wand_apply.
- { eapply twp_cmpxchg_suc; eauto. }
+ rewrite -swp_bind //. eapply wand_apply.
+ { eapply swp_cmpxchg_suc; eauto. }
rewrite envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply sep_mono_r, wand_mono.
+ rewrite right_id -!later_intro. by apply sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_faa Δ Δ' Δ'' s E i K l z1 z2 Φ :
@@ -387,20 +650,21 @@ Lemma tac_wp_faa Δ Δ' Δ'' s E i K l z1 z2 Φ :
envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ????.
- rewrite -wp_bind. eapply wand_apply; first exact: (wp_faa _ _ _ z1 z2).
- rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
+ rewrite -wp_bind -(swp_wp 1) // -swp_step into_laterN_env_sound.
+ eapply later_mono, wand_apply; first exact: (swp_faa _ _ _ _ z1 z2).
+ rewrite -!later_intro envs_simple_replace_sound //; simpl.
+ rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.
-Lemma tac_twp_faa Δ Δ' s E i K l z1 z2 Φ :
+Lemma tac_swp_faa k Δ Δ' s E i K l z1 z2 Φ :
envs_lookup i Δ = Some (false, l ↦ LitV z1)%I →
envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (z1 + z2))) Δ = Some Δ' →
- envs_entails Δ' (WP fill K (Val $ LitV z1) @ s; E [{ Φ }]) →
- envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E [{ Φ }]).
+ envs_entails Δ' (WP fill K (Val $ LitV z1) @ s; E {{ Φ }}) →
+ envs_entails Δ (SWP fill K (FAA (LitV l) (LitV z2)) at k @ s; E {{ Φ }}).
Proof.
rewrite envs_entails_eq=> ???.
- rewrite -twp_bind. eapply wand_apply; first exact: (twp_faa _ _ _ z1 z2).
+ rewrite -swp_bind //. eapply wand_apply; first exact: (swp_faa _ _ _ _ z1 z2).
rewrite envs_simple_replace_sound //; simpl.
- rewrite right_id. by apply sep_mono_r, wand_mono.
+ rewrite right_id -!later_intro. by apply sep_mono_r, wand_mono.
Qed.
End heap.
@@ -418,6 +682,24 @@ Tactic Notation "wp_apply_core" open_constr(lem) tactic(tac) :=
lazymatch iTypeOf H with
| Some (_,?P) => fail "wp_apply: cannot apply" P
end
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ reshape_expr e ltac:(fun K e' =>
+ swp_bind_core K; tac H) ||
+ lazymatch iTypeOf H with
+ | Some (_,?P) => fail "wp_apply: cannot apply" P
+ end
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ reshape_expr e ltac:(fun K e' =>
+ rwp_bind_core K; tac H) ||
+ lazymatch iTypeOf H with
+ | Some (_,?P) => fail "wp_apply: cannot apply" P
+ end
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ reshape_expr e ltac:(fun K e' =>
+ rswp_bind_core K; tac H) ||
+ lazymatch iTypeOf H with
+ | Some (_,?P) => fail "wp_apply: cannot apply" P
+ end
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
reshape_expr e ltac:(fun K e' =>
twp_bind_core K; tac H) ||
@@ -428,7 +710,8 @@ Tactic Notation "wp_apply_core" open_constr(lem) tactic(tac) :=
end).
Tactic Notation "wp_apply" open_constr(lem) :=
wp_apply_core lem (fun H => iApplyHyp H; try iNext; try wp_expr_simpl).
-(** Tactic tailored for atomic triples: the first, simple one just runs
+
+(*(** Tactic tailored for atomic triples: the first, simple one just runs
[iAuIntro] on the goal, as atomic triples always have an atomic update as their
premise. The second one additionaly does some framing: it gets rid of [Hs] from
the context, which is intended to be the non-laterable assertions that iAuIntro
@@ -438,6 +721,7 @@ Tactic Notation "awp_apply" open_constr(lem) :=
wp_apply_core lem (fun H => iApplyHyp H; last iAuIntro).
Tactic Notation "awp_apply" open_constr(lem) "without" constr(Hs) :=
wp_apply_core lem (fun H => iApply wp_frame_wand_l; iSplitL Hs; [iAccu|iApplyHyp H; last iAuIntro]).
+ *)
Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
let Htmp := iFresh in
@@ -471,6 +755,46 @@ Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
[idtac|iSolveTC
|finish ()]
in (process_single ()) || (process_array ())
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ let process_single _ :=
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_alloc _ _ _ _ _ Htmp K))
+ |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
+ finish ()
+ in
+ let process_array _ :=
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_allocN _ _ _ _ _ Htmp K))
+ |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
+ finish ()
+ in (process_single ()) || (process_array ())
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ let process_single _ :=
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_alloc _ _ _ Htmp K))
+ |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
+ finish ()
+ in
+ let process_array _ :=
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_allocN _ _ _ Htmp K))
+ |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
+ finish ()
+ in (process_single ()) || (process_array ())
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ let process_single _ :=
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_alloc _ _ _ _ _ Htmp K))
+ |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
+ [iSolveTC|finish ()]
+ in
+ let process_array _ :=
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_allocN _ _ _ _ _ Htmp K))
+ |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
+ [idtac|iSolveTC
+ |finish ()]
+ in (process_single ()) || (process_array ())
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
let process_single _ :=
first
@@ -482,7 +806,7 @@ Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
first
[reshape_expr e ltac:(fun K e' => eapply (tac_twp_allocN _ _ _ Htmp K))
|fail 1 "wp_alloc: cannot find 'Alloc' in" e];
- finish ()
+ [idtac| finish ()]
in (process_single ()) || (process_array ())
| _ => fail "wp_alloc: not a 'wp'"
end.
@@ -503,6 +827,24 @@ Tactic Notation "wp_load" :=
[iSolveTC
|solve_mapsto ()
|wp_finish]
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_load _ _ _ _ _ K))
+ |fail 1 "wp_load: cannot find 'Load' in" e];
+ [solve_mapsto ()
+ |wp_finish]
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_load _ _ _ _ K))
+ |fail 1 "wp_load: cannot find 'Load' in" e];
+ [solve_mapsto ()
+ |wp_finish]
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_load _ _ _ _ _ K))
+ |fail 1 "wp_load: cannot find 'Load' in" e];
+ [solve_mapsto ()
+ |wp_finish]
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
first
[reshape_expr e ltac:(fun K e' => eapply (tac_twp_load _ _ _ _ K))
@@ -526,6 +868,27 @@ Tactic Notation "wp_store" :=
|solve_mapsto ()
|pm_reflexivity
|first [wp_seq|wp_finish]]
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_store _ _ _ _ _ _ K))
+ |fail 1 "wp_store: cannot find 'Store' in" e];
+ [solve_mapsto ()
+ |pm_reflexivity
+ |first [wp_seq|wp_finish]]
+ | |- envs_entails _ (rwp ?s ?E ?e ?Q) =>
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rwp_store _ _ _ _ _ K))
+ |fail 1 "wp_store: cannot find 'Store' in" e];
+ [solve_mapsto ()
+ |pm_reflexivity
+ |first [wp_seq|wp_finish]]
+ | |- envs_entails _ (rswp ?k ?s ?E ?e ?Q) =>
+ first
+ [reshape_expr e ltac:(fun K e' => eapply (tac_rswp_store _ _ _ _ _ _ K))
+ |fail 1 "wp_store: cannot find 'Store' in" e];
+ [solve_mapsto ()
+ |pm_reflexivity
+ |first [wp_seq|wp_finish]]
| |- envs_entails _ (twp ?s ?E ?e ?Q) =>
first
[reshape_expr e ltac:(fun K e' => eapply (tac_twp_store _ _ _ _ _ K))
@@ -536,6 +899,7 @@ Tactic Notation "wp_store" :=
| _ => fail "wp_store: not a 'wp'"
end.
+(* TODO: refinement versions *)
Tactic Notation "wp_cmpxchg" "as" simple_intropattern(H1) "|" simple_intropattern(H2) :=
let solve_mapsto _ :=
let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
@@ -552,9 +916,9 @@ Tactic Notation "wp_cmpxchg" "as" simple_intropattern(H1) "|" simple_intropatter
|try solve_vals_compare_safe
|intros H1; wp_finish
|intros H2; wp_finish]
- | |- envs_entails _ (twp ?E ?e ?Q) =>
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg _ _ _ _ _ K))
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_cmpxchg _ _ _ _ _ _ K))
|fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
[solve_mapsto ()
|pm_reflexivity
@@ -579,9 +943,9 @@ Tactic Notation "wp_cmpxchg_fail" :=
|try (simpl; congruence) (* value inequality *)
|try solve_vals_compare_safe
|wp_finish]
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_fail _ _ _ _ K))
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_cmpxchg_fail _ _ _ _ _ K))
|fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
[solve_mapsto ()
|try (simpl; congruence) (* value inequality *)
@@ -606,9 +970,9 @@ Tactic Notation "wp_cmpxchg_suc" :=
|try (simpl; congruence) (* value equality *)
|try solve_vals_compare_safe
|wp_finish]
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_suc _ _ _ _ _ K))
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_cmpxchg_suc _ _ _ _ _ _ K))
|fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
[solve_mapsto ()
|pm_reflexivity
@@ -632,9 +996,9 @@ Tactic Notation "wp_faa" :=
|solve_mapsto ()
|pm_reflexivity
|wp_finish]
- | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
+ | |- envs_entails _ (swp ?k ?s ?E ?e ?Q) =>
first
- [reshape_expr e ltac:(fun K e' => eapply (tac_twp_faa _ _ _ _ _ K))
+ [reshape_expr e ltac:(fun K e' => eapply (tac_swp_faa _ _ _ _ _ _ K))
|fail 1 "wp_faa: cannot find 'FAA' in" e];
[solve_mapsto ()
|pm_reflexivity
diff --git a/theories/heap_lang/total_adequacy.v b/theories/heap_lang/total_adequacy.v
deleted file mode 100644
index df83c1542262baae6879521cf1110864640ee607..0000000000000000000000000000000000000000
--- a/theories/heap_lang/total_adequacy.v
+++ /dev/null
@@ -1,19 +0,0 @@
-From iris.program_logic Require Export total_adequacy.
-From iris.heap_lang Require Export adequacy.
-From iris.heap_lang Require Import proofmode notation.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Definition heap_total Σ `{!heapPreG Σ} s e σ φ :
- (∀ `{!heapG Σ}, WP e @ s; ⊤ [{ v, ⌜φ v⌠}]%I) →
- sn erased_step ([e], σ).
-Proof.
- intros Hwp; eapply (twp_total _ _); iIntros (?) "".
- iMod (gen_heap_init σ.(heap)) as (?) "Hh".
- iMod (proph_map_init [] σ.(used_proph_id)) as (?) "Hp".
- iModIntro.
- iExists
- (λ σ κs _, (gen_heap_ctx σ.(heap) ∗ proph_map_ctx κs σ.(used_proph_id))%I),
- (λ _, True%I); iFrame.
- iApply (Hwp (HeapG _ _ _ _)).
-Qed.
diff --git a/theories/program_logic/adequacy.v b/theories/program_logic/adequacy.v
index 95d2a04ff73b35eaec1ebe6ca7af5aaddd27fb70..100a4b3218558267bce41b69cb00d11c686a9e9e 100644
--- a/theories/program_logic/adequacy.v
+++ b/theories/program_logic/adequacy.v
@@ -5,45 +5,62 @@ From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.
-(** This file contains the adequacy statements of the Iris program logic. First
-we prove a number of auxilary results. *)
+(** This file contains the adequacy statements of the Iris program logic. First we prove a number of auxilary results. *)
+
+Lemma lstep_fupd_soundness {SI} {Σ: gFunctors SI} `{TransfiniteIndex SI} `{!invPreG Σ} φ n:
+ (∀ Hinv : invG Σ, @sbi_emp_valid SI (iPropSI Σ) (>={⊤}=={⊤}=>^n ⌜φâŒ)%I) → φ.
+Proof.
+ intros Hiter. assert ((True ⊢ â§^n ⌜φ⌠: iProp Σ)%I → φ) as Hlater;
+ last (apply Hlater).
+ { intros H1.
+ eapply pure_soundness, uPred_primitive.big_laterN_soundness, H1.
+ }
+ apply (fupd_plain_soundness ⊤ ⊤ _)=> Hinv.
+ iPoseProof (Hiter Hinv) as "H". by iApply lstep_fupdN_plain.
+Qed.
+
Section adequacy.
-Context `{!irisG Λ Σ}.
+Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
Implicit Types e : expr Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types Φs : list (val Λ → iProp Σ).
+
+
Notation wptp s t := ([∗ list] ef ∈ t, WP ef @ s; ⊤ {{ fork_post }})%I.
+Existing Instance elim_eventuallyN.
+Existing Instance elim_gstep.
Lemma wp_step s e1 σ1 κ κs e2 σ2 efs m Φ :
prim_step e1 σ1 κ e2 σ2 efs →
- state_interp σ1 (κ ++ κs) m -∗ WP e1 @ s; ⊤ {{ Φ }} ={⊤,∅}▷=∗
- state_interp σ2 κs (length efs + m) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s efs.
+ state_interp σ1 (κ ++ κs) m -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ >={⊤}=={⊤}=>
+ (state_interp σ2 κs (length efs + m) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s efs).
Proof.
rewrite {1}wp_unfold /wp_pre. iIntros (?) "Hσ H".
rewrite (val_stuck e1 σ1 κ e2 σ2 efs) //.
- iMod ("H" $! σ1 with "Hσ") as "(_ & H)".
- iMod ("H" $! e2 σ2 efs with "[//]") as "H".
- by iIntros "!> !>".
+ iMod ("H" $! σ1 with "Hσ") as "H". iMod "H".
+ iDestruct "H" as (n) "H".
+ iApply (gstepN_gstep _ _ _ (S n)). iModIntro.
+ replace (S n) with (n + 1) by lia. iApply eventuallyN_compose. iMod "H".
+ iMod "H" as "[% H]". iMod ("H" $! e2 σ2 efs with "[//]") as "H".
+ by iIntros "!> !> !> !>".
Qed.
Lemma wptp_step s e1 t1 t2 κ κs σ1 σ2 Φ :
step (e1 :: t1,σ1) κ (t2, σ2) →
- state_interp σ1 (κ ++ κs) (length t1) -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ wptp s t1 ==∗
+ state_interp σ1 (κ ++ κs) (length t1) -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ wptp s t1 -∗
∃ e2 t2', ⌜t2 = e2 :: t2'⌠∗
- |={⊤,∅}▷=> state_interp σ2 κs (pred (length t2)) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s t2'.
+ >={⊤}=={⊤}=> (state_interp σ2 κs (pred (length t2)) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s t2').
Proof.
iIntros (Hstep) "Hσ He Ht".
destruct Hstep as [e1' σ1' e2' σ2' efs [|? t1'] t2' ?? Hstep]; simplify_eq/=.
- - iExists e2', (t2' ++ efs). iModIntro. iSplitR; first by eauto.
- iMod (wp_step with "Hσ He") as "H"; first done.
- iIntros "!> !>". iMod "H" as "(Hσ & He2 & Hefs)".
- iIntros "!>". rewrite Nat.add_comm app_length. iFrame.
+ - iExists e2', (t2' ++ efs). iSplitR; first by eauto.
+ iMod (wp_step with "Hσ He") as "(Hσ & He2 & Hefs)"; first done.
+ rewrite Nat.add_comm app_length. iFrame.
- iExists e, (t1' ++ e2' :: t2' ++ efs); iSplitR; first eauto.
- iFrame "He". iDestruct "Ht" as "(Ht1 & He1 & Ht2)".
- iModIntro. iMod (wp_step with "Hσ He1") as "H"; first done.
- iIntros "!> !>". iMod "H" as "(Hσ & He2 & Hefs)". iIntros "!>".
+ iDestruct "Ht" as "(Ht1 & He1 & Ht2)".
+ iMod (wp_step with "Hσ He1") as "(Hσ & He2 & Hefs)"; first done.
rewrite !app_length /= !app_length.
replace (length t1' + S (length t2' + length efs))
with (length efs + (length t1' + S (length t2'))) by omega. iFrame.
@@ -52,36 +69,57 @@ Qed.
Lemma wptp_steps s n e1 t1 κs κs' t2 σ1 σ2 Φ :
nsteps n (e1 :: t1, σ1) κs (t2, σ2) →
state_interp σ1 (κs ++ κs') (length t1) -∗ WP e1 @ s; ⊤ {{ Φ }} -∗ wptp s t1
- ={⊤,∅}▷=∗^n ∃ e2 t2',
- ⌜t2 = e2 :: t2'⌠∗
+ -∗ (>={⊤}=={⊤}=>^n
+ (∃ e2 t2', ⌜t2 = e2 :: t2'⌠∗
state_interp σ2 κs' (pred (length t2)) ∗
- WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s t2'.
+ WP e2 @ s; ⊤ {{ Φ }} ∗ wptp s t2')).
Proof.
revert e1 t1 κs κs' t2 σ1 σ2; simpl.
induction n as [|n IH]=> e1 t1 κs κs' t2 σ1 σ2 /=.
{ inversion_clear 1; iIntros "???"; iExists e1, t1; iFrame; eauto 10. }
iIntros (Hsteps) "Hσ He Ht". inversion_clear Hsteps as [|?? [t1' σ1']].
rewrite -(assoc_L (++)).
- iMod (wptp_step with "Hσ He Ht") as (e1' t1'' ?) ">H"; first eauto; simplify_eq.
- iIntros "!> !>". iMod "H" as "(Hσ & He & Ht)". iModIntro.
- by iApply (IH with "Hσ He Ht").
+ iPoseProof (wptp_step with "Hσ He Ht") as (e1' t1'' ?) ">(Hσ & He & Ht)"; first eauto.
+ simplify_eq. by iApply (IH with "Hσ He Ht").
Qed.
Lemma wp_safe κs m e σ Φ :
state_interp σ κs m -∗
- WP e {{ Φ }} ={⊤}=∗ ⌜is_Some (to_val e) ∨ reducible e σâŒ.
+ WP e {{ Φ }} ={⊤}=∗ ⧠⌜is_Some (to_val e) ∨ reducible e σâŒ.
Proof.
rewrite wp_unfold /wp_pre. iIntros "Hσ H".
destruct (to_val e) as [v|] eqn:?; first by eauto.
- iSpecialize ("H" $! σ [] κs with "Hσ"). rewrite sep_elim_l.
- iMod (fupd_plain_mask with "H") as %?; eauto.
+ iSpecialize ("H" $! σ [] κs with "Hσ").
+ iAssert (|={⊤,∅}=> ⧠⌜reducible e σâŒ)%I with "[H]" as "H".
+ { iMod "H". iMod (eventually_plain with "[H]") as "H"; last by iModIntro. apply _.
+ iMod "H" as (n) "H". iModIntro. iExists (S n). replace (S n) with (n + 1)by lia. iApply eventuallyN_compose.
+ iMod "H". by iMod "H" as "[$ _]". }
+ iMod (fupd_plain_mask with "H") as "H"; eauto.
+ iModIntro. iMod "H" as "%". by iRight.
+Qed.
+
+Lemma list_big_later {X} (L: list X) (P: X → iProp Σ): ([∗ list] x ∈ L, ⧠P x) ⊢ ⧠[∗ list] x ∈ L, P x.
+Proof.
+ iInduction L as [|L] "IH"; simpl.
+ - iIntros "_". by iExists 0.
+ - iIntros "[H1 H2]". iSpecialize ("IH" with "H2").
+ iDestruct "H1" as (n1) "H1". iDestruct "IH" as (n2) "IH".
+ iExists (n1 + n2). iNext. iFrame.
+Qed.
+
+Lemma big_later_eventually P E: ⧠P -∗ <E> P.
+Proof.
+ iDestruct 1 as (n) "H". iExists n.
+ iModIntro. iInduction n as [ | n] "IH"; simpl; eauto.
+ iModIntro. iNext. iModIntro. by iApply "IH".
Qed.
+Existing Instance elim_gstep_N.
Lemma wptp_strong_adequacy Φ κs' s n e1 t1 κs e2 t2 σ1 σ2 :
nsteps n (e1 :: t1, σ1) κs (t2, σ2) →
state_interp σ1 (κs ++ κs') (length t1) -∗
WP e1 @ s; ⊤ {{ Φ }} -∗
- wptp s t1 ={⊤,∅}▷=∗^(S n) ∃ e2 t2',
+ wptp s t1 -∗ >={⊤}=={⊤}=>^(S n) ∃ e2 t2',
⌜ t2 = e2 :: t2' ⌠∗
⌜ ∀ e2, s = NotStuck → e2 ∈ t2 → (is_Some (to_val e2) ∨ reducible e2 σ2) ⌠∗
state_interp σ2 κs' (length t2') ∗
@@ -90,17 +128,30 @@ Lemma wptp_strong_adequacy Φ κs' s n e1 t1 κs e2 t2 σ1 σ2 :
Proof.
iIntros (Hstep) "Hσ He Ht". rewrite Nat_iter_S_r.
iDestruct (wptp_steps with "Hσ He Ht") as "Hwp"; first done.
- iApply (step_fupdN_wand with "Hwp").
- iDestruct 1 as (e2' t2' ?) "(Hσ & Hwp & Ht)"; simplify_eq/=.
+ iMod "Hwp". iDestruct "Hwp" as (e2' t2' ?) "(Hσ & Hwp & Ht)"; simplify_eq/=.
iMod (fupd_plain_keep_l ⊤
- ⌜ ∀ e2, s = NotStuck → e2 ∈ (e2' :: t2') → (is_Some (to_val e2) ∨ reducible e2 σ2) âŒ%I
+ ( ⌜s = NotStuck⌠→ [∗ list] e2 ∈ (e2' :: t2'), ⧠⌜(is_Some (to_val e2) ∨ reducible e2 σ2) âŒ)%I
(state_interp σ2 κs' (length t2') ∗ WP e2' @ s; ⊤ {{ v, Φ v }} ∗ wptp s t2')%I
with "[$Hσ $Hwp $Ht]") as "(Hsafe&Hσ&Hwp&Hvs)".
- { iIntros "(Hσ & Hwp & Ht)" (e' -> He').
- apply elem_of_cons in He' as [<-|(t1''&t2''&->)%elem_of_list_split].
- - iMod (wp_safe with "Hσ Hwp") as "$"; auto.
- - iDestruct "Ht" as "(_ & He' & _)". by iMod (wp_safe with "Hσ He'"). }
- iApply step_fupd_fupd. iApply step_fupd_intro; first done. iNext.
+ { iIntros "(Hσ & Hwp & Ht)" (->); simpl.
+ iMod (fupd_plain_keep_l ⊤ (⧠⌜is_Some (to_val e2') ∨ reducible e2' σ2âŒ)%I
+ (state_interp σ2 κs' (length t2') ∗ WP e2' @ ⊤ {{ v, Φ v }})%I
+ with "[$Hσ $Hwp]") as "($ & Hσ & _)".
+ { iIntros "[H1 H2]". iApply (wp_safe with "H1 H2"). }
+ clear Hstep. generalize (length t2') as l. intros l. iInduction t2' as [| e3 t3] "IH"; simpl.
+ - by iModIntro.
+ - iDestruct "Ht" as "[Hwp Ht]".
+ iMod (fupd_plain_keep_l ⊤ (⧠⌜is_Some (to_val e3) ∨ reducible e3 σ2âŒ)%I
+ (state_interp σ2 κs' l ∗ WP e3 {{ v, fork_post v }})%I
+ with "[$Hσ $Hwp]") as "($ & Hσ & _)".
+ { iIntros "[H1 H2]". iApply (wp_safe with "H1 H2"). }
+ iMod ("IH" with "Ht Hσ") as "$". by iModIntro. }
+ iAssert (⧠⌜ ∀ e2, s = NotStuck → e2 ∈ (e2' :: t2') → (is_Some (to_val e2) ∨ reducible e2 σ2) âŒ)%I with "[Hsafe]" as "Hsafe".
+ { destruct s; last (iExists 0; iIntros (? H); discriminate). iSpecialize ("Hsafe" with "[]"); eauto.
+ iMod (list_big_later with "Hsafe") as "Hsafe". iIntros (e) "_ %".
+ by iApply (big_sepL_elem_of with "Hsafe"). }
+ iMod (fupd_intro_mask') as "Hclose". apply empty_subseteq. iModIntro.
+ iApply big_later_eventually. iMod "Hsafe". iMod "Hclose" as "_".
iExists _, _. iSplitL ""; first done. iFrame "Hsafe Hσ".
iSplitL "Hwp".
- destruct (to_val e2') as [v2|] eqn:He2'; last done.
@@ -113,14 +164,15 @@ Proof.
Qed.
End adequacy.
+Existing Instance elim_gstep_N.
(** Iris's generic adequacy result *)
-Theorem wp_strong_adequacy Σ Λ `{!invPreG Σ} e1 σ1 n κs t2 σ2 φ :
+Theorem wp_strong_adequacy {SI} `{TransfiniteIndex SI} (Σ: gFunctors SI) Λ `{!invPreG Σ} e1 σ1 n κs t2 σ2 φ :
(∀ `{Hinv : !invG Σ},
- (|={⊤}=> ∃
+ ⊢ (|={⊤}=> ∃
(s: stuckness)
(stateI : state Λ → list (observation Λ) → nat → iProp Σ)
(Φ fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ Hinv stateI fork_post in
+ let _ : irisG Λ Σ := IrisG _ _ _ Hinv stateI fork_post in
stateI σ1 κs 0 ∗
WP e1 @ s; ⊤ {{ Φ }} ∗
(∀ e2 t2',
@@ -145,19 +197,20 @@ Theorem wp_strong_adequacy Σ Λ `{!invPreG Σ} e1 σ1 n κs t2 σ2 φ :
φ.
Proof.
intros Hwp ?.
- eapply (step_fupdN_soundness' _ (S (S n)))=> Hinv. rewrite Nat_iter_S.
+ eapply (@lstep_fupd_soundness _ Σ _ _ _ (S (S n) + 1))=> Hinv.
+ rewrite Nat_iter_add Nat_iter_S.
iMod Hwp as (s stateI Φ fork_post) "(Hσ & Hwp & Hφ)".
- iApply step_fupd_intro; [done|]; iModIntro.
- iApply step_fupdN_S_fupd. iApply (step_fupdN_wand with "[-Hφ]").
- { iApply (@wptp_strong_adequacy _ _ (IrisG _ _ Hinv stateI fork_post) _ []
- with "[Hσ] Hwp"); eauto; by rewrite right_id_L. }
- iIntros "Hpost". iDestruct "Hpost" as (e2 t2' ->) "(? & ? & ? & ?)".
+ iApply lstep_intro. iModIntro.
+ iPoseProof (@wptp_strong_adequacy _ _ _ (IrisG _ _ _ Hinv stateI fork_post) _ []
+ with "[Hσ] Hwp") as "Hpost". 1-3:eauto. by rewrite right_id_L. iSpecialize ("Hpost" with "[$]").
+ iMod "Hpost". iDestruct "Hpost" as (e2 t2' ->) "(? & ? & ? & ?)".
+ iApply lstep_intro.
iApply fupd_plain_mask_empty.
iMod ("Hφ" with "[% //] [$] [$] [$] [$]"). done.
Qed.
(** Since the full adequacy statement is quite a mouthful, we prove some more
-intuitive and simpler corollaries. These lemmas are morover stated in terms of
+intuitive and simpler corollaries. These lemmas are moreover stated in terms of
[rtc erased_step] so one does not have to provide the trace. *)
Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ)
(φ : val Λ → state Λ → Prop) := {
@@ -191,12 +244,12 @@ Proof.
right; exists (t2' ++ e3 :: t2'' ++ efs), σ3, κ; econstructor; eauto.
Qed.
-Corollary wp_adequacy Σ Λ `{!invPreG Σ} s e σ φ :
+Corollary wp_adequacy {SI} `{TransfiniteIndex SI} {Σ: gFunctors SI} Λ `{!invPreG Σ} s e σ φ :
(∀ `{Hinv : !invG Σ} κs,
- (|={⊤}=> ∃
+ sbi_emp_valid (|={⊤}=> ∃
(stateI : state Λ → list (observation Λ) → iProp Σ)
(fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ Hinv (λ σ κs _, stateI σ κs) fork_post in
+ let _ : irisG Λ Σ := IrisG _ _ _ Hinv (λ σ κs _, stateI σ κs) fork_post in
stateI σ κs ∗ WP e @ s; ⊤ {{ v, ⌜φ v⌠}})%I) →
adequate s e σ (λ v _, φ v).
Proof.
@@ -209,12 +262,12 @@ Proof.
iIntros (v2 t2'' [= -> <-]). by rewrite to_of_val.
Qed.
-Corollary wp_invariance Σ Λ `{!invPreG Σ} s e1 σ1 t2 σ2 φ :
+Corollary wp_invariance {SI} `{TransfiniteIndex SI} {Σ: gFunctors SI} Λ `{!invPreG Σ} s e1 σ1 t2 σ2 φ :
(∀ `{Hinv : !invG Σ} κs,
- (|={⊤}=> ∃
+ sbi_emp_valid (|={⊤}=> ∃
(stateI : state Λ → list (observation Λ) → nat → iProp Σ)
(fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ Hinv stateI fork_post in
+ let _ : irisG Λ Σ := IrisG _ _ _ Hinv stateI fork_post in
stateI σ1 κs 0 ∗ WP e1 @ s; ⊤ {{ _, True }} ∗
(stateI σ2 [] (pred (length t2)) -∗ ∃ E, |={⊤,E}=> ⌜φâŒ))%I) →
rtc erased_step ([e1], σ1) (t2, σ2) →
diff --git a/theories/program_logic/atomic.v b/theories/program_logic/atomic.v
deleted file mode 100644
index 847f2705c4e62060a7deda32e7ee79a3476eec51..0000000000000000000000000000000000000000
--- a/theories/program_logic/atomic.v
+++ /dev/null
@@ -1,127 +0,0 @@
-From stdpp Require Import namespaces.
-From iris.program_logic Require Export weakestpre.
-From iris.proofmode Require Import tactics classes.
-From iris.bi.lib Require Export atomic.
-From iris.bi Require Import telescopes.
-Set Default Proof Using "Type".
-
-(* This hard-codes the inner mask to be empty, because we have yet to find an
-example where we want it to be anything else. *)
-Definition atomic_wp `{!irisG Λ Σ} {TA TB : tele}
- (e: expr Λ) (* expression *)
- (Eo : coPset) (* (outer) mask *)
- (α: TA → iProp Σ) (* atomic pre-condition *)
- (β: TA → TB → iProp Σ) (* atomic post-condition *)
- (f: TA → TB → val Λ) (* Turn the return data into the return value *)
- : iProp Σ :=
- (∀ (Φ : val Λ → iProp Σ),
- atomic_update Eo ∅ α β (λ.. x y, Φ (f x y)) -∗
- WP e {{ Φ }})%I.
-(* Note: To add a private postcondition, use
- atomic_update α β Eo Ei (λ x y, POST x y -∗ Φ (f x y)) *)
-
-Notation "'<<<' ∀ x1 .. xn , α '>>>' e @ Eo '<<<' ∃ y1 .. yn , β , 'RET' v '>>>'" :=
- (atomic_wp (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
- (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- e%E
- Eo
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, α%I) ..)
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, β%I) .. )
- ) .. )
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, v%V) .. )
- ) .. )
- )
- (at level 20, Eo, α, β, v at level 200, x1 binder, xn binder, y1 binder, yn binder,
- format "'[hv' '<<<' ∀ x1 .. xn , α '>>>' '/ ' e @ Eo '/' '[ ' '<<<' ∃ y1 .. yn , β , '/' 'RET' v '>>>' ']' ']'")
- : stdpp_scope.
-
-Notation "'<<<' ∀ x1 .. xn , α '>>>' e @ Eo '<<<' β , 'RET' v '>>>'" :=
- (atomic_wp (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
- (TB:=TeleO)
- e%E
- Eo
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn, α%I) ..)
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleO) β%I
- ) .. )
- (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
- λ x1, .. (λ xn,
- tele_app (TT:=TeleO) v%V
- ) .. )
- )
- (at level 20, Eo, α, β, v at level 200, x1 binder, xn binder,
- format "'[hv' '<<<' ∀ x1 .. xn , α '>>>' '/ ' e @ Eo '/' '[ ' '<<<' β , '/' 'RET' v '>>>' ']' ']'")
- : stdpp_scope.
-
-Notation "'<<<' α '>>>' e @ Eo '<<<' ∃ y1 .. yn , β , 'RET' v '>>>'" :=
- (atomic_wp (TA:=TeleO)
- (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- e%E
- Eo
- (tele_app (TT:=TeleO) α%I)
- (tele_app (TT:=TeleO) $
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, β%I) .. ))
- (tele_app (TT:=TeleO) $
- tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
- (λ y1, .. (λ yn, v%V) .. ))
- )
- (at level 20, Eo, α, β, v at level 200, y1 binder, yn binder,
- format "'[hv' '<<<' α '>>>' '/ ' e @ Eo '/' '[ ' '<<<' ∃ y1 .. yn , β , '/' 'RET' v '>>>' ']' ']'")
- : stdpp_scope.
-
-Notation "'<<<' α '>>>' e @ Eo '<<<' β , 'RET' v '>>>'" :=
- (atomic_wp (TA:=TeleO)
- (TB:=TeleO)
- e%E
- Eo
- (tele_app (TT:=TeleO) α%I)
- (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) β%I)
- (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) v%V)
- )
- (at level 20, Eo, α, β, v at level 200,
- format "'[hv' '<<<' α '>>>' '/ ' e @ Eo '/' '[ ' '<<<' β , '/' 'RET' v '>>>' ']' ']'")
- : stdpp_scope.
-
-(** Theory *)
-Section lemmas.
- Context `{!irisG Λ Σ} {TA TB : tele}.
- Notation iProp := (iProp Σ).
- Implicit Types (α : TA → iProp) (β : TA → TB → iProp) (f : TA → TB → val Λ).
-
- Lemma atomic_wp_seq e Eo α β f {HL : ∀.. x, Laterable (α x)} :
- atomic_wp e Eo α β f -∗
- ∀ Φ, ∀.. x, α x -∗ (∀.. y, β x y -∗ Φ (f x y)) -∗ WP e {{ Φ }}.
- Proof.
- rewrite ->tforall_forall in HL. iIntros "Hwp" (Φ x) "Hα HΦ".
- iApply wp_frame_wand_l. iSplitL "HΦ"; first iAccu. iApply "Hwp".
- iAuIntro. iAaccIntro with "Hα"; first by eauto. iIntros (y) "Hβ !>".
- (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
- rewrite ->!tele_app_bind. iIntros "HΦ". iApply "HΦ". done.
- Qed.
-
- (* Sequential triples with a persistent precondition and no initial quantifier
- are atomic. *)
- Lemma seq_wp_atomic e Eo (α : [tele] → iProp) (β : [tele] → TB → iProp)
- (f : [tele] → TB → val Λ) {HP : Persistent (α [tele_arg])} :
- (∀ Φ, α [tele_arg] -∗ (∀.. y, β [tele_arg] y -∗ Φ (f [tele_arg] y)) -∗ WP e {{ Φ }}) -∗
- atomic_wp e Eo α β f.
- Proof.
- simpl in HP. iIntros "Hwp" (Φ) "HΦ". iApply fupd_wp.
- iMod ("HΦ") as "[#Hα [Hclose _]]". iMod ("Hclose" with "Hα") as "HΦ".
- iApply wp_fupd. iApply ("Hwp" with "Hα"). iIntros "!>" (y) "Hβ".
- iMod ("HΦ") as "[_ [_ Hclose]]". iMod ("Hclose" with "Hβ") as "HΦ".
- (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
- rewrite ->!tele_app_bind. done.
- Qed.
-
-End lemmas.
diff --git a/theories/program_logic/ectx_lifting.v b/theories/program_logic/ectx_lifting.v
index a164cb131c7094b1577c1284b296eab7c60ad42f..571315485b3d93e8ea271841e65d839c6d5d4df3 100644
--- a/theories/program_logic/ectx_lifting.v
+++ b/theories/program_logic/ectx_lifting.v
@@ -4,7 +4,7 @@ From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Section wp.
-Context {Λ : ectxLanguage} `{!irisG Λ Σ} {Hinh : Inhabited (state Λ)}.
+Context {SI} {Σ: gFunctors SI} {Λ : ectxLanguage} `{!irisG Λ Σ} {Hinh : Inhabited (state Λ)}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
@@ -59,7 +59,7 @@ Lemma wp_lift_pure_head_stuck E Φ e :
sub_redexes_are_values e →
(∀ σ, head_stuck e σ) →
WP e @ E ?{{ Φ }}%I.
-Proof using Hinh.
+Proof.
iIntros (?? Hstuck). iApply wp_lift_head_stuck; [done|done|].
iIntros (σ κs n) "_". iMod (fupd_intro_mask' E ∅) as "_"; first set_solver.
by auto.
@@ -97,6 +97,21 @@ Proof.
iApply "H"; eauto.
Qed.
+Lemma swp_lift_atomic_head_step {k s E Φ} e1 :
+ (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
+ ⌜head_reducible e1 σ1⌠∗
+ ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ state_interp σ2 κs (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
+ ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros "H". iApply swp_lift_atomic_step; eauto.
+ iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
+ iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep).
+ iApply "H"; eauto.
+Qed.
+
Lemma wp_lift_atomic_head_step_no_fork_fupd {s E1 E2 Φ} e1 :
to_val e1 = None →
(∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=∗
@@ -126,6 +141,19 @@ Proof.
iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
Qed.
+Lemma swp_lift_atomic_head_step_no_fork {k s E Φ} e1 :
+ (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
+ ⌜head_reducible e1 σ1⌠∗
+ ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ ⌜efs = []⌠∗ state_interp σ2 κs n ∗ from_option Φ False (to_val e2))
+ ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros "H". iApply swp_lift_atomic_head_step; eauto.
+ iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
+ iNext; iIntros (v2 σ2 efs Hstep).
+ iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
+Qed.
+
Lemma wp_lift_pure_det_head_step_no_fork {s E E' Φ} e1 e2 :
to_val e1 = None →
(∀ σ1, head_reducible e1 σ1) →
diff --git a/theories/program_logic/ectxi_language.v b/theories/program_logic/ectxi_language.v
index 603d216516f1f8c2bb60ae876a68106f656f33f7..a8e3807d7c275e14b8704f0bd0c03a04f0efb1f9 100644
--- a/theories/program_logic/ectxi_language.v
+++ b/theories/program_logic/ectxi_language.v
@@ -94,6 +94,9 @@ Section ectxi_language.
Lemma fill_app (K1 K2 : ectx) e : fill (K1 ++ K2) e = fill K2 (fill K1 e).
Proof. apply foldl_app. Qed.
+ Lemma fill_cons Ki (K2 : ectx) e : fill (Ki :: K2) e = fill K2 (fill_item Ki e).
+ Proof. replace (Ki :: K2) with ([Ki] ++ K2) by auto. rewrite fill_app //. Qed.
+
Definition ectxi_lang_ectx_mixin :
EctxLanguageMixin of_val to_val [] (flip (++)) fill head_step.
Proof.
diff --git a/theories/program_logic/hoare.v b/theories/program_logic/hoare.v
index e2af2d5c1574b974a0ea0cf57d7a19ff1ef8ab5f..4e03f84bc6b70ff78f07221a402d699d796bb762 100644
--- a/theories/program_logic/hoare.v
+++ b/theories/program_logic/hoare.v
@@ -3,10 +3,10 @@ From iris.base_logic.lib Require Export viewshifts.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
-Definition ht `{!irisG Λ Σ} (s : stuckness) (E : coPset) (P : iProp Σ)
+Definition ht {SI} `{!@irisG Λ SI Σ} (s : stuckness) (E : coPset) (P : iProp Σ)
(e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ :=
(□ (P -∗ WP e @ s; E {{ Φ }}))%I.
-Instance: Params (@ht) 5 := {}.
+Instance: Params (@ht) 6 := {}.
Notation "{{ P } } e @ s ; E {{ Φ } }" := (ht s E P%I e%E Φ%I)
(at level 20, P, e, Φ at level 200,
@@ -41,7 +41,7 @@ Notation "{{ P } } e ? {{ v , Q } }" := (ht MaybeStuck ⊤ P%I e%E (λ v, Q)%I)
format "{{ P } } e ? {{ v , Q } }") : stdpp_scope.
Section hoare.
-Context `{!irisG Λ Σ}.
+Context {SI} `{!@irisG Λ SI Σ}.
Implicit Types s : stuckness.
Implicit Types P Q : iProp Σ.
Implicit Types Φ Ψ : val Λ → iProp Σ.
@@ -79,11 +79,11 @@ Proof.
iIntros (v) "Hv". by iApply "HΦ".
Qed.
-Lemma ht_atomic s E1 E2 P P' Φ Φ' e `{!Atomic (stuckness_to_atomicity s) e} :
+Lemma ht_atomic s E1 E2 P P' Φ Φ' e `{!Atomic StronglyAtomic e} :
(P ={E1,E2}=> P') ∧ {{ P' }} e @ s; E2 {{ Φ' }} ∧ (∀ v, Φ' v ={E2,E1}=> Φ v)
⊢ {{ P }} e @ s; E1 {{ Φ }}.
Proof.
- iIntros "(#Hvs & #Hwp & #HΦ) !# HP". iApply (wp_atomic _ _ E2); auto.
+ iIntros "(#Hvs & #Hwp & #HΦ) !# HP". iApply (wp_atomic _ E2); auto.
iMod ("Hvs" with "HP") as "HP". iModIntro.
iApply (wp_wand with "(Hwp HP)").
iIntros (v) "Hv". by iApply "HΦ".
diff --git a/theories/program_logic/language.v b/theories/program_logic/language.v
index d8d4b39cf033805ecbbb3c20a7f6beee0cdba12d..e8862d4915a17e2911931f1f53774aabcfc0a12f 100644
--- a/theories/program_logic/language.v
+++ b/theories/program_logic/language.v
@@ -37,9 +37,9 @@ Arguments of_val {_} _.
Arguments to_val {_} _.
Arguments prim_step {_} _ _ _ _ _ _.
-Canonical Structure stateO Λ := leibnizO (state Λ).
-Canonical Structure valO Λ := leibnizO (val Λ).
-Canonical Structure exprO Λ := leibnizO (expr Λ).
+Canonical Structure stateO (SI: indexT) Λ : ofeT SI := leibnizO SI (state Λ).
+Canonical Structure valO (SI: indexT) Λ : ofeT SI := leibnizO SI (val Λ).
+Canonical Structure exprO (SI: indexT) Λ : ofeT SI := leibnizO SI (expr Λ).
Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.
diff --git a/theories/program_logic/lifting.v b/theories/program_logic/lifting.v
index 3219b14562eebf13e43e3b30f9b20a44c8b43230..36ceb429b01db9beb1d50b06de52ac60a39dd7c8 100644
--- a/theories/program_logic/lifting.v
+++ b/theories/program_logic/lifting.v
@@ -3,7 +3,7 @@ From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Section lifting.
-Context `{!irisG Λ Σ}.
+Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
Implicit Types s : stuckness.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
@@ -24,17 +24,33 @@ Lemma wp_lift_step_fupd s E Φ e1 :
⊢ WP e1 @ s; E {{ Φ }}.
Proof.
rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs n) "Hσ".
- iMod ("H" with "Hσ") as "(%&H)". iModIntro. iSplit. by destruct s.
+ iMod ("H" with "Hσ") as "(%&H)". iApply lstep_intro. iModIntro. iSplit.
+ by destruct s.
iIntros (????). iApply "H". eauto.
Qed.
+Lemma swp_lift_step_fupd k s E Φ e1 :
+ (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
+ ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,∅,E}▷=∗
+ state_interp σ2 κs (length efs + n) ∗
+ WP e2 @ s; E {{ Φ }} ∗
+ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
+ ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ rewrite swp_unfold /swp_def. iIntros "H" (σ1 κ κs n) "Hσ".
+ iMod ("H" with "Hσ") as "(%&H)". iApply lstepN_intro. iModIntro.
+ iSplit; eauto.
+Qed.
+
Lemma wp_lift_stuck E Φ e :
to_val e = None →
(∀ σ κs n, state_interp σ κs n ={E,∅}=∗ ⌜stuck e σâŒ)
⊢ WP e @ E ?{{ Φ }}.
Proof.
rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs n) "Hσ".
- iMod ("H" with "Hσ") as %[? Hirr]. iModIntro. iSplit; first done.
+ iMod ("H" with "Hσ") as %[? Hirr]. iApply lstep_intro. iModIntro.
+ iSplit; first done.
iIntros (e2 σ2 efs ?). by case: (Hirr κ e2 σ2 efs).
Qed.
@@ -53,6 +69,19 @@ Proof.
iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !> !>". by iApply "H".
Qed.
+Lemma swp_lift_step k s E Φ e1 :
+ (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,∅}=∗
+ ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
+ state_interp σ2 κs (length efs + n) ∗
+ WP e2 @ s; E {{ Φ }} ∗
+ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
+ ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros "H". iApply swp_lift_step_fupd. iIntros (????) "Hσ".
+ iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !> !>". by iApply "H".
+Qed.
+
Lemma wp_lift_pure_step_no_fork `{!Inhabited (state Λ)} s E E' Φ e1 :
(∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
(∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
@@ -70,6 +99,23 @@ Proof.
iDestruct ("H" with "[//]") as "H". simpl. iFrame.
Qed.
+
+Lemma swp_lift_pure_step_no_fork k s E E' Φ e1 :
+ (∀ σ1, s = NotStuck → reducible e1 σ1) →
+ (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
+ (|={E,E'}▷=> ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌠→ WP e2 @ s; E {{ Φ }})
+ ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros (Hsafe Hstep) "H". iApply swp_lift_step.
+ iIntros (σ1 κ κs n) "Hσ". iMod "H".
+ iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
+ { iPureIntro. destruct s; eauto. }
+ iNext. iIntros (e2 σ2 efs ?).
+ destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
+ iMod "Hclose" as "_". iMod "H". iModIntro.
+ iDestruct ("H" with "[//]") as "H". simpl. iFrame.
+Qed.
+
Lemma wp_lift_pure_stuck `{!Inhabited (state Λ)} E Φ e :
(∀ σ, stuck e σ) →
True ⊢ WP e @ E ?{{ Φ }}.
@@ -104,6 +150,27 @@ Proof.
iApply wp_value; last done. by apply of_to_val.
Qed.
+Lemma swp_lift_atomic_step_fupd {k s E1 E2 Φ} e1 :
+ (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=∗
+ ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={E1,E2}▷=∗
+ state_interp σ2 κs (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
+ ⊢ SWP e1 at k @ s; E1 {{ Φ }}.
+Proof.
+ iIntros "H".
+ iApply (swp_lift_step_fupd k s E1 _ e1)=>//; iIntros (σ1 κ κs n) "Hσ1".
+ iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
+ iMod (fupd_intro_mask' E1 ∅) as "Hclose"; first set_solver.
+ iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_".
+ iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|].
+ iMod (fupd_intro_mask' E2 ∅) as "Hclose"; [set_solver|]. iIntros "!> !>".
+ iMod "Hclose" as "_". iMod "H" as "($ & HQ & $)".
+ destruct (to_val e2) eqn:?; last by iExFalso.
+ iApply wp_value; last done. by apply of_to_val.
+Qed.
+
Lemma wp_lift_atomic_step {s E Φ} e1 :
to_val e1 = None →
(∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
@@ -120,6 +187,22 @@ Proof.
by iApply "H".
Qed.
+Lemma swp_lift_atomic_step {k s E Φ} e1 :
+ (∀ σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=∗
+ ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ state_interp σ2 κs (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
+ ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros "H". iApply swp_lift_atomic_step_fupd.
+ iIntros (????) "?". iMod ("H" with "[$]") as "[$ H]".
+ iIntros "!> *". iIntros (Hstep) "!> !>".
+ by iApply "H".
+Qed.
+
+
Lemma wp_lift_pure_det_step_no_fork `{!Inhabited (state Λ)} {s E E' Φ} e1 e2 :
(∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
(∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
@@ -132,6 +215,18 @@ Proof.
iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
Qed.
+Lemma swp_lift_pure_det_step_no_fork {k s E E' Φ} e1 e2 :
+ (∀ σ1, s = NotStuck → reducible e1 σ1) →
+ (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
+ κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
+ (|={E,E'}▷=> WP e2 @ s; E {{ Φ }}) ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros (? Hpuredet) "H". iApply (swp_lift_pure_step_no_fork k s E E'); try done.
+ { naive_solver. }
+ iApply (step_fupd_wand with "H"); iIntros "H".
+ iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
+Qed.
+
Lemma wp_pure_step_fupd `{!Inhabited (state Λ)} s E E' e1 e2 φ n Φ :
PureExec φ n e1 e2 →
φ →
@@ -145,6 +240,26 @@ Proof.
- by iApply (step_fupd_wand with "Hwp").
Qed.
+Lemma swp_pure_step_fupd k s E E' e1 e2 φ n Φ `{!Inhabited (state Λ)} :
+ PureExec φ (S n) e1 e2 →
+ φ →
+ (|={E,E'}▷=>^(S n) WP e2 @ s; E {{ Φ }}) ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
+ iInduction n as [|n] "IH" forall (e1 Hexec); simpl;
+ inversion Hexec as [|n' ? e1' ? Hstep Hrest]; subst.
+ all: iApply swp_lift_pure_det_step_no_fork.
+ 1, 4: intros σ; intros H; subst; eauto using pure_step_safe, reducible_no_obs_reducible, reducible_not_val.
+ 1, 3: eauto using pure_step_det.
+ - inversion Hrest; subst; eauto.
+ - iSpecialize ("IH" with "[//] Hwp").
+ iMod "IH". iModIntro. iNext. iMod "IH". iModIntro.
+ iPoseProof (swp_wp with "IH") as "IH"; eauto.
+ inversion Hrest; subst.
+ unshelve eauto using pure_step_safe, reducible_no_obs_reducible, reducible_not_val.
+ exact inhabitant.
+Qed.
+
Lemma wp_pure_step_later `{!Inhabited (state Λ)} s E e1 e2 φ n Φ :
PureExec φ n e1 e2 →
φ →
@@ -153,4 +268,14 @@ Proof.
intros Hexec ?. rewrite -wp_pure_step_fupd //. clear Hexec.
induction n as [|n IH]; by rewrite //= -step_fupd_intro // IH.
Qed.
+
+
+Lemma swp_pure_step_later `{!Inhabited (state Λ)} k s E e1 e2 φ n Φ :
+ PureExec φ (S n) e1 e2 →
+ φ →
+ ▷^(S n) WP e2 @ s; E {{ Φ }} ⊢ SWP e1 at k @ s; E {{ Φ }}.
+Proof.
+ intros Hexec ?. rewrite -swp_pure_step_fupd //. iIntros "H".
+ iApply step_fupdN_intro; eauto.
+Qed.
End lifting.
diff --git a/theories/program_logic/ownp.v b/theories/program_logic/ownp.v
deleted file mode 100644
index 40f4763f94dd1f05d7895876f7aeb87d4dd9b1f3..0000000000000000000000000000000000000000
--- a/theories/program_logic/ownp.v
+++ /dev/null
@@ -1,296 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.program_logic Require Import lifting adequacy.
-From iris.program_logic Require ectx_language.
-From iris.algebra Require Import excl auth.
-From iris.proofmode Require Import tactics classes.
-Set Default Proof Using "Type".
-
-(**
-This module provides an interface to handling ownership of the global state that
-works more like Iris 2.0 did. The state interpretation (in WP) is fixed to be
-authoritative ownership of the entire state (using the [excl] RA). Users can
-then put the corresponding fragment into an invariant on their own to establish
-a more interesting notion of ownership, such as the standard heap with disjoint
-union.
-*)
-
-Class ownPG (Λ : language) (Σ : gFunctors) := OwnPG {
- ownP_invG : invG Σ;
- ownP_inG :> inG Σ (authR (optionUR (exclR (stateO Λ))));
- ownP_name : gname;
-}.
-
-Instance ownPG_irisG `{!ownPG Λ Σ} : irisG Λ Σ := {
- iris_invG := ownP_invG;
- state_interp σ κs _ := own ownP_name (◠(Excl' σ))%I;
- fork_post _ := True%I;
-}.
-Global Opaque iris_invG.
-
-Definition ownPΣ (Λ : language) : gFunctors :=
- #[invΣ;
- GFunctor (authR (optionUR (exclR (stateO Λ))))].
-
-Class ownPPreG (Λ : language) (Σ : gFunctors) : Set := IrisPreG {
- ownPPre_invG :> invPreG Σ;
- ownPPre_state_inG :> inG Σ (authR (optionUR (exclR (stateO Λ))))
-}.
-
-Instance subG_ownPΣ {Λ Σ} : subG (ownPΣ Λ) Σ → ownPPreG Λ Σ.
-Proof. solve_inG. Qed.
-
-(** Ownership *)
-Definition ownP `{!ownPG Λ Σ} (σ : state Λ) : iProp Σ :=
- own ownP_name (◯ (Excl' σ)).
-
-Typeclasses Opaque ownP.
-Instance: Params (@ownP) 3 := {}.
-
-(* Adequacy *)
-Theorem ownP_adequacy Σ `{!ownPPreG Λ Σ} s e σ φ :
- (∀ `{!ownPG Λ Σ}, ownP σ ⊢ WP e @ s; ⊤ {{ v, ⌜φ v⌠}}) →
- adequate s e σ (λ v _, φ v).
-Proof.
- intros Hwp. apply (wp_adequacy Σ _).
- iIntros (? κs).
- iMod (own_alloc (◠(Excl' σ) ⋅ ◯ (Excl' σ))) as (γσ) "[Hσ Hσf]";
- first by apply auth_both_valid.
- iModIntro. iExists (λ σ κs, own γσ (◠(Excl' σ)))%I, (λ _, True%I).
- iFrame "Hσ".
- iApply (Hwp (OwnPG _ _ _ _ γσ)). rewrite /ownP. iFrame.
-Qed.
-
-Theorem ownP_invariance Σ `{!ownPPreG Λ Σ} s e σ1 t2 σ2 φ :
- (∀ `{!ownPG Λ Σ},
- ownP σ1 ={⊤}=∗ WP e @ s; ⊤ {{ _, True }} ∗
- |={⊤,∅}=> ∃ σ', ownP σ' ∧ ⌜φ σ'âŒ) →
- rtc erased_step ([e], σ1) (t2, σ2) →
- φ σ2.
-Proof.
- intros Hwp Hsteps. eapply (wp_invariance Σ Λ s e σ1 t2 σ2 _)=> //.
- iIntros (? κs).
- iMod (own_alloc (◠(Excl' σ1) ⋅ ◯ (Excl' σ1))) as (γσ) "[Hσ Hσf]";
- first by apply auth_both_valid.
- iExists (λ σ κs' _, own γσ (◠(Excl' σ)))%I, (λ _, True%I).
- iFrame "Hσ".
- iMod (Hwp (OwnPG _ _ _ _ γσ) with "[Hσf]") as "[$ H]";
- first by rewrite /ownP; iFrame.
- iIntros "!> Hσ". iExists ∅. iMod "H" as (σ2') "[Hσf %]". rewrite /ownP.
- iDestruct (own_valid_2 with "Hσ Hσf")
- as %[Hp%Excl_included _]%auth_both_valid; simplify_eq; auto.
-Qed.
-
-
-(** Lifting *)
-Section lifting.
- Context `{!ownPG Λ Σ}.
- Implicit Types s : stuckness.
- Implicit Types e : expr Λ.
- Implicit Types Φ : val Λ → iProp Σ.
-
- Lemma ownP_eq σ1 σ2 κs n : state_interp σ1 κs n -∗ ownP σ2 -∗ ⌜σ1 = σ2âŒ.
- Proof.
- iIntros "Hσ◠Hσ◯". rewrite /ownP.
- iDestruct (own_valid_2 with "Hσ◠Hσ◯") as %[Hps _]%auth_both_valid.
- by pose proof (leibniz_equiv _ _ (Excl_included _ _ Hps)) as ->.
- Qed.
- Lemma ownP_state_twice σ1 σ2 : ownP σ1 ∗ ownP σ2 ⊢ False.
- Proof. rewrite /ownP -own_op own_valid. by iIntros (?). Qed.
- Global Instance ownP_timeless σ : Timeless (@ownP Λ Σ _ σ).
- Proof. rewrite /ownP; apply _. Qed.
-
- Lemma ownP_lift_step s E Φ e1 :
- (|={E,∅}=> ∃ σ1, ⌜if s is NotStuck then reducible e1 σ1 else to_val e1 = None⌠∗
- ▷ ownP σ1 ∗
- ▷ ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗
- ownP σ2
- ={∅,E}=∗ WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros "H". destruct (to_val e1) as [v|] eqn:EQe1.
- - apply of_to_val in EQe1 as <-. iApply fupd_wp.
- iMod "H" as (σ1) "[Hred _]"; iDestruct "Hred" as %Hred.
- destruct s; last done. apply reducible_not_val in Hred.
- move: Hred; by rewrite to_of_val.
- - iApply wp_lift_step; [done|]; iIntros (σ1 κ κs n) "Hσκs".
- iMod "H" as (σ1' ?) "[>Hσf H]".
- iDestruct (ownP_eq with "Hσκs Hσf") as %<-.
- iModIntro; iSplit; [by destruct s|]; iNext; iIntros (e2 σ2 efs Hstep).
- iDestruct "Hσκs" as "Hσ". rewrite /ownP.
- iMod (own_update_2 with "Hσ Hσf") as "[Hσ Hσf]".
- { apply auth_update. apply option_local_update.
- by apply (exclusive_local_update _ (Excl σ2)). }
- iFrame "Hσ". iApply ("H" with "[]"); eauto with iFrame.
- Qed.
-
- Lemma ownP_lift_stuck E Φ e :
- (|={E,∅}=> ∃ σ, ⌜stuck e σ⌠∗ ▷ (ownP σ))
- ⊢ WP e @ E ?{{ Φ }}.
- Proof.
- iIntros "H". destruct (to_val e) as [v|] eqn:EQe.
- - apply of_to_val in EQe as <-. iApply fupd_wp.
- iMod "H" as (σ1) "[H _]". iDestruct "H" as %[Hnv _]. exfalso.
- by rewrite to_of_val in Hnv.
- - iApply wp_lift_stuck; [done|]. iIntros (σ1 κs n) "Hσ".
- iMod "H" as (σ1') "(% & >Hσf)".
- by iDestruct (ownP_eq with "Hσ Hσf") as %->.
- Qed.
-
- Lemma ownP_lift_pure_step `{!Inhabited (state Λ)} s E Φ e1 :
- (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ σ1 κ e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1) →
- (▷ ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌠→
- WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros (Hsafe Hstep) "H"; iApply wp_lift_step.
- { specialize (Hsafe inhabitant). destruct s; last done.
- by eapply reducible_not_val. }
- iIntros (σ1 κ κs n) "Hσ". iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
- iModIntro; iSplit; [by destruct s|]; iNext; iIntros (e2 σ2 efs ?).
- destruct (Hstep σ1 κ e2 σ2 efs); auto; subst.
- by iMod "Hclose"; iModIntro; iFrame; iApply "H".
- Qed.
-
- (** Derived lifting lemmas. *)
- Lemma ownP_lift_atomic_step {s E Φ} e1 σ1 :
- (if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (▷ (ownP σ1) ∗
- ▷ ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗
- ownP σ2 -∗
- from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros (?) "[Hσ H]"; iApply ownP_lift_step.
- iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
- iModIntro; iExists σ1; iFrame; iSplit; first by destruct s.
- iNext; iIntros (κ e2 σ2 efs ?) "Hσ".
- iDestruct ("H" $! κ e2 σ2 efs with "[] [Hσ]") as "[HΦ $]"; [by eauto..|].
- destruct (to_val e2) eqn:?; last by iExFalso.
- iMod "Hclose"; iApply wp_value; last done. by apply of_to_val.
- Qed.
-
- Lemma ownP_lift_atomic_det_step {s E Φ e1} σ1 v2 σ2 efs :
- (if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ κ' e2' σ2' efs', prim_step e1 σ1 κ' e2' σ2' efs' →
- σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = efs) →
- ▷ (ownP σ1) ∗ ▷ (ownP σ2 -∗
- Φ v2 ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros (? Hdet) "[Hσ1 Hσ2]"; iApply ownP_lift_atomic_step; try done.
- iFrame; iNext; iIntros (κ' e2' σ2' efs' ?) "Hσ2'".
- edestruct (Hdet κ') as (<-&Hval&<-); first done. rewrite Hval.
- iApply ("Hσ2" with "Hσ2'").
- Qed.
-
- Lemma ownP_lift_atomic_det_step_no_fork {s E e1} σ1 v2 σ2 :
- (if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ κ' e2' σ2' efs', prim_step e1 σ1 κ' e2' σ2' efs' →
- σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = []) →
- {{{ ▷ (ownP σ1) }}} e1 @ s; E {{{ RET v2; ownP σ2 }}}.
- Proof.
- intros. rewrite -(ownP_lift_atomic_det_step σ1 v2 σ2 []); [|done..].
- rewrite big_sepL_nil right_id. apply bi.wand_intro_r. iIntros "[Hs Hs']".
- iSplitL "Hs"; first by iFrame. iModIntro. iIntros "Hσ2". iApply "Hs'". iFrame.
- Qed.
-
- Lemma ownP_lift_pure_det_step_no_fork `{!Inhabited (state Λ)} {s E Φ} e1 e2 :
- (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
- (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- intros. rewrite -(wp_lift_pure_det_step_no_fork e1 e2) //; eauto.
- Qed.
-End lifting.
-
-Section ectx_lifting.
- Import ectx_language.
- Context {Λ : ectxLanguage} `{!ownPG Λ Σ} {Hinh : Inhabited (state Λ)}.
- Implicit Types s : stuckness.
- Implicit Types Φ : val Λ → iProp Σ.
- Implicit Types e : expr Λ.
- Hint Resolve head_prim_reducible head_reducible_prim_step : core.
- Hint Resolve (reducible_not_val _ inhabitant) : core.
- Hint Resolve head_stuck_stuck : core.
-
- Lemma ownP_lift_head_step s E Φ e1 :
- (|={E,∅}=> ∃ σ1, ⌜head_reducible e1 σ1⌠∗ ▷ (ownP σ1) ∗
- ▷ ∀ κ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌠-∗
- ownP σ2
- ={∅,E}=∗ WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros "H". iApply ownP_lift_step.
- iMod "H" as (σ1 ?) "[>Hσ1 Hwp]". iModIntro. iExists σ1. iSplit.
- { destruct s; try by eauto using reducible_not_val. }
- iFrame. iNext. iIntros (κ e2 σ2 efs ?) "Hσ2".
- iApply ("Hwp" with "[] Hσ2"); eauto.
- Qed.
-
- Lemma ownP_lift_head_stuck E Φ e :
- sub_redexes_are_values e →
- (|={E,∅}=> ∃ σ, ⌜head_stuck e σ⌠∗ ▷ (ownP σ))
- ⊢ WP e @ E ?{{ Φ }}.
- Proof.
- iIntros (?) "H". iApply ownP_lift_stuck. iMod "H" as (σ) "[% >Hσ]".
- iExists σ. iModIntro. by auto with iFrame.
- Qed.
-
- Lemma ownP_lift_pure_head_step s E Φ e1 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1) →
- (▷ ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌠→
- WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof using Hinh.
- iIntros (??) "H". iApply ownP_lift_pure_step; eauto.
- { by destruct s; auto. }
- iNext. iIntros (?????). iApply "H"; eauto.
- Qed.
-
- Lemma ownP_lift_atomic_head_step {s E Φ} e1 σ1 :
- head_reducible e1 σ1 →
- ▷ (ownP σ1) ∗ ▷ (∀ κ e2 σ2 efs,
- ⌜head_step e1 σ1 κ e2 σ2 efs⌠-∗ ownP σ2 -∗
- from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros (?) "[Hst H]". iApply ownP_lift_atomic_step; eauto.
- { by destruct s; eauto using reducible_not_val. }
- iSplitL "Hst"; first done.
- iNext. iIntros (???? ?) "Hσ". iApply ("H" with "[] Hσ"); eauto.
- Qed.
-
- Lemma ownP_lift_atomic_det_head_step {s E Φ e1} σ1 v2 σ2 efs :
- head_reducible e1 σ1 →
- (∀ κ' e2' σ2' efs', head_step e1 σ1 κ' e2' σ2' efs' →
- σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = efs) →
- ▷ (ownP σ1) ∗ ▷ (ownP σ2 -∗
- Φ v2 ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
- ⊢ WP e1 @ s; E {{ Φ }}.
- Proof.
- intros Hr Hs.
- destruct s; apply ownP_lift_atomic_det_step; eauto using reducible_not_val;
- intros; eapply Hs; eauto 10.
- Qed.
-
- Lemma ownP_lift_atomic_det_head_step_no_fork {s E e1} σ1 κ v2 σ2 :
- head_reducible e1 σ1 →
- (∀ κ' e2' σ2' efs', head_step e1 σ1 κ' e2' σ2' efs' →
- κ' = κ ∧ σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = []) →
- {{{ ▷ (ownP σ1) }}} e1 @ s; E {{{ RET v2; ownP σ2 }}}.
- Proof.
- intros ???; apply ownP_lift_atomic_det_step_no_fork; last naive_solver.
- by destruct s; eauto using reducible_not_val.
- Qed.
-
- Lemma ownP_lift_pure_det_head_step_no_fork {s E Φ} e1 e2 :
- (∀ σ1, head_reducible e1 σ1) →
- (∀ σ1 κ e2' σ2 efs', head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
- Proof using Hinh.
- iIntros (??) "H"; iApply wp_lift_pure_det_step_no_fork; try by eauto.
- by destruct s; eauto using reducible_not_val.
- Qed.
-End ectx_lifting.
diff --git a/theories/program_logic/refinement/ref_adequacy.v b/theories/program_logic/refinement/ref_adequacy.v
new file mode 100644
index 0000000000000000000000000000000000000000..0a9b9d39175f03e9084bf72dba1ef169c066e5cf
--- /dev/null
+++ b/theories/program_logic/refinement/ref_adequacy.v
@@ -0,0 +1,354 @@
+From iris.program_logic Require Export language.
+From iris.bi Require Export weakestpre fixpoint.
+From iris.proofmode Require Import base tactics classes.
+From iris.algebra Require Import auth list.
+From iris.base_logic Require Export satisfiable gen_heap.
+From iris.base_logic.lib Require Export fancy_updates logical_step.
+From iris.program_logic.refinement Require Export ref_source ref_weakestpre.
+Set Default Proof Using "Type".
+
+
+
+Lemma sn_not_ex_loop {A} `{Classical} (R : relation A) x :
+ ¬ex_loop R x → sn R x.
+Proof.
+ intros Hex. destruct (excluded_middle (sn R x)) as [|Hsn]; [done|].
+ destruct Hex. revert x Hsn. cofix IH; intros x Hsn.
+ destruct (excluded_middle (∃ y, R x y ∧ ¬sn R y)) as [(y&?&?)|Hnot].
+ - exists y; auto.
+ - destruct Hsn. constructor. intros y Hxy.
+ destruct (excluded_middle (sn R y)); naive_solver.
+Qed.
+
+
+Section refinements.
+Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
+Implicit Types s : stuckness.
+Implicit Types P : iProp Σ.
+Implicit Types Φ : val Λ → iProp Σ.
+Implicit Types v : val Λ.
+Implicit Types e : expr Λ.
+Implicit Types a : A.
+Implicit Types b : bool.
+
+(** We first prove that termination is preserverd: if the source is strongly normalising, then also the target is strongly normalising *)
+
+(* With rwp_tp, we lift the essential parts for termination preserving refinement of rwp to thread pools. *)
+Definition rwp_tp_pre (rwp_tp: list (expr Λ) → iProp Σ) (t1: list (expr Λ)) : iProp Σ :=
+ (∀ t2 σ σ' κ a n,
+ ⌜step (t1, σ) κ (t2, σ')âŒ
+ -∗ source_interp a ∗ ref_state_interp σ n
+ ={⊤, ∅}=∗ ∃ b,
+ ▷?b |={∅, ⊤}=> ∃ m,
+ ref_state_interp σ' m
+ ∗ if b then ∃ a', ⌜a ↪⺠a'⌠∗ rwp_tp t2 ∗ source_interp a'
+ else rwp_tp t2 ∗ source_interp a)%I.
+
+(* Not every recursive occurrence is guarded by a later. We obtain a fixpoint of the defintion using a least fixpoint operator.*)
+Definition rwp_tp (t : list (expr Λ)) : iProp Σ := bi_least_fixpoint rwp_tp_pre t.
+
+Lemma rwp_tp_pre_mono (rwp_tp1 rwp_tp2 : list (expr Λ) → iProp Σ) :
+ ⊢ (<pers> (∀ t, rwp_tp1 t -∗ rwp_tp2 t) →
+ ∀ t, rwp_tp_pre rwp_tp1 t -∗ rwp_tp_pre rwp_tp2 t)%I.
+Proof.
+ iIntros "#H"; iIntros (t) "Hwp". rewrite /rwp_tp_pre.
+ iIntros (t2 σ1 σ2 κ a n1) "Hstep Hσ".
+ iMod ("Hwp" with "[$] [$]") as (b) "Hwp".
+ iModIntro. iExists b. iNext. iMod "Hwp". iModIntro.
+ iDestruct "Hwp" as (m) "(Hσ & Hwp)". iExists m. iFrame "Hσ".
+ destruct b; eauto.
+ - iDestruct "Hwp" as (a') "(Hstep & Hgn & Hsrc)".
+ iExists a'. iFrame. by iApply "H".
+ - iDestruct "Hwp" as "(Hgn & $)". by iApply "H".
+Qed.
+
+Local Instance rwp_tp_pre_mono' : BiMonoPred rwp_tp_pre.
+Proof.
+ constructor; first apply rwp_tp_pre_mono.
+ intros wp Hwp n t1 t2 ?%(discrete_iff _ _)%leibniz_equiv; solve_proper.
+Qed.
+
+
+Lemma rwp_tp_unfold t : rwp_tp t ⊣⊢ rwp_tp_pre rwp_tp t.
+Proof. by rewrite /rwp_tp least_fixpoint_unfold. Qed.
+
+Lemma rwp_tp_ind Ψ :
+ ⊢ ((□ ∀ t, rwp_tp_pre (λ t, Ψ t ∧ rwp_tp t) t -∗ Ψ t) → ∀ t, rwp_tp t -∗ Ψ t)%I.
+Proof.
+ iIntros "#IH" (t) "H".
+ assert (NonExpansive Ψ).
+ { by intros n ?? ->%(discrete_iff _ _)%leibniz_equiv. }
+ iApply (least_fixpoint_strong_ind _ Ψ with "[] H").
+ iIntros "!#" (t') "H". by iApply "IH".
+Qed.
+
+Instance rwp_tp_Permutation : Proper ((≡ₚ) ==> (⊢)) rwp_tp.
+Proof.
+ iIntros (t1 t1' Ht) "Ht1". iRevert (t1' Ht); iRevert (t1) "Ht1".
+ iApply rwp_tp_ind; iIntros "!#" (t1) "IH"; iIntros (t1' Ht).
+ rewrite rwp_tp_unfold /rwp_tp_pre. iIntros (t2 σ1 σ2 κ a n Hstep) "Hσ".
+ destruct (step_Permutation t1' t1 t2 κ σ1 σ2) as (t2'&?&?); try done.
+ iMod ("IH" with "[% //] Hσ") as (b) "IH". iModIntro. iExists b. iNext.
+ iMod "IH" as (n2) "(Hσ & IH)".
+ iModIntro. iExists n2. iFrame "Hσ".
+ destruct b.
+ - iDestruct "IH" as (a') "(Hstep & [IH _] & Hsrc)".
+ iExists a'. iFrame. by iApply "IH".
+ - iDestruct "IH" as "([IH _] & $)".
+ by iApply "IH".
+Qed.
+
+Lemma rwp_tp_app t1 t2: rwp_tp t1 -∗ rwp_tp t2 -∗ rwp_tp (t1 ++ t2).
+Proof.
+ iIntros "H1". iRevert (t2). iRevert (t1) "H1".
+ iApply rwp_tp_ind; iIntros "!#" (t1) "IH1". iIntros (t2) "H2".
+ iRevert (t1) "IH1"; iRevert (t2) "H2".
+ iApply rwp_tp_ind; iIntros "!#" (t2) "IH2". iIntros (t1) "IH1".
+ rewrite rwp_tp_unfold {4}/rwp_tp_pre. iIntros (t1'' σ1 σ2 κ a n Hstep) "Hσ1".
+ destruct Hstep as [e1 σ1' e2 σ2' efs' t1' t2' [=Ht ?] ? Hstep]; simplify_eq/=.
+ apply app_eq_inv in Ht as [(t&?&?)|(t&?&?)]; subst.
+ - destruct t as [|e1' ?]; simplify_eq/=.
+ + iMod ("IH2" with "[%] Hσ1") as (b) "IH2".
+ { by eapply step_atomic with (t1:=[]). }
+ iModIntro. iExists b. iNext. iMod "IH2" as (n2) "[Hσ IH2]". iModIntro. iExists n2. iFrame "Hσ".
+ rewrite -{2}(left_id_L [] (++) (e2 :: _)). destruct b.
+ * iDestruct "IH2" as (a' Hsrc) "[[IH2 _] Hsrc]". iExists a'. iFrame "Hsrc".
+ iSplit; first by iPureIntro. iApply "IH2".
+ by rewrite (right_id_L [] (++)).
+ * iDestruct "IH2" as "[[IH2 _] Hsrc]". iFrame "Hsrc". iApply "IH2".
+ by rewrite (right_id_L [] (++)).
+ + iMod ("IH1" with "[%] Hσ1") as (b) "IH1".
+ { by econstructor. }
+ iModIntro. iExists b. iApply (bi.laterN_wand with "[IH2] IH1"). iNext.
+ iIntros "IH1". iMod "IH1" as (n2) "(Hσ & IH1)". iModIntro.
+ iExists n2. iFrame "Hσ".
+ iAssert (rwp_tp t2) with "[IH2]" as "Ht2".
+ { rewrite rwp_tp_unfold. iApply (rwp_tp_pre_mono with "[] IH2").
+ iIntros "!# * [_ ?] //". }
+ destruct b.
+ * iDestruct "IH1" as (a' Hsrc) "[[IH1 _] Hsrc]".
+ iExists a'. iFrame "Hsrc". iSplit; first by iPureIntro.
+ rewrite -assoc_L (comm _ t2) !cons_middle !assoc_L. by iApply "IH1".
+ * iDestruct "IH1" as "[[IH1 _] Hsrc]".
+ iFrame "Hsrc". rewrite -assoc_L (comm _ t2) !cons_middle !assoc_L. by iApply "IH1".
+ - iMod ("IH2" with "[%] Hσ1") as (b) "IH2"; first by econstructor.
+ iModIntro. iExists b. iApply (bi.laterN_wand with "[IH1] IH2"). iNext.
+ iIntros "IH2". iMod "IH2" as (n2) "[Hσ IH2]". iModIntro. iExists n2.
+ iFrame "Hσ". rewrite -assoc_L. destruct b.
+ + iDestruct "IH2" as (a' Hsrc) "[[IH2 _] Hsrc]". iExists a'. iFrame "Hsrc".
+ iSplit; first by iPureIntro. by iApply "IH2".
+ + iDestruct "IH2" as "[[IH2 _] Hsrc]". iFrame "Hsrc". by iApply "IH2".
+Qed.
+
+(* rwp_tp subsumes rwp *)
+Lemma rwp_rwp_tp s Φ e : RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩ -∗ rwp_tp [e].
+Proof.
+ iIntros "He". remember (⊤ : coPset) as E eqn:HE.
+ iRevert (HE). iRevert (e E Φ) "He". iApply rwp_ind.
+ iIntros "!#" (e E Φ). iIntros "IH" (->).
+ rewrite /rwp_pre /rwp_step rwp_tp_unfold /rwp_tp_pre.
+ iIntros (t' σ σ' κ a n Hstep).
+ destruct Hstep as [e1 σ1 e2 σ2 efs [|? t1] t2 ?? Hstep];
+ simplify_eq/=; try discriminate_list.
+ destruct (to_val e1) as [v|] eqn:He1.
+ { apply val_stuck in Hstep; naive_solver. }
+ iIntros "[Ha Hσ]".
+ iMod ("IH" with "[$Ha $Hσ]") as (b) "IH". iModIntro.
+ iExists b. iApply (bi.laterN_wand with "[] IH"). iNext.
+ iIntros "H". iMod "H" as "[_ IH]".
+ iMod ("IH" with "[% //]") as "(Hsrc & Hσ & IH & IHs)".
+ iModIntro. iExists (length efs + n). iFrame "Hσ".
+ iAssert (rwp_tp (e2 :: efs))%I with "[IH IHs]" as "Hrwp_tp".
+ { iApply (rwp_tp_app [_] with "(IH [//])").
+ clear. iInduction efs as [|e efs] "IH"; simpl.
+ { rewrite rwp_tp_unfold /rwp_tp_pre. iIntros (t2 σ1 κ σ2 a n1 Hstep).
+ destruct Hstep; simplify_eq/=; discriminate_list. }
+ iDestruct "IHs" as "[IH' IHfork]".
+ iApply (rwp_tp_app [_] with "(IH' [//])"). by iApply "IH".
+ }
+ destruct b; iFrame.
+Qed.
+
+
+(* We unfold the refinement to a sequence of later operations interleaved with fancy updates. *)
+Definition guarded_pre (grd: (A -d> iProp Σ -d> iProp Σ)) : A -d> iProp Σ -d> iProp Σ :=
+ λ (a: A) (P: iProp Σ),
+ (|={⊤,∅}=> (|={∅,⊤}=> P) ∨ (▷ |={∅,⊤}=> ∃ a', ⌜a ↪⺠a'⌠∗ grd a' P))%I.
+
+Global Instance guarded_pre_contractive: Contractive (guarded_pre).
+Proof.
+ intros α ev1 ev2 Heq. rewrite /guarded_pre; simpl.
+ intros e_S P. do 2 f_equiv. f_contractive. intros ??.
+ do 2 f_equiv. intros e_s'. f_equiv. by apply Heq.
+Qed.
+
+Definition guarded := fixpoint guarded_pre.
+
+Lemma guarded_unfold a P: guarded a P ≡ (|={⊤,∅}=> (|={∅,⊤}=> P) ∨ (â–· |={∅,⊤}=> ∃ a', ⌜a ↪âºa'⌠∗ guarded a' P))%I.
+Proof. unfold guarded. apply (@fixpoint_unfold SI (A -d> iProp Σ -d> iProp Σ) _ guarded_pre _). Qed.
+
+(* Guarded propositions eventually become true, if the source does not allow infinite loops. *)
+Lemma guarded_satisfiable `{LargeIndex SI} a P:
+ sn source_rel a
+ → satisfiable_at ⊤ (guarded a P)
+ → satisfiable_at ⊤ P.
+Proof.
+ intros Hsn % sn_tc. induction Hsn as [a Ha IH]. rewrite guarded_unfold.
+ intros Hsat. apply satisfiable_at_fupd in Hsat.
+ apply satisfiable_at_or in Hsat as [Hsat|Hsat].
+ { by apply satisfiable_at_fupd in Hsat. }
+ apply satisfiable_at_later in Hsat.
+ apply satisfiable_at_fupd in Hsat.
+ apply satisfiable_at_exists in Hsat as [b Hsat]; last apply _.
+ apply satisfiable_at_sep in Hsat as [Hsat1 % satisfiable_at_pure Hsat2].
+ by eapply IH.
+Qed.
+
+
+
+Lemma rwp_tp_guarded_false t:
+ rwp_tp t ⊢ ∀ σ a n, ⌜ex_loop erased_step (t, σ)âŒ
+ -∗ source_interp a
+ -∗ ref_state_interp σ n
+ -∗ guarded a False.
+Proof.
+ iApply (rwp_tp_ind (λ t, ∀ σ a n, ⌜ex_loop erased_step (t, σ)⌠-∗ source_interp a -∗ ref_state_interp σ n -∗ guarded a False)%I with "[]"). clear t.
+ iModIntro. iIntros (t). rewrite /rwp_tp_pre. iIntros "Hrwp_tp". iIntros (σ a n Hloop) "Hsrc Hσ".
+ inversion Hloop as [x [t' σ'] [κ Hstep] Hloop']; subst x; clear Hloop.
+ iSpecialize ("Hrwp_tp" $! t' σ σ' κ a n with "[]"); eauto.
+ iSpecialize ("Hrwp_tp" with "[$Hsrc $Hσ]"). iApply guarded_unfold.
+ iMod "Hrwp_tp" as (b) "Hrwp_tp". destruct b.
+ + iModIntro. iRight. iNext. iMod "Hrwp_tp" as (m) "(Hσ & Hev)".
+ iModIntro. iDestruct "Hev" as (a' Hsrc) "[[Hev _] Hsrc]".
+ iExists a'. iSplit; first by iPureIntro.
+ iApply ("Hev" with "[] Hsrc Hσ"); eauto.
+ + iMod "Hrwp_tp" as (m) "(Hσ & [Hev _] & Ha)".
+ iSpecialize ("Hev" with "[//] Ha Hσ").
+ by rewrite guarded_unfold.
+Qed.
+
+Lemma rwp_adequacy `{LargeIndex SI} Φ a e σ n s:
+ sn source_rel a
+ → ex_loop erased_step ([e], σ)
+ → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩)%I
+ → False.
+Proof.
+ intros Hsn Hloop Hsat. eapply (satisfiable_at_mono _ _ (guarded a False)%I) in Hsat.
+ - apply guarded_satisfiable in Hsat; eauto. by eapply satisfiable_at_pure.
+ - iIntros "(Hsrc & Hσ & Hwp)".
+ iApply (rwp_tp_guarded_false with "[Hwp] [//] Hsrc Hσ").
+ by iApply rwp_rwp_tp.
+Qed.
+
+Lemma rwp_sn_preservation `{Classical} `{LargeIndex SI} Φ a e σ n s:
+ sn source_rel a
+ → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩)%I
+ → sn erased_step ([e], σ).
+Proof.
+ intros Hsn Hsat. eapply sn_not_ex_loop. intros Hloop.
+ eapply rwp_adequacy; eauto.
+Qed.
+
+
+(** the following lemmas are completely independent from the preceding lemmas*)
+(** they provide a general result which can be used to prove that the result of a computation refines a source computation
+ -- however, the concrete shape of this strongly depends on the chosen source and state interpretations *)
+
+(* we are ignoring any threads that are forked off *)
+Lemma rwp_prim_step `{LargeIndex SI} F s κ a n e e' σ σ' Φ efs:
+ prim_step e σ κ e' σ' efs →
+ satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩ ∗ F)%I
+ → ∃ a' m, rtc source_rel a a'
+ ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ RWP e' @ s; ⊤ ⟨⟨ Φ ⟩⟩
+ ∗ ([∗ list] e ∈ efs, RWP e @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩) ∗ F)%I.
+Proof.
+ intros Hstep Hsat.
+ eapply satisfiable_at_mono with (Q := (|={⊤, ∅}=> ▷ |={∅, ⊤}=> ∃ a' m, ⌜rtc source_rel a a'⌠∗ source_interp a' ∗ ref_state_interp σ' m ∗ RWP e' @ s; ⊤ ⟨⟨ Φ ⟩⟩ ∗ ([∗ list] e ∈ efs, RWP e @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩) ∗ F)%I) in Hsat; last first.
+ - rewrite rwp_unfold /rwp_pre /rwp_step.
+ iIntros "(Hsrc & SI & Hwp & F)".
+ erewrite val_stuck; eauto.
+ iMod ("Hwp" $! σ n a with "[$Hsrc $SI]") as ([]) "Hwp"; simpl; iModIntro; iNext; iMod "Hwp" as "[_ Hwp]".
+ + iMod ("Hwp" $! _ _ _ _ Hstep) as "(Hsrc & SI & RWP & Hfork)".
+ iDestruct "Hsrc" as (a' Hsteps) "Hsrc".
+ iModIntro. iExists a', _. iFrame. iPureIntro.
+ by apply tc_rtc.
+ + iMod ("Hwp" $! _ _ _ _ Hstep) as "(Hsrc & SI & RWP & Hfork)".
+ iModIntro. iExists a, _. iFrame. by iPureIntro.
+ - apply satisfiable_at_fupd in Hsat.
+ apply satisfiable_at_later in Hsat.
+ apply satisfiable_at_fupd in Hsat.
+ apply satisfiable_at_exists in Hsat as [a' Hsat]; auto.
+ apply satisfiable_at_exists in Hsat as [m Hsat]; auto.
+ apply satisfiable_at_sep in Hsat as [Hsteps Hsat].
+ apply satisfiable_at_pure in Hsteps.
+ exists a', m. eauto.
+Qed.
+
+
+Definition thread_wps s Φ (es: list (expr Λ)) : iProp Σ :=
+ ([∗ list] i ↦ e ∈ es, if i is 0 then RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩ else RWP e @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)%I.
+
+(* thread lifting *)
+Lemma rwp_erased_step `{LargeIndex SI} s Φ a n ts ts' σ σ':
+ erased_step (ts, σ) (ts', σ')
+ → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ thread_wps s Φ ts)%I
+ → ∃ a' m, rtc source_rel a a'
+ ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ thread_wps s Φ ts')%I.
+Proof.
+ intros [κ Hstep] Hsat. inversion Hstep as [e1 σ1 e2 σ2 efs t1 t2 Heq1 Heq2 Hstep'].
+ injection Heq1 as -> ->. injection Heq2 as -> ->. revert Hsat.
+ destruct t1; simpl in *; rewrite /thread_wps //=.
+ - intros Hsat. eapply rwp_prim_step in Hsat; eauto. rewrite /thread_wps //=.
+ destruct Hsat as (a' & m & Hrtc & Hsat).
+ exists a', m. split; auto.
+ by rewrite big_sepL_app [(([∗ list] y ∈ t2, _) ∗ _)%I]bi.sep_comm.
+ - rewrite big_sepL_app //=.
+ intros Hsat; eapply satisfiable_at_mono with (Q := (_ ∗ _ ∗ _ ∗ _)%I)in Hsat; last first.
+ { iIntros "(Hsrc & SI & Hrwp & Ht1 & He & Ht2)".
+ iSplitL "Hsrc"; first iAssumption.
+ iSplitL "SI"; first iAssumption.
+ iSplitL "He"; first iAssumption.
+ iCombine "Hrwp Ht1 Ht2" as "H"; iAssumption. }
+ eapply rwp_prim_step in Hsat; eauto.
+ destruct Hsat as (a' & m & Hrtc & Hsat).
+ exists a', m. split; auto.
+ eapply satisfiable_at_mono; first apply Hsat.
+ iIntros "($ & $ & He2 & Hefs & $ & Ht1 & Ht2)".
+ rewrite big_sepL_app //= big_sepL_app; iFrame.
+Qed.
+
+
+Lemma rwp_erased_steps `{LargeIndex SI} s Φ a n ts ts' σ σ':
+ rtc erased_step (ts, σ) (ts', σ')
+ → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ thread_wps s Φ ts)%I
+ → ∃ a' m, rtc source_rel a a'
+ ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ thread_wps s Φ ts')%I.
+Proof.
+ intros Hsteps. remember (ts, σ) as c. remember (ts', σ') as c'.
+ revert ts σ Heqc ts' σ' Heqc' n a.
+ induction Hsteps as [|x [ts'' σ''] z Hstep]; intros ts σ Heqc ts' σ' Heqc' n a; subst.
+ - injection Heqc' as -> ->. intros Hsteps. exists a, n; by split.
+ - intros Hsat. eapply rwp_erased_step in Hsat as (a' & m & Hsteps' & Hsat); last eauto.
+ edestruct IHHsteps as (a'' & m' & Hsteps'' & Hsat'); [done|done| |].
+ + apply Hsat.
+ + exists a'', m'; split; eauto. transitivity a'; eauto.
+Qed.
+
+Lemma rwp_result `{LargeIndex SI} Φ ts a n e v σ σ' s:
+ rtc erased_step ([e], σ) (of_val v :: ts, σ')
+ → satisfiable_at ⊤ (source_interp a ∗ ref_state_interp σ n ∗ RWP e @ s; ⊤ ⟨⟨ Φ ⟩⟩)%I
+ → ∃ a' m, rtc source_rel a a'
+ ∧ satisfiable_at ⊤ (source_interp a' ∗ ref_state_interp σ' m ∗ Φ v)%I.
+Proof.
+ intros Hsteps Hsat. eapply rwp_erased_steps in Hsteps; last first.
+ { rewrite /thread_wps //=. eapply satisfiable_at_mono; first apply Hsat.
+ by iIntros "($ & $ & $)". }
+ destruct Hsteps as (a' & m & Hrtc & Hsat'). exists a', m; split; auto.
+ eapply satisfiable_at_fupd, satisfiable_at_mono; first apply Hsat'.
+ iIntros "(Hsrc & Href & Hthread)".
+ rewrite /thread_wps. iDestruct "Hthread" as "[Hthread _]".
+ rewrite rwp_unfold /rwp_pre to_of_val.
+ by iMod ("Hthread" with "[$]") as "($&$&$)".
+Qed.
+
+End refinements.
diff --git a/theories/program_logic/refinement/ref_ectx_lifting.v b/theories/program_logic/refinement/ref_ectx_lifting.v
new file mode 100644
index 0000000000000000000000000000000000000000..d6614261192f68e9d87e8ce990cc4792f63a0289
--- /dev/null
+++ b/theories/program_logic/refinement/ref_ectx_lifting.v
@@ -0,0 +1,201 @@
+(** Some derived lemmas for ectx-based languages *)
+From iris.program_logic Require Export ectx_language.
+
+From iris.program_logic.refinement Require Export ref_weakestpre ref_lifting.
+From iris.proofmode Require Import tactics.
+Set Default Proof Using "Type".
+
+Section rwp.
+Context {SI} {Σ: gFunctors SI} {A} {Λ: ectxLanguage} `{Hsrc: !source Σ A} `{Hiris: !ref_irisG Λ Σ} `{Hexp: Inhabited (expr Λ)} `{Hstate: Inhabited (state Λ)}.
+Implicit Types s : stuckness.
+Implicit Types P Q : iProp Σ.
+Implicit Types a : A.
+Implicit Types b : bool.
+Implicit Types Φ : val Λ → iProp Σ.
+Hint Resolve head_prim_reducible head_reducible_prim_step : core.
+Hint Resolve (reducible_not_val _ inhabitant) : core.
+Hint Resolve head_stuck_stuck : core.
+
+
+(* refinement weakest precondition *)
+Lemma rwp_lift_head_step_fupd {s E Φ} e1 :
+ to_val e1 = None →
+ (∀ σ1 n (a: A), source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
+ ∃ b, ▷? b |={∅}=> ⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
+ (if b then ∃ a' : A, ⌜a ↪⺠a'⌠∗ source_interp a' else source_interp a) ∗
+ ref_state_interp σ2 (length efs + n) ∗
+ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (?) "H". iApply rwp_lift_step_fupd=>//. iIntros (σ1 n a) "Hσ".
+ iMod ("H" with "Hσ") as (b) "H"; iExists b. iModIntro. iNext. iMod "H" as "[% H]". iModIntro.
+ iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs κ ?).
+ iApply "H"; eauto.
+Qed.
+
+Lemma rwp_lift_atomic_head_step_fupd {s E Φ} e1 :
+ to_val e1 = None →
+ (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
+ ∃ b, ▷? b |={E}=> ⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ (if b then ∃ (a': A), ⌜a ↪⺠a'⌠∗ source_interp a' else source_interp a) ∗
+ ref_state_interp σ2 (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (?) "H". iApply rwp_lift_atomic_step_fupd; [done|].
+ iIntros (σ1 Qs a) "H'". iMod ("H" with "H'") as (b) "H'".
+ iModIntro. iExists b. iNext. iMod "H'" as "[% H']". iModIntro.
+ iSplit; first by destruct s; auto. iIntros (e2 σ2 efs κ Hstep).
+ iMod ("H'" with "[]"); eauto.
+Qed.
+
+Lemma rwp_lift_pure_head_step_no_fork s E Φ e1 :
+ (∀ σ1, head_reducible e1 σ1) →
+ (∀ κ σ1 e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
+ (∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌠→ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)%I
+ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
+ intros Hsafe Hstep.
+ iIntros "H". iApply rwp_lift_head_step_fupd; auto.
+ iIntros (σ1 n a) "[Ha Hσ]". iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
+ iModIntro. iExists false. iModIntro; iSplit; auto.
+ iIntros (e2 σ2 efs κ H'). destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
+ iMod "Hclose" as "_". iModIntro.
+ iDestruct ("H" with "[//]") as "H". simpl. iFrame.
+Qed.
+
+Lemma rwp_lift_pure_det_head_step_no_fork {s E Φ} e1 e2 :
+ to_val e1 = None →
+ (∀ σ1, head_reducible e1 σ1) →
+ (∀ σ1 κ e2' σ2 efs',
+ head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
+ (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
+ intros H2 Hstep Hpuredet.
+ iIntros "H". iApply rwp_lift_pure_head_step_no_fork; auto.
+ { naive_solver. }
+ iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
+Qed.
+
+
+(* lemmas for the indexed version *)
+Lemma rswp_lift_head_step_fupd {k s E Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E,∅}=∗
+ |={∅, ∅}▷=>^k ⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_step_fupd=>//. iIntros (σ1 n) "Hσ".
+ iMod ("H" with "Hσ") as "H". iModIntro. iApply (step_fupdN_wand with "H").
+ iIntros "[% H]".
+ iSplit; first by destruct s; eauto.
+ iIntros (e2 σ2 efs κ ?).
+ iApply "H"; eauto.
+Qed.
+
+Lemma rswp_lift_atomic_head_step_fupd {k s E Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
+ |={E,E}▷=>^k ⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_atomic_step_fupd; eauto.
+ iIntros (σ1 Qs) "Hσ1". iMod ("H" with "Hσ1") as "H"; iModIntro.
+ iApply (step_fupdN_wand with "H"); iIntros "[% H]".
+ iSplit; first by destruct s; auto. iIntros (e2 σ2 efs κ Hstep).
+ iApply "H"; eauto.
+Qed.
+
+Lemma rswp_lift_atomic_head_step {k s E Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
+ ▷^k (⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_atomic_head_step_fupd; eauto.
+ iIntros (σ1 Qs) "Hσ1". iMod ("H" with "Hσ1") as "H"; iModIntro.
+ by iApply step_fupdN_intro.
+Qed.
+
+Lemma rswp_lift_atomic_head_step_no_fork_fupd {k s E Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
+ |={E,E}▷=>^k ⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ ⌜efs = []⌠∗ ref_state_interp σ2 n ∗ from_option Φ False (to_val e2))
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_atomic_head_step_fupd; eauto.
+ iIntros (σ1 Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "H"; iModIntro.
+ iApply (step_fupdN_wand with "H"); iIntros "[$ H]" (v2 σ2 efs κ Hstep).
+ iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
+Qed.
+
+Lemma rswp_lift_atomic_head_step_no_fork {k s E Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
+ ▷^k (⌜head_reducible e1 σ1⌠∗
+ ∀ e2 σ2 efs κ, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ ⌜efs = []⌠∗ ref_state_interp σ2 n ∗ from_option Φ False (to_val e2)))
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_atomic_head_step_no_fork_fupd.
+ iIntros (σ1 Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "H"; iModIntro.
+ by iApply step_fupdN_intro.
+Qed.
+
+
+Lemma rswp_lift_pure_head_step_no_fork_fupd k s E Φ e1 :
+ (∀ σ1, head_reducible e1 σ1) →
+ (∀ κ σ1 e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
+ (|={E,E}▷=>^k ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌠→ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)%I
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
+ intros Hsafe Hstep.
+ iIntros "H". iApply rswp_lift_pure_step_no_fork; eauto.
+ iModIntro. iApply (step_fupdN_wand with "H"); iIntros "H" (κ e2 efs σ Hs).
+ iApply "H"; eauto.
+Qed.
+
+Lemma rswp_lift_pure_head_step_no_fork k s E Φ e1 :
+ (∀ σ1, head_reducible e1 σ1) →
+ (∀ κ σ1 e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
+ (▷^k ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌠→ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)%I
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
+ iIntros (Hsafe Hstep) "H". iApply rswp_lift_pure_head_step_no_fork_fupd; eauto.
+ by iApply step_fupdN_intro.
+Qed.
+
+Lemma rswp_lift_pure_det_head_step_no_fork_fupd {k s E Φ} e1 e2 :
+ (∀ σ1, head_reducible e1 σ1) →
+ (∀ σ1 κ e2' σ2 efs',
+ head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
+ (|={E,E}▷=>^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
+ iIntros (Hstep Hdet) "H". iApply rswp_lift_pure_head_step_no_fork_fupd; eauto.
+ { naive_solver. }
+ iApply (step_fupdN_wand with "H"); by iIntros "H" (κ e2' efs σ (_&_&->&->)%Hdet).
+Qed.
+
+Lemma rswp_lift_pure_det_head_step_no_fork {k s E Φ} e1 e2 :
+ (∀ σ1, head_reducible e1 σ1) →
+ (∀ σ1 κ e2' σ2 efs',
+ head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
+ (▷^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof using A Hexp Hiris Hsrc Hstate SI Λ Σ.
+ iIntros (Hsafe Hstep) "H". iApply rswp_lift_pure_det_head_step_no_fork_fupd; eauto.
+ by iApply step_fupdN_intro.
+Qed.
+End rwp.
diff --git a/theories/program_logic/refinement/ref_lifting.v b/theories/program_logic/refinement/ref_lifting.v
new file mode 100644
index 0000000000000000000000000000000000000000..a1b1c4c6ba7012578ab46973b9cfc80b5116ce19
--- /dev/null
+++ b/theories/program_logic/refinement/ref_lifting.v
@@ -0,0 +1,244 @@
+From iris.proofmode Require Import tactics.
+Set Default Proof Using "Type".
+
+From iris.program_logic.refinement Require Export ref_weakestpre.
+(* TODO: move to the right place *)
+Section step_fupdN.
+
+ Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
+
+ Lemma step_fupdN_mask_comm n E1 E2 E3 E4 (P: PROP):
+ E1 ⊆ E2 → E4 ⊆ E3 →
+ ((|={E1, E2}=>|={E2, E3}▷=>^n P) ⊢ |={E1, E4}▷=>^n |={E1, E2}=> P)%I.
+ Proof.
+ iIntros (Hsub1 Hsub2) "H". iInduction n as [|n] "IH"; auto; simpl.
+ iMod "H". iMod "H". iMod (fupd_intro_mask' E3 E4) as "Hclose"; auto.
+ iModIntro. iNext. iMod "Hclose". iMod "H".
+ iMod (fupd_intro_mask' E2 E1) as "Hclose'"; auto.
+ iModIntro. iApply "IH". iMod "Hclose'". by iModIntro.
+ Qed.
+
+ Lemma step_fupdN_mask_comm' n E1 E2 (P: PROP):
+ E2 ⊆ E1 →
+ ((|={E1, E1}▷=>^n |={E1, E2}=> P) ⊢ |={E1, E2}=> |={E2, E2}▷=>^n P)%I.
+ Proof.
+ iIntros (Hsub) "H". iInduction n as [|n] "IH"; auto; simpl.
+ iMod "H". iMod (fupd_intro_mask' E1 E2) as "Hclose"; auto.
+ do 2 iModIntro. iNext. iMod "Hclose". iMod "H". by iApply "IH".
+ Qed.
+
+
+End step_fupdN.
+
+
+Section lifting.
+Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} `{Inhabited (expr Λ)}.
+Implicit Types s : stuckness.
+Implicit Types P Q : iProp Σ.
+Implicit Types Φ : val Λ → iProp Σ.
+Implicit Types v : val Λ.
+Implicit Types e : expr Λ.
+Implicit Types a : A.
+Implicit Types b : bool.
+
+(* refinement weakest precondition *)
+Hint Resolve reducible_no_obs_reducible : core.
+
+Lemma rwp_lift_step_fupd s E Φ e1 :
+ to_val e1 = None →
+ (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
+ ∃ b, ▷? b |={∅}=> (⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗ |={∅,E}=>
+ (if b then ∃ (a': A), ⌜a ↪⺠a'⌠∗ source_interp a' else source_interp a) ∗
+ ref_state_interp σ2 (length efs + n) ∗ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗ [∗ list] i ↦ ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
+ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ by rewrite rwp_unfold /rwp_pre /rwp_step=> ->.
+Qed.
+
+Lemma rwp_lift_atomic_step_fupd {s E Φ} e1 :
+ to_val e1 = None →
+ (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
+ ∃ b, ▷? b |={E}=> ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ (if b then ∃ (a': A), ⌜a ↪⺠a'⌠∗ source_interp a' else source_interp a) ∗
+ ref_state_interp σ2 (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (?) "H".
+ iApply (rwp_lift_step_fupd s E _ e1)=>//; iIntros (σ1 n a) "H'".
+ iMod ("H" $! σ1 with "H'") as (b) "H". iExists b.
+ iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
+ iModIntro. iNext. iMod "Hclose" as "_". iMod "H" as "[$ H]".
+ iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
+ iIntros "!>" (e2 σ2 efs κ ?). iMod "Hclose" as "_".
+ iMod ("H" $! e2 σ2 efs with "[#]") as "($ & $ & H & $)"; [done|].
+ iModIntro.
+ destruct (to_val e2) eqn:?; last by iExFalso.
+ iApply rwp_value; last done. by apply of_to_val.
+Qed.
+
+Lemma rwp_lift_pure_step_no_fork `{!Inhabited (state Λ)} s E Φ e1 :
+ (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
+ (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
+ (∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌠→ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)
+ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (Hsafe Hstep) "H". iApply rwp_lift_step_fupd.
+ { specialize (Hsafe inhabitant). destruct s; eauto using reducible_not_val. }
+ iIntros (σ1 n e_s) "Hσ".
+ iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver.
+ iExists false. iModIntro. iSplit.
+ { iPureIntro. destruct s; done. }
+ iIntros (e2 σ2 efs κ ?).
+ destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
+ iMod "Hclose" as "_". iModIntro.
+ iDestruct ("H" with "[//]") as "H". simpl. iFrame.
+Qed.
+
+Lemma rwp_lift_pure_det_step_no_fork `{!Inhabited (state Λ)} {s E Φ} e1 e2 :
+ (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
+ (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
+ κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
+ (RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (? Hpuredet) "H". iApply (rwp_lift_pure_step_no_fork s E); try done.
+ { naive_solver. }
+ iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
+Qed.
+
+Lemma rwp_pure_step `{!Inhabited (state Λ)} s E e1 e2 φ n Φ :
+ PureExec φ n e1 e2 →
+ φ →
+ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e1 @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
+ iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done.
+ iApply rwp_lift_pure_det_step_no_fork.
+ - intros σ. specialize (Hsafe σ). destruct s; eauto using reducible_not_val.
+ - done.
+ - by iApply "IH".
+Qed.
+
+
+(* step refinement weakest lemmas *)
+Lemma rswp_lift_step_fupd k s E Φ e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E,∅}=∗
+ |={∅,∅}▷=>^k ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ rewrite rswp_unfold /rswp_def /rswp_step. iIntros "H" (σ1 n ?) "(?&Hσ)".
+ iMod ("H" with "Hσ") as "H". iModIntro. iApply (step_fupdN_wand with "H").
+ iIntros "($&H)". iFrame. eauto.
+Qed.
+
+Lemma rswp_lift_step k s E Φ e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E,∅}=∗
+ ▷^k (⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_step_fupd. iIntros (??) "Hσ".
+ iMod ("H" with "Hσ") as "H". iIntros "!>". by iApply step_fupdN_intro.
+Qed.
+
+Lemma rswp_lift_pure_step_no_fork k s E E' Φ e1 :
+ (∀ σ1, s = NotStuck → reducible e1 σ1) →
+ (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
+ (|={E}=>|={E,E'}▷=>^k ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌠→ RWP e2 @ s; E ⟨⟨ Φ ⟩⟩)
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (Hsafe Hstep) "H". iApply rswp_lift_step_fupd.
+ iIntros (σ1 n) "Hσ". iMod "H".
+ iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver.
+ iApply (step_fupdN_wand with "[Hclose H]").
+ { iApply (step_fupdN_mask_comm _ _ E E'); first set_solver; first set_solver.
+ iMod "Hclose". by iModIntro. }
+ iIntros "H". iSplit.
+ { iPureIntro. destruct s; eauto. }
+ iIntros (e2 σ2 efs κ Hstep'). iMod "H"; iModIntro.
+ destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
+ iDestruct ("H" with "[//]") as "H". simpl. iFrame.
+Qed.
+
+Lemma rswp_lift_atomic_step_fupd {k s E1 Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E1}=∗
+ |={E1,E1}▷=>^k ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={E1}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩)
+ ⊢ RSWP e1 at k @ s; E1 ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H".
+ iApply (rswp_lift_step_fupd k s E1 _ e1)=>//; iIntros (σ1 n) "Hσ1".
+ iMod ("H" $! σ1 with "Hσ1") as "H". iApply step_fupdN_mask_comm'; first set_solver.
+ iApply (step_fupdN_wand with "H"); iIntros "[% H]".
+ iMod (fupd_intro_mask' E1 ∅) as "Hclose"; first set_solver.
+ iModIntro; iSplit; auto.
+ iIntros (e2 σ2 efs κ Hstep). iMod "Hclose".
+ iMod ("H" with "[//]") as "($ & H & $)".
+ destruct (to_val e2) eqn:?; last by iExFalso.
+ iApply rwp_value; last done. by apply of_to_val.
+Qed.
+
+Lemma rswp_lift_atomic_step {k s E Φ} e1 :
+ (∀ σ1 n, ref_state_interp σ1 n ={E}=∗
+ ▷^k (⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
+ ref_state_interp σ2 (length efs + n) ∗
+ from_option Φ False (to_val e2) ∗
+ [∗ list] ef ∈ efs, RWP ef @ s; ⊤ ⟨⟨ ref_fork_post ⟩⟩))
+ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply rswp_lift_atomic_step_fupd.
+ iIntros (??) "?". iMod ("H" with "[$]") as "H".
+ iIntros "!>". by iApply step_fupdN_intro; first done.
+Qed.
+
+Lemma rswp_lift_pure_det_step_no_fork {k s E E' Φ} e1 e2 :
+ (∀ σ1, s = NotStuck → reducible e1 σ1) →
+ (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
+ κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
+ (|={E,E'}▷=>^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (? Hpuredet) "H". iApply (rswp_lift_pure_step_no_fork k s E); try done.
+ { naive_solver. }
+ iModIntro. iApply (step_fupdN_wand with "H"); iIntros "H".
+ iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto.
+Qed.
+
+
+(* RSWP lemmas are designed to be used with a single step only. The RSWP returns to RWP after a single step.*)
+Lemma rswp_pure_step_fupd k s E E' e1 e2 φ Φ `{!Inhabited (state Λ)} :
+ PureExec φ 1 e1 e2 →
+ φ →
+ (|={E,E'}▷=>^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
+ inversion Hexec as [|n' ? e1' ? Hstep Hrest]; subst.
+ iApply rswp_lift_pure_det_step_no_fork.
+ - intros σ; intros ->; eauto using pure_step_safe, reducible_no_obs_reducible, reducible_not_val.
+ - eauto using pure_step_det.
+ - inversion Hrest; subst; eauto.
+Qed.
+
+Lemma rswp_pure_step_later `{!Inhabited (state Λ)} k s E e1 e2 φ Φ :
+ PureExec φ 1 e1 e2 →
+ φ →
+ ▷^k RWP e2 @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e1 at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ intros Hexec ?. rewrite -rswp_pure_step_fupd //. iIntros "H".
+ iApply step_fupdN_intro; eauto.
+Qed.
+
+End lifting.
diff --git a/theories/program_logic/refinement/ref_source.v b/theories/program_logic/refinement/ref_source.v
new file mode 100644
index 0000000000000000000000000000000000000000..e269ea4370de3765ea8e37e728fa008e9ddf9c92
--- /dev/null
+++ b/theories/program_logic/refinement/ref_source.v
@@ -0,0 +1,372 @@
+From iris.base_logic.lib Require Export fancy_updates.
+From iris.proofmode Require Import base tactics classes.
+From iris.algebra Require Import excl auth ord_stepindex arithmetic.
+Set Default Proof Using "Type".
+
+Class source {SI: indexT} (Σ: gFunctors SI) (A: Type) := mkSource {
+ source_rel : relation A;
+ source_interp : A → iProp Σ
+}.
+
+Infix "↪" := (source_rel) (at level 60).
+
+(* We use the transitive closure.
+ It's normalization is equivalent to normalization of source_rel. *)
+Infix "↪âº" := (tc source_rel) (at level 60).
+
+Infix "↪⋆" := (rtc source_rel) (at level 60).
+
+Lemma sn_tc {X} (R: X → X → Prop) (x: X): sn R x ↔ sn (tc R) x.
+Proof.
+ split.
+ - induction 1 as [x _ IH]; constructor; simpl; intros y Hy; revert IH; simpl.
+ destruct Hy as [x y Honce|x y z Honce Hsteps]; intros IH; eauto.
+ destruct (IH _ Honce) as [Hy]; eauto.
+ - induction 1 as [z _ IH]; constructor; intros ??; apply IH; simpl in *; eauto using tc_once.
+Qed.
+
+
+
+Section src_update.
+ Context {SI A} {Σ: gFunctors SI} `{!source Σ A} `{!invG Σ}.
+
+ Definition src_update E (P: iProp Σ) : iProp Σ :=
+ (∀ a: A, source_interp a -∗ |={E}=> ∃ b: A, ⌜a ↪⺠b⌠∗ source_interp b ∗ P)%I.
+
+ Definition weak_src_update E (P: iProp Σ) : iProp Σ :=
+ (∀ a: A, source_interp a -∗ |={E}=> ∃ b: A, ⌜a ↪⋆ b⌠∗ source_interp b ∗ P)%I.
+
+ Lemma src_update_bind E P Q: src_update E P ∗ (P -∗ src_update E Q) ⊢ src_update E Q.
+ Proof.
+ rewrite /src_update. iIntros "[P PQ]" (a) "Ha".
+ iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
+ iSpecialize ("PQ" with "P").
+ iMod ("PQ" $! b with "Hb") as (c Hbc) "[Hc Q]".
+ iModIntro. iExists c. iFrame. iPureIntro.
+ by trans b.
+ Qed.
+
+ Lemma src_update_mono_fupd E P Q: src_update E P ∗ (P ={E}=∗ Q) ⊢ src_update E Q.
+ Proof.
+ iIntros "[HP PQ]". iIntros (a) "Hsrc".
+ iMod ("HP" with "Hsrc") as (b Hstep) "[Hsrc P]".
+ iMod ("PQ" with "P"). iFrame. iModIntro.
+ iExists b; by iFrame.
+ Qed.
+
+ Lemma src_update_mono E P Q: src_update E P ∗ (P -∗ Q) ⊢ src_update E Q.
+ Proof.
+ iIntros "[Hupd HPQ]". iApply (src_update_mono_fupd with "[$Hupd HPQ]").
+ iIntros "P". iModIntro. by iApply "HPQ".
+ Qed.
+
+ Lemma fupd_src_update E P : (|={E}=> src_update E P) ⊢ src_update E P.
+ Proof.
+ iIntros "H". rewrite /src_update. iIntros (e) "Hsrc".
+ iMod "H". by iApply "H".
+ Qed.
+
+ Lemma src_update_weak_src_update E P: src_update E P ⊢ weak_src_update E P.
+ Proof.
+ rewrite /src_update /weak_src_update. iIntros "P" (a) "Ha".
+ iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
+ iModIntro. iExists b. iFrame. iPureIntro.
+ by apply tc_rtc.
+ Qed.
+
+ Lemma weak_src_update_return E P: P ⊢ weak_src_update E P.
+ Proof.
+ rewrite /src_update. iIntros "P" (a) "Ha".
+ iModIntro. iExists (a). iFrame. iPureIntro.
+ reflexivity.
+ Qed.
+
+ Lemma weak_src_update_bind_l E P Q: weak_src_update E P ∗ (P -∗ src_update E Q) ⊢ src_update E Q.
+ Proof.
+ rewrite /src_update. iIntros "[P PQ]" (a) "Ha".
+ iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
+ iSpecialize ("PQ" with "P").
+ iMod ("PQ" $! b with "Hb") as (c Hbc) "[Hc Q]".
+ iModIntro. iExists c. iFrame. iPureIntro.
+ by eapply tc_rtc_l.
+ Qed.
+
+ Lemma weak_src_update_bind_r E P Q: src_update E P ∗ (P -∗ weak_src_update E Q) ⊢ src_update E Q.
+ Proof.
+ rewrite /src_update. iIntros "[P PQ]" (a) "Ha".
+ iMod ("P" $! a with "Ha") as (b Hab) "[Hb P]".
+ iSpecialize ("PQ" with "P").
+ iMod ("PQ" $! b with "Hb") as (c Hbc) "[Hc Q]".
+ iModIntro. iExists c. iFrame. iPureIntro.
+ by eapply tc_rtc_r.
+ Qed.
+
+ Lemma weak_src_update_mono_fupd E P Q: weak_src_update E P ∗ (P ={E}=∗ Q) ⊢ weak_src_update E Q.
+ Proof.
+ iIntros "[HP PQ]". iIntros (a) "Hsrc".
+ iMod ("HP" with "Hsrc") as (b Hstep) "[Hsrc P]".
+ iMod ("PQ" with "P"). iFrame. iModIntro.
+ iExists b; by iFrame.
+ Qed.
+
+ Lemma weak_src_update_mono E P Q: weak_src_update E P ∗ (P -∗ Q) ⊢ weak_src_update E Q.
+ Proof.
+ iIntros "[Hupd HPQ]". iApply (weak_src_update_mono_fupd with "[$Hupd HPQ]").
+ iIntros "P". iModIntro. by iApply "HPQ".
+ Qed.
+
+ Lemma fupd_weak_src_update E P : (|={E}=> weak_src_update E P) ⊢ weak_src_update E P.
+ Proof.
+ iIntros "H". rewrite /weak_src_update. iIntros (e) "Hsrc".
+ iMod "H". by iApply "H".
+ Qed.
+
+End src_update.
+
+
+Section auth_source.
+
+ Structure auth_source SI := {
+ auth_sourceUR :> ucmraT SI;
+ auth_source_discrete : CmraDiscrete auth_sourceUR;
+ auth_source_trans : relation auth_sourceUR;
+ auth_source_trans_proper: Proper (equiv ==> equiv ==> iff) auth_source_trans;
+ auth_source_step_frame (a a' f: auth_sourceUR):
+ auth_source_trans a a' → ✓ (a ⋅ f) → ✓ (a' ⋅ f) ∧ auth_source_trans (a ⋅ f) (a' ⋅ f);
+ auth_source_op_cancel (a f f': auth_sourceUR):
+ ✓ (a ⋅ f) → a ⋅ f ≡ a ⋅ f' → f ≡ f'
+ }.
+ Existing Instance auth_source_trans_proper.
+ Existing Instance auth_source_discrete.
+
+ Class auth_sourceG {SI} (Σ: gFunctors SI) (S: auth_source SI) := {
+ sourceG_inG :> inG Σ (authR S);
+ sourceG_name : gname;
+ }.
+
+ Global Instance source_auth_source {SI} (Σ: gFunctors SI) (S: auth_source SI) `{!auth_sourceG Σ S} : source Σ S :=
+ {|
+ source_rel := auth_source_trans _ S;
+ source_interp a := own sourceG_name (â— a)
+ |}.
+
+ Definition srcA {SI} {Σ: gFunctors SI} (S: auth_source SI) `{!auth_sourceG Σ S} (s: S) : iProp Σ := own sourceG_name (◠s).
+ Definition srcF {SI} {Σ: gFunctors SI} (S: auth_source SI) `{!auth_sourceG Σ S} (s: S) : iProp Σ := own sourceG_name (◯ s).
+
+
+ Section auth_updates.
+ Context {SI} {Σ: gFunctors SI} (S: auth_source SI) `{!auth_sourceG Σ S}.
+
+ Lemma source_step_update (E_s e_s e_s': S):
+ ✓ E_s → e_s ≼ E_s → e_s ↪ e_s' → ∃ E_s', (E_s, e_s) ~l~> (E_s', e_s') ∧ E_s ↪ E_s'.
+ Proof.
+ intros Hv Hincl Hstep.
+ destruct Hincl as [e_f Heq]. erewrite Heq in Hv.
+ specialize (auth_source_step_frame _ S _ _ _ Hstep Hv) as [Hv' Hstep'].
+ exists (e_s' â‹… e_f). split; rewrite Heq.
+ - intros α [e_f'|]; simpl; intros ? Heq'; split.
+ + by apply cmra_valid_validN.
+ + f_equiv. eapply discrete_iff; first apply _.
+ eapply discrete_iff in Heq'; last apply _.
+ eapply auth_source_op_cancel; last eauto; eauto.
+ + by apply cmra_valid_validN.
+ + specialize (ucmra_unit_right_id e_s') as H'. rewrite -{2}H'. f_equiv.
+ eapply discrete_iff; first apply _.
+ eapply discrete_iff in Heq'; last apply _.
+ eapply auth_source_op_cancel; first apply Hv.
+ by rewrite ucmra_unit_right_id.
+ - eapply Hstep'.
+ Qed.
+
+ Lemma auth_src_update `{!invG Σ} E s s':
+ s ↪ s' → srcF S s ⊢ src_update E (srcF S s').
+ Proof.
+ intros Hstep. unfold src_update. iIntros "SF" (E_s). iIntros "SA".
+ iCombine "SA SF" as "S".
+ iPoseProof (own_valid_l with "S") as (Hv) "S".
+ apply auth_both_valid in Hv as [Hincl Hv].
+ eapply source_step_update in Hv as [E_s' [Hl Hstep']]; eauto.
+ iMod (own_update _ _ (â— E_s' â‹… â—¯ s') with "S") as "S".
+ - by apply auth_update.
+ - iModIntro. iExists (E_s'); iDestruct "S" as "($ & $)".
+ iPureIntro; eauto using tc_once.
+ Qed.
+
+
+ Lemma srcF_split s t:
+ srcF S (s ⋅ t) ⊣⊢ srcF S s ∗ srcF S t.
+ Proof.
+ rewrite /srcF -own_op auth_frag_op //=.
+ Qed.
+ End auth_updates.
+
+End auth_source.
+
+Class Credit (SI: indexT) := credit_source: auth_source SI.
+Notation "$ a" := (srcF credit_source a) (at level 60).
+Notation "â—$ a" := (srcA credit_source a) (at level 60).
+
+
+(* nat auth source *)
+Section nat_auth_source.
+
+ Context (SI: indexT).
+
+ Lemma nat_source_step_frame (a a' f : natR SI):
+ a' < a → ✓ (a ⋅ f) → ✓ (a' ⋅ f) ∧ (a' ⋅ f) < (a ⋅ f).
+ Proof.
+ intros Hαβ _; split; first done.
+ rewrite !nat_op_plus. lia.
+ Qed.
+
+ Lemma nat_source_op_cancel (a f f' : natR SI):
+ ✓ (a ⋅ f) → a ⋅ f = a ⋅ f' → f = f'.
+ Proof using SI.
+ intros _; rewrite !nat_op_plus. by intros H% Nat.add_cancel_l.
+ Qed.
+
+
+ (* we define an auth structure for ordinals *)
+ Program Canonical Structure natA : auth_source SI := {|
+ auth_sourceUR := natUR SI;
+ auth_source_trans := flip lt;
+ auth_source_discrete := _;
+ auth_source_trans_proper := _;
+ auth_source_step_frame := nat_source_step_frame;
+ auth_source_op_cancel := nat_source_op_cancel
+ |}.
+
+ Lemma nat_srcF_split `{!auth_sourceG Σ natA} (n m: nat):
+ srcF natA (n + m) ⊣⊢ srcF natA n ∗ srcF natA m.
+ Proof. apply srcF_split. Qed.
+
+ Lemma nat_srcF_succ `{!auth_sourceG Σ natA} (n: nat):
+ srcF natA (S n) ⊣⊢ srcF natA 1 ∗ srcF natA n.
+ Proof. rewrite -srcF_split //=. Qed.
+
+ Global Instance nat_credit `{!auth_sourceG Σ natA}: Credit SI := natA.
+
+End nat_auth_source.
+
+(* ord auth source *)
+Section ord_auth_source.
+
+ Context (SI: indexT).
+ Lemma ord_source_step_frame (a a' f : OrdR SI):
+ a' ≺ a → ✓ (a ⋅ f) → ✓ (a' ⋅ f) ∧ (a' ⋅ f) ≺ (a ⋅ f).
+ Proof.
+ intros Hαβ _; split; first done.
+ by eapply natural_addition_strict_compat.
+ Qed.
+
+ Lemma ord_source_op_cancel (a f f' : OrdR SI):
+ ✓ (a ⋅ f) → a ⋅ f = a ⋅ f' → f = f'.
+ Proof using SI.
+ intros _; rewrite comm_L [a â‹… f']comm_L.
+ by apply natural_addition_cancel.
+ Qed.
+
+ (* we define an auth structure for ordinals *)
+ Program Canonical Structure ordA : auth_source SI := {|
+ auth_sourceUR := OrdUR SI;
+ auth_source_trans := flip (index_lt ordI);
+ auth_source_discrete := _;
+ auth_source_trans_proper := _;
+ auth_source_step_frame := ord_source_step_frame;
+ auth_source_op_cancel := ord_source_op_cancel
+ |}.
+
+ Lemma ord_srcF_split `{!auth_sourceG Σ ordA} (n m: Ord):
+ srcF ordA (n ⊕ m) ⊣⊢ srcF ordA n ∗ srcF ordA m.
+ Proof. apply srcF_split. Qed.
+
+ Definition one := succ zero.
+ Lemma ord_srcF_succ `{!auth_sourceG Σ ordA} (n: Ord):
+ srcF ordA (succ n) ⊣⊢ srcF ordA one ∗ srcF ordA n.
+ Proof.
+ rewrite -ord_srcF_split //= natural_addition_succ natural_addition_zero_left_id //=.
+ Qed.
+
+ Global Instance ord_credit `{!auth_sourceG Σ ordA}: Credit SI := ordA.
+
+End ord_auth_source.
+
+Inductive lex {X Y} (R: X → X → Prop) (S: Y → Y → Prop) : (X * Y) → (X * Y) -> Prop :=
+| lex_left x x' y y': R x x' → lex R S (x, y) (x', y')
+| lex_right x y y': S y y' → lex R S (x, y) (x, y').
+
+Lemma sn_lex {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x y: sn R x -> (forall y, sn S y) → sn (lex R S) (x, y).
+Proof.
+ intros Sx Sy. revert y; induction Sx as [x _ IHx]; intros y.
+ induction (Sy y) as [y _ IHy].
+ constructor. intros [x' y']; simpl; inversion 1; subst.
+ - apply IHx; auto.
+ - apply IHy; auto.
+Qed.
+
+Lemma tc_lex_left {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x x' y y': tc R x x' → tc (lex R S) (x, y) (x', y').
+Proof.
+ induction 1 as [x x' Hstep| x x' x'' Hstep Hsteps] in y, y'.
+ - constructor 1. by constructor.
+ - econstructor 2; eauto. by eapply (lex_left _ _ _ _ y y).
+Qed.
+
+Lemma tc_lex_right {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x y y': tc S y y' → tc (lex R S) (x, y) (x, y').
+Proof.
+ induction 1 as [y y' Hstep|y y' y'' Hstep Hsteps].
+ - constructor 1. by constructor.
+ - econstructor 2; eauto. by constructor 2.
+Qed.
+
+Lemma lex_rtc {X Y} (R: X → X → Prop) (S: Y → Y → Prop) x x' y y': rtc (lex R S) (x, y) (x', y') → rtc R x x'.
+Proof.
+ remember (x, y) as p1. remember (x', y') as p2. intros Hrtc.
+ revert x x' y y' Heqp1 Heqp2. induction Hrtc as [p|p1 p2 p3 Hstep Hsteps IH]; intros x x' y y' -> Heq.
+ - injection Heq. by intros -> ->.
+ - subst p3. inversion Hstep; subst.
+ + etransitivity; last by eapply IH.
+ eapply rtc_l; by eauto.
+ + by eapply IH.
+Qed.
+
+
+(* stuttering: we can stutter with any auth source *)
+Section lexicographic.
+
+ Context {SI A B} {Σ: gFunctors SI} `{src1: !source Σ A} `{src2: !source Σ B}.
+
+ Global Instance lex_source : source Σ (A * B) := {|
+ source_rel := lex source_rel source_rel;
+ source_interp := (λ '(a, b), source_interp a ∗ source_interp b)%I;
+ |}.
+
+ Lemma source_update_embed_l_strong `{!invG Σ} E P Q:
+ @src_update _ _ Σ src1 _ E P ∗
+ (∀ b: B, source_interp b ={E}=∗ ∃ b': B, source_interp b' ∗ Q)
+ ⊢ @src_update _ _ Σ lex_source _ E (P ∗ Q).
+ Proof.
+ rewrite /src_update; simpl. iIntros "[H Hupd]".
+ iIntros ([a b]) "[Hs Hsrc]". iMod ("H" with "Hs") as (a' Hstep) "[SI P]".
+ iFrame. iMod ("Hupd" with "Hsrc") as (b') "[Hsrc $]". iModIntro. iExists (a', b'); iFrame.
+ iPureIntro. by apply tc_lex_left.
+ Qed.
+
+ Lemma source_update_embed_l `{!invG Σ} E P:
+ @src_update _ _ Σ src1 _ E P ⊢ @src_update _ _ Σ lex_source _ E P.
+ Proof.
+ iIntros "H". iPoseProof (source_update_embed_l_strong _ _ True%I with "[$H]") as "H".
+ - iIntros (b) "Hsrc". iModIntro. iExists b. iFrame.
+ - iApply src_update_mono; iFrame; iIntros "[$ _]".
+ Qed.
+
+ Lemma source_update_embed_r `{!invG Σ} E P:
+ @src_update _ _ Σ src2 _ E P ⊢ @src_update _ _ Σ lex_source _ E P.
+ Proof.
+ rewrite /src_update; simpl. iIntros "H".
+ iIntros ([a b]) "[Ha Hb]". iMod ("H" with "Hb") as (b' Hstep) "[SI P]".
+ iFrame. iModIntro. iExists (a, b'); iFrame.
+ iPureIntro. by apply tc_lex_right.
+ Qed.
+
+
+End lexicographic.
diff --git a/theories/program_logic/refinement/ref_weakestpre.v b/theories/program_logic/refinement/ref_weakestpre.v
new file mode 100644
index 0000000000000000000000000000000000000000..a04bc2706ecb9efb131748bc189f33e9e6709897
--- /dev/null
+++ b/theories/program_logic/refinement/ref_weakestpre.v
@@ -0,0 +1,691 @@
+From iris.program_logic Require Export language.
+From iris.bi Require Export fixpoint weakestpre.
+From iris.proofmode Require Import base tactics classes.
+From iris.algebra Require Import auth list.
+From iris.base_logic Require Export gen_heap.
+From iris.base_logic.lib Require Export fancy_updates logical_step.
+From iris.program_logic.refinement Require Export ref_source.
+Set Default Proof Using "Type".
+
+From iris.program_logic Require Import weakestpre.
+
+Class ref_irisG (Λ : language) {SI} (Σ : gFunctors SI) := IrisG {
+ ref_iris_invG :> invG Σ;
+ (** The state interpretation is an invariant that should hold in between each
+ step of reduction. Here [Λstate] is the global state and [nat] is the number of forked-off threads
+ (not the total number of threads, which is one higher because there is always
+ a main thread). *)
+ ref_state_interp : state Λ → nat → iProp Σ;
+
+ (** A fixed postcondition for any forked-off thread. For most languages, e.g.
+ heap_lang, this will simply be [True]. However, it is useful if one wants to
+ keep track of resources precisely, as in e.g. Iron. *)
+ ref_fork_post : val Λ → iProp Σ;
+}.
+
+(* we first define the core of the WP for the case that e1 is not a value.
+ Φ is the prop that needs to hold for the expression (and forked-off threads) that we step to. *)
+Definition rwp_step {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} E s (e1: expr Λ) (φ: expr Λ → list (expr Λ) → iProp Σ) : iProp Σ :=
+ (∀ σ1 n (a: A), source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
+ ∃ b, ▷? b |={∅}=> (⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗ |={∅,E}=> (
+ (if b then ∃ (a': A), ⌜a ↪⺠a'⌠∗ source_interp a' else source_interp a) ∗
+ ref_state_interp σ2 (length efs + n) ∗ φ e2 efs)))%I.
+
+(* a "stronger" version: we cannot take a source step, but have to prove that the target
+ can take a step under k laters *)
+Definition rswp_step {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (k: nat) E s (e1: expr Λ) (φ: expr Λ → list (expr Λ) → iProp Σ) : iProp Σ :=
+ (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E,∅}=∗
+ |={∅, ∅}▷=>^k (⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs κ, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗ |={∅,E}=> (
+ source_interp a ∗
+ ref_state_interp σ2 (length efs + n) ∗ φ e2 efs)))%I.
+
+(* pre-definition of rwp of which we will take a fixpoint. *)
+Definition rwp_pre {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (s: stuckness)
+ (rwp : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
+ coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := λ E e1 Φ,
+ match to_val e1 with
+ | Some v => ∀ σ n a, source_interp a ∗ ref_state_interp σ n ={E}=∗ source_interp a ∗ ref_state_interp σ n ∗ Φ v
+ | None => rwp_step E s e1 (λ e2 efs, (rwp E e2 Φ) ∗ [∗ list] i ↦ ef ∈ efs, rwp ⊤ ef ref_fork_post)
+ end%I.
+
+Lemma rwp_pre_mono {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} s (wp1 wp2 : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
+ ⊢ ((□ ∀ E e Φ, wp1 E e Φ -∗ wp2 E e Φ) →
+ ∀ E e Φ, rwp_pre s wp1 E e Φ -∗ rwp_pre s wp2 E e Φ)%I.
+Proof.
+iIntros "#H"; iIntros (E e1 Φ) "Hwp". rewrite /rwp_pre /rwp_step.
+destruct (to_val e1) as [v|]; first done.
+iIntros (σ1 n e_s) "Hσ". iMod ("Hwp" with "Hσ") as (b) "Hwp"; iModIntro.
+iExists b. iApply (bi.laterN_wand with "[] Hwp"). iNext. iIntros "Hwp". iMod "Hwp" as "($ & Hwp)". iModIntro.
+iIntros (e2 σ2 efs κ) "Hstep"; iMod ("Hwp" with "Hstep") as "(Hsrc & Hσ & Hwp & Hfork)".
+iModIntro; iFrame "Hsrc Hσ". iSplitL "Hwp"; first by iApply "H".
+iApply (@big_sepL_impl with "Hfork"); iIntros "!#" (k e _) "Hwp".
+ by iApply "H".
+Qed.
+
+(* Uncurry [rwp_pre] and equip its type with an OFE structure *)
+Definition rwp_pre' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (s : stuckness) :
+(prodO (prodO (leibnizO SI coPset) (exprO SI Λ)) (val Λ -d> iProp Σ) → iProp Σ) →
+prodO (prodO (leibnizO SI coPset) (exprO SI Λ)) (val Λ -d> iProp Σ) → iProp Σ
+:= curry3 ∘ rwp_pre s ∘ uncurry3.
+
+Local Instance rwp_pre_mono' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} s :
+ BiMonoPred (rwp_pre' s).
+Proof.
+constructor.
+- iIntros (wp1 wp2) "#H"; iIntros ([[E e1] Φ]); iRevert (E e1 Φ).
+ iApply rwp_pre_mono. iIntros "!#" (E e Φ). iApply ("H" $! (E,e,Φ)).
+- intros wp Hwp n [[E1 e1] Φ1] [[E2 e2] Φ2]
+ [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=.
+ rewrite /uncurry3 /rwp_pre /rwp_step. do 28 (f_equiv || done).
+ by apply pair_ne.
+Qed.
+
+(* take the least fixpoint of the above definition *)
+Definition rwp_def {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (s : stuckness) (E : coPset)
+ (e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ
+ := bi_least_fixpoint (rwp_pre' s) (E,e,Φ).
+Definition rwp_aux {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : seal (@rwp_def SI Σ A Λ _ _). by eexists. Qed.
+Instance rwp' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : Rwp Λ (iProp Σ) stuckness := rwp_aux.(unseal).
+Definition rwp_eq {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : rwp = @rwp_def SI Σ A Λ _ _ := rwp_aux.(seal_eq).
+
+(* take a rswp_step and afterwards, we prove an rwp *)
+Definition rswp_def {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} (k: nat) (s : stuckness) (E : coPset) (e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ
+ := rswp_step k E s e (λ e2 efs, (rwp s E e2 Φ)
+ ∗ [∗ list] i ↦ ef ∈ efs, rwp s ⊤ ef ref_fork_post)%I.
+Definition rswp_aux {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : seal (@rswp_def SI Σ A Λ _ _). by eexists. Qed.
+Instance rswp' {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : Rswp Λ (iProp Σ) stuckness := rswp_aux.(unseal).
+Definition rswp_eq {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ} : rswp = @rswp_def SI Σ A Λ _ _ := rswp_aux.(seal_eq).
+
+
+
+Section rwp.
+Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
+Implicit Types s : stuckness.
+Implicit Types P : iProp Σ.
+Implicit Types Φ : val Λ → iProp Σ.
+Implicit Types v : val Λ.
+Implicit Types e : expr Λ.
+Implicit Types a : A.
+Implicit Types b : bool.
+
+(* Weakest pre *)
+Lemma rwp_unfold s E e Φ :
+ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊣⊢ rwp_pre s (rwp (PROP:=iProp Σ) s) E e Φ.
+Proof. by rewrite rwp_eq /rwp_def least_fixpoint_unfold. Qed.
+
+
+Lemma rwp_strong_ind s Ψ :
+ (∀ n E e, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ E e))
+ → ⊢ (□ (∀ e E Φ, rwp_pre s (λ E e Φ, Ψ E e Φ ∧ RWP e @ s; E ⟨⟨ Φ ⟩⟩) E e Φ -∗ Ψ E e Φ)
+ → ∀ e E Φ, RWP e @ s; E ⟨⟨ Φ ⟩⟩ -∗ Ψ E e Φ)%I.
+Proof.
+ iIntros (HΨ). iIntros "#IH" (e E Φ) "H". rewrite rwp_eq.
+ set (Ψ' := curry3 Ψ :
+ prodO (prodO (leibnizO SI coPset) (exprO SI Λ)) (val Λ -d> iProp Σ) → iProp Σ).
+ assert (NonExpansive Ψ').
+ { intros n [[E1 e1] Φ1] [[E2 e2] Φ2]
+ [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=. by apply HΨ. }
+ iApply (least_fixpoint_strong_ind _ Ψ' with "[] H").
+ iIntros "!#" ([[??] ?]) "H". by iApply "IH".
+Qed.
+
+Lemma rwp_ind s Ψ :
+ (∀ n E e, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ E e))
+ → ⊢ (□ (∀ e E Φ, rwp_pre s (λ E e Φ, Ψ E e Φ) E e Φ -∗ Ψ E e Φ)
+ → ∀ e E Φ, RWP e @ s; E ⟨⟨ Φ ⟩⟩ -∗ Ψ E e Φ)%I.
+Proof.
+ iIntros (HΨ) "#H". iApply rwp_strong_ind. iIntros "!>" (e E Φ) "Hrwp".
+ iApply "H". iApply (rwp_pre_mono with "[] Hrwp"). clear.
+ iIntros "!>" (E e Φ) "[$ _]".
+Qed.
+
+Global Instance rwp_ne s E e n :
+ Proper (pointwise_relation _ (dist n) ==> dist n) (rwp (PROP:=iProp Σ) s E e).
+Proof.
+ intros Φ1 Φ2 HΦ. rewrite !rwp_eq. by apply (least_fixpoint_ne _), pair_ne, HΦ.
+Qed.
+
+Global Instance rwp_proper s E e :
+ Proper (pointwise_relation _ (≡) ==> (≡)) (rwp (PROP:=iProp Σ) s E e).
+Proof.
+ by intros Φ Φ' ?; apply equiv_dist=>n; apply rwp_ne=>v; apply equiv_dist.
+Qed.
+
+Lemma rwp_value' s E Φ v : Φ v ⊢ RWP of_val v @ s; E ⟨⟨ Φ ⟩⟩.
+Proof. iIntros "HΦ". rewrite rwp_unfold /rwp_pre to_of_val. iIntros (???) "($&$)". auto. Qed.
+(*
+Lemma rwp_value_inv' s E Φ v : RWP of_val v @ s; E ⟨⟨ Φ ⟩⟩ ={E}=∗ Φ v.
+Proof. by rewrite rwp_unfold /rwp_pre to_of_val. Qed.
+*)
+
+
+Lemma rwp_strong_mono' s1 s2 E1 E2 e Φ Ψ :
+ s1 ⊑ s2 → E1 ⊆ E2 →
+ RWP e @ s1; E1 ⟨⟨ Φ ⟩⟩ -∗
+ (∀ σ n a v, source_interp a ∗ ref_state_interp σ n ∗ Φ v ={E2}=∗
+ source_interp a ∗ ref_state_interp σ n ∗ Ψ v) -∗
+ RWP e @ s2; E2 ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros (? HE) "H HΦ". iRevert (E2 Ψ HE) "HΦ"; iRevert (e E1 Φ) "H".
+ iApply rwp_ind; first solve_proper.
+ iIntros "!#" (e E1 Φ) "IH"; iIntros (E2 Ψ HE) "HΦ".
+ rewrite !rwp_unfold /rwp_pre /rwp_step.
+ destruct (to_val e) as [v|] eqn:?.
+ { iIntros (???) "H".
+ iSpecialize ("IH" with "[$]").
+ iMod (fupd_mask_mono with "IH") as "(H1&H2&H)"; auto.
+ by iApply ("HΦ" with "[$]"). }
+ iIntros (σ1 n e_s) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
+ iMod ("IH" with "[$]") as "IH". iModIntro. iDestruct "IH" as (b) "IH". iExists b.
+ iNext. iMod "IH" as "[? IH]"; iModIntro.
+ iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs κ Hstep).
+ iSpecialize ("IH" with "[//]"). iMod "IH". iMod "Hclose" as "_". iModIntro.
+ iDestruct "IH" as "($ & $ & IH & Hefs)". iSplitR "Hefs".
+ - iApply ("IH" with "[//] HΦ").
+ - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
+ iIntros "IH". iApply ("IH" with "[]"); auto.
+Qed.
+
+Lemma rwp_strong_mono s1 s2 E1 E2 e Φ Ψ :
+ s1 ⊑ s2 → E1 ⊆ E2 →
+ RWP e @ s1; E1 ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ RWP e @ s2; E2 ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros (??) "Hrwp H". iApply (rwp_strong_mono' with "[$]"); auto.
+ iIntros (????) "($&$&HΦ)". by iApply "H".
+Qed.
+
+Lemma fupd_rwp s E e Φ : (|={E}=> RWP e @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ rewrite rwp_unfold /rwp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
+ { by iMod "H". }
+ iIntros (σ1 n e_s) "HS". iMod "H". by iApply "H".
+Qed.
+Lemma fupd_rwp' s E e Φ : (∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
+ source_interp a ∗ ref_state_interp σ1 n ∗
+ RWP e @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H".
+ iEval (rewrite rwp_unfold /rwp_pre). destruct (to_val e) as [v|] eqn:Heq.
+ { iIntros. iSpecialize ("H" with "[$]"). rewrite rwp_unfold /rwp_pre Heq.
+ iMod "H" as "(H1&H2&Hwand)". by iMod ("Hwand" with "[$]") as "$". }
+ iIntros (σ1 n e_s) "HS".
+ iSpecialize ("H" with "[$]"). rewrite rwp_unfold /rwp_pre Heq.
+ iMod "H" as "(H1&H2&Hwand)". by iMod ("Hwand" with "[$]") as "$".
+Qed.
+Lemma rwp_fupd s E e Φ : RWP e @ s; E ⟨⟨ v, |={E}=> Φ v ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof. iIntros "H". iApply (rwp_strong_mono s s E with "H"); auto. Qed.
+
+Lemma rwp_fupd' s E e Φ : RWP e @ s; E ⟨⟨ v, ∀ σ1 n a, source_interp a ∗ ref_state_interp σ1 n ={E}=∗
+ source_interp a ∗ ref_state_interp σ1 n ∗ Φ v⟩⟩
+ ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". iApply (rwp_strong_mono' s s E with "H"); auto. iIntros (????) "(?&?&H)".
+ by iMod ("H" with "[$]").
+Qed.
+
+
+(* TODO: We do not need StronglyAtomic for the definition with a single later but for the definition with a logical step. *)
+Lemma rwp_atomic E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
+ (|={E1,E2}=> RWP e @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩) ⊢ RWP e @ s; E1 ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". rewrite !rwp_unfold /rwp_pre.
+ destruct (to_val e) as [v|] eqn:He.
+ { iIntros. iMod ("H"). iMod ("H" with "[$]") as "($&$&$)". }
+ iIntros (σ1 n e_s) "Hσ". iMod "H".
+ iMod ("H" $! σ1 with "Hσ") as "H". iModIntro.
+ iDestruct "H" as (b) "H". iExists b. iNext. iMod "H" as "[$ H]"; iModIntro.
+ iIntros (e2 σ2 efs κ Hstep). iSpecialize ("H" with "[//]"). iMod "H".
+ iDestruct "H" as "(Hsrc & Hσ & H & Hefs)".
+ rewrite rwp_unfold /rwp_pre. destruct (to_val e2) as [v2|] eqn:He2.
+ - rewrite rwp_unfold /rwp_pre He2.
+ destruct b.
+ * iDestruct "Hsrc" as (??) "H'". iMod ("H" with "[$]") as "(Hsrc&$&H)".
+ iFrame. iMod "H". iIntros "!>".
+ iSplitL "Hsrc"; first eauto.
+ iIntros (???) "(?&?) !>". iFrame.
+ * iMod ("H" with "[$]") as "(Hsrc&$&H)".
+ iFrame. iMod "H". iIntros "!>".
+ iIntros (???) "(?&?) !>". iFrame.
+ - specialize (atomic _ _ _ _ _ Hstep) as []; congruence.
+Qed.
+
+Lemma rwp_bind K `{!LanguageCtx K} s E e Φ :
+ RWP e @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩ ⊢ RWP K e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ revert Φ. cut (∀ Φ', RWP e @ s; E ⟨⟨ Φ' ⟩⟩ -∗ ∀ Φ,
+ (∀ v, Φ' v -∗ RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩) -∗ RWP K e @ s; E ⟨⟨ Φ ⟩⟩).
+ { iIntros (help Φ) "H". iApply (help with "H"); auto. }
+ iIntros (Φ') "H". iRevert (e E Φ') "H". iApply rwp_strong_ind; first solve_proper.
+ iIntros "!#" (e E1 Φ') "IH". iIntros (Φ) "HΦ".
+ rewrite /rwp_pre /rwp_step.
+ destruct (to_val e) as [v|] eqn:He.
+ { apply of_to_val in He as <-. iApply fupd_rwp'.
+ iIntros. iMod ("IH" with "[$]") as "($&$&H)".
+ by iApply "HΦ". }
+ rewrite rwp_unfold /rwp_pre /rwp_step fill_not_val //.
+ iIntros (σ1 n a) "H". iMod ("IH" with "H") as "IH". iModIntro.
+ iDestruct "IH" as (b) "IH". iExists b. iNext.
+ iMod "IH" as "[% IH]"; iModIntro. iSplit.
+ { iPureIntro. destruct s; last done.
+ unfold reducible in *. naive_solver eauto using fill_step. }
+ iIntros (e2 σ2 efs κ Hstep).
+ destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
+ iMod ("IH" $! e2' σ2 efs with "[//]") as "($ & $ & IH & IHfork)". iIntros "!>".
+ iSplitL "IH HΦ".
+ - iDestruct "IH" as "[IH _]". by iApply "IH".
+ - by setoid_rewrite bi.and_elim_r.
+Qed.
+
+
+Lemma rwp_bind_inv K `{!LanguageCtx K} s E e Φ :
+ RWP K e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩.
+Proof.
+ iIntros "H". remember (K e) as e' eqn:He'.
+ iRevert (e He'). iRevert (e' E Φ) "H". iApply rwp_strong_ind; first solve_proper.
+ iIntros "!#" (e' E1 Φ) "IH". iIntros (e ->).
+ rewrite !rwp_unfold {2}/rwp_pre.
+ destruct (to_val e) as [v|] eqn:He.
+ { iIntros (???) "($&$)". iModIntro. apply of_to_val in He as <-. rewrite !rwp_unfold.
+ iApply (rwp_pre_mono with "[] IH"). by iIntros "!#" (E e Φ') "[_ ?]". }
+ rewrite /rwp_pre fill_not_val //.
+ iIntros (σ1 κs n) "Hσ". iMod ("IH" with "[$]") as (b) "IH". iModIntro.
+ iExists b. iNext. iMod "IH" as "[% IH]"; iModIntro. iSplit.
+ { destruct s; eauto using reducible_fill. }
+ iIntros (e2 σ2 efs κ Hstep).
+ iMod ("IH" $! (K e2) σ2 efs κ with "[]") as "(Hsrc & Hσ & IH & IHefs)"; eauto using fill_step.
+ iModIntro. iFrame "Hsrc Hσ". iSplitR "IHefs".
+ - iDestruct "IH" as "[IH _]". by iApply "IH".
+ - by setoid_rewrite bi.and_elim_r.
+Qed.
+
+(** * Derived rules *)
+Lemma rwp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros (HΦ) "H"; iApply (rwp_strong_mono with "H"); auto.
+ iIntros (v) "?". by iApply HΦ.
+Qed.
+Lemma rwp_stuck_mono s1 s2 E e Φ :
+ s1 ⊑ s2 → RWP e @ s1; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s2; E ⟨⟨ Φ ⟩⟩.
+Proof. iIntros (?) "H". iApply (rwp_strong_mono with "H"); auto. Qed.
+Lemma rwp_stuck_weaken s E e Φ :
+ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ E ?⟨⟨ Φ ⟩⟩.
+Proof. apply rwp_stuck_mono. by destruct s. Qed.
+Lemma rwp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → RWP e @ s; E1 ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E2 ⟨⟨ Φ ⟩⟩.
+Proof. iIntros (?) "H"; iApply (rwp_strong_mono with "H"); auto. Qed.
+Global Instance rwp_mono' s E e :
+ Proper (pointwise_relation _ (⊢) ==> (⊢)) (rwp (PROP:=iProp Σ) s E e).
+Proof. by intros Φ Φ' ?; apply rwp_mono. Qed.
+
+Lemma rwp_value s E Φ e v : IntoVal e v → Φ v ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof. intros <-. by apply rwp_value'. Qed.
+Lemma rwp_value_fupd' s E Φ v : (|={E}=> Φ v) ⊢ RWP of_val v @ s; E ⟨⟨ Φ ⟩⟩.
+Proof. intros. by rewrite -rwp_fupd -rwp_value'. Qed.
+Lemma rwp_value_fupd s E Φ e v `{!IntoVal e v} :
+ (|={E}=> Φ v) ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof. intros. rewrite -rwp_fupd -rwp_value //. Qed.
+(*
+Lemma rwp_value_inv s E Φ e v : IntoVal e v → RWP e @ s; E ⟨⟨ Φ ⟩⟩ ={E}=∗ Φ v.
+Proof. intros <-. by apply rwp_value_inv'. Qed.
+*)
+
+Lemma rwp_frame_l s E e Φ R : R ∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ v, R ∗ Φ v ⟩⟩.
+Proof. iIntros "[? H]". iApply (rwp_strong_mono with "H"); auto with iFrame. Qed.
+Lemma rwp_frame_r s E e Φ R : RWP e @ s; E ⟨⟨ Φ ⟩⟩ ∗ R ⊢ RWP e @ s; E ⟨⟨ v, Φ v ∗ R ⟩⟩.
+Proof. iIntros "[H ?]". iApply (rwp_strong_mono with "H"); auto with iFrame. Qed.
+
+Lemma rwp_wand s E e Φ Ψ :
+ RWP e @ s; E ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v -∗ Ψ v) -∗ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros "Hwp H". iApply (rwp_strong_mono with "Hwp"); auto.
+ iIntros (?) "?". by iApply "H".
+Qed.
+Lemma rwp_wand_l s E e Φ Ψ :
+ (∀ v, Φ v -∗ Ψ v) ∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof. iIntros "[H Hwp]". iApply (rwp_wand with "Hwp H"). Qed.
+Lemma rwp_wand_r s E e Φ Ψ :
+ RWP e @ s; E ⟨⟨ Φ ⟩⟩ ∗ (∀ v, Φ v -∗ Ψ v) ⊢ RWP e @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof. iIntros "[Hwp H]". iApply (rwp_wand with "Hwp H"). Qed.
+Lemma rwp_frame_wand_l s E e Q Φ :
+ Q ∗ RWP e @ s; E ⟨⟨ v, Q -∗ Φ v ⟩⟩ -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "[HQ HRWP]". iApply (rwp_wand with "HRWP").
+ iIntros (v) "HΦ". by iApply "HΦ".
+Qed.
+
+End rwp.
+
+
+Section rswp.
+Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
+Implicit Types s : stuckness.
+Implicit Types P : iProp Σ.
+Implicit Types Φ : val Λ → iProp Σ.
+Implicit Types v : val Λ.
+Implicit Types e : expr Λ.
+Implicit Types a : A.
+Implicit Types b : bool.
+Implicit Types k : nat.
+
+(* Weakest pre *)
+Lemma rswp_unfold k s E e Φ :
+ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊣⊢ rswp_def k s E e Φ.
+Proof. by rewrite rswp_eq. Qed.
+
+
+Global Instance rswp_ne k s E e n :
+ Proper (pointwise_relation _ (dist n) ==> dist n) (rswp (PROP:=iProp Σ) k s E e).
+Proof.
+ intros Φ1 Φ2 HΦ. rewrite !rswp_eq /rswp_def /rswp_step.
+ do 20 f_equiv. by rewrite HΦ.
+Qed.
+
+Global Instance rswp_proper s E e :
+ Proper (pointwise_relation _ (≡) ==> (≡)) (rwp (PROP:=iProp Σ) s E e).
+Proof.
+ apply _.
+Qed.
+
+Lemma rswp_strong_mono k s1 s2 E1 E2 e Φ Ψ :
+ s1 ⊑ s2 → E1 ⊆ E2 →
+ RSWP e at k @ s1; E1 ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ RSWP e at k @ s2; E2 ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros (? HE); rewrite !rswp_eq /rswp_def /rswp_step.
+ iIntros "H HΦ" (σ1 n a) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
+ iMod ("H" with "[$]") as "H". iModIntro. iApply (step_fupdN_wand with "H").
+ iIntros "[H' H]". iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs κ Hstep).
+ iSpecialize ("H" with "[//]"). iMod "H". iMod "Hclose" as "_". iModIntro.
+ iDestruct "H" as "($ & $ & H & Hefs)". iSplitR "Hefs".
+ - iApply (rwp_strong_mono with "H"); auto.
+ - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k' ef _).
+ iIntros "H"; iApply (rwp_strong_mono with "H"); auto.
+Qed.
+
+
+Lemma fupd_rswp k s E e Φ : (|={E}=> RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) ⊢ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ rewrite rswp_eq /rswp_def /rswp_step. iIntros "H".
+ iIntros (σ1 n a) "HS". iMod "H". by iApply "H".
+Qed.
+Lemma rswp_fupd k s E e Φ : RSWP e at k @ s; E ⟨⟨ v, |={E}=> Φ v ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof. iIntros "H". iApply (rswp_strong_mono k s s E with "H"); auto. Qed.
+
+
+(* do not take a source step, end up with an rswp with no later budget *)
+Lemma rwp_no_step E e s Φ:
+ to_val e = None →
+ (RSWP e at 0 @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
+Proof.
+ rewrite rswp_eq rwp_unfold /rswp_def /rwp_pre /rswp_step /rwp_step.
+ iIntros (He) "Hswp". rewrite He. iIntros (σ1 n a) "[Ha Hσ]".
+ iMod ("Hswp" with "[$]") as "[$ Hswp]". iModIntro.
+ iExists false. iModIntro. iIntros (e2 σ2 efs κ Hstep).
+ by iMod ("Hswp" with "[//]") as "($ & $ & $)".
+Qed.
+
+(* take a source step, end up with an rswp with a budget of one later *)
+Lemma rwp_take_step P E e s Φ:
+ to_val e = None
+ → ⊢ ((P -∗ RSWP e at 1 @ s; E ⟨⟨ Φ ⟩⟩) -∗ src_update E P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
+Proof.
+ rewrite rswp_eq rwp_unfold /rswp_def /rwp_pre /rswp_step /rwp_step.
+ iIntros (He) "Hswp Hsrc". rewrite He. iIntros (σ1 n a) "[Ha Hσ]". rewrite /src_update.
+ iMod ("Hsrc" with "Ha") as (a' Ha) "(Hsource_interp & P)". iMod ("Hswp" with "P [$]") as "Hswp".
+ iMod "Hswp". iModIntro. iExists true. iNext. iMod "Hswp" as "[$ Hswp]"; iModIntro.
+ iIntros (e2 σ2 efs κ Hstep'). iMod ("Hswp" with "[//]") as "(Hsrc & $ & Hrwp & $)".
+ iModIntro; iFrame. iExists a'; iSplit; eauto.
+Qed.
+
+Lemma rwp_weaken' P E e s Φ:
+ to_val e = None
+ → ⊢ ((P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) -∗ weak_src_update E P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
+Proof.
+ rewrite rwp_unfold /rwp_pre /rwp_step.
+ iIntros (He) "Hwp Hsrc". rewrite He. iIntros (σ1 n a) "[Ha Hσ]". rewrite /src_update.
+ iMod ("Hsrc" with "Ha") as (a' Ha) "(Hsource_interp & P)". iMod ("Hwp" with "P [$Hsource_interp $Hσ]") as (b) "Hwp".
+ iModIntro. destruct Ha as [a|].
+ { iExists b. iFrame. }
+ iExists true. destruct b; iNext.
+ - iMod "Hwp" as "[$ Hwp]"; iModIntro.
+ iIntros (e2 σ2 efs κ Hstep'); iMod ("Hwp" with "[//]") as "(Hstep & $ & $)"; iModIntro.
+ iDestruct "Hstep" as (a' Hsteps) "S". iExists a'. iFrame. iPureIntro.
+ eapply tc_l, tc_rtc_l; eauto.
+ - iMod "Hwp" as "[$ Hwp]"; iModIntro.
+ iIntros (e2 σ2 efs κ Hstep'); iMod ("Hwp" with "[//]") as "(Hstep & $ & $)"; iModIntro.
+ iExists z. iFrame. iPureIntro.
+ eapply tc_rtc_r; eauto. by apply tc_once.
+Qed.
+
+Lemma rwp_weaken P E e s Φ:
+ to_val e = None
+ → ⊢ ((P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩) -∗ src_update E P -∗ RWP e @ s; E ⟨⟨ Φ ⟩⟩)%I.
+Proof.
+ intros H. rewrite src_update_weak_src_update. by apply rwp_weaken'.
+Qed.
+
+Lemma rswp_do_step k E e s Φ:
+ ▷ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at (S k) @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ rewrite rswp_eq /rswp_def /rswp_step.
+ iIntros "H". iIntros (σ1 n a) "Hσ". iMod (fupd_intro_mask' _ ∅) as "Hclose"; first set_solver.
+ simpl; do 2 iModIntro. iNext. iSpecialize ("H" with "Hσ"). by iMod "Hclose".
+Qed.
+
+(* TODO: We do not need StronglyAtomic for the definition with a single later but for the definition with a logical step. *)
+Lemma rswp_atomic k E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
+ (|={E1,E2}=> RSWP e at k @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩) ⊢ RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "H". rewrite !rswp_eq /rswp_def /rswp_step.
+ iIntros (σ1 n a) "Hσ". iMod "H".
+ iMod ("H" $! σ1 with "Hσ") as "H". iModIntro.
+ iApply (step_fupdN_wand with "H"); iIntros "[$ H]".
+ iIntros (e2 σ2 efs κ Hstep). iSpecialize ("H" with "[//]"). iMod "H".
+ iDestruct "H" as "(? & Hσ & H & Hefs)".
+ rewrite rwp_unfold /rwp_pre. destruct (to_val e2) as [v2|] eqn:He2.
+ - rewrite rwp_unfold /rwp_pre He2. iDestruct ("H" with "[$]") as ">($&$&>$)". iFrame. eauto.
+ - specialize (atomic _ _ _ _ _ Hstep) as []; congruence.
+Qed.
+
+Lemma rswp_bind K `{!LanguageCtx K} k s E e Φ :
+ to_val e = None →
+ RSWP e at k @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩ ⊢ RSWP K e at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros (He) "H". rewrite !rswp_eq /rswp_def /rswp_step.
+ iIntros (σ1 n a) "Hσ". iMod ("H" with "Hσ") as "H".
+ iModIntro. iApply (step_fupdN_wand with "H").
+ iIntros "[% H]". iSplit.
+ { iPureIntro. destruct s; last done.
+ unfold reducible in *. naive_solver eauto using fill_step. }
+ iIntros (e2 σ2 efs κ Hstep).
+ destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
+ iMod ("H" $! e2' σ2 efs with "[//]") as "($ & $ & H & $)". iIntros "!>".
+ by iApply rwp_bind.
+Qed.
+
+
+Lemma rswp_bind_inv K `{!LanguageCtx K} k s E e Φ :
+ to_val e = None →
+ RSWP K e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ v, RWP K (of_val v) @ s; E ⟨⟨ Φ ⟩⟩ ⟩⟩.
+Proof.
+ iIntros (He) "H". rewrite !rswp_eq /rswp_def /rswp_step.
+ iIntros (σ1 n a) "Hσ". iMod ("H" with "Hσ") as "H".
+ iModIntro. iApply (step_fupdN_wand with "H").
+ iIntros "[% H]". iSplit.
+ { destruct s; eauto using reducible_fill. }
+ iIntros (e2 σ2 efs κ Hstep).
+ iMod ("H" $! (K e2) σ2 efs κ with "[]") as "($ & $ & H & $)"; eauto using fill_step.
+ iModIntro. by iApply rwp_bind_inv.
+Qed.
+
+(** * Derived rules *)
+Lemma rswp_mono k s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros (HΦ) "H". iApply (rswp_strong_mono with "[H] []"); auto.
+ iIntros (v) "?". by iApply HΦ.
+Qed.
+Lemma rswp_stuck_mono k s1 s2 E e Φ :
+ s1 ⊑ s2 → RSWP e at k @ s1; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s2; E ⟨⟨ Φ ⟩⟩.
+Proof. iIntros (?) "H". iApply (rswp_strong_mono with "H"); auto. Qed.
+Lemma rswp_stuck_weaken k s E e Φ :
+ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ E ?⟨⟨ Φ ⟩⟩.
+Proof. apply rswp_stuck_mono. by destruct s. Qed.
+Lemma rswp_mask_mono k s E1 E2 e Φ : E1 ⊆ E2 → RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E2 ⟨⟨ Φ ⟩⟩.
+Proof. iIntros (?) "H"; iApply (rswp_strong_mono with "H"); auto. Qed.
+Global Instance rswp_mono' k s E e :
+ Proper (pointwise_relation _ (⊢) ==> (⊢)) (rswp (PROP:=iProp Σ) k s E e).
+Proof. by intros Φ Φ' ?; apply rswp_mono. Qed.
+
+Lemma rswp_frame_l k s E e Φ R : R ∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ v, R ∗ Φ v ⟩⟩.
+Proof. iIntros "[? H]". iApply (rswp_strong_mono with "H"); auto with iFrame. Qed.
+Lemma rswp_frame_r k s E e Φ R : RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ∗ R ⊢ RSWP e at k @ s; E ⟨⟨ v, Φ v ∗ R ⟩⟩.
+Proof. iIntros "[H ?]". iApply (rswp_strong_mono with "H"); auto with iFrame. Qed.
+
+Lemma rswp_wand k s E e Φ Ψ :
+ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ -∗ (∀ v, Φ v -∗ Ψ v) -∗ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof.
+ iIntros "Hwp H". iApply (rswp_strong_mono with "Hwp"); auto.
+ iIntros (?) "?". by iApply "H".
+Qed.
+Lemma rswp_wand_l k s E e Φ Ψ :
+ (∀ v, Φ v -∗ Ψ v) ∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ⊢ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof. iIntros "[H Hwp]". iApply (rswp_wand with "Hwp H"). Qed.
+Lemma rswp_wand_r k s E e Φ Ψ :
+ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩ ∗ (∀ v, Φ v -∗ Ψ v) ⊢ RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩.
+Proof. iIntros "[Hwp H]". iApply (rswp_wand with "Hwp H"). Qed.
+Lemma rswp_frame_wand_l k s E e Q Φ :
+ Q ∗ RSWP e at k @ s; E ⟨⟨ v, Q -∗ Φ v ⟩⟩ -∗ RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩.
+Proof.
+ iIntros "[HQ HWP]". iApply (rswp_wand with "HWP").
+ iIntros (v) "HΦ". by iApply "HΦ".
+Qed.
+
+End rswp.
+
+
+(** Proofmode class instances *)
+Section proofmode_classes.
+ Context {SI} {Σ: gFunctors SI} {A Λ} `{!source Σ A} `{!ref_irisG Λ Σ}.
+ Implicit Types P Q : iProp Σ.
+ Implicit Types Φ : val Λ → iProp Σ.
+
+ Global Instance frame_rwp p s E e R Φ Ψ :
+ (∀ v, Frame p R (Φ v) (Ψ v)) →
+ Frame p R (RWP e @ s; E ⟨⟨ Φ ⟩⟩) (RWP e @ s; E ⟨⟨ Ψ ⟩⟩).
+ Proof. rewrite /Frame=> HR. rewrite rwp_frame_l. apply rwp_mono, HR. Qed.
+
+ Global Instance frame_rswp k p s E e R Φ Ψ :
+ (∀ v, Frame p R (Φ v) (Ψ v)) →
+ Frame p R (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E ⟨⟨ Ψ ⟩⟩).
+ Proof. rewrite /Frame=> HR. rewrite rswp_frame_l. apply rswp_mono, HR. Qed.
+
+ Global Instance is_except_0_rwp s E e Φ : IsExcept0 (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof. by rewrite /IsExcept0 -{2}fupd_rwp -except_0_fupd -fupd_intro. Qed.
+
+ Global Instance is_except_0_rswp k s E e Φ : IsExcept0 (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof. by rewrite /IsExcept0 -{2}fupd_rswp -except_0_fupd -fupd_intro. Qed.
+
+ Global Instance elim_modal_bupd_rwp p s E e P Φ :
+ ElimModal True p false (|==> P) P (RWP e @ s; E ⟨⟨ Φ ⟩⟩) (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof.
+ by rewrite /ElimModal bi.intuitionistically_if_elim
+ (bupd_fupd E) fupd_frame_r bi.wand_elim_r fupd_rwp.
+ Qed.
+
+ Global Instance elim_modal_bupd_rswp k p s E e P Φ :
+ ElimModal True p false (|==> P) P (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof.
+ by rewrite /ElimModal bi.intuitionistically_if_elim
+ (bupd_fupd E) fupd_frame_r bi.wand_elim_r fupd_rswp.
+ Qed.
+
+ Global Instance elim_modal_fupd_rwp p s E e P Φ :
+ ElimModal True p false (|={E}=> P) P (RWP e @ s; E ⟨⟨ Φ ⟩⟩) (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof.
+ by rewrite /ElimModal bi.intuitionistically_if_elim
+ fupd_frame_r bi.wand_elim_r fupd_rwp.
+ Qed.
+
+ Global Instance elim_modal_fupd_rswp k p s E e P Φ :
+ ElimModal True p false (|={E}=> P) P (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof.
+ by rewrite /ElimModal bi.intuitionistically_if_elim
+ fupd_frame_r bi.wand_elim_r fupd_rswp.
+ Qed.
+
+ Global Instance elim_modal_fupd_rwp_atomic s p E1 E2 e P Φ :
+ Atomic StronglyAtomic e →
+ ElimModal True p false (|={E1,E2}=> P) P
+ (RWP e @ s; E1 ⟨⟨ Φ ⟩⟩) (RWP e @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩)%I.
+ Proof.
+ intros. by rewrite /ElimModal bi.intuitionistically_if_elim
+ fupd_frame_r bi.wand_elim_r rwp_atomic.
+ Qed.
+
+ Global Instance elim_modal_fupd_rswp_atomic k s p E1 E2 e P Φ :
+ Atomic StronglyAtomic e →
+ ElimModal True p false (|={E1,E2}=> P) P
+ (RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩) (RSWP e at k @ s; E2 ⟨⟨ v, |={E2,E1}=> Φ v ⟩⟩)%I.
+ Proof.
+ intros. by rewrite /ElimModal bi.intuitionistically_if_elim
+ fupd_frame_r bi.wand_elim_r rswp_atomic.
+ Qed.
+
+
+ Global Instance add_modal_fupd_rwp s E e P Φ :
+ AddModal (|={E}=> P) P (RWP e @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof. by rewrite /AddModal fupd_frame_r bi.wand_elim_r fupd_rwp. Qed.
+
+ Global Instance add_modal_fupd_rswp k s E e P Φ :
+ AddModal (|={E}=> P) P (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩).
+ Proof. by rewrite /AddModal fupd_frame_r bi.wand_elim_r fupd_rswp. Qed.
+
+
+ Global Instance elim_acc_wp {X} s E1 E2 α β γ e Φ :
+ Atomic StronglyAtomic e →
+ ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
+ α β γ (RWP e @ s; E1 ⟨⟨ Φ ⟩⟩)
+ (λ x, RWP e @ s; E2 ⟨⟨ v, |={E2}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
+ Proof.
+ intros ?. rewrite /ElimAcc.
+ iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
+ iApply (rwp_wand with "(Hinner Hα)").
+ iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
+ Qed.
+
+ Global Instance elim_acc_rswp {X} k s E1 E2 α β γ e Φ :
+ Atomic StronglyAtomic e →
+ ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
+ α β γ (RSWP e at k @ s; E1 ⟨⟨ Φ ⟩⟩)
+ (λ x, RSWP e at k @ s; E2 ⟨⟨ v, |={E2}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
+ Proof.
+ intros ?. rewrite /ElimAcc.
+ iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
+ iApply (rswp_wand with "(Hinner Hα)").
+ iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
+ Qed.
+
+ Global Instance elim_acc_wp_nonatomic {X} E α β γ e s Φ :
+ ElimAcc (X:=X) (fupd E E) (fupd E E)
+ α β γ (RWP e @ s; E ⟨⟨ Φ ⟩⟩)
+ (λ x, RWP e @ s; E ⟨⟨ v, |={E}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
+ Proof.
+ rewrite /ElimAcc.
+ iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
+ iApply rwp_fupd.
+ iApply (rwp_wand with "(Hinner Hα)").
+ iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
+ Qed.
+
+ Global Instance elim_acc_swp_nonatomic {X} k E α β γ e s Φ :
+ ElimAcc (X:=X) (fupd E E) (fupd E E)
+ α β γ (RSWP e at k @ s; E ⟨⟨ Φ ⟩⟩)
+ (λ x, RSWP e at k @ s; E ⟨⟨ v, |={E}=> β x ∗ (γ x -∗? Φ v) ⟩⟩)%I.
+ Proof.
+ rewrite /ElimAcc.
+ iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
+ iApply rswp_fupd.
+ iApply (rswp_wand with "(Hinner Hα)").
+ iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
+ Qed.
+End proofmode_classes.
diff --git a/theories/program_logic/refinement/seq_weakestpre.v b/theories/program_logic/refinement/seq_weakestpre.v
new file mode 100644
index 0000000000000000000000000000000000000000..0b647dea54385f36d56bc15518b411f33a70e03e
--- /dev/null
+++ b/theories/program_logic/refinement/seq_weakestpre.v
@@ -0,0 +1,32 @@
+From iris.proofmode Require Import tactics.
+From iris.base_logic.lib Require Import na_invariants.
+From iris.program_logic.refinement Require Import ref_weakestpre tc_weakestpre.
+Set Default Proof Using "Type".
+
+
+(* sequential reasoning *)
+Class seqG {SI} (Σ: gFunctors SI) := {
+ seqG_na_invG :> na_invG Σ;
+ seqG_name: gname;
+}.
+
+Definition seq {SI A Λ} {Σ: gFunctors SI} `{!source Σ A} `{!ref_irisG Λ Σ} `{!seqG Σ} E (e: expr Λ) Φ : iProp Σ :=
+ (na_own seqG_name E -∗ RWP e ⟨⟨ v, na_own seqG_name E ∗ Φ v ⟩⟩)%I.
+
+Definition se_inv {SI} {Σ: gFunctors SI} `{!invG Σ} `{!seqG Σ} (N: namespace) (P: iProp Σ) := na_inv seqG_name N P.
+
+Notation "'SEQ' e @ E ⟨⟨ v , Q ⟩ ⟩" := (seq E e%E (λ v, Q)) (at level 20, e, Q at level 200,
+format "'[' 'SEQ' e '/' '[ ' @ E ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+Notation "'SEQ' e ⟨⟨ v , Q ⟩ ⟩" := (seq ⊤ e%E (λ v, Q)) (at level 20, e, Q at level 200,
+format "'[' 'SEQ' e '/' '[ ' ⟨⟨ v , Q ⟩ ⟩ ']' ']'") : bi_scope.
+
+Lemma seq_value {SI A Λ} {Σ: gFunctors SI} `{!source Σ A} `{!ref_irisG Λ Σ} `{!seqG Σ} Φ E (v: val Λ) e `{!IntoVal e v}: Φ v ⊢ SEQ e @ E ⟨⟨ v, Φ v⟩⟩.
+Proof.
+ iIntros "Hv Hna". iApply rwp_value. iFrame.
+Qed.
+
+
+Notation "'SEQ' e @ E [{ v , Q } ]" := (@seq _ (ordA _) _ _ _ _ _ E e%E (λ v, Q)) (at level 20, e, Q at level 200,
+format "'[' 'SEQ' e '/' '[ ' @ E [{ v , Q } ] ']' ']'") : bi_scope.
+Notation "'SEQ' e [{ v , Q } ]" := (@seq _ (ordA _) _ _ _ _ _ ⊤ e%E (λ v, Q)) (at level 20, e, Q at level 200,
+format "'[' 'SEQ' e '/' '[ ' [{ v , Q } ] ']' ']'") : bi_scope.
diff --git a/theories/program_logic/refinement/tc_weakestpre.v b/theories/program_logic/refinement/tc_weakestpre.v
new file mode 100644
index 0000000000000000000000000000000000000000..a5f00b1a4b2b9a3ef940c65a866bc4f507e12926
--- /dev/null
+++ b/theories/program_logic/refinement/tc_weakestpre.v
@@ -0,0 +1,103 @@
+From iris.program_logic Require Export language.
+From iris.proofmode Require Import base tactics classes.
+From iris.algebra Require Import auth.
+From iris.algebra.ordinals Require Export ord_stepindex arithmetic.
+From iris.program_logic.refinement Require Import ref_adequacy ref_source ref_weakestpre.
+Set Default Proof Using "Type".
+
+
+(* time credits weakest precondition, using notation of total weakest-pre *)
+Notation tcG Σ := (auth_sourceG Σ (ordA _)).
+
+Global Program Instance tcwp {SI} {Σ: gFunctors SI} `{!tcG Σ} `{!ref_irisG Λ Σ} : Twp Λ (iProp Σ) stuckness := rwp.
+
+Section lemmas.
+ Context {SI} {Σ: gFunctors SI} {Λ} `{!ref_irisG Λ Σ} `{!tcG Σ}.
+
+ Definition one := (succ zero).
+
+ Lemma tc_split α β: $ (α ⊕ β) ≡ ($α ∗ $β)%I.
+ Proof.
+ by rewrite -ord_op_plus /srcF auth_frag_op own_op.
+ Qed.
+
+ Lemma tc_succ α: $ succ α ≡ ($ α ∗ $ one)%I.
+ Proof.
+ by rewrite -tc_split /one natural_addition_comm natural_addition_succ natural_addition_zero_left_id.
+ Qed.
+
+ Lemma tcwp_rwp e E s Φ:
+ twp s E e Φ ≡ rwp s E e Φ.
+ Proof. reflexivity. Qed.
+
+ Lemma tcwp_burn_credit e E s (Φ: val Λ → iProp Σ):
+ to_val e = None →
+ ⊢ ($ one -∗ (▷ RSWP e at 0 @ s; E ⟨⟨ v, Φ v ⟩⟩) -∗ WP e @ s; E [{ v, Φ v }])%I.
+ Proof.
+ iIntros (?) "Hone Hwp". rewrite tcwp_rwp.
+ iApply (rwp_take_step with "[Hwp] [Hone]"); first done.
+ - iIntros "_". iApply rswp_do_step. by iNext.
+ - iApply (@auth_src_update _ _ (ordA SI) with "Hone").
+ eapply succ_greater.
+ Qed.
+
+ Lemma tc_weaken (α β: Ord) e s E Φ:
+ to_val e = None
+ → β ⪯ α
+ → ($β -∗ WP e @ s; E [{ Φ }]) ∗ $ α ⊢ WP e @ s; E [{ Φ }].
+ Proof.
+ intros He [->|]; iIntros "[Hwp Hc]".
+ - by iApply "Hwp".
+ - iApply (rwp_weaken with "[Hwp] [Hc]"); first done.
+ + iExact "Hwp".
+ + by iApply (@auth_src_update _ _ (ordA SI) with "Hc").
+ Qed.
+
+ Lemma tc_alloc_zero s E e Φ: ($ zero -∗ WP e @ s; E [{ Φ }]) ⊢ WP e @ s; E [{ Φ }].
+ Proof.
+ iIntros "H".
+ iMod (@own_unit _ _ _ sourceG_inG sourceG_name) as "Hz".
+ replace (ε: @authR SI (auth_sourceUR SI (ordA SI)))
+ with (â—¯ zero: @authR SI (auth_sourceUR SI (ordA SI))) by reflexivity.
+ by iSpecialize ("H" with "Hz").
+ Qed.
+
+ Global Instance tc_timeless α : Timeless ($ α).
+ Proof. apply _. Qed.
+
+ Global Instance zero_persistent : Persistent ($ zero).
+ Proof.
+ apply own_core_persistent, auth_frag_core_id.
+ replace zero with (core zero) by reflexivity.
+ apply cmra_core_core_id.
+ Qed.
+
+ Global Instance tcwp_elim_wand p e s E Φ Ψ :
+ ElimModal True p false (twp s E e Φ) emp (twp s E e Ψ) (∀ v, Φ v ={E}=∗ Ψ v).
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (bi.intuitionistically_if_elim with "P") as "P".
+ iApply (rwp_strong_mono with "P"); auto. iIntros (v) "HΦ". by iApply ("HPQ" with "[] HΦ").
+ Qed.
+End lemmas.
+
+
+
+(* adequacy lemmas *)
+Lemma tcwp_adequacy {SI} {Σ: gFunctors SI} {Λ} `{!ref_irisG Λ Σ} `{!tcG Σ} `{LargeIndex SI} Φ (e: expr Λ) σ (n: nat) (α: Ord):
+ satisfiable_at ⊤ (â—$ α ∗ ref_state_interp σ n ∗ (WP e [{ v, Φ v}]))%I
+ → ex_loop erased_step ([e], σ)
+ → False.
+Proof.
+ specialize (@rwp_adequacy SI Σ Ord Λ _ _ _ Φ α e σ n NotStuck).
+ simpl; rewrite /srcA. intros Had Hsat Hloop. eapply Had; auto.
+ by apply wf_ord_lt.
+Qed.
+
+(* instantiation with the ordinal index to be sure *)
+Lemma tcwp_adequacy' {Λ} {Σ: gFunctors ordI} `{!ref_irisG Λ Σ} `{!tcG Σ} Φ e (n: nat) σ (α: Ord):
+ satisfiable_at ⊤ (â—$ α ∗ ref_state_interp σ n ∗ (WP e [{ v, Φ v}]))%I
+ → ex_loop erased_step ([e], σ)
+ → False.
+Proof.
+ apply tcwp_adequacy.
+Qed.
diff --git a/theories/program_logic/total_adequacy.v b/theories/program_logic/total_adequacy.v
deleted file mode 100644
index 7d5512c4cd4fb38836bd811af0fd20b2f08e3ef4..0000000000000000000000000000000000000000
--- a/theories/program_logic/total_adequacy.v
+++ /dev/null
@@ -1,131 +0,0 @@
-From iris.program_logic Require Export total_weakestpre adequacy.
-From iris.algebra Require Import gmap auth agree gset coPset list.
-From iris.bi Require Import big_op fixpoint.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-Import uPred.
-
-Section adequacy.
-Context `{!irisG Λ Σ}.
-Implicit Types e : expr Λ.
-
-Definition twptp_pre (twptp : list (expr Λ) → iProp Σ)
- (t1 : list (expr Λ)) : iProp Σ :=
- (∀ t2 σ1 κ κs σ2 n, ⌜step (t1,σ1) κ (t2,σ2)⌠-∗
- state_interp σ1 κs n ={⊤}=∗ ∃ n', ⌜κ = []⌠∗ state_interp σ2 κs n' ∗ twptp t2)%I.
-
-Lemma twptp_pre_mono (twptp1 twptp2 : list (expr Λ) → iProp Σ) :
- (<pers> (∀ t, twptp1 t -∗ twptp2 t) →
- ∀ t, twptp_pre twptp1 t -∗ twptp_pre twptp2 t)%I.
-Proof.
- iIntros "#H"; iIntros (t) "Hwp". rewrite /twptp_pre.
- iIntros (t2 σ1 κ κs σ2 n1) "Hstep Hσ".
- iMod ("Hwp" with "[$] [$]") as (n2) "($ & Hσ & ?)".
- iModIntro. iExists n2. iFrame "Hσ". by iApply "H".
-Qed.
-
-Local Instance twptp_pre_mono' : BiMonoPred twptp_pre.
-Proof.
- constructor; first apply twptp_pre_mono.
- intros wp Hwp n t1 t2 ?%(discrete_iff _ _)%leibniz_equiv; solve_proper.
-Qed.
-
-Definition twptp (t : list (expr Λ)) : iProp Σ :=
- bi_least_fixpoint twptp_pre t.
-
-Lemma twptp_unfold t : twptp t ⊣⊢ twptp_pre twptp t.
-Proof. by rewrite /twptp least_fixpoint_unfold. Qed.
-
-Lemma twptp_ind Ψ :
- ((□ ∀ t, twptp_pre (λ t, Ψ t ∧ twptp t) t -∗ Ψ t) → ∀ t, twptp t -∗ Ψ t)%I.
-Proof.
- iIntros "#IH" (t) "H".
- assert (NonExpansive Ψ).
- { by intros n ?? ->%(discrete_iff _ _)%leibniz_equiv. }
- iApply (least_fixpoint_strong_ind _ Ψ with "[] H").
- iIntros "!#" (t') "H". by iApply "IH".
-Qed.
-
-Instance twptp_Permutation : Proper ((≡ₚ) ==> (⊢)) twptp.
-Proof.
- iIntros (t1 t1' Ht) "Ht1". iRevert (t1' Ht); iRevert (t1) "Ht1".
- iApply twptp_ind; iIntros "!#" (t1) "IH"; iIntros (t1' Ht).
- rewrite twptp_unfold /twptp_pre. iIntros (t2 σ1 κ κs σ2 n Hstep) "Hσ".
- destruct (step_Permutation t1' t1 t2 κ σ1 σ2) as (t2'&?&?); try done.
- iMod ("IH" $! t2' with "[% //] Hσ") as (n2) "($ & Hσ & IH & _)".
- iModIntro. iExists n2. iFrame "Hσ". by iApply "IH".
-Qed.
-
-Lemma twptp_app t1 t2 : twptp t1 -∗ twptp t2 -∗ twptp (t1 ++ t2).
-Proof.
- iIntros "H1". iRevert (t2). iRevert (t1) "H1".
- iApply twptp_ind; iIntros "!#" (t1) "IH1". iIntros (t2) "H2".
- iRevert (t1) "IH1"; iRevert (t2) "H2".
- iApply twptp_ind; iIntros "!#" (t2) "IH2". iIntros (t1) "IH1".
- rewrite twptp_unfold /twptp_pre. iIntros (t1'' σ1 κ κs σ2 n Hstep) "Hσ1".
- destruct Hstep as [e1 σ1' e2 σ2' efs' t1' t2' [=Ht ?] ? Hstep]; simplify_eq/=.
- apply app_eq_inv in Ht as [(t&?&?)|(t&?&?)]; subst.
- - destruct t as [|e1' ?]; simplify_eq/=.
- + iMod ("IH2" with "[%] Hσ1") as (n2) "($ & Hσ & IH2 & _)".
- { by eapply step_atomic with (t1:=[]). }
- iModIntro. iExists n2. iFrame "Hσ".
- rewrite -{2}(left_id_L [] (++) (e2 :: _)). iApply "IH2".
- by setoid_rewrite (right_id_L [] (++)).
- + iMod ("IH1" with "[%] Hσ1") as (n2) "($ & Hσ & IH1 & _)"; first by econstructor.
- iAssert (twptp t2) with "[IH2]" as "Ht2".
- { rewrite twptp_unfold. iApply (twptp_pre_mono with "[] IH2").
- iIntros "!# * [_ ?] //". }
- iModIntro. iExists n2. iFrame "Hσ".
- rewrite -assoc_L (comm _ t2) !cons_middle !assoc_L. by iApply "IH1".
- - iMod ("IH2" with "[%] Hσ1") as (n2) "($ & Hσ & IH2 & _)"; first by econstructor.
- iModIntro. iExists n2. iFrame "Hσ". rewrite -assoc_L. by iApply "IH2".
-Qed.
-
-Lemma twp_twptp s Φ e : WP e @ s; ⊤ [{ Φ }] -∗ twptp [e].
-Proof.
- iIntros "He". remember (⊤ : coPset) as E eqn:HE.
- iRevert (HE). iRevert (e E Φ) "He". iApply twp_ind.
- iIntros "!#" (e E Φ); iIntros "IH" (->).
- rewrite twptp_unfold /twptp_pre /twp_pre. iIntros (t1' σ1' κ κs σ2' n Hstep) "Hσ1".
- destruct Hstep as [e1 σ1 e2 σ2 efs [|? t1] t2 ?? Hstep];
- simplify_eq/=; try discriminate_list.
- destruct (to_val e1) as [v|] eqn:He1.
- { apply val_stuck in Hstep; naive_solver. }
- iMod ("IH" with "Hσ1") as "[_ IH]".
- iMod ("IH" with "[% //]") as "($ & Hσ & [IH _] & IHfork)".
- iModIntro. iExists (length efs + n). iFrame "Hσ".
- iApply (twptp_app [_] with "(IH [//])").
- clear. iInduction efs as [|e efs] "IH"; simpl.
- { rewrite twptp_unfold /twptp_pre. iIntros (t2 σ1 κ κs σ2 n1 Hstep).
- destruct Hstep; simplify_eq/=; discriminate_list. }
- iDestruct "IHfork" as "[[IH' _] IHfork]".
- iApply (twptp_app [_] with "(IH' [//])"). by iApply "IH".
-Qed.
-
-Lemma twptp_total n σ t :
- state_interp σ [] n -∗ twptp t ={⊤}=∗ â–· ⌜sn erased_step (t, σ)âŒ.
-Proof.
- iIntros "Hσ Ht". iRevert (σ n) "Hσ". iRevert (t) "Ht".
- iApply twptp_ind; iIntros "!#" (t) "IH"; iIntros (σ n) "Hσ".
- iApply (pure_mono _ _ (Acc_intro _)). iIntros ([t' σ'] [κ Hstep]).
- rewrite /twptp_pre.
- iMod ("IH" with "[% //] Hσ") as (n' ->) "[Hσ [H _]]".
- by iApply "H".
-Qed.
-End adequacy.
-
-Theorem twp_total Σ Λ `{!invPreG Σ} s e σ Φ :
- (∀ `{Hinv : !invG Σ},
- (|={⊤}=> ∃
- (stateI : state Λ → list (observation Λ) → nat → iProp Σ)
- (fork_post : val Λ → iProp Σ),
- let _ : irisG Λ Σ := IrisG _ _ Hinv stateI fork_post in
- stateI σ [] 0 ∗ WP e @ s; ⊤ [{ Φ }])%I) →
- sn erased_step ([e], σ). (* i.e. ([e], σ) is strongly normalizing *)
-Proof.
- intros Hwp. apply (soundness (M:=iResUR Σ) _ 1); simpl.
- apply (fupd_plain_soundness ⊤ ⊤ _)=> Hinv.
- iMod (Hwp) as (stateI fork_post) "[Hσ H]".
- iApply (@twptp_total _ _ (IrisG _ _ Hinv stateI fork_post) with "Hσ").
- by iApply (@twp_twptp _ _ (IrisG _ _ Hinv stateI fork_post)).
-Qed.
diff --git a/theories/program_logic/total_ectx_lifting.v b/theories/program_logic/total_ectx_lifting.v
deleted file mode 100644
index 3e1168bfcc0d6b725e691b603856dfd91e195fd0..0000000000000000000000000000000000000000
--- a/theories/program_logic/total_ectx_lifting.v
+++ /dev/null
@@ -1,83 +0,0 @@
-(** Some derived lemmas for ectx-based languages *)
-From iris.program_logic Require Export ectx_language.
-From iris.program_logic Require Export total_weakestpre total_lifting.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Section wp.
-Context {Λ : ectxLanguage} `{!irisG Λ Σ} {Hinh : Inhabited (state Λ)}.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Hint Resolve head_prim_reducible_no_obs head_reducible_prim_step
- head_reducible_no_obs_reducible : core.
-
-Lemma twp_lift_head_step {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κs n, state_interp σ1 κs n ={E,∅}=∗
- ⌜head_reducible_no_obs e1 σ1⌠∗
- ∀ κ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
- ⌜κ = []⌠∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E [{ Φ }] ∗
- [∗ list] i ↦ ef ∈ efs, WP ef @ s; ⊤ [{ fork_post }])
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (?) "H".
- iApply (twp_lift_step _ E)=>//. iIntros (σ1 κs n) "Hσ".
- iMod ("H" $! σ1 with "Hσ") as "[% H]"; iModIntro.
- iSplit; [destruct s; auto|]. iIntros (κ e2 σ2 efs Hstep).
- iApply "H". by eauto.
-Qed.
-
-Lemma twp_lift_pure_head_step_no_fork {s E Φ} e1 :
- (∀ σ1, head_reducible_no_obs e1 σ1) →
- (∀ σ1 κ e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (|={E}=> ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌠→ WP e2 @ s; E [{ Φ }] )
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof using Hinh.
- iIntros (??) ">H". iApply twp_lift_pure_step_no_fork; eauto.
- iIntros "!>" (?????). iApply "H"; eauto.
-Qed.
-
-Lemma twp_lift_atomic_head_step {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κs n, state_interp σ1 κs n ={E}=∗
- ⌜head_reducible_no_obs e1 σ1⌠∗
- ∀ κ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
- ⌜κ = []⌠∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ fork_post }])
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (?) "H". iApply twp_lift_atomic_step; eauto.
- iIntros (σ1 κs n) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[% H]"; iModIntro.
- iSplit; first by destruct s; auto. iIntros (κ e2 σ2 efs Hstep). iApply "H"; eauto.
-Qed.
-
-Lemma twp_lift_atomic_head_step_no_fork {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κs n, state_interp σ1 κs n ={E}=∗
- ⌜head_reducible_no_obs e1 σ1⌠∗
- ∀ κ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
- ⌜κ = []⌠∗ ⌜efs = []⌠∗ state_interp σ2 κs n ∗ from_option Φ False (to_val e2))
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (?) "H". iApply twp_lift_atomic_head_step; eauto.
- iIntros (σ1 κs n) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
- iIntros (κ v2 σ2 efs Hstep).
- iMod ("H" with "[# //]") as "(-> & -> & ? & $) /=". by iFrame.
-Qed.
-
-Lemma twp_lift_pure_det_head_step_no_fork {s E Φ} e1 e2 :
- to_val e1 = None →
- (∀ σ1, head_reducible_no_obs e1 σ1) →
- (∀ σ1 κ e2' σ2 efs',
- head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- WP e2 @ s; E [{ Φ }] ⊢ WP e1 @ s; E [{ Φ }].
-Proof using Hinh.
- intros. rewrite -(twp_lift_pure_det_step_no_fork e1 e2); eauto.
-Qed.
-End wp.
diff --git a/theories/program_logic/total_lifting.v b/theories/program_logic/total_lifting.v
deleted file mode 100644
index c2e7a9086c0da1dd55d196e791c494c20c41a5e6..0000000000000000000000000000000000000000
--- a/theories/program_logic/total_lifting.v
+++ /dev/null
@@ -1,89 +0,0 @@
-From iris.program_logic Require Export total_weakestpre.
-From iris.bi Require Export big_op.
-From iris.proofmode Require Import tactics.
-Set Default Proof Using "Type".
-
-Section lifting.
-Context `{!irisG Λ Σ}.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-Implicit Types σ : state Λ.
-Implicit Types P Q : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-
-Hint Resolve reducible_no_obs_reducible : core.
-
-Lemma twp_lift_step s E Φ e1 :
- to_val e1 = None →
- (∀ σ1 κs n, state_interp σ1 κs n ={E,∅}=∗
- ⌜if s is NotStuck then reducible_no_obs e1 σ1 else True⌠∗
- ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
- ⌜κ = []⌠∗
- state_interp σ2 κs (length efs + n) ∗
- WP e2 @ s; E [{ Φ }] ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ fork_post }])
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof. by rewrite twp_unfold /twp_pre=> ->. Qed.
-
-(** Derived lifting lemmas. *)
-Lemma twp_lift_pure_step_no_fork `{!Inhabited (state Λ)} s E Φ e1 :
- (∀ σ1, reducible_no_obs e1 σ1) →
- (∀ σ1 κ e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
- (|={E}=> ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌠→ WP e2 @ s; E [{ Φ }])
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (Hsafe Hstep) ">H". iApply twp_lift_step.
- { eapply reducible_not_val, reducible_no_obs_reducible, (Hsafe inhabitant). }
- iIntros (σ1 κs n) "Hσ".
- iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
- { iPureIntro. destruct s; auto. }
- iIntros (κ e2 σ2 efs ?). destruct (Hstep σ1 κ e2 σ2 efs) as (->&<-&->); auto.
- iMod "Hclose" as "_". iModIntro.
- iDestruct ("H" with "[//]") as "H". simpl. by iFrame.
-Qed.
-
-(* Atomic steps don't need any mask-changing business here, one can
- use the generic lemmas here. *)
-Lemma twp_lift_atomic_step {s E Φ} e1 :
- to_val e1 = None →
- (∀ σ1 κs n, state_interp σ1 κs n ={E}=∗
- ⌜if s is NotStuck then reducible_no_obs e1 σ1 else True⌠∗
- ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={E}=∗
- ⌜κ = []⌠∗
- state_interp σ2 κs (length efs + n) ∗
- from_option Φ False (to_val e2) ∗
- [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ fork_post }])
- ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (?) "H".
- iApply (twp_lift_step _ E _ e1)=>//; iIntros (σ1 κs n) "Hσ1".
- iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
- iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
- iIntros "!>" (κ e2 σ2 efs) "%". iMod "Hclose" as "_".
- iMod ("H" $! κ e2 σ2 efs with "[#]") as "($ & $ & HΦ & $)"; first by eauto.
- destruct (to_val e2) eqn:?; last by iExFalso.
- iApply twp_value; last done. by apply of_to_val.
-Qed.
-
-Lemma twp_lift_pure_det_step_no_fork `{!Inhabited (state Λ)} {s E Φ} e1 e2 :
- (∀ σ1, reducible_no_obs e1 σ1) →
- (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
- κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
- (|={E}=> WP e2 @ s; E [{ Φ }]) ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (? Hpuredet) ">H". iApply (twp_lift_pure_step_no_fork s E); try done.
- { naive_solver. }
- iIntros "!>" (κ' e' efs' σ (_&_&->&->)%Hpuredet); auto.
-Qed.
-
-Lemma twp_pure_step `{!Inhabited (state Λ)} s E e1 e2 φ n Φ :
- PureExec φ n e1 e2 →
- φ →
- WP e2 @ s; E [{ Φ }] ⊢ WP e1 @ s; E [{ Φ }].
-Proof.
- iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
- iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done.
- iApply twp_lift_pure_det_step_no_fork; [done|naive_solver|].
- iModIntro. by iApply "IH".
-Qed.
-End lifting.
diff --git a/theories/program_logic/total_weakestpre.v b/theories/program_logic/total_weakestpre.v
deleted file mode 100644
index 9ab29cf73e84b91398d9090e775206a8a7d20f35..0000000000000000000000000000000000000000
--- a/theories/program_logic/total_weakestpre.v
+++ /dev/null
@@ -1,292 +0,0 @@
-From iris.program_logic Require Export weakestpre.
-From iris.proofmode Require Import tactics.
-From iris.bi Require Import fixpoint big_op.
-Set Default Proof Using "Type".
-Import uPred.
-
-Definition twp_pre `{!irisG Λ Σ} (s : stuckness)
- (wp : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
- coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := λ E e1 Φ,
- match to_val e1 with
- | Some v => |={E}=> Φ v
- | None => ∀ σ1 κs n,
- state_interp σ1 κs n ={E,∅}=∗
- ⌜if s is NotStuck then reducible_no_obs e1 σ1 else True⌠∗
- ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,E}=∗
- ⌜κ = []⌠∗
- state_interp σ2 κs (length efs + n) ∗
- wp E e2 Φ ∗
- [∗ list] ef ∈ efs, wp ⊤ ef fork_post
- end%I.
-
-Lemma twp_pre_mono `{!irisG Λ Σ} s
- (wp1 wp2 : coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ) :
- ((□ ∀ E e Φ, wp1 E e Φ -∗ wp2 E e Φ) →
- ∀ E e Φ, twp_pre s wp1 E e Φ -∗ twp_pre s wp2 E e Φ)%I.
-Proof.
- iIntros "#H"; iIntros (E e1 Φ) "Hwp". rewrite /twp_pre.
- destruct (to_val e1) as [v|]; first done.
- iIntros (σ1 κs n) "Hσ". iMod ("Hwp" with "Hσ") as "($ & Hwp)"; iModIntro.
- iIntros (κ e2 σ2 efs) "Hstep".
- iMod ("Hwp" with "Hstep") as (?) "(Hσ & Hwp & Hfork)".
- iModIntro. iFrame "Hσ". iSplit; first done. iSplitL "Hwp".
- - by iApply "H".
- - iApply (@big_sepL_impl with "Hfork"); iIntros "!#" (k e _) "Hwp".
- by iApply "H".
-Qed.
-
-(* Uncurry [twp_pre] and equip its type with an OFE structure *)
-Definition twp_pre' `{!irisG Λ Σ} (s : stuckness) :
- (prodO (prodO (leibnizO coPset) (exprO Λ)) (val Λ -d> iProp Σ) → iProp Σ) →
- prodO (prodO (leibnizO coPset) (exprO Λ)) (val Λ -d> iProp Σ) → iProp Σ :=
- curry3 ∘ twp_pre s ∘ uncurry3.
-
-Local Instance twp_pre_mono' `{!irisG Λ Σ} s : BiMonoPred (twp_pre' s).
-Proof.
- constructor.
- - iIntros (wp1 wp2) "#H"; iIntros ([[E e1] Φ]); iRevert (E e1 Φ).
- iApply twp_pre_mono. iIntros "!#" (E e Φ). iApply ("H" $! (E,e,Φ)).
- - intros wp Hwp n [[E1 e1] Φ1] [[E2 e2] Φ2]
- [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=.
- rewrite /uncurry3 /twp_pre. do 24 (f_equiv || done). by apply pair_ne.
-Qed.
-
-Definition twp_def `{!irisG Λ Σ} (s : stuckness) (E : coPset)
- (e : expr Λ) (Φ : val Λ → iProp Σ) :
- iProp Σ := bi_least_fixpoint (twp_pre' s) (E,e,Φ).
-Definition twp_aux `{!irisG Λ Σ} : seal (@twp_def Λ Σ _). by eexists. Qed.
-Instance twp' `{!irisG Λ Σ} : Twp Λ (iProp Σ) stuckness := twp_aux.(unseal).
-Definition twp_eq `{!irisG Λ Σ} : twp = @twp_def Λ Σ _ := twp_aux.(seal_eq).
-
-Section twp.
-Context `{!irisG Λ Σ}.
-Implicit Types s : stuckness.
-Implicit Types P : iProp Σ.
-Implicit Types Φ : val Λ → iProp Σ.
-Implicit Types v : val Λ.
-Implicit Types e : expr Λ.
-
-(* Weakest pre *)
-Lemma twp_unfold s E e Φ : WP e @ s; E [{ Φ }] ⊣⊢ twp_pre s (twp s) E e Φ.
-Proof. by rewrite twp_eq /twp_def least_fixpoint_unfold. Qed.
-Lemma twp_ind s Ψ :
- (∀ n E e, Proper (pointwise_relation _ (dist n) ==> dist n) (Ψ E e)) →
- (□ (∀ e E Φ, twp_pre s (λ E e Φ, Ψ E e Φ ∧ WP e @ s; E [{ Φ }]) E e Φ -∗ Ψ E e Φ) →
- ∀ e E Φ, WP e @ s; E [{ Φ }] -∗ Ψ E e Φ)%I.
-Proof.
- iIntros (HΨ). iIntros "#IH" (e E Φ) "H". rewrite twp_eq.
- set (Ψ' := curry3 Ψ :
- prodO (prodO (leibnizO coPset) (exprO Λ)) (val Λ -d> iProp Σ) → iProp Σ).
- assert (NonExpansive Ψ').
- { intros n [[E1 e1] Φ1] [[E2 e2] Φ2]
- [[?%leibniz_equiv ?%leibniz_equiv] ?]; simplify_eq/=. by apply HΨ. }
- iApply (least_fixpoint_strong_ind _ Ψ' with "[] H").
- iIntros "!#" ([[??] ?]) "H". by iApply "IH".
-Qed.
-
-Global Instance twp_ne s E e n :
- Proper (pointwise_relation _ (dist n) ==> dist n) (twp (PROP:=iProp Σ) s E e).
-Proof.
- intros Φ1 Φ2 HΦ. rewrite !twp_eq. by apply (least_fixpoint_ne _), pair_ne, HΦ.
-Qed.
-Global Instance twp_proper s E e :
- Proper (pointwise_relation _ (≡) ==> (≡)) (twp (PROP:=iProp Σ) s E e).
-Proof.
- by intros Φ Φ' ?; apply equiv_dist=>n; apply twp_ne=>v; apply equiv_dist.
-Qed.
-
-Lemma twp_value' s E Φ v : Φ v -∗ WP of_val v @ s; E [{ Φ }].
-Proof. iIntros "HΦ". rewrite twp_unfold /twp_pre to_of_val. auto. Qed.
-Lemma twp_value_inv' s E Φ v : WP of_val v @ s; E [{ Φ }] ={E}=∗ Φ v.
-Proof. by rewrite twp_unfold /twp_pre to_of_val. Qed.
-
-Lemma twp_strong_mono s1 s2 E1 E2 e Φ Ψ :
- s1 ⊑ s2 → E1 ⊆ E2 →
- WP e @ s1; E1 [{ Φ }] -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; E2 [{ Ψ }].
-Proof.
- iIntros (? HE) "H HΦ". iRevert (E2 Ψ HE) "HΦ"; iRevert (e E1 Φ) "H".
- iApply twp_ind; first solve_proper.
- iIntros "!#" (e E1 Φ) "IH"; iIntros (E2 Ψ HE) "HΦ".
- rewrite !twp_unfold /twp_pre. destruct (to_val e) as [v|] eqn:?.
- { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). }
- iIntros (σ1 κs n) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
- iMod ("IH" with "[$]") as "[% IH]".
- iModIntro; iSplit; [by destruct s1, s2|]. iIntros (κ e2 σ2 efs Hstep).
- iMod ("IH" with "[//]") as (?) "(Hσ & IH & IHefs)"; auto.
- iMod "Hclose" as "_"; iModIntro.
- iFrame "Hσ". iSplit; first done. iSplitR "IHefs".
- - iDestruct "IH" as "[IH _]". iApply ("IH" with "[//] HΦ").
- - iApply (big_sepL_impl with "IHefs"); iIntros "!#" (k ef _) "[IH _]".
- iApply "IH"; auto.
-Qed.
-
-Lemma fupd_twp s E e Φ : (|={E}=> WP e @ s; E [{ Φ }]) -∗ WP e @ s; E [{ Φ }].
-Proof.
- rewrite twp_unfold /twp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
- { by iMod "H". }
- iIntros (σ1 κs n) "Hσ1". iMod "H". by iApply "H".
-Qed.
-Lemma twp_fupd s E e Φ : WP e @ s; E [{ v, |={E}=> Φ v }] -∗ WP e @ s; E [{ Φ }].
-Proof. iIntros "H". iApply (twp_strong_mono with "H"); auto. Qed.
-
-Lemma twp_atomic s E1 E2 e Φ `{!Atomic (stuckness_to_atomicity s) e} :
- (|={E1,E2}=> WP e @ s; E2 [{ v, |={E2,E1}=> Φ v }]) -∗ WP e @ s; E1 [{ Φ }].
-Proof.
- iIntros "H". rewrite !twp_unfold /twp_pre /=.
- destruct (to_val e) as [v|] eqn:He.
- { by iDestruct "H" as ">>> $". }
- iIntros (σ1 κs n) "Hσ". iMod "H". iMod ("H" $! σ1 with "Hσ") as "[$ H]".
- iModIntro. iIntros (κ e2 σ2 efs Hstep).
- iMod ("H" with "[//]") as (?) "(Hσ & H & Hefs)". destruct s.
- - rewrite !twp_unfold /twp_pre. destruct (to_val e2) as [v2|] eqn:He2.
- + iDestruct "H" as ">> $". by iFrame.
- + iMod ("H" with "[$]") as "[H _]". iDestruct "H" as %(? & ? & ? & ?).
- by edestruct (atomic _ _ _ _ _ Hstep).
- - destruct (atomic _ _ _ _ _ Hstep) as [v <-%of_to_val].
- iMod (twp_value_inv' with "H") as ">H".
- iModIntro. iSplit; first done. iFrame "Hσ Hefs". by iApply twp_value'.
-Qed.
-
-Lemma twp_bind K `{!LanguageCtx K} s E e Φ :
- WP e @ s; E [{ v, WP K (of_val v) @ s; E [{ Φ }] }] -∗ WP K e @ s; E [{ Φ }].
-Proof.
- revert Φ. cut (∀ Φ', WP e @ s; E [{ Φ' }] -∗ ∀ Φ,
- (∀ v, Φ' v -∗ WP K (of_val v) @ s; E [{ Φ }]) -∗ WP K e @ s; E [{ Φ }]).
- { iIntros (help Φ) "H". iApply (help with "H"); auto. }
- iIntros (Φ') "H". iRevert (e E Φ') "H". iApply twp_ind; first solve_proper.
- iIntros "!#" (e E1 Φ') "IH". iIntros (Φ) "HΦ".
- rewrite /twp_pre. destruct (to_val e) as [v|] eqn:He.
- { apply of_to_val in He as <-. iApply fupd_twp. by iApply "HΦ". }
- rewrite twp_unfold /twp_pre fill_not_val //.
- iIntros (σ1 κs n) "Hσ". iMod ("IH" with "[$]") as "[% IH]". iModIntro; iSplit.
- { iPureIntro. unfold reducible_no_obs in *.
- destruct s; naive_solver eauto using fill_step. }
- iIntros (κ e2 σ2 efs Hstep).
- destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
- iMod ("IH" $! κ e2' σ2 efs with "[//]") as (?) "(Hσ & IH & IHefs)".
- iModIntro. iFrame "Hσ". iSplit; first done. iSplitR "IHefs".
- - iDestruct "IH" as "[IH _]". by iApply "IH".
- - by setoid_rewrite and_elim_r.
-Qed.
-
-Lemma twp_bind_inv K `{!LanguageCtx K} s E e Φ :
- WP K e @ s; E [{ Φ }] -∗ WP e @ s; E [{ v, WP K (of_val v) @ s; E [{ Φ }] }].
-Proof.
- iIntros "H". remember (K e) as e' eqn:He'.
- iRevert (e He'). iRevert (e' E Φ) "H". iApply twp_ind; first solve_proper.
- iIntros "!#" (e' E1 Φ) "IH". iIntros (e ->).
- rewrite !twp_unfold {2}/twp_pre. destruct (to_val e) as [v|] eqn:He.
- { iModIntro. apply of_to_val in He as <-. rewrite !twp_unfold.
- iApply (twp_pre_mono with "[] IH"). by iIntros "!#" (E e Φ') "[_ ?]". }
- rewrite /twp_pre fill_not_val //.
- iIntros (σ1 κs n) "Hσ". iMod ("IH" with "[$]") as "[% IH]". iModIntro; iSplit.
- { destruct s; eauto using reducible_no_obs_fill. }
- iIntros (κ e2 σ2 efs Hstep).
- iMod ("IH" $! κ (K e2) σ2 efs with "[]") as (?) "(Hσ & IH & IHefs)"; eauto using fill_step.
- iModIntro. iFrame "Hσ". iSplit; first done. iSplitR "IHefs".
- - iDestruct "IH" as "[IH _]". by iApply "IH".
- - by setoid_rewrite and_elim_r.
-Qed.
-
-Lemma twp_wp s E e Φ : WP e @ s; E [{ Φ }] -∗ WP e @ s; E {{ Φ }}.
-Proof.
- iIntros "H". iLöb as "IH" forall (E e Φ).
- rewrite wp_unfold twp_unfold /wp_pre /twp_pre. destruct (to_val e) as [v|]=>//.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "Hσ") as "[% H]". iIntros "!>". iSplitR.
- { destruct s; last done. eauto using reducible_no_obs_reducible. }
- iIntros (e2 σ2 efs) "Hstep". iMod ("H" with "Hstep") as (->) "(Hσ & H & Hfork)".
- iApply step_fupd_intro; [set_solver+|]. iNext.
- iFrame "Hσ". iSplitL "H". by iApply "IH".
- iApply (@big_sepL_impl with "Hfork").
- iIntros "!#" (k ef _) "H". by iApply "IH".
-Qed.
-
-(** * Derived rules *)
-Lemma twp_mono s E e Φ Ψ :
- (∀ v, Φ v -∗ Ψ v) → WP e @ s; E [{ Φ }] -∗ WP e @ s; E [{ Ψ }].
-Proof.
- iIntros (HΦ) "H"; iApply (twp_strong_mono with "H"); auto.
- iIntros (v) "?". by iApply HΦ.
-Qed.
-Lemma twp_stuck_mono s1 s2 E e Φ :
- s1 ⊑ s2 → WP e @ s1; E [{ Φ }] ⊢ WP e @ s2; E [{ Φ }].
-Proof. iIntros (?) "H". iApply (twp_strong_mono with "H"); auto. Qed.
-Lemma twp_stuck_weaken s E e Φ :
- WP e @ s; E [{ Φ }] ⊢ WP e @ E ?[{ Φ }].
-Proof. apply twp_stuck_mono. by destruct s. Qed.
-Lemma twp_mask_mono s E1 E2 e Φ :
- E1 ⊆ E2 → WP e @ s; E1 [{ Φ }] -∗ WP e @ s; E2 [{ Φ }].
-Proof. iIntros (?) "H"; iApply (twp_strong_mono with "H"); auto. Qed.
-Global Instance twp_mono' s E e :
- Proper (pointwise_relation _ (⊢) ==> (⊢)) (twp (PROP:=iProp Σ) s E e).
-Proof. by intros Φ Φ' ?; apply twp_mono. Qed.
-
-Lemma twp_value s E Φ e v : IntoVal e v → Φ v -∗ WP e @ s; E [{ Φ }].
-Proof. intros <-. by apply twp_value'. Qed.
-Lemma twp_value_fupd' s E Φ v : (|={E}=> Φ v) -∗ WP of_val v @ s; E [{ Φ }].
-Proof. intros. by rewrite -twp_fupd -twp_value'. Qed.
-Lemma twp_value_fupd s E Φ e v : IntoVal e v → (|={E}=> Φ v) -∗ WP e @ s; E [{ Φ }].
-Proof. intros ?. rewrite -twp_fupd -twp_value //. Qed.
-Lemma twp_value_inv s E Φ e v : IntoVal e v → WP e @ s; E [{ Φ }] ={E}=∗ Φ v.
-Proof. intros <-. by apply twp_value_inv'. Qed.
-
-Lemma twp_frame_l s E e Φ R : R ∗ WP e @ s; E [{ Φ }] -∗ WP e @ s; E [{ v, R ∗ Φ v }].
-Proof. iIntros "[? H]". iApply (twp_strong_mono with "H"); auto with iFrame. Qed.
-Lemma twp_frame_r s E e Φ R : WP e @ s; E [{ Φ }] ∗ R -∗ WP e @ s; E [{ v, Φ v ∗ R }].
-Proof. iIntros "[H ?]". iApply (twp_strong_mono with "H"); auto with iFrame. Qed.
-
-Lemma twp_wand s E e Φ Ψ :
- WP e @ s; E [{ Φ }] -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E [{ Ψ }].
-Proof.
- iIntros "H HΦ". iApply (twp_strong_mono with "H"); auto.
- iIntros (?) "?". by iApply "HΦ".
-Qed.
-Lemma twp_wand_l s E e Φ Ψ :
- (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; E [{ Φ }] -∗ WP e @ s; E [{ Ψ }].
-Proof. iIntros "[H Hwp]". iApply (twp_wand with "Hwp H"). Qed.
-Lemma twp_wand_r s E e Φ Ψ :
- WP e @ s; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E [{ Ψ }].
-Proof. iIntros "[Hwp H]". iApply (twp_wand with "Hwp H"). Qed.
-End twp.
-
-(** Proofmode class instances *)
-Section proofmode_classes.
- Context `{!irisG Λ Σ}.
- Implicit Types P Q : iProp Σ.
- Implicit Types Φ : val Λ → iProp Σ.
-
- Global Instance frame_twp p s E e R Φ Ψ :
- (∀ v, Frame p R (Φ v) (Ψ v)) →
- Frame p R (WP e @ s; E [{ Φ }]) (WP e @ s; E [{ Ψ }]).
- Proof. rewrite /Frame=> HR. rewrite twp_frame_l. apply twp_mono, HR. Qed.
-
- Global Instance is_except_0_wp s E e Φ : IsExcept0 (WP e @ s; E [{ Φ }]).
- Proof. by rewrite /IsExcept0 -{2}fupd_twp -except_0_fupd -fupd_intro. Qed.
-
- Global Instance elim_modal_bupd_twp p s E e P Φ :
- ElimModal True p false (|==> P) P (WP e @ s; E [{ Φ }]) (WP e @ s; E [{ Φ }]).
- Proof.
- by rewrite /ElimModal intuitionistically_if_elim
- (bupd_fupd E) fupd_frame_r wand_elim_r fupd_twp.
- Qed.
-
- Global Instance elim_modal_fupd_twp p s E e P Φ :
- ElimModal True p false (|={E}=> P) P (WP e @ s; E [{ Φ }]) (WP e @ s; E [{ Φ }]).
- Proof.
- by rewrite /ElimModal intuitionistically_if_elim
- fupd_frame_r wand_elim_r fupd_twp.
- Qed.
-
- Global Instance elim_modal_fupd_twp_atomic p s E1 E2 e P Φ :
- Atomic (stuckness_to_atomicity s) e →
- ElimModal True p false (|={E1,E2}=> P) P
- (WP e @ s; E1 [{ Φ }]) (WP e @ s; E2 [{ v, |={E2,E1}=> Φ v }])%I.
- Proof.
- intros. by rewrite /ElimModal intuitionistically_if_elim
- fupd_frame_r wand_elim_r twp_atomic.
- Qed.
-
- Global Instance add_modal_fupd_twp s E e P Φ :
- AddModal (|={E}=> P) P (WP e @ s; E [{ Φ }]).
- Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_twp. Qed.
-End proofmode_classes.
diff --git a/theories/program_logic/weakestpre.v b/theories/program_logic/weakestpre.v
index 134ce595b8ff85757ce4178af75f51eafbff083b..62e59e1d1e152fd80cec552d2b100466a113a3d0 100644
--- a/theories/program_logic/weakestpre.v
+++ b/theories/program_logic/weakestpre.v
@@ -1,11 +1,79 @@
From iris.base_logic.lib Require Export fancy_updates.
+From iris.base_logic.lib Require Export logical_step.
From iris.program_logic Require Export language.
From iris.bi Require Export weakestpre.
From iris.proofmode Require Import base tactics classes.
Set Default Proof Using "Type".
Import uPred.
-Class irisG (Λ : language) (Σ : gFunctors) := IrisG {
+Section eventually.
+
+ Context {SI} {PROP: sbi SI} `{FU: BiFUpd SI PROP}.
+
+
+ Global Instance big_later_elim p (P Q: PROP):
+ ElimModal True p false (⧠P) P (⧠Q) Q.
+ Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iDestruct "P" as (n) "P". iExists n. iNext. by iApply "HPQ".
+ Qed.
+
+ Global Instance plain_big_later `{BP: BiPlainly SI PROP} (P: PROP): Plain P → Plain (⧠P).
+ Proof. apply _. Qed.
+
+ Global Instance plain_big_laterN `{BP: BiPlainly SI PROP} (P: PROP) n: Plain P → Plain (â§^n P).
+ Proof. intros HP. induction n; simpl; apply _. Qed.
+
+ Lemma eventuallyN_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP) n E:
+ Plain P → (<E>_n P) ⊢ |={E}=> ▷^(S n) P.
+ Proof.
+ iIntros (HP) "H". iInduction n as [ | n] "IH".
+ - iMod "H". by iModIntro.
+ - simpl. iSpecialize ("IH" with "H").
+ iMod "IH".
+ iPoseProof (fupd_trans with "IH") as "IH".
+ iPoseProof (fupd_plain_later with "IH") as "IH".
+ iMod "IH". iModIntro.
+ iNext. by iApply except_0_later.
+ Qed.
+
+ Lemma eventually_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP) E:
+ Plain P → (<E> P) ⊢ |={E}=> ⧠P.
+ Proof.
+ intros HP. iIntros "H".
+ unfold eventually. iMod "H". iDestruct "H" as (n) "H".
+ iDestruct (eventuallyN_plain _ with "H") as "H".
+ iMod "H". iModIntro. eauto.
+ Qed.
+
+ Existing Instance elim_eventuallyN.
+ Lemma lstep_fupd_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP):
+ Plain P → ((>={⊤}=={⊤}=> P) ⊢ |={⊤}=> ⧠P)%I.
+ Proof.
+ iIntros (HP) "H".
+ iApply (fupd_plain_mask _ ∅). iMod "H".
+ iApply eventually_plain.
+ iApply eventually_fupd_right.
+ iMod "H" as (n) "H". iApply (eventuallyN_eventually (n)). iMod "H".
+ by iApply (fupd_plain_mask _ ⊤).
+ Qed.
+
+ Lemma lstep_fupdN_plain `{BP: BiPlainly SI PROP} `{@BiFUpdPlainly SI PROP FU BP} (P : PROP) n:
+ Plain P → ((>={⊤}=={⊤}=>^n P) ⊢ |={⊤}=> â§^n P)%I.
+ Proof.
+ intros HP. iIntros "H". iInduction n as [|n] "IH"; simpl.
+ - by iModIntro.
+ - iAssert (>={⊤}=={⊤}=> â§^n P)%I with "[H]" as "H".
+ { do 2 iMod "H". iModIntro. iDestruct "H" as (n') "H".
+ iApply (eventuallyN_eventually (n' )). iMod "H".
+ iMod "H". by iSpecialize ("IH" with "H").
+ }
+ iApply (lstep_fupd_plain with "H").
+ Qed.
+End eventually.
+
+
+Class irisG (Λ : language) {SI} (Σ : gFunctors SI) := IrisG {
iris_invG :> invG Σ;
(** The state interpretation is an invariant that should hold in between each
@@ -22,34 +90,48 @@ Class irisG (Λ : language) (Σ : gFunctors) := IrisG {
}.
Global Opaque iris_invG.
-Definition wp_pre `{!irisG Λ Σ} (s : stuckness)
+Definition wp_pre {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} (s : stuckness)
(wp : coPset -d> expr Λ -d> (val Λ -d> iProp Σ) -d> iProp Σ) :
coPset -d> expr Λ -d> (val Λ -d> iProp Σ) -d> iProp Σ := λ E e1 Φ,
match to_val e1 with
| Some v => |={E}=> Φ v
| None => ∀ σ1 κ κs n,
- state_interp σ1 (κ ++ κs) n ={E,∅}=∗
+ state_interp σ1 (κ ++ κs) n -∗ >={E}=={∅}=> (
⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
- ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠={∅,∅,E}▷=∗
+ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗ |={∅,∅,E}▷=> (
state_interp σ2 κs (length efs + n) ∗
wp E e2 Φ ∗
- [∗ list] i ↦ ef ∈ efs, wp ⊤ ef fork_post
+ [∗ list] i ↦ ef ∈ efs, wp ⊤ ef fork_post))
end%I.
-Local Instance wp_pre_contractive `{!irisG Λ Σ} s : Contractive (wp_pre s).
+Local Instance wp_pre_contractive {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} s : Contractive (wp_pre s).
Proof.
rewrite /wp_pre=> n wp wp' Hwp E e1 Φ.
- repeat (f_contractive || f_equiv); apply Hwp.
+ do 20 f_equiv. f_contractive. intros β Hβ. do 3 f_equiv. apply (Hwp β Hβ).
+ do 3 f_equiv. apply (Hwp β Hβ).
Qed.
-Definition wp_def `{!irisG Λ Σ} (s : stuckness) :
+Definition wp_def {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} (s : stuckness) :
coPset → expr Λ → (val Λ → iProp Σ) → iProp Σ := fixpoint (wp_pre s).
-Definition wp_aux `{!irisG Λ Σ} : seal (@wp_def Λ Σ _). by eexists. Qed.
-Instance wp' `{!irisG Λ Σ} : Wp Λ (iProp Σ) stuckness := wp_aux.(unseal).
-Definition wp_eq `{!irisG Λ Σ} : wp = @wp_def Λ Σ _ := wp_aux.(seal_eq).
+Definition wp_aux {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : seal (@wp_def SI Σ Λ _). by eexists. Qed.
+Instance wp' {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : Wp Λ (iProp Σ) stuckness := wp_aux.(unseal).
+Definition wp_eq {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : wp = @wp_def SI Σ Λ _ := wp_aux.(seal_eq).
+
+Definition swp_def {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} (k: nat) (s : stuckness) (E: coPset) (e1: expr Λ) (Φ: val Λ → iProp Σ) : iProp Σ :=
+ (∀ σ1 κ κs n,
+ state_interp σ1 (κ ++ κs) n -∗ >={E}=={∅}=>_k (
+ ⌜if s is NotStuck then reducible e1 σ1 else True⌠∗
+ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌠-∗ |={∅,∅,E}▷=> (
+ state_interp σ2 κs (length efs + n) ∗
+ WP e2 @ s; E {{ v, Φ v }} ∗
+ [∗ list] i ↦ ef ∈ efs, WP ef @ s; ⊤ {{ v, fork_post v }})))%I.
+Definition swp_aux {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : seal (@swp_def SI Σ Λ _). by eexists. Qed.
+Instance swp' {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : Swp Λ (iProp Σ) stuckness := swp_aux.(unseal).
+Definition swp_eq {SI} {Σ: gFunctors SI} `{!irisG Λ Σ} : swp = @swp_def SI Σ Λ _ :=
+ swp_aux.(seal_eq).
Section wp.
-Context `{!irisG Λ Σ}.
+Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
@@ -61,16 +143,22 @@ Lemma wp_unfold s E e Φ :
WP e @ s; E {{ Φ }} ⊣⊢ wp_pre s (wp (PROP:=iProp Σ) s) E e Φ.
Proof. rewrite wp_eq. apply (fixpoint_unfold (wp_pre s)). Qed.
+Lemma swp_unfold k s E e Φ :
+ SWP e at k @ s; E {{ Φ }} ⊣⊢ swp_def k s E e Φ.
+Proof. by rewrite swp_eq. Qed.
+
+
Global Instance wp_ne s E e n :
Proper (pointwise_relation _ (dist n) ==> dist n) (wp (PROP:=iProp Σ) s E e).
Proof.
- revert e. induction (lt_wf n) as [n _ IH]=> e Φ Ψ HΦ.
+ revert e. induction (index_lt_wf SI n) as [n _ IH]=> e Φ Ψ HΦ.
rewrite !wp_unfold /wp_pre.
(* FIXME: figure out a way to properly automate this proof *)
(* FIXME: reflexivity, as being called many times by f_equiv and f_contractive
is very slow here *)
- do 24 (f_contractive || f_equiv). apply IH; first lia.
- intros v. eapply dist_le; eauto with lia.
+ do 20 f_equiv. f_contractive. intros β Hβ.
+ do 3 f_equiv. eapply IH; eauto.
+ intros v. eapply dist_le; eauto.
Qed.
Global Instance wp_proper s E e :
Proper (pointwise_relation _ (≡) ==> (≡)) (wp (PROP:=iProp Σ) s E e).
@@ -78,11 +166,30 @@ Proof.
by intros Φ Φ' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist.
Qed.
+Global Instance swp_ne k s E e n :
+ Proper (pointwise_relation _ (dist n) ==> dist n) (swp (PROP:=iProp Σ) k s E e).
+Proof.
+ intros Φ Ψ HΦ. rewrite !swp_unfold /swp_def.
+ (* FIXME: figure out a way to properly automate this proof *)
+ (* FIXME: reflexivity, as being called many times by f_equiv and f_contractive
+ is very slow here *)
+ do 19 f_equiv. f_contractive. intros β Hβ.
+ do 3 f_equiv. eapply wp_ne.
+ intros v. eapply dist_le; eauto.
+Qed.
+Global Instance swp_proper k s E e :
+ Proper (pointwise_relation _ (≡) ==> (≡)) (swp k (PROP:=iProp Σ) s E e).
+Proof.
+ by intros Φ Φ' ?; apply equiv_dist=>n; apply swp_ne=>v; apply equiv_dist.
+Qed.
+
Lemma wp_value' s E Φ v : Φ v ⊢ WP of_val v @ s; E {{ Φ }}.
Proof. iIntros "HΦ". rewrite wp_unfold /wp_pre to_of_val. auto. Qed.
Lemma wp_value_inv' s E Φ v : WP of_val v @ s; E {{ Φ }} ={E}=∗ Φ v.
Proof. by rewrite wp_unfold /wp_pre to_of_val. Qed.
+Section gstep.
+Local Existing Instance elim_gstep.
Lemma wp_strong_mono s1 s2 E1 E2 e Φ Ψ :
s1 ⊑ s2 → E1 ⊆ E2 →
WP e @ s1; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; E2 {{ Ψ }}.
@@ -92,11 +199,11 @@ Proof.
destruct (to_val e) as [v|] eqn:?.
{ iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). }
iIntros (σ1 κ κs n) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
- iMod ("H" with "[$]") as "[% H]".
- iModIntro. iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
- iMod ("H" with "[//]") as "H". iIntros "!> !>".
- iMod "H" as "(Hσ & H & Hefs)".
- iMod "Hclose" as "_". iModIntro. iFrame "Hσ". iSplitR "Hefs".
+ iMod ("H" with "[$]") as "[? H]".
+ iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
+ iSpecialize ("H" with "[//]"). iMod "H". iModIntro. iNext. iMod "H". iMod "Hclose" as "_".
+ iModIntro.
+ iDestruct "H" as "(Hσ & H & Hefs)". iFrame "Hσ". iSplitR "Hefs".
- iApply ("IH" with "[//] H HΦ").
- iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
iIntros "H". iApply ("IH" with "[] H"); auto.
@@ -111,38 +218,79 @@ Qed.
Lemma wp_fupd s E e Φ : WP e @ s; E {{ v, |={E}=> Φ v }} ⊢ WP e @ s; E {{ Φ }}.
Proof. iIntros "H". iApply (wp_strong_mono s s E with "H"); auto. Qed.
-Lemma wp_atomic s E1 E2 e Φ `{!Atomic (stuckness_to_atomicity s) e} :
+
+Lemma wp_atomic E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
(|={E1,E2}=> WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @ s; E1 {{ Φ }}.
Proof.
iIntros "H". rewrite !wp_unfold /wp_pre.
destruct (to_val e) as [v|] eqn:He.
{ by iDestruct "H" as ">>> $". }
- iIntros (σ1 κ κs n) "Hσ". iMod "H". iMod ("H" $! σ1 with "Hσ") as "[$ H]".
- iModIntro. iIntros (e2 σ2 efs Hstep).
- iMod ("H" with "[//]") as "H". iIntros "!>!>".
- iMod "H" as "(Hσ & H & Hefs)". destruct s.
- - rewrite !wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2.
- + iDestruct "H" as ">> $". by iFrame.
- + iMod ("H" $! _ [] with "[$]") as "[H _]". iDestruct "H" as %(? & ? & ? & ? & ?).
- by edestruct (atomic _ _ _ _ _ Hstep).
- - destruct (atomic _ _ _ _ _ Hstep) as [v <-%of_to_val].
- iMod (wp_value_inv' with "H") as ">H".
- iModIntro. iFrame "Hσ Hefs". by iApply wp_value'.
+ iIntros (σ1 κ κs n) "Hσ". iMod "H".
+ iMod ("H" $! σ1 with "Hσ") as "[$ H]".
+ iIntros (e2 σ2 efs Hstep). iSpecialize ("H" with "[//]"). iMod "H". iModIntro. iNext.
+ iMod "H" as "(Hσ & H & Hefs)".
+ + rewrite wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2.
+ * rewrite wp_unfold /wp_pre He2. iDestruct "H" as ">> $". by iFrame.
+ * specialize (atomic _ _ _ _ _ Hstep) as []; congruence.
Qed.
-Lemma wp_step_fupd s E1 E2 e P Φ :
- to_val e = None → E2 ⊆ E1 →
- (|={E1,E2}▷=> P) -∗ WP e @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ WP e @ s; E1 {{ Φ }}.
+
+Local Existing Instance elim_gstepN.
+Lemma swp_strong_mono k1 k2 s1 s2 E1 E2 e Φ Ψ :
+ s1 ⊑ s2 → E1 ⊆ E2 → k1 ≤ k2 →
+ SWP e at k1 @ s1; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ SWP e at k2 @ s2; E2 {{ Ψ }}.
Proof.
- rewrite !wp_unfold /wp_pre. iIntros (-> ?) "HR H".
- iIntros (σ1 κ κs n) "Hσ". iMod "HR". iMod ("H" with "[$]") as "[$ H]".
- iIntros "!>" (e2 σ2 efs Hstep). iMod ("H" $! e2 σ2 efs with "[% //]") as "H".
- iIntros "!>!>". iMod "H" as "(Hσ & H & Hefs)".
- iMod "HR". iModIntro. iFrame "Hσ Hefs".
- iApply (wp_strong_mono s s E2 with "H"); [done..|].
- iIntros (v) "H". by iApply "H".
+ iIntros (? HE Hk) "H HΦ". rewrite !swp_unfold /swp_def.
+ iIntros (σ1 κ κs n) "S". iMod (fupd_intro_mask' E2 E1) as "E"; eauto.
+ iSpecialize ("H" with "S"). iApply (gstepN_mono _ _ _ _ _ _ Hk).
+ iMod ("H") as "[? H]".
+ iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
+ iSpecialize ("H" with "[//]"). iMod "H". iModIntro. iNext. iMod "H". iMod "E" as "_".
+ iModIntro.
+ iDestruct "H" as "(Hσ & H & Hefs)". iFrame "Hσ". iSplitR "Hefs".
+ - iApply (wp_strong_mono with "H"); eauto.
+ - iApply (big_sepL_impl with "Hefs"); iIntros "!#" (k ef _).
+ iIntros "H". iApply (wp_strong_mono with "H"); eauto.
+Qed.
+
+Lemma fupd_swp k s E e Φ : (|={E}=> SWP e at k @ s; E {{ Φ }})%I ⊢ SWP e at k @ s; E {{ Φ }}.
+Proof.
+ rewrite swp_unfold /swp_def. iIntros "SWP".
+ iIntros (σ1 κ κs n) "S". iMod "SWP".
+ iApply "SWP"; iFrame.
+Qed.
+
+Lemma swp_fupd k s E e Φ : SWP e at k @ s; E {{ v, |={E}=> Φ v}} ⊢ SWP e at k @ s; E {{ Φ }}.
+Proof. iIntros "H". iApply (swp_strong_mono k k s s E with "H"); auto. Qed.
+
+
+Lemma swp_atomic k E1 E2 e s Φ `{!Atomic StronglyAtomic e} :
+ (|={E1, E2}=> SWP e at k @ s; E2 {{ v, |={E2, E1}=> Φ v}})%I ⊢ SWP e at k @ s; E1 {{ Φ }}.
+Proof.
+ rewrite !swp_unfold /swp_def. iIntros "SWP". iIntros (σ1 κ κs n) "S".
+ iMod "SWP". iMod ("SWP" with "S") as "[$ SWP]".
+ iIntros (e2 σ2 efs Hstep). iMod ("SWP" with "[//]") as "SWP". iModIntro. iNext.
+ iMod "SWP" as "($& SWP & $)". destruct (atomic _ _ _ _ _ Hstep) as [v Hv].
+ rewrite !wp_unfold /wp_pre Hv. do 2 iMod "SWP". by do 2 iModIntro.
+Qed.
+
+Lemma swp_wp k s E e Φ : to_val e = None →
+ SWP e at k @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Φ }}%I.
+Proof.
+ intros H; rewrite swp_unfold wp_unfold /swp_def /wp_pre H.
+ iIntros "SWP". iIntros (σ1 κ κs n) "S".
+ iApply gstepN_gstep. iMod ("SWP" with "S") as "$".
+Qed.
+
+Lemma swp_step k E e s Φ : ▷ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at S k @ s; E {{ Φ }}.
+Proof.
+ rewrite !swp_unfold /swp_def. iIntros "SWP". iIntros (σ1 κ κs n) "S".
+ iMod (fupd_intro_mask') as "M". apply empty_subseteq.
+ do 3 iModIntro. iMod "M" as "_".
+ iMod ("SWP" with "S") as "$".
Qed.
+
Lemma wp_bind K `{!LanguageCtx K} s E e Φ :
WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }} ⊢ WP K e @ s; E {{ Φ }}.
Proof.
@@ -150,16 +298,31 @@ Proof.
destruct (to_val e) as [v|] eqn:He.
{ apply of_to_val in He as <-. by iApply fupd_wp. }
rewrite wp_unfold /wp_pre fill_not_val //.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]". iModIntro; iSplit.
+ iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
{ iPureIntro. destruct s; last done.
unfold reducible in *. naive_solver eauto using fill_step. }
iIntros (e2 σ2 efs Hstep).
destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
- iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!>!>".
+ iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!> !>".
iMod "H" as "(Hσ & H & Hefs)".
iModIntro. iFrame "Hσ Hefs". by iApply "IH".
Qed.
+Lemma swp_bind k K `{!LanguageCtx K} s E e Φ : to_val e = None →
+ SWP e at k @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }} ⊢ SWP K e at k @ s; E {{ Φ }}.
+Proof.
+ iIntros (H) "H". rewrite !swp_unfold /swp_def.
+ iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
+ { iPureIntro. destruct s; last done.
+ unfold reducible in *. naive_solver eauto using fill_step. }
+ iIntros (e2 σ2 efs Hstep).
+ destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
+ iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!> !>".
+ iMod "H" as "(Hσ & H & Hefs)".
+ iModIntro. iFrame "Hσ Hefs". by iApply wp_bind.
+Qed.
+
+
Lemma wp_bind_inv K `{!LanguageCtx K} s E e Φ :
WP K e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }}.
Proof.
@@ -167,14 +330,26 @@ Proof.
destruct (to_val e) as [v|] eqn:He.
{ apply of_to_val in He as <-. by rewrite !wp_unfold /wp_pre. }
rewrite fill_not_val //.
- iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]". iModIntro; iSplit.
+ iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
{ destruct s; eauto using reducible_fill. }
iIntros (e2 σ2 efs Hstep).
iMod ("H" $! (K e2) σ2 efs with "[]") as "H"; [by eauto using fill_step|].
- iIntros "!>!>". iMod "H" as "(Hσ & H & Hefs)".
+ iIntros "!> !>". iMod "H" as "(Hσ & H & Hefs)".
iModIntro. iFrame "Hσ Hefs". by iApply "IH".
Qed.
+Lemma swp_bind_inv K `{!LanguageCtx K} k s E e Φ : to_val e = None →
+ SWP K e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }}.
+Proof.
+ iIntros (H) "H". rewrite !swp_unfold /swp_def.
+ iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]"; iSplit.
+ { destruct s; eauto using reducible_fill. }
+ iIntros (e2 σ2 efs Hstep).
+ iMod ("H" $! (K e2) σ2 efs with "[]") as "H"; [by eauto using fill_step|].
+ iIntros "!> !>". iMod "H" as "(Hσ & H & Hefs)".
+ iModIntro. iFrame "Hσ Hefs". by iApply wp_bind_inv.
+Qed.
+
(** * Derived rules *)
Lemma wp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
Proof.
@@ -208,6 +383,40 @@ Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.
Lemma wp_frame_r s E e Φ R : WP e @ s; E {{ Φ }} ∗ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.
+End gstep.
+
+Existing Instance elim_eventuallyN.
+Lemma wp_step_fupd s E1 E2 e P Φ :
+ to_val e = None → E2 ⊆ E1 →
+ (|={E1,E2}▷=> P) -∗ WP e @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ WP e @ s; E1 {{ Φ }}.
+Proof.
+ rewrite !wp_unfold /wp_pre. iIntros (-> ?) "HR H".
+ iIntros (σ1 κ κs n) "Hσ". iMod "HR".
+ iMod ("H" with "[$]") as ">H". iDestruct "H" as (n1) "H".
+ iApply (gstepN_gstep _ _ _ (S n1)). iApply gstepN_later; first eauto. iNext.
+ iModIntro. iMod "H". iMod "H" as "[$ H]". iModIntro.
+ iIntros(e2 σ2 efs Hstep).
+ iSpecialize ("H" $! e2 σ2 efs with "[% //]"). iMod "H". iModIntro. iNext.
+ iMod "H" as "(Hσ & H & Hefs)".
+ iMod "HR". iModIntro. iFrame "Hσ Hefs".
+ iApply (wp_strong_mono s s E2 with "H"); [done..|].
+ iIntros (v) "H". by iApply "H".
+Qed.
+
+Lemma swp_step_fupd k s E1 E2 e P Φ :
+ E2 ⊆ E1 →
+ (|={E1,E2}▷=> P) -∗ SWP e at k @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ SWP e at k @ s; E1 {{ Φ }}.
+Proof.
+ rewrite !swp_unfold /swp_def. iIntros (?) "HR H".
+ iIntros (σ1 κ κs n) "Hσ". iMod "HR". iMod ("H" with "[$]") as "H". iModIntro.
+ iMod "H". iMod "H" as "[$ H]". iModIntro. iIntros(e2 σ2 efs Hstep).
+ iSpecialize ("H" $! e2 σ2 efs with "[% //]"). iMod "H". iModIntro. iNext.
+ iMod "H" as "(Hσ & H & Hefs)".
+ iMod "HR". iModIntro. iFrame "Hσ Hefs".
+ iApply (wp_strong_mono s s E2 with "H"); [done..|].
+ iIntros (v) "H". by iApply "H".
+Qed.
+
Lemma wp_frame_step_l s E1 E2 e Φ R :
to_val e = None → E2 ⊆ E1 →
(|={E1,E2}▷=> R) ∗ WP e @ s; E2 {{ Φ }} ⊢ WP e @ s; E1 {{ v, R ∗ Φ v }}.
@@ -248,11 +457,127 @@ Proof.
iIntros (v) "HΦ". by iApply "HΦ".
Qed.
+(* we can pull out a logical step from a WP when switching to the SWP *)
+Local Existing Instance elim_fupd_step.
+Instance elim_fupd_stepN b E P Q n:
+ ElimModal True b false (|={E, E}â–·=>^n P)%I P (|={E, E}â–·=>^n Q)%I Q.
+Proof.
+ iIntros (_) "(P & HPQ)". iPoseProof (intuitionistically_if_elim with "P") as "P".
+ iInduction n as [ |n] "IH"; cbn.
+ - by iApply "HPQ".
+ - iMod "P". fold Nat.iter. by iApply ("IH" with "HPQ").
+Qed.
+Lemma fupd_fupd_step E P n :
+ (|={E}=> |={E, E}▷=>^n P)%I -∗ |={E, E}▷=>^n (|={E}=> P)%I.
+Proof.
+ iIntros "H". iInduction n as [ | n] "IH"; cbn.
+ iApply "H".
+ iMod "H".
+ iApply "IH". iMod "H". iModIntro. iApply "H".
+Qed.
+
+Lemma fupd_step_fupd E P n :
+ (|={E, E}▷=>^n |={E}=> P)%I -∗ (|={E}=> |={E, E}▷=>^n P)%I .
+Proof.
+ iIntros "H". iInduction n as [ | n] "IH". cbn.
+ iApply "H". iApply "IH". iModIntro.
+ iMod "H". iModIntro. iNext. iApply fupd_fupd_step.
+ iMod "H". iApply "IH". iApply "H".
+Qed.
+
+Lemma swp_wp_lstep k2 s E e Φ : to_val e = None →
+ (>={E}=={E}=> SWP e at k2 @ s ; E {{ Φ }}) ⊢ WP e @ s; E {{ Φ }}%I.
+Proof.
+ intros H; rewrite wp_unfold swp_unfold /wp_pre /swp_def H.
+ iIntros "WP". iIntros (σ1 κ κs n) "S".
+ do 2 iMod "WP". iDestruct ("WP") as (k1) "WP".
+ iApply (lstepN_lstep _ _ (k1 + (1 + k2))). iModIntro. iApply eventuallyN_compose.
+ iMod ("WP"). iApply eventuallyN_compose. iMod "WP".
+ iMod ("WP" with "S") as "WP".
+ do 4 iModIntro. do 2 iMod "WP". iModIntro.
+ iApply "WP".
+Qed.
End wp.
+
+Section swp.
+ Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
+ Implicit Types s : stuckness.
+ Implicit Types P : iProp Σ.
+ Implicit Types Φ : val Λ → iProp Σ.
+ Implicit Types v : val Λ.
+ Implicit Types e : expr Λ.
+ Variable (k: nat).
+
+ Lemma swp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ Ψ }}.
+ Proof.
+ iIntros (HΦ) "H"; iApply (swp_strong_mono with "H"); auto.
+ iIntros (v) "?". by iApply HΦ.
+ Qed.
+ Lemma swp_stuck_mono s1 s2 E e Φ :
+ s1 ⊑ s2 → SWP e at k @ s1; E {{ Φ }} ⊢ SWP e at k @ s2; E {{ Φ }}.
+ Proof. iIntros (?) "H". iApply (swp_strong_mono with "H"); auto. Qed.
+ Lemma swp_stuck_weaken s E e Φ :
+ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ E ?{{ Φ }}.
+ Proof. apply swp_stuck_mono. by destruct s. Qed.
+ Lemma swp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → SWP e at k @ s; E1 {{ Φ }} ⊢ SWP e at k @ s; E2 {{ Φ }}.
+ Proof. iIntros (?) "H"; iApply (swp_strong_mono with "H"); auto. Qed.
+ Global Instance swp_mono' s E e :
+ Proper (pointwise_relation _ (⊢) ==> (⊢)) (swp (PROP:=iProp Σ) k s E e).
+ Proof. by intros Φ Φ' ?; apply swp_mono. Qed.
+
+ Lemma swp_frame_l s E e Φ R : R ∗ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ v, R ∗ Φ v }}.
+ Proof. iIntros "[? H]". iApply (swp_strong_mono with "H"); auto with iFrame. Qed.
+ Lemma swp_frame_r s E e Φ R : SWP e at k @ s; E {{ Φ }} ∗ R ⊢ SWP e at k @ s; E {{ v, Φ v ∗ R }}.
+ Proof. iIntros "[H ?]". iApply (swp_strong_mono with "H"); auto with iFrame. Qed.
+
+ Lemma swp_frame_step_l s E1 E2 e Φ R :
+ to_val e = None → E2 ⊆ E1 →
+ (|={E1,E2}▷=> R) ∗ SWP e at k @ s; E2 {{ Φ }} ⊢ SWP e at k @ s; E1 {{ v, R ∗ Φ v }}.
+ Proof.
+ iIntros (??) "[Hu Hwp]". iApply (swp_step_fupd with "Hu"); try done.
+ iApply (swp_mono with "Hwp"). by iIntros (?) "$$".
+ Qed.
+ Lemma swp_frame_step_r s E1 E2 e Φ R :
+ to_val e = None → E2 ⊆ E1 →
+ SWP e at k @ s; E2 {{ Φ }} ∗ (|={E1,E2}▷=> R) ⊢ SWP e at k @ s; E1 {{ v, Φ v ∗ R }}.
+ Proof.
+ rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R).
+ apply swp_frame_step_l.
+ Qed.
+ Lemma swp_frame_step_l' s E e Φ R :
+ to_val e = None → ▷ R ∗ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ v, R ∗ Φ v }}.
+ Proof. iIntros (?) "[??]". iApply (swp_frame_step_l s E E); try iFrame; eauto. Qed.
+ Lemma swp_frame_step_r' s E e Φ R :
+ to_val e = None → SWP e at k @ s; E {{ Φ }} ∗ ▷ R ⊢ SWP e at k @ s; E {{ v, Φ v ∗ R }}.
+ Proof. iIntros (?) "[??]". iApply (swp_frame_step_r s E E); try iFrame; eauto. Qed.
+
+ Lemma swp_wand s E e Φ Ψ :
+ SWP e at k @ s; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ SWP e at k @ s; E {{ Ψ }}.
+ Proof.
+ iIntros "Hwp H". iApply (swp_strong_mono with "Hwp"); auto.
+ iIntros (?) "?". by iApply "H".
+ Qed.
+ Lemma swp_wand_l s E e Φ Ψ :
+ (∀ v, Φ v -∗ Ψ v) ∗ SWP e at k @ s; E {{ Φ }} ⊢ SWP e at k @ s; E {{ Ψ }}.
+ Proof. iIntros "[H Hwp]". iApply (swp_wand with "Hwp H"). Qed.
+ Lemma swp_wand_r s E e Φ Ψ :
+ SWP e at k @ s; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ SWP e at k @ s; E {{ Ψ }}.
+ Proof. iIntros "[Hwp H]". iApply (swp_wand with "Hwp H"). Qed.
+ Lemma swp_frame_wand_l s E e Q Φ :
+ Q ∗ SWP e at k @ s; E {{ v, Q -∗ Φ v }} -∗ SWP e at k @ s; E {{ Φ }}.
+ Proof.
+ iIntros "[HQ HWP]". iApply (swp_wand with "HWP").
+ iIntros (v) "HΦ". by iApply "HΦ".
+ Qed.
+
+ Lemma swp_finish E e s Φ : SWP e at 0%nat @ s; E {{ Φ }} ⊢ SWP e at 0%nat @ s; E {{ Φ }}.
+ Proof. eauto. Qed.
+End swp.
+
(** Proofmode class instances *)
Section proofmode_classes.
- Context `{!irisG Λ Σ}.
+ Context {SI} {Σ: gFunctors SI} `{!irisG Λ Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
@@ -261,9 +586,17 @@ Section proofmode_classes.
Frame p R (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Ψ }}).
Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed.
+ Global Instance frame_swp k p s E e R Φ Ψ :
+ (∀ v, Frame p R (Φ v) (Ψ v)) →
+ Frame p R (SWP e at k @ s; E {{ Φ }}) (SWP e at k @ s; E {{ Ψ }}).
+ Proof. rewrite /Frame=> HR. rewrite swp_frame_l. apply swp_mono, HR. Qed.
+
Global Instance is_except_0_wp s E e Φ : IsExcept0 (WP e @ s; E {{ Φ }}).
Proof. by rewrite /IsExcept0 -{2}fupd_wp -except_0_fupd -fupd_intro. Qed.
+ Global Instance is_except_0_swp k s E e Φ : IsExcept0 (SWP e at k @ s; E {{ Φ }}).
+ Proof. by rewrite /IsExcept0 -{2}fupd_swp -except_0_fupd -fupd_intro. Qed.
+
Global Instance elim_modal_bupd_wp p s E e P Φ :
ElimModal True p false (|==> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
Proof.
@@ -271,6 +604,13 @@ Section proofmode_classes.
(bupd_fupd E) fupd_frame_r wand_elim_r fupd_wp.
Qed.
+ Global Instance elim_modal_bupd_swp k p s E e P Φ :
+ ElimModal True p false (|==> P) P (SWP e at k @ s; E {{ Φ }}) (SWP e at k @ s; E {{ Φ }}).
+ Proof.
+ by rewrite /ElimModal intuitionistically_if_elim
+ (bupd_fupd E) fupd_frame_r wand_elim_r fupd_swp.
+ Qed.
+
Global Instance elim_modal_fupd_wp p s E e P Φ :
ElimModal True p false (|={E}=> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
Proof.
@@ -278,8 +618,15 @@ Section proofmode_classes.
fupd_frame_r wand_elim_r fupd_wp.
Qed.
- Global Instance elim_modal_fupd_wp_atomic p s E1 E2 e P Φ :
- Atomic (stuckness_to_atomicity s) e →
+ Global Instance elim_modal_fupd_swp k p s E e P Φ :
+ ElimModal True p false (|={E}=> P) P (SWP e at k @ s; E {{ Φ }}) (SWP e at k @ s; E {{ Φ }}).
+ Proof.
+ by rewrite /ElimModal intuitionistically_if_elim
+ fupd_frame_r wand_elim_r fupd_swp.
+ Qed.
+
+ Global Instance elim_modal_fupd_wp_atomic s p E1 E2 e P Φ :
+ Atomic StronglyAtomic e →
ElimModal True p false (|={E1,E2}=> P) P
(WP e @ s; E1 {{ Φ }}) (WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }})%I.
Proof.
@@ -287,12 +634,27 @@ Section proofmode_classes.
fupd_frame_r wand_elim_r wp_atomic.
Qed.
+ Global Instance elim_modal_fupd_swp_atomic k s p E1 E2 e P Φ :
+ Atomic StronglyAtomic e →
+ ElimModal True p false (|={E1,E2}=> P) P
+ (SWP e at k @ s; E1 {{ Φ }}) (SWP e at k @ s; E2 {{ v, |={E2,E1}=> Φ v }})%I.
+ Proof.
+ intros. by rewrite /ElimModal intuitionistically_if_elim
+ fupd_frame_r wand_elim_r swp_atomic.
+ Qed.
+
+
Global Instance add_modal_fupd_wp s E e P Φ :
AddModal (|={E}=> P) P (WP e @ s; E {{ Φ }}).
Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_wp. Qed.
- Global Instance elim_acc_wp {X} E1 E2 α β γ e s Φ :
- Atomic (stuckness_to_atomicity s) e →
+ Global Instance add_modal_fupd_swp k s E e P Φ :
+ AddModal (|={E}=> P) P (SWP e at k @ s; E {{ Φ }}).
+ Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_swp. Qed.
+
+
+ Global Instance elim_acc_wp {X} s E1 E2 α β γ e Φ :
+ Atomic StronglyAtomic e →
ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
α β γ (WP e @ s; E1 {{ Φ }})
(λ x, WP e @ s; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I.
@@ -303,6 +665,18 @@ Section proofmode_classes.
iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
Qed.
+ Global Instance elim_acc_swp {X} k s E1 E2 α β γ e Φ :
+ Atomic StronglyAtomic e →
+ ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1)
+ α β γ (SWP e at k @ s; E1 {{ Φ }})
+ (λ x, SWP e at k @ s; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I.
+ Proof.
+ intros ?. rewrite /ElimAcc.
+ iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
+ iApply (swp_wand with "(Hinner Hα)").
+ iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
+ Qed.
+
Global Instance elim_acc_wp_nonatomic {X} E α β γ e s Φ :
ElimAcc (X:=X) (fupd E E) (fupd E E)
α β γ (WP e @ s; E {{ Φ }})
@@ -314,4 +688,17 @@ Section proofmode_classes.
iApply (wp_wand with "(Hinner Hα)").
iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
Qed.
+
+ Global Instance elim_acc_swp_nonatomic {X} k E α β γ e s Φ :
+ ElimAcc (X:=X) (fupd E E) (fupd E E)
+ α β γ (SWP e at k @ s; E {{ Φ }})
+ (λ x, SWP e at k @ s; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I.
+ Proof.
+ rewrite /ElimAcc.
+ iIntros "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
+ iApply swp_fupd.
+ iApply (swp_wand with "(Hinner Hα)").
+ iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
+ Qed.
End proofmode_classes.
+
diff --git a/theories/proofmode/class_instances_bi.v b/theories/proofmode/class_instances_bi.v
index 7b9c78bd3eb03371587aec1e7ec5a37d97b56b14..50cbe1b783499243c3a9956b2c17c5e8c9ec7fb6 100644
--- a/theories/proofmode/class_instances_bi.v
+++ b/theories/proofmode/class_instances_bi.v
@@ -5,7 +5,7 @@ Set Default Proof Using "Type".
Import bi.
Section bi_instances.
-Context {PROP : bi}.
+Context {SI} {PROP : bi SI}.
Implicit Types P Q R : PROP.
Implicit Types mP : option PROP.
@@ -31,7 +31,8 @@ Qed.
The first [`{BiEmbed PROP PROP'}] is not considered as a premise by
Coq TC search mechanism because the rest of the hypothesis is dependent
on it. *)
-Global Instance as_emp_valid_embed `{BiEmbed PROP PROP'} (φ : Prop) (P : PROP) :
+
+Global Instance as_emp_valid_embed `{BiEmbed SI PROP PROP'} (φ : Prop) (P : PROP) :
BiEmbed PROP PROP' →
AsEmpValid0 φ P → AsEmpValid φ ⎡P⎤.
Proof. rewrite /AsEmpValid0 /AsEmpValid=> _ ->. rewrite embed_emp_valid //. Qed.
@@ -46,7 +47,7 @@ Global Instance from_affinely_intuitionistically P :
Proof. by rewrite /FromAffinely. Qed.
(** IntoAbsorbingly *)
-Global Instance into_absorbingly_True : @IntoAbsorbingly PROP True emp | 0.
+Global Instance into_absorbingly_True : @IntoAbsorbingly SI PROP True emp | 0.
Proof. by rewrite /IntoAbsorbingly -absorbingly_True_emp absorbingly_pure. Qed.
Global Instance into_absorbingly_absorbing P : Absorbing P → IntoAbsorbingly P P | 1.
Proof. intros. by rewrite /IntoAbsorbingly absorbing_absorbingly. Qed.
@@ -99,7 +100,7 @@ Proof.
rewrite /KnownLFromAssumption /FromAssumption /= =><-.
rewrite intuitionistically_persistently_elim //.
Qed.
-Global Instance from_assumption_persistently_l_false `{BiAffine PROP} P Q :
+Global Instance from_assumption_persistently_l_false `{BiAffine SI PROP} P Q :
FromAssumption true P Q → KnownLFromAssumption false (<pers> P) Q.
Proof.
rewrite /KnownLFromAssumption /FromAssumption /= =><-.
@@ -125,12 +126,12 @@ Proof.
by rewrite forall_elim.
Qed.
-Global Instance from_assumption_bupd `{BiBUpd PROP} p P Q :
+Global Instance from_assumption_bupd `{BiBUpd SI PROP} p P Q :
FromAssumption p P Q → KnownRFromAssumption p P (|==> Q).
Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply bupd_intro. Qed.
(** IntoPure *)
-Global Instance into_pure_pure φ : @IntoPure PROP ⌜φ⌠φ.
+Global Instance into_pure_pure φ : @IntoPure SI PROP ⌜φ⌠φ.
Proof. by rewrite /IntoPure. Qed.
Global Instance into_pure_pure_and (φ1 φ2 : Prop) P1 P2 :
@@ -171,14 +172,14 @@ Proof. rewrite /IntoPure=> ->. by rewrite absorbingly_pure. Qed.
Global Instance into_pure_persistently P φ :
IntoPure P φ → IntoPure (<pers> P) φ.
Proof. rewrite /IntoPure=> ->. apply: persistently_elim. Qed.
-Global Instance into_pure_embed `{BiEmbed PROP PROP'} P φ :
+Global Instance into_pure_embed `{BiEmbed SI PROP PROP'} P φ :
IntoPure P φ → IntoPure ⎡P⎤ φ.
Proof. rewrite /IntoPure=> ->. by rewrite embed_pure. Qed.
(** FromPure *)
-Global Instance from_pure_emp : @FromPure PROP true emp True.
+Global Instance from_pure_emp : @FromPure SI PROP true emp True.
Proof. rewrite /FromPure /=. apply (affine _). Qed.
-Global Instance from_pure_pure φ : @FromPure PROP false ⌜φ⌠φ.
+Global Instance from_pure_pure φ : @FromPure SI PROP false ⌜φ⌠φ.
Proof. by rewrite /FromPure /=. Qed.
Global Instance from_pure_pure_and a1 a2 (φ1 φ2 : Prop) P1 P2 :
FromPure a1 P1 φ1 → FromPure a2 P2 φ2 →
@@ -257,11 +258,11 @@ Proof.
rewrite /FromPure=> <- /=. rewrite -affinely_affinely_if.
by rewrite -persistent_absorbingly_affinely_2.
Qed.
-Global Instance from_pure_embed `{BiEmbed PROP PROP'} a P φ :
+Global Instance from_pure_embed `{BiEmbed SI PROP PROP'} a P φ :
FromPure a P φ → FromPure a ⎡P⎤ φ.
Proof. rewrite /FromPure=> <-. by rewrite -embed_pure embed_affinely_if_2. Qed.
-Global Instance from_pure_bupd `{BiBUpd PROP} a P φ :
+Global Instance from_pure_bupd `{BiBUpd SI PROP} a P φ :
FromPure a P φ → FromPure a (|==> P) φ.
Proof. rewrite /FromPure=> <-. apply bupd_intro. Qed.
@@ -283,7 +284,7 @@ Proof.
eauto using persistently_mono, intuitionistically_elim,
intuitionistically_into_persistently_1.
Qed.
-Global Instance into_persistent_embed `{BiEmbed PROP PROP'} p P Q :
+Global Instance into_persistent_embed `{BiEmbed SI PROP PROP'} p P Q :
IntoPersistent p P Q → IntoPersistent p ⎡P⎤ ⎡Q⎤ | 0.
Proof.
rewrite /IntoPersistent -embed_persistently -embed_persistently_if=> -> //.
@@ -317,29 +318,30 @@ Proof. by rewrite /FromModal /= -absorbingly_intro. Qed.
(* When having a modality nested in an embedding, e.g. [ ⎡|==> P⎤ ], we prefer
the embedding over the modality. *)
-Global Instance from_modal_embed `{BiEmbed PROP PROP'} (P : PROP) :
- FromModal (@modality_embed PROP PROP' _) ⎡P⎤ ⎡P⎤ P.
+Global Instance from_modal_embed `{BiEmbed SI PROP PROP'} (P : PROP) :
+ FromModal (@modality_embed SI PROP PROP' _) ⎡P⎤ ⎡P⎤ P.
Proof. by rewrite /FromModal. Qed.
-Global Instance from_modal_id_embed `{BiEmbed PROP PROP'} `(sel : A) P Q :
+Global Instance from_modal_id_embed `{BiEmbed SI PROP PROP'} `(sel : A) P Q :
FromModal modality_id sel P Q →
FromModal modality_id sel ⎡P⎤ ⎡Q⎤ | 100.
Proof. by rewrite /FromModal /= =><-. Qed.
-Global Instance from_modal_affinely_embed `{BiEmbed PROP PROP'} `(sel : A) P Q :
+Global Instance from_modal_affinely_embed `{BiEmbed SI PROP PROP'} `(sel : A) P Q :
FromModal modality_affinely sel P Q →
FromModal modality_affinely sel ⎡P⎤ ⎡Q⎤ | 100.
Proof. rewrite /FromModal /= =><-. by rewrite embed_affinely_2. Qed.
-Global Instance from_modal_persistently_embed `{BiEmbed PROP PROP'} `(sel : A) P Q :
+Global Instance from_modal_persistently_embed `{BiEmbed SI PROP PROP'} `(sel : A) P Q :
FromModal modality_persistently sel P Q →
FromModal modality_persistently sel ⎡P⎤ ⎡Q⎤ | 100.
Proof. rewrite /FromModal /= =><-. by rewrite embed_persistently. Qed.
-Global Instance from_modal_intuitionistically_embed `{BiEmbed PROP PROP'} `(sel : A) P Q :
+Global Instance from_modal_intuitionistically_embed `{BiEmbed SI PROP PROP'} `(sel : A) P Q :
FromModal modality_intuitionistically sel P Q →
FromModal modality_intuitionistically sel ⎡P⎤ ⎡Q⎤ | 100.
Proof. rewrite /FromModal /= =><-. by rewrite embed_intuitionistically_2. Qed.
-Global Instance from_modal_bupd `{BiBUpd PROP} P :
+
+Global Instance from_modal_bupd `{BiBUpd SI PROP} P :
FromModal modality_id (|==> P) (|==> P) P.
Proof. by rewrite /FromModal /= -bupd_intro. Qed.
@@ -463,7 +465,7 @@ Global Instance into_wand_persistently_false q R P Q :
Absorbing R → IntoWand false q R P Q → IntoWand false q (<pers> R) P Q.
Proof. intros ?. by rewrite /IntoWand persistently_elim. Qed.
-Global Instance into_wand_embed `{BiEmbed PROP PROP'} p q R P Q :
+Global Instance into_wand_embed `{BiEmbed SI PROP PROP'} p q R P Q :
IntoWand p q R P Q → IntoWand p q ⎡R⎤ ⎡P⎤ ⎡Q⎤.
Proof. by rewrite /IntoWand !embed_intuitionistically_if_2 -embed_wand=> ->. Qed.
@@ -472,7 +474,7 @@ Proof. by rewrite /IntoWand !embed_intuitionistically_if_2 -embed_wand=> ->. Qed
the result of wand elimination will have the affine modality. Otherwise, it
won't. Note that when the wand [⎡RR⎤] is under an affine modality, the instance
[into_wand_affine] would already have been used. *)
-Global Instance into_wand_affine_embed_true `{BiEmbed PROP PROP'} q (PP QQ RR : PROP) :
+Global Instance into_wand_affine_embed_true `{BiEmbed SI PROP PROP'} q (PP QQ RR : PROP) :
IntoWand true q RR PP QQ → IntoWand true q ⎡RR⎤ (<affine> ⎡PP⎤) (<affine> ⎡QQ⎤) | 100.
Proof.
rewrite /IntoWand /=.
@@ -483,7 +485,7 @@ Proof.
by rewrite wand_elim_r intuitionistically_affinely.
- by rewrite intuitionistically_affinely affinely_sep_2 -embed_sep wand_elim_r.
Qed.
-Global Instance into_wand_affine_embed_false `{BiEmbed PROP PROP'} q (PP QQ RR : PROP) :
+Global Instance into_wand_affine_embed_false `{BiEmbed SI PROP PROP'} q (PP QQ RR : PROP) :
IntoWand false q RR (<affine> PP) QQ → IntoWand false q ⎡RR⎤ (<affine> ⎡PP⎤) ⎡QQ⎤ | 100.
Proof.
rewrite /IntoWand /= => ->.
@@ -491,19 +493,19 @@ Proof.
Qed.
-Global Instance into_wand_bupd `{BiBUpd PROP} p q R P Q :
+Global Instance into_wand_bupd `{BiBUpd SI PROP} p q R P Q :
IntoWand false false R P Q → IntoWand p q (|==> R) (|==> P) (|==> Q).
Proof.
rewrite /IntoWand /= => HR. rewrite !intuitionistically_if_elim HR.
apply wand_intro_l. by rewrite bupd_sep wand_elim_r.
Qed.
-Global Instance into_wand_bupd_persistent `{BiBUpd PROP} p q R P Q :
+Global Instance into_wand_bupd_persistent `{BiBUpd SI PROP} p q R P Q :
IntoWand false q R P Q → IntoWand p q (|==> R) P (|==> Q).
Proof.
rewrite /IntoWand /= => HR. rewrite intuitionistically_if_elim HR.
apply wand_intro_l. by rewrite bupd_frame_l wand_elim_r.
Qed.
-Global Instance into_wand_bupd_args `{BiBUpd PROP} p q R P Q :
+Global Instance into_wand_bupd_args `{BiBUpd SI PROP} p q R P Q :
IntoWand p false R P Q → IntoWand' p q R (|==> P) (|==> Q).
Proof.
rewrite /IntoWand' /IntoWand /= => ->.
@@ -516,14 +518,14 @@ Proof. by rewrite /FromWand. Qed.
Global Instance from_wand_wandM mP1 P2 :
FromWand (mP1 -∗? P2) (default emp mP1)%I P2.
Proof. by rewrite /FromWand wandM_sound. Qed.
-Global Instance from_wand_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance from_wand_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
FromWand P Q1 Q2 → FromWand ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. by rewrite /FromWand -embed_wand => <-. Qed.
(** FromImpl *)
Global Instance from_impl_impl P1 P2 : FromImpl (P1 → P2) P1 P2.
Proof. by rewrite /FromImpl. Qed.
-Global Instance from_impl_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance from_impl_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
FromImpl P Q1 Q2 → FromImpl ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. by rewrite /FromImpl -embed_impl => <-. Qed.
@@ -545,7 +547,7 @@ Proof.
by rewrite absorbingly_elim_persistently -{2}(intuitionistically_elim P2).
Qed.
-Global Instance from_and_pure φ ψ : @FromAnd PROP ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
+Global Instance from_and_pure φ ψ : @FromAnd SI PROP ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
Proof. by rewrite /FromAnd pure_and. Qed.
Global Instance from_and_persistently P Q1 Q2 :
@@ -557,7 +559,7 @@ Global Instance from_and_persistently_sep P Q1 Q2 :
FromAnd (<pers> P) (<pers> Q1) (<pers> Q2) | 11.
Proof. rewrite /FromAnd=> <-. by rewrite -persistently_and persistently_and_sep. Qed.
-Global Instance from_and_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance from_and_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
FromAnd P Q1 Q2 → FromAnd ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. by rewrite /FromAnd -embed_and => <-. Qed.
@@ -609,7 +611,7 @@ Global Instance from_sep_and P1 P2 :
FromSep (P1 ∧ P2) P1 P2 | 101.
Proof. intros. by rewrite /FromSep sep_and. Qed.
-Global Instance from_sep_pure φ ψ : @FromSep PROP ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
+Global Instance from_sep_pure φ ψ : @FromSep SI PROP ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
Proof. by rewrite /FromSep pure_and sep_and. Qed.
Global Instance from_sep_affinely P Q1 Q2 :
@@ -626,7 +628,7 @@ Global Instance from_sep_persistently P Q1 Q2 :
FromSep (<pers> P) (<pers> Q1) (<pers> Q2).
Proof. rewrite /FromSep=> <-. by rewrite persistently_sep_2. Qed.
-Global Instance from_sep_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance from_sep_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
FromSep P Q1 Q2 → FromSep ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. by rewrite /FromSep -embed_sep => <-. Qed.
@@ -658,7 +660,7 @@ Global Instance from_sep_big_sepMS_disj_union `{Countable A} (Φ : A → PROP) X
FromSep ([∗ mset] y ∈ X1 ⊎ X2, Φ y) ([∗ mset] y ∈ X1, Φ y) ([∗ mset] y ∈ X2, Φ y).
Proof. by rewrite /FromSep big_sepMS_disj_union. Qed.
-Global Instance from_sep_bupd `{BiBUpd PROP} P Q1 Q2 :
+Global Instance from_sep_bupd `{BiBUpd SI PROP} P Q1 Q2 :
FromSep P Q1 Q2 → FromSep (|==> P) (|==> Q1) (|==> Q2).
Proof. rewrite /FromSep=><-. apply bupd_sep. Qed.
@@ -678,7 +680,7 @@ Proof.
by rewrite -(affine_affinely Q) affinely_and_r affinely_and (from_affinely P').
Qed.
-Global Instance into_and_sep `{BiPositive PROP} P Q : IntoAnd true (P ∗ Q) P Q.
+Global Instance into_and_sep `{BiPositive SI PROP} P Q : IntoAnd true (P ∗ Q) P Q.
Proof.
rewrite /IntoAnd /= intuitionistically_sep -and_sep_intuitionistically intuitionistically_and //.
Qed.
@@ -687,7 +689,7 @@ Global Instance into_and_sep_affine P Q :
IntoAnd true (P ∗ Q) P Q.
Proof. intros. by rewrite /IntoAnd /= sep_and. Qed.
-Global Instance into_and_pure p φ ψ : @IntoAnd PROP p ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
+Global Instance into_and_pure p φ ψ : @IntoAnd SI PROP p ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
Proof. by rewrite /IntoAnd pure_and intuitionistically_if_and. Qed.
Global Instance into_and_affinely p P Q1 Q2 :
@@ -712,7 +714,7 @@ Proof.
- rewrite -persistently_and !intuitionistically_persistently_elim //.
- intros ->. by rewrite persistently_and.
Qed.
-Global Instance into_and_embed `{BiEmbed PROP PROP'} p P Q1 Q2 :
+Global Instance into_and_embed `{BiEmbed SI PROP PROP'} p P Q1 Q2 :
IntoAnd p P Q1 Q2 → IntoAnd p ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof.
rewrite /IntoAnd -embed_and=> HP. apply intuitionistically_if_intro'.
@@ -747,17 +749,17 @@ Proof.
- by rewrite persistent_and_affinely_sep_r_1.
Qed.
-Global Instance into_sep_pure φ ψ : @IntoSep PROP ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
+Global Instance into_sep_pure φ ψ : @IntoSep SI PROP ⌜φ ∧ ψ⌠⌜φ⌠⌜ψâŒ.
Proof. by rewrite /IntoSep pure_and persistent_and_sep_1. Qed.
-Global Instance into_sep_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance into_sep_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. rewrite /IntoSep -embed_sep=> -> //. Qed.
-Global Instance into_sep_affinely `{BiPositive PROP} P Q1 Q2 :
+Global Instance into_sep_affinely `{BiPositive SI PROP} P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep (<affine> P) (<affine> Q1) (<affine> Q2) | 0.
Proof. rewrite /IntoSep /= => ->. by rewrite affinely_sep. Qed.
-Global Instance into_sep_intuitionistically `{BiPositive PROP} P Q1 Q2 :
+Global Instance into_sep_intuitionistically `{BiPositive SI PROP} P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep (□ P) (□ Q1) (□ Q2) | 0.
Proof. rewrite /IntoSep /= => ->. by rewrite intuitionistically_sep. Qed.
(* FIXME: This instance is kind of strange, it just gets rid of the bi_affinely.
@@ -767,7 +769,7 @@ Global Instance into_sep_affinely_trim P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep (<affine> P) Q1 Q2 | 20.
Proof. rewrite /IntoSep /= => ->. by rewrite affinely_elim. Qed.
-Global Instance into_sep_persistently `{BiPositive PROP} P Q1 Q2 :
+Global Instance into_sep_persistently `{BiPositive SI PROP} P Q1 Q2 :
IntoSep P Q1 Q2 →
IntoSep (<pers> P) (<pers> Q1) (<pers> Q2).
Proof. rewrite /IntoSep /= => ->. by rewrite persistently_sep. Qed.
@@ -814,7 +816,7 @@ Proof. by rewrite /IntoSep big_sepMS_disj_union. Qed.
(** FromOr *)
Global Instance from_or_or P1 P2 : FromOr (P1 ∨ P2) P1 P2.
Proof. by rewrite /FromOr. Qed.
-Global Instance from_or_pure φ ψ : @FromOr PROP ⌜φ ∨ ψ⌠⌜φ⌠⌜ψâŒ.
+Global Instance from_or_pure φ ψ : @FromOr SI PROP ⌜φ ∨ ψ⌠⌜φ⌠⌜ψâŒ.
Proof. by rewrite /FromOr pure_or. Qed.
Global Instance from_or_affinely P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (<affine> P) (<affine> Q1) (<affine> Q2).
@@ -829,11 +831,11 @@ Global Instance from_or_persistently P Q1 Q2 :
FromOr P Q1 Q2 →
FromOr (<pers> P) (<pers> Q1) (<pers> Q2).
Proof. rewrite /FromOr=> <-. by rewrite persistently_or. Qed.
-Global Instance from_or_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance from_or_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
FromOr P Q1 Q2 → FromOr ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. by rewrite /FromOr -embed_or => <-. Qed.
-Global Instance from_or_bupd `{BiBUpd PROP} P Q1 Q2 :
+Global Instance from_or_bupd `{BiBUpd SI PROP} P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (|==> P) (|==> Q1) (|==> Q2).
Proof.
rewrite /FromOr=><-.
@@ -843,7 +845,7 @@ Qed.
(** IntoOr *)
Global Instance into_or_or P Q : IntoOr (P ∨ Q) P Q.
Proof. by rewrite /IntoOr. Qed.
-Global Instance into_or_pure φ ψ : @IntoOr PROP ⌜φ ∨ ψ⌠⌜φ⌠⌜ψâŒ.
+Global Instance into_or_pure φ ψ : @IntoOr SI PROP ⌜φ ∨ ψ⌠⌜φ⌠⌜ψâŒ.
Proof. by rewrite /IntoOr pure_or. Qed.
Global Instance into_or_affinely P Q1 Q2 :
IntoOr P Q1 Q2 → IntoOr (<affine> P) (<affine> Q1) (<affine> Q2).
@@ -858,7 +860,7 @@ Global Instance into_or_persistently P Q1 Q2 :
IntoOr P Q1 Q2 →
IntoOr (<pers> P) (<pers> Q1) (<pers> Q2).
Proof. rewrite /IntoOr=>->. by rewrite persistently_or. Qed.
-Global Instance into_or_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
+Global Instance into_or_embed `{BiEmbed SI PROP PROP'} P Q1 Q2 :
IntoOr P Q1 Q2 → IntoOr ⎡P⎤ ⎡Q1⎤ ⎡Q2⎤.
Proof. by rewrite /IntoOr -embed_or => <-. Qed.
@@ -869,7 +871,7 @@ Global Instance from_exist_texist {A} (Φ : tele_arg A → PROP) :
FromExist (∃.. a, Φ a) Φ.
Proof. by rewrite /FromExist bi_texist_exist. Qed.
Global Instance from_exist_pure {A} (φ : A → Prop) :
- @FromExist PROP A ⌜∃ x, φ x⌠(λ a, ⌜φ aâŒ)%I.
+ @FromExist SI PROP A ⌜∃ x, φ x⌠(λ a, ⌜φ aâŒ)%I.
Proof. by rewrite /FromExist pure_exist. Qed.
Global Instance from_exist_affinely {A} P (Φ : A → PROP) :
FromExist P Φ → FromExist (<affine> P) (λ a, <affine> (Φ a))%I.
@@ -883,11 +885,11 @@ Proof. rewrite /FromExist=> <-. by rewrite absorbingly_exist. Qed.
Global Instance from_exist_persistently {A} P (Φ : A → PROP) :
FromExist P Φ → FromExist (<pers> P) (λ a, <pers> (Φ a))%I.
Proof. rewrite /FromExist=> <-. by rewrite persistently_exist. Qed.
-Global Instance from_exist_embed `{BiEmbed PROP PROP'} {A} P (Φ : A → PROP) :
+Global Instance from_exist_embed `{BiEmbed SI PROP PROP'} {A} P (Φ : A → PROP) :
FromExist P Φ → FromExist ⎡P⎤ (λ a, ⎡Φ a⎤%I).
Proof. by rewrite /FromExist -embed_exist => <-. Qed.
-Global Instance from_exist_bupd `{BiBUpd PROP} {A} P (Φ : A → PROP) :
+Global Instance from_exist_bupd `{BiBUpd SI PROP} {A} P (Φ : A → PROP) :
FromExist P Φ → FromExist (|==> P) (λ a, |==> Φ a)%I.
Proof.
rewrite /FromExist=><-. apply exist_elim=> a. by rewrite -(exist_intro a).
@@ -900,7 +902,7 @@ Global Instance into_exist_texist {A} (Φ : tele_arg A → PROP) :
IntoExist (∃.. a, Φ a) Φ | 10.
Proof. by rewrite /IntoExist bi_texist_exist. Qed.
Global Instance into_exist_pure {A} (φ : A → Prop) :
- @IntoExist PROP A ⌜∃ x, φ x⌠(λ a, ⌜φ aâŒ)%I.
+ @IntoExist SI PROP A ⌜∃ x, φ x⌠(λ a, ⌜φ aâŒ)%I.
Proof. by rewrite /IntoExist pure_exist. Qed.
Global Instance into_exist_affinely {A} P (Φ : A → PROP) :
IntoExist P Φ → IntoExist (<affine> P) (λ a, <affine> (Φ a))%I.
@@ -927,7 +929,7 @@ Proof. rewrite /IntoExist=> HP. by rewrite HP absorbingly_exist. Qed.
Global Instance into_exist_persistently {A} P (Φ : A → PROP) :
IntoExist P Φ → IntoExist (<pers> P) (λ a, <pers> (Φ a))%I.
Proof. rewrite /IntoExist=> HP. by rewrite HP persistently_exist. Qed.
-Global Instance into_exist_embed `{BiEmbed PROP PROP'} {A} P (Φ : A → PROP) :
+Global Instance into_exist_embed `{BiEmbed SI PROP PROP'} {A} P (Φ : A → PROP) :
IntoExist P Φ → IntoExist ⎡P⎤ (λ a, ⎡Φ a⎤%I).
Proof. by rewrite /IntoExist -embed_exist => <-. Qed.
@@ -946,7 +948,7 @@ Proof. rewrite /IntoForall=> HP. by rewrite HP intuitionistically_forall. Qed.
Global Instance into_forall_persistently {A} P (Φ : A → PROP) :
IntoForall P Φ → IntoForall (<pers> P) (λ a, <pers> (Φ a))%I.
Proof. rewrite /IntoForall=> HP. by rewrite HP persistently_forall. Qed.
-Global Instance into_forall_embed `{BiEmbed PROP PROP'} {A} P (Φ : A → PROP) :
+Global Instance into_forall_embed `{BiEmbed SI PROP PROP'} {A} P (Φ : A → PROP) :
IntoForall P Φ → IntoForall ⎡P⎤ (λ a, ⎡Φ a⎤%I).
Proof. by rewrite /IntoForall -embed_forall => <-. Qed.
@@ -984,10 +986,10 @@ Global Instance from_forall_tforall {A} (Φ : tele_arg A → PROP) :
FromForall (∀.. x, Φ x)%I Φ.
Proof. by rewrite /FromForall bi_tforall_forall. Qed.
Global Instance from_forall_pure {A} (φ : A → Prop) :
- @FromForall PROP A (⌜∀ a : A, φ aâŒ)%I (λ a, ⌜ φ a âŒ)%I.
+ @FromForall SI PROP A (⌜∀ a : A, φ aâŒ)%I (λ a, ⌜ φ a âŒ)%I.
Proof. by rewrite /FromForall pure_forall. Qed.
Global Instance from_forall_pure_not (φ : Prop) :
- @FromForall PROP φ (⌜¬ φâŒ)%I (λ a : φ, False)%I.
+ @FromForall SI PROP φ (⌜¬ φâŒ)%I (λ a : φ, False)%I.
Proof. by rewrite /FromForall pure_forall. Qed.
Global Instance from_forall_impl_pure P Q φ :
IntoPureT P φ → FromForall (P → Q)%I (λ _ : φ, Q)%I.
@@ -1004,7 +1006,7 @@ Proof.
- by rewrite (into_pure P) -pure_wand_forall wand_elim_l.
Qed.
-Global Instance from_forall_intuitionistically `{BiAffine PROP} {A} P (Φ : A → PROP) :
+Global Instance from_forall_intuitionistically `{BiAffine SI PROP} {A} P (Φ : A → PROP) :
FromForall P Φ → FromForall (□ P) (λ a, □ (Φ a))%I.
Proof.
rewrite /FromForall=> <-. setoid_rewrite intuitionistically_into_persistently.
@@ -1013,12 +1015,12 @@ Qed.
Global Instance from_forall_persistently {A} P (Φ : A → PROP) :
FromForall P Φ → FromForall (<pers> P)%I (λ a, <pers> (Φ a))%I.
Proof. rewrite /FromForall=> <-. by rewrite persistently_forall. Qed.
-Global Instance from_forall_embed `{BiEmbed PROP PROP'} {A} P (Φ : A → PROP) :
+Global Instance from_forall_embed `{BiEmbed SI PROP PROP'} {A} P (Φ : A → PROP) :
FromForall P Φ → FromForall ⎡P⎤%I (λ a, ⎡Φ a⎤%I).
Proof. by rewrite /FromForall -embed_forall => <-. Qed.
(** IntoInv *)
-Global Instance into_inv_embed {PROP' : bi} `{BiEmbed PROP PROP'} P N :
+Global Instance into_inv_embed {PROP' : bi SI} `{BiEmbed SI PROP PROP'} P N :
IntoInv P N → IntoInv ⎡P⎤ N := {}.
(** ElimModal *)
@@ -1044,19 +1046,19 @@ Proof.
absorbingly_sep_l wand_elim_r absorbing_absorbingly.
Qed.
-Global Instance elim_modal_bupd `{BiBUpd PROP} p P Q :
+Global Instance elim_modal_bupd `{BiBUpd SI PROP} p P Q :
ElimModal True p false (|==> P) P (|==> Q) (|==> Q).
Proof.
by rewrite /ElimModal
intuitionistically_if_elim bupd_frame_r wand_elim_r bupd_trans.
Qed.
-Global Instance elim_modal_embed_bupd_goal `{BiEmbedBUpd PROP PROP'}
+Global Instance elim_modal_embed_bupd_goal `{BiEmbedBUpd SI PROP PROP'}
p p' φ (P P' : PROP') (Q Q' : PROP) :
ElimModal φ p p' P P' (|==> ⎡Q⎤)%I (|==> ⎡Q'⎤)%I →
ElimModal φ p p' P P' ⎡|==> Q⎤ ⎡|==> Q'⎤.
Proof. by rewrite /ElimModal !embed_bupd. Qed.
-Global Instance elim_modal_embed_bupd_hyp `{BiEmbedBUpd PROP PROP'}
+Global Instance elim_modal_embed_bupd_hyp `{BiEmbedBUpd SI PROP PROP'}
p p' φ (P : PROP) (P' Q Q' : PROP') :
ElimModal φ p p' (|==> ⎡P⎤)%I P' Q Q' →
ElimModal φ p p' ⎡|==> P⎤ P' Q Q'.
@@ -1077,12 +1079,12 @@ Global Instance add_modal_forall {A} P P' (Φ : A → PROP) :
Proof.
rewrite /AddModal=> H. apply forall_intro=> a. by rewrite (forall_elim a).
Qed.
-Global Instance add_modal_embed_bupd_goal `{BiEmbedBUpd PROP PROP'}
+Global Instance add_modal_embed_bupd_goal `{BiEmbedBUpd SI PROP PROP'}
(P P' : PROP') (Q : PROP) :
AddModal P P' (|==> ⎡Q⎤)%I → AddModal P P' ⎡|==> Q⎤.
Proof. by rewrite /AddModal !embed_bupd. Qed.
-Global Instance add_modal_bupd `{BiBUpd PROP} P Q : AddModal (|==> P) P (|==> Q).
+Global Instance add_modal_bupd `{BiBUpd SI PROP} P Q : AddModal (|==> P) P (|==> Q).
Proof. by rewrite /AddModal bupd_frame_r wand_elim_r bupd_trans. Qed.
(** ElimInv *)
@@ -1120,10 +1122,10 @@ Proof.
Qed.
(** IntoEmbed *)
-Global Instance into_embed_embed {PROP' : bi} `{BiEmbed PROP PROP'} P :
+Global Instance into_embed_embed {PROP' : bi SI} `{BiEmbed SI PROP PROP'} P :
IntoEmbed ⎡P⎤ P.
Proof. by rewrite /IntoEmbed. Qed.
-Global Instance into_embed_affinely `{BiEmbedBUpd PROP PROP'} (P : PROP') (Q : PROP) :
+Global Instance into_embed_affinely `{BiEmbedBUpd SI PROP PROP'} (P : PROP') (Q : PROP) :
IntoEmbed P Q → IntoEmbed (<affine> P) (<affine> Q).
Proof. rewrite /IntoEmbed=> ->. by rewrite embed_affinely_2. Qed.
End bi_instances.
diff --git a/theories/proofmode/class_instances_sbi.v b/theories/proofmode/class_instances_sbi.v
index bda75b7782e05a282d1a876de54395abb166d6ca..6f1393bb57e7fdae03e6593b59b2436adf114077 100644
--- a/theories/proofmode/class_instances_sbi.v
+++ b/theories/proofmode/class_instances_sbi.v
@@ -5,7 +5,7 @@ Set Default Proof Using "Type".
Import bi.
Section sbi_instances.
-Context {PROP : sbi}.
+Context {SI} {PROP : sbi SI}.
Implicit Types P Q R : PROP.
(** FromAssumption *)
@@ -19,17 +19,17 @@ Global Instance from_assumption_except_0 p P Q :
FromAssumption p P Q → KnownRFromAssumption p P (◇ Q)%I.
Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply except_0_intro. Qed.
-Global Instance from_assumption_fupd `{BiBUpdFUpd PROP} E p P Q :
+Global Instance from_assumption_fupd `{BiBUpdFUpd SI PROP} E p P Q :
FromAssumption p P (|==> Q) → KnownRFromAssumption p P (|={E}=> Q)%I.
Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply bupd_fupd. Qed.
-Global Instance from_assumption_plainly_l_true `{BiPlainly PROP} P Q :
+Global Instance from_assumption_plainly_l_true `{BiPlainly SI PROP} P Q :
FromAssumption true P Q → KnownLFromAssumption true (■P) Q.
Proof.
rewrite /KnownLFromAssumption /FromAssumption /= =><-.
rewrite intuitionistically_plainly_elim //.
Qed.
-Global Instance from_assumption_plainly_l_false `{BiPlainly PROP, BiAffine PROP} P Q :
+Global Instance from_assumption_plainly_l_false `{BiPlainly SI PROP, BiAffine SI PROP} P Q :
FromAssumption true P Q → KnownLFromAssumption false (■P) Q.
Proof.
rewrite /KnownLFromAssumption /FromAssumption /= =><-.
@@ -37,8 +37,8 @@ Proof.
Qed.
(** FromPure *)
-Global Instance from_pure_internal_eq {A : ofeT} (a b : A) :
- @FromPure PROP false (a ≡ b) (a ≡ b).
+Global Instance from_pure_internal_eq {A : ofeT SI} (a b : A) :
+ @FromPure SI PROP false (a ≡ b) (a ≡ b).
Proof. by rewrite /FromPure pure_internal_eq. Qed.
Global Instance from_pure_later a P φ : FromPure a P φ → FromPure a (▷ P) φ.
Proof. rewrite /FromPure=> ->. apply later_intro. Qed.
@@ -47,20 +47,20 @@ Proof. rewrite /FromPure=> ->. apply laterN_intro. Qed.
Global Instance from_pure_except_0 a P φ : FromPure a P φ → FromPure a (◇ P) φ.
Proof. rewrite /FromPure=> ->. apply except_0_intro. Qed.
-Global Instance from_pure_fupd `{BiFUpd PROP} a E P φ :
+Global Instance from_pure_fupd `{BiFUpd SI PROP} a E P φ :
FromPure a P φ → FromPure a (|={E}=> P) φ.
Proof. rewrite /FromPure. intros <-. apply fupd_intro. Qed.
-Global Instance from_pure_plainly `{BiPlainly PROP} P φ :
+Global Instance from_pure_plainly `{BiPlainly SI PROP} P φ :
FromPure false P φ → FromPure false (■P) φ.
Proof. rewrite /FromPure=> <-. by rewrite plainly_pure. Qed.
(** IntoPure *)
-Global Instance into_pure_eq {A : ofeT} (a b : A) :
- Discrete a → @IntoPure PROP (a ≡ b) (a ≡ b).
+Global Instance into_pure_eq {A : ofeT SI} (a b : A) :
+ Discrete a → @IntoPure SI PROP (a ≡ b) (a ≡ b).
Proof. intros. by rewrite /IntoPure discrete_eq. Qed.
-Global Instance into_pure_plainly `{BiPlainly PROP} P φ :
+Global Instance into_pure_plainly `{BiPlainly SI PROP} P φ :
IntoPure P φ → IntoPure (■P) φ.
Proof. rewrite /IntoPure=> ->. apply: plainly_elim. Qed.
@@ -92,30 +92,30 @@ Proof.
(laterN_intro _ (â–¡?p R)%I) -laterN_wand HR.
Qed.
-Global Instance into_wand_fupd `{BiFUpd PROP} E p q R P Q :
+Global Instance into_wand_fupd `{BiFUpd SI PROP} E p q R P Q :
IntoWand false false R P Q →
IntoWand p q (|={E}=> R) (|={E}=> P) (|={E}=> Q).
Proof.
rewrite /IntoWand /= => HR. rewrite !intuitionistically_if_elim HR.
apply wand_intro_l. by rewrite fupd_sep wand_elim_r.
Qed.
-Global Instance into_wand_fupd_persistent `{BiFUpd PROP} E1 E2 p q R P Q :
+Global Instance into_wand_fupd_persistent `{BiFUpd SI PROP} E1 E2 p q R P Q :
IntoWand false q R P Q → IntoWand p q (|={E1,E2}=> R) P (|={E1,E2}=> Q).
Proof.
rewrite /IntoWand /= => HR. rewrite intuitionistically_if_elim HR.
apply wand_intro_l. by rewrite fupd_frame_l wand_elim_r.
Qed.
-Global Instance into_wand_fupd_args `{BiFUpd PROP} E1 E2 p q R P Q :
+Global Instance into_wand_fupd_args `{BiFUpd SI PROP} E1 E2 p q R P Q :
IntoWand p false R P Q → IntoWand' p q R (|={E1,E2}=> P) (|={E1,E2}=> Q).
Proof.
rewrite /IntoWand' /IntoWand /= => ->.
apply wand_intro_l. by rewrite intuitionistically_if_elim fupd_wand_r.
Qed.
-Global Instance into_wand_plainly_true `{BiPlainly PROP} q R P Q :
+Global Instance into_wand_plainly_true `{BiPlainly SI PROP} q R P Q :
IntoWand true q R P Q → IntoWand true q (■R) P Q.
Proof. rewrite /IntoWand /= intuitionistically_plainly_elim //. Qed.
-Global Instance into_wand_plainly_false `{BiPlainly PROP} q R P Q :
+Global Instance into_wand_plainly_false `{BiPlainly SI PROP} q R P Q :
Absorbing R → IntoWand false q R P Q → IntoWand false q (■R) P Q.
Proof. intros ?. by rewrite /IntoWand plainly_elim. Qed.
@@ -130,26 +130,26 @@ Global Instance from_and_except_0 P Q1 Q2 :
FromAnd P Q1 Q2 → FromAnd (◇ P) (◇ Q1) (◇ Q2).
Proof. rewrite /FromAnd=><-. by rewrite except_0_and. Qed.
-Global Instance from_and_plainly `{BiPlainly PROP} P Q1 Q2 :
+Global Instance from_and_plainly `{BiPlainly SI PROP} P Q1 Q2 :
FromAnd P Q1 Q2 → FromAnd (■P) (■Q1) (■Q2).
Proof. rewrite /FromAnd=> <-. by rewrite plainly_and. Qed.
(** FromSep *)
Global Instance from_sep_later P Q1 Q2 :
FromSep P Q1 Q2 → FromSep (▷ P) (▷ Q1) (▷ Q2).
-Proof. rewrite /FromSep=> <-. by rewrite later_sep. Qed.
+Proof. rewrite /FromSep=> <-. by rewrite later_sep_2. Qed.
Global Instance from_sep_laterN n P Q1 Q2 :
FromSep P Q1 Q2 → FromSep (▷^n P) (▷^n Q1) (▷^n Q2).
-Proof. rewrite /FromSep=> <-. by rewrite laterN_sep. Qed.
+Proof. rewrite /FromSep=> <-. by rewrite laterN_sep_2. Qed.
Global Instance from_sep_except_0 P Q1 Q2 :
FromSep P Q1 Q2 → FromSep (◇ P) (◇ Q1) (◇ Q2).
Proof. rewrite /FromSep=><-. by rewrite except_0_sep. Qed.
-Global Instance from_sep_fupd `{BiFUpd PROP} E P Q1 Q2 :
+Global Instance from_sep_fupd `{BiFUpd SI PROP} E P Q1 Q2 :
FromSep P Q1 Q2 → FromSep (|={E}=> P) (|={E}=> Q1) (|={E}=> Q2).
Proof. rewrite /FromSep =><-. apply fupd_sep. Qed.
-Global Instance from_sep_plainly `{BiPlainly PROP} P Q1 Q2 :
+Global Instance from_sep_plainly `{BiPlainly SI PROP} P Q1 Q2 :
FromSep P Q1 Q2 → FromSep (■P) (■Q1) (■Q2).
Proof. rewrite /FromSep=> <-. by rewrite plainly_sep_2. Qed.
@@ -176,7 +176,7 @@ Proof.
intuitionistically_if_elim except_0_and.
Qed.
-Global Instance into_and_plainly `{BiPlainly PROP} p P Q1 Q2 :
+Global Instance into_and_plainly `{BiPlainly SI PROP} p P Q1 Q2 :
IntoAnd p P Q1 Q2 → IntoAnd p (■P) (■Q1) (■Q2).
Proof.
rewrite /IntoAnd /=. destruct p; simpl.
@@ -186,10 +186,10 @@ Proof.
Qed.
(** IntoSep *)
-Global Instance into_sep_later P Q1 Q2 :
+Global Instance into_sep_later `{FiniteIndex SI} P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep (▷ P) (▷ Q1) (▷ Q2).
Proof. rewrite /IntoSep=> ->. by rewrite later_sep. Qed.
-Global Instance into_sep_laterN n P Q1 Q2 :
+Global Instance into_sep_laterN `{FiniteIndex SI} n P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep (▷^n P) (▷^n Q1) (▷^n Q2).
Proof. rewrite /IntoSep=> ->. by rewrite laterN_sep. Qed.
Global Instance into_sep_except_0 P Q1 Q2 :
@@ -197,7 +197,7 @@ Global Instance into_sep_except_0 P Q1 Q2 :
Proof. rewrite /IntoSep=> ->. by rewrite except_0_sep. Qed.
(* FIXME: This instance is overly specific, generalize it. *)
-Global Instance into_sep_affinely_later `{!Timeless (PROP:=PROP) emp} P Q1 Q2 :
+Global Instance into_sep_affinely_later `{FiniteIndex SI} `{!Timeless (PROP:=PROP) emp} P Q1 Q2 :
IntoSep P Q1 Q2 → Affine Q1 → Affine Q2 →
IntoSep (<affine> â–· P) (<affine> â–· Q1) (<affine> â–· Q2).
Proof.
@@ -208,11 +208,11 @@ Proof.
by rewrite -(False_elim Q1) -(False_elim Q2).
Qed.
-Global Instance into_sep_plainly `{BiPlainly PROP, BiPositive PROP} P Q1 Q2 :
+Global Instance into_sep_plainly `{BiPlainly SI PROP, BiPositive SI PROP} P Q1 Q2 :
IntoSep P Q1 Q2 → IntoSep (■P) (■Q1) (■Q2).
Proof. rewrite /IntoSep /= => ->. by rewrite plainly_sep. Qed.
-Global Instance into_sep_plainly_affine `{BiPlainly PROP} P Q1 Q2 :
+Global Instance into_sep_plainly_affine `{BiPlainly SI PROP} P Q1 Q2 :
IntoSep P Q1 Q2 →
TCOr (Affine Q1) (Absorbing Q2) → TCOr (Absorbing Q1) (Affine Q2) →
IntoSep (â– P) (â– Q1) (â– Q2).
@@ -221,39 +221,40 @@ Proof.
Qed.
(** FromOr *)
-Global Instance from_or_later P Q1 Q2 :
+(* TODO: allow this without assumption? *)
+Global Instance from_or_later `{FiniteBoundedExistential SI} P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (▷ P) (▷ Q1) (▷ Q2).
Proof. rewrite /FromOr=><-. by rewrite later_or. Qed.
-Global Instance from_or_laterN n P Q1 Q2 :
+Global Instance from_or_laterN `{FiniteBoundedExistential SI} n P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (▷^n P) (▷^n Q1) (▷^n Q2).
Proof. rewrite /FromOr=><-. by rewrite laterN_or. Qed.
Global Instance from_or_except_0 P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (◇ P) (◇ Q1) (◇ Q2).
Proof. rewrite /FromOr=><-. by rewrite except_0_or. Qed.
-Global Instance from_or_fupd `{BiFUpd PROP} E1 E2 P Q1 Q2 :
+Global Instance from_or_fupd `{BiFUpd SI PROP} E1 E2 P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (|={E1,E2}=> P) (|={E1,E2}=> Q1) (|={E1,E2}=> Q2).
Proof.
rewrite /FromOr=><-. apply or_elim; apply fupd_mono;
[apply bi.or_intro_l|apply bi.or_intro_r].
Qed.
-Global Instance from_or_plainly `{BiPlainly PROP} P Q1 Q2 :
+Global Instance from_or_plainly `{BiPlainly SI PROP} P Q1 Q2 :
FromOr P Q1 Q2 → FromOr (■P) (■Q1) (■Q2).
Proof. rewrite /FromOr=> <-. by rewrite -plainly_or_2. Qed.
(** IntoOr *)
-Global Instance into_or_later P Q1 Q2 :
+Global Instance into_or_later `{FiniteBoundedExistential SI} P Q1 Q2 :
IntoOr P Q1 Q2 → IntoOr (▷ P) (▷ Q1) (▷ Q2).
Proof. rewrite /IntoOr=>->. by rewrite later_or. Qed.
-Global Instance into_or_laterN n P Q1 Q2 :
+Global Instance into_or_laterN `{FiniteBoundedExistential SI} n P Q1 Q2 :
IntoOr P Q1 Q2 → IntoOr (▷^n P) (▷^n Q1) (▷^n Q2).
Proof. rewrite /IntoOr=>->. by rewrite laterN_or. Qed.
Global Instance into_or_except_0 P Q1 Q2 :
IntoOr P Q1 Q2 → IntoOr (◇ P) (◇ Q1) (◇ Q2).
Proof. rewrite /IntoOr=>->. by rewrite except_0_or. Qed.
-Global Instance into_or_plainly `{BiPlainly PROP, BiPlainlyExist PROP} P Q1 Q2 :
+Global Instance into_or_plainly `{BiPlainly SI PROP, BiPlainlyExist SI PROP} P Q1 Q2 :
IntoOr P Q1 Q2 → IntoOr (■P) (■Q1) (■Q2).
Proof. rewrite /IntoOr=>->. by rewrite plainly_or. Qed.
@@ -272,28 +273,28 @@ Global Instance from_exist_except_0 {A} P (Φ : A → PROP) :
FromExist P Φ → FromExist (◇ P) (λ a, ◇ (Φ a))%I.
Proof. rewrite /FromExist=> <-. by rewrite except_0_exist_2. Qed.
-Global Instance from_exist_fupd `{BiFUpd PROP} {A} E1 E2 P (Φ : A → PROP) :
+Global Instance from_exist_fupd `{BiFUpd SI PROP} {A} E1 E2 P (Φ : A → PROP) :
FromExist P Φ → FromExist (|={E1,E2}=> P) (λ a, |={E1,E2}=> Φ a)%I.
Proof.
rewrite /FromExist=><-. apply exist_elim=> a. by rewrite -(exist_intro a).
Qed.
-Global Instance from_exist_plainly `{BiPlainly PROP} {A} P (Φ : A → PROP) :
+Global Instance from_exist_plainly `{BiPlainly SI PROP} {A} P (Φ : A → PROP) :
FromExist P Φ → FromExist (■P) (λ a, ■(Φ a))%I.
Proof. rewrite /FromExist=> <-. by rewrite -plainly_exist_2. Qed.
(** IntoExist *)
-Global Instance into_exist_later {A} P (Φ : A → PROP) :
+Global Instance into_exist_later `{FiniteIndex SI} {A} P (Φ : A → PROP) :
IntoExist P Φ → Inhabited A → IntoExist (▷ P) (λ a, ▷ (Φ a))%I.
Proof. rewrite /IntoExist=> HP ?. by rewrite HP later_exist. Qed.
-Global Instance into_exist_laterN {A} n P (Φ : A → PROP) :
+Global Instance into_exist_laterN `{FiniteIndex SI} {A} n P (Φ : A → PROP) :
IntoExist P Φ → Inhabited A → IntoExist (▷^n P) (λ a, ▷^n (Φ a))%I.
Proof. rewrite /IntoExist=> HP ?. by rewrite HP laterN_exist. Qed.
Global Instance into_exist_except_0 {A} P (Φ : A → PROP) :
IntoExist P Φ → Inhabited A → IntoExist (◇ P) (λ a, ◇ (Φ a))%I.
Proof. rewrite /IntoExist=> HP ?. by rewrite HP except_0_exist. Qed.
-Global Instance into_exist_plainly `{BiPlainlyExist PROP} {A} P (Φ : A → PROP) :
+Global Instance into_exist_plainly `{BiPlainlyExist SI PROP} {A} P (Φ : A → PROP) :
IntoExist P Φ → IntoExist (■P) (λ a, ■(Φ a))%I.
Proof. rewrite /IntoExist=> HP. by rewrite HP plainly_exist. Qed.
@@ -310,7 +311,7 @@ Global Instance into_forall_except_0 {A} P (Φ : A → PROP) :
IntoForall P Φ → IntoForall (◇ P) (λ a, ◇ (Φ a))%I.
Proof. rewrite /IntoForall=> HP. by rewrite HP except_0_forall. Qed.
-Global Instance into_forall_plainly `{BiPlainly PROP} {A} P (Φ : A → PROP) :
+Global Instance into_forall_plainly `{BiPlainly SI PROP} {A} P (Φ : A → PROP) :
IntoForall P Φ → IntoForall (■P) (λ a, ■(Φ a))%I.
Proof. rewrite /IntoForall=> HP. by rewrite HP plainly_forall. Qed.
@@ -327,11 +328,11 @@ Global Instance from_forall_except_0 {A} P (Φ : A → PROP) :
FromForall P Φ → FromForall (◇ P)%I (λ a, ◇ (Φ a))%I.
Proof. rewrite /FromForall=> <-. by rewrite except_0_forall. Qed.
-Global Instance from_forall_plainly `{BiPlainly PROP} {A} P (Φ : A → PROP) :
+Global Instance from_forall_plainly `{BiPlainly SI PROP} {A} P (Φ : A → PROP) :
FromForall P Φ → FromForall (■P)%I (λ a, ■(Φ a))%I.
Proof. rewrite /FromForall=> <-. by rewrite plainly_forall. Qed.
-Global Instance from_forall_fupd `{BiFUpdPlainly PROP} E1 E2 {A} P (Φ : A → PROP) :
+Global Instance from_forall_fupd `{BiFUpdPlainly SI PROP} E1 E2 {A} P (Φ : A → PROP) :
(* Some cases in which [E2 ⊆ E1] holds *)
TCOr (TCEq E1 E2) (TCOr (TCEq E1 ⊤) (TCEq E2 ∅)) →
FromForall P Φ → (∀ x, Plain (Φ x)) →
@@ -340,7 +341,7 @@ Proof.
rewrite /FromForall=> -[->|[->|->]] <- ?; rewrite fupd_plain_forall; set_solver.
Qed.
-Global Instance from_forall_step_fupd `{BiFUpdPlainly PROP} E1 E2 {A} P (Φ : A → PROP) :
+Global Instance from_forall_step_fupd `{BiFUpdPlainly SI PROP} E1 E2 {A} P (Φ : A → PROP) :
(* Some cases in which [E2 ⊆ E1] holds *)
TCOr (TCEq E1 E2) (TCOr (TCEq E1 ⊤) (TCEq E2 ∅)) →
FromForall P Φ → (∀ x, Plain (Φ x)) →
@@ -354,15 +355,15 @@ Global Instance is_except_0_except_0 P : IsExcept0 (â—‡ P).
Proof. by rewrite /IsExcept0 except_0_idemp. Qed.
Global Instance is_except_0_later P : IsExcept0 (â–· P).
Proof. by rewrite /IsExcept0 except_0_later. Qed.
-Global Instance is_except_0_embed `{SbiEmbed PROP PROP'} P :
+Global Instance is_except_0_embed `{SbiEmbed SI PROP PROP'} P :
IsExcept0 P → IsExcept0 ⎡P⎤.
Proof. by rewrite /IsExcept0 -embed_except_0=>->. Qed.
-Global Instance is_except_0_bupd `{BiBUpd PROP} P : IsExcept0 P → IsExcept0 (|==> P).
+Global Instance is_except_0_bupd `{BiBUpd SI PROP} P : IsExcept0 P → IsExcept0 (|==> P).
Proof.
rewrite /IsExcept0=> HP.
by rewrite -{2}HP -(except_0_idemp P) -except_0_bupd -(except_0_intro P).
Qed.
-Global Instance is_except_0_fupd `{BiFUpd PROP} E1 E2 P :
+Global Instance is_except_0_fupd `{BiFUpd SI PROP} E1 E2 P :
IsExcept0 (|={E1,E2}=> P).
Proof. by rewrite /IsExcept0 except_0_fupd. Qed.
@@ -376,46 +377,46 @@ Proof. by rewrite /FromModal. Qed.
Global Instance from_modal_except_0 P : FromModal modality_id (â—‡ P) (â—‡ P) P.
Proof. by rewrite /FromModal /= -except_0_intro. Qed.
-Global Instance from_modal_fupd E P `{BiFUpd PROP} :
+Global Instance from_modal_fupd E P `{BiFUpd SI PROP} :
FromModal modality_id (|={E}=> P) (|={E}=> P) P.
Proof. by rewrite /FromModal /= -fupd_intro. Qed.
-Global Instance from_modal_later_embed `{SbiEmbed PROP PROP'} `(sel : A) n P Q :
+Global Instance from_modal_later_embed `{SbiEmbed SI PROP PROP'} `(sel : A) n P Q :
FromModal (modality_laterN n) sel P Q →
FromModal (modality_laterN n) sel ⎡P⎤ ⎡Q⎤.
Proof. rewrite /FromModal /= =><-. by rewrite embed_laterN. Qed.
-Global Instance from_modal_plainly `{BiPlainly PROP} P :
+Global Instance from_modal_plainly `{BiPlainly SI PROP} P :
FromModal modality_plainly (â– P) (â– P) P | 2.
Proof. by rewrite /FromModal. Qed.
-Global Instance from_modal_plainly_embed `{BiPlainly PROP, BiPlainly PROP',
- BiEmbedPlainly PROP PROP', !SbiEmbed PROP PROP'} `(sel : A) P Q :
+Global Instance from_modal_plainly_embed `{BiPlainly SI PROP, BiPlainly SI PROP',
+ BiEmbedPlainly SI PROP PROP', !SbiEmbed PROP PROP'} `(sel : A) P Q :
FromModal modality_plainly sel P Q →
FromModal (PROP2:=PROP') modality_plainly sel ⎡P⎤ ⎡Q⎤ | 100.
Proof. rewrite /FromModal /= =><-. by rewrite embed_plainly. Qed.
(** IntoInternalEq *)
-Global Instance into_internal_eq_internal_eq {A : ofeT} (x y : A) :
- @IntoInternalEq PROP A (x ≡ y) x y.
+Global Instance into_internal_eq_internal_eq {A : ofeT SI} (x y : A) :
+ @IntoInternalEq SI PROP A (x ≡ y) x y.
Proof. by rewrite /IntoInternalEq. Qed.
-Global Instance into_internal_eq_affinely {A : ofeT} (x y : A) P :
+Global Instance into_internal_eq_affinely {A : ofeT SI} (x y : A) P :
IntoInternalEq P x y → IntoInternalEq (<affine> P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite affinely_elim. Qed.
-Global Instance into_internal_eq_intuitionistically {A : ofeT} (x y : A) P :
+Global Instance into_internal_eq_intuitionistically {A : ofeT SI} (x y : A) P :
IntoInternalEq P x y → IntoInternalEq (□ P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite intuitionistically_elim. Qed.
-Global Instance into_internal_eq_absorbingly {A : ofeT} (x y : A) P :
+Global Instance into_internal_eq_absorbingly {A : ofeT SI} (x y : A) P :
IntoInternalEq P x y → IntoInternalEq (<absorb> P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite absorbingly_internal_eq. Qed.
-Global Instance into_internal_eq_plainly `{BiPlainly PROP} {A : ofeT} (x y : A) P :
+Global Instance into_internal_eq_plainly `{BiPlainly SI PROP} {A : ofeT SI} (x y : A) P :
IntoInternalEq P x y → IntoInternalEq (■P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite plainly_elim. Qed.
-Global Instance into_internal_eq_persistently {A : ofeT} (x y : A) P :
+Global Instance into_internal_eq_persistently {A : ofeT SI} (x y : A) P :
IntoInternalEq P x y → IntoInternalEq (<pers> P) x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite persistently_elim. Qed.
Global Instance into_internal_eq_embed
- `{SbiEmbed PROP PROP'} {A : ofeT} (x y : A) P :
+ `{SbiEmbed SI PROP PROP'} {A : ofeT SI} (x y : A) P :
IntoInternalEq P x y → IntoInternalEq ⎡P⎤ x y.
Proof. rewrite /IntoInternalEq=> ->. by rewrite embed_internal_eq. Qed.
@@ -436,13 +437,13 @@ Proof. rewrite /IntoExcept0=> ->. by rewrite except_0_intuitionistically_2. Qed.
Global Instance into_except_0_absorbingly P Q :
IntoExcept0 P Q → IntoExcept0 (<absorb> P) (<absorb> Q).
Proof. rewrite /IntoExcept0=> ->. by rewrite except_0_absorbingly. Qed.
-Global Instance into_except_0_plainly `{BiPlainly PROP, BiPlainlyExist PROP} P Q :
+Global Instance into_except_0_plainly `{BiPlainly SI PROP, BiPlainlyExist SI PROP} P Q :
IntoExcept0 P Q → IntoExcept0 (■P) (■Q).
Proof. rewrite /IntoExcept0=> ->. by rewrite except_0_plainly. Qed.
Global Instance into_except_0_persistently P Q :
IntoExcept0 P Q → IntoExcept0 (<pers> P) (<pers> Q).
Proof. rewrite /IntoExcept0=> ->. by rewrite except_0_persistently. Qed.
-Global Instance into_except_0_embed `{SbiEmbed PROP PROP'} P Q :
+Global Instance into_except_0_embed `{SbiEmbed SI PROP PROP'} P Q :
IntoExcept0 P Q → IntoExcept0 ⎡P⎤ ⎡Q⎤.
Proof. rewrite /IntoExcept0=> ->. by rewrite embed_except_0. Qed.
@@ -454,35 +455,35 @@ Proof.
by rewrite except_0_intuitionistically_if_2 -except_0_sep wand_elim_r.
Qed.
-Global Instance elim_modal_bupd_plain_goal `{BiBUpdPlainly PROP} p P Q :
+Global Instance elim_modal_bupd_plain_goal `{BiBUpdPlainly SI PROP} p P Q :
Plain Q → ElimModal True p false (|==> P) P Q Q.
Proof.
intros. by rewrite /ElimModal intuitionistically_if_elim
bupd_frame_r wand_elim_r bupd_plain.
Qed.
-Global Instance elim_modal_bupd_plain `{BiBUpdPlainly PROP} p P Q :
+Global Instance elim_modal_bupd_plain `{BiBUpdPlainly SI PROP} p P Q :
Plain P → ElimModal True p p (|==> P) P Q Q.
Proof. intros. by rewrite /ElimModal bupd_plain wand_elim_r. Qed.
-Global Instance elim_modal_bupd_fupd `{BiBUpdFUpd PROP} p E1 E2 P Q :
+Global Instance elim_modal_bupd_fupd `{BiBUpdFUpd SI PROP} p E1 E2 P Q :
ElimModal True p false (|==> P) P (|={E1,E2}=> Q) (|={E1,E2}=> Q) | 10.
Proof.
by rewrite /ElimModal intuitionistically_if_elim
(bupd_fupd E1) fupd_frame_r wand_elim_r fupd_trans.
Qed.
-Global Instance elim_modal_fupd_fupd `{BiFUpd PROP} p E1 E2 E3 P Q :
+Global Instance elim_modal_fupd_fupd `{BiFUpd SI PROP} p E1 E2 E3 P Q :
ElimModal True p false (|={E1,E2}=> P) P (|={E1,E3}=> Q) (|={E2,E3}=> Q).
Proof.
by rewrite /ElimModal intuitionistically_if_elim
fupd_frame_r wand_elim_r fupd_trans.
Qed.
-Global Instance elim_modal_embed_fupd_goal `{BiEmbedFUpd PROP PROP'}
+Global Instance elim_modal_embed_fupd_goal `{BiEmbedFUpd SI PROP PROP'}
p p' φ E1 E2 E3 (P P' : PROP') (Q Q' : PROP) :
ElimModal φ p p' P P' (|={E1,E3}=> ⎡Q⎤)%I (|={E2,E3}=> ⎡Q'⎤)%I →
ElimModal φ p p' P P' ⎡|={E1,E3}=> Q⎤ ⎡|={E2,E3}=> Q'⎤.
Proof. by rewrite /ElimModal !embed_fupd. Qed.
-Global Instance elim_modal_embed_fupd_hyp `{BiEmbedFUpd PROP PROP'}
+Global Instance elim_modal_embed_fupd_hyp `{BiEmbedFUpd SI PROP PROP'}
p p' φ E1 E2 (P : PROP) (P' Q Q' : PROP') :
ElimModal φ p p' (|={E1,E2}=> ⎡P⎤)%I P' Q Q' →
ElimModal φ p p' ⎡|={E1,E2}=> P⎤ P' Q Q'.
@@ -513,17 +514,17 @@ Proof.
by rewrite -except_0_sep wand_elim_r except_0_later.
Qed.
-Global Instance add_modal_fupd `{BiFUpd PROP} E1 E2 P Q :
+Global Instance add_modal_fupd `{BiFUpd SI PROP} E1 E2 P Q :
AddModal (|={E1}=> P) P (|={E1,E2}=> Q).
Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_trans. Qed.
-Global Instance add_modal_embed_fupd_goal `{BiEmbedFUpd PROP PROP'}
+Global Instance add_modal_embed_fupd_goal `{BiEmbedFUpd SI PROP PROP'}
E1 E2 (P P' : PROP') (Q : PROP) :
AddModal P P' (|={E1,E2}=> ⎡Q⎤)%I → AddModal P P' ⎡|={E1,E2}=> Q⎤.
Proof. by rewrite /AddModal !embed_fupd. Qed.
(** ElimAcc *)
-Global Instance elim_acc_fupd `{BiFUpd PROP} {X} E1 E2 E α β mγ Q :
+Global Instance elim_acc_fupd `{BiFUpd SI PROP} {X} E1 E2 E α β mγ Q :
(* FIXME: Why %I? ElimAcc sets the right scopes! *)
ElimAcc (X:=X) (fupd E1 E2) (fupd E2 E1) α β mγ
(|={E1,E}=> Q)
@@ -567,7 +568,7 @@ Proof.
move=> Hn [_ ->|->] <-; by rewrite -!laterN_plus -Hn Nat.add_comm.
Qed.
-Global Instance into_laterN_Next {A : ofeT} only_head n n' (x y : A) :
+Global Instance into_laterN_Next {A : ofeT SI} only_head n n' (x y : A) :
NatCancel n 1 n' 0 →
IntoLaterN (PROP:=PROP) only_head n (Next x ≡ Next y) (x ≡ y) | 2.
Proof.
@@ -594,11 +595,12 @@ Global Instance into_laterN_exist {A} n (Φ Ψ : A → PROP) :
IntoLaterN false n (∃ x, Φ x) (∃ x, Ψ x).
Proof. rewrite /IntoLaterN /MaybeIntoLaterN -laterN_exist_2=> ?. by apply exist_mono. Qed.
-Global Instance into_laterN_or_l n P1 P2 Q1 Q2 :
+(* TODO: decide whether to allow this *)
+Global Instance into_laterN_or_l `{FiniteBoundedExistential SI} n P1 P2 Q1 Q2 :
IntoLaterN false n P1 Q1 → MaybeIntoLaterN false n P2 Q2 →
IntoLaterN false n (P1 ∨ P2) (Q1 ∨ Q2) | 10.
Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> -> ->. by rewrite laterN_or. Qed.
-Global Instance into_laterN_or_r n P P2 Q2 :
+Global Instance into_laterN_or_r `{FiniteBoundedExistential SI} n P P2 Q2 :
IntoLaterN false n P2 Q2 →
IntoLaterN false n (P ∨ P2) (P ∨ Q2) | 11.
Proof.
@@ -611,24 +613,25 @@ Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> ->. by rewrite laterN_affinely_2.
Global Instance into_later_intuitionistically n P Q :
IntoLaterN false n P Q → IntoLaterN false n (□ P) (□ Q).
Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> ->. by rewrite laterN_intuitionistically_2. Qed.
-Global Instance into_later_absorbingly n P Q :
+(* TODO: currently depends on BiAffine because of laterN_absorbingly *)
+Global Instance into_later_absorbingly `{BiAffine SI PROP} n P Q :
IntoLaterN false n P Q → IntoLaterN false n (<absorb> P) (<absorb> Q).
Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> ->. by rewrite laterN_absorbingly. Qed.
-Global Instance into_later_plainly `{BiPlainly PROP} n P Q :
+Global Instance into_later_plainly `{BiPlainly SI PROP} n P Q :
IntoLaterN false n P Q → IntoLaterN false n (■P) (■Q).
Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> ->. by rewrite laterN_plainly. Qed.
Global Instance into_later_persistently n P Q :
IntoLaterN false n P Q → IntoLaterN false n (<pers> P) (<pers> Q).
Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> ->. by rewrite laterN_persistently. Qed.
-Global Instance into_later_embed`{SbiEmbed PROP PROP'} n P Q :
+Global Instance into_later_embed`{SbiEmbed SI PROP PROP'} n P Q :
IntoLaterN false n P Q → IntoLaterN false n ⎡P⎤ ⎡Q⎤.
Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> ->. by rewrite embed_laterN. Qed.
Global Instance into_laterN_sep_l n P1 P2 Q1 Q2 :
IntoLaterN false n P1 Q1 → MaybeIntoLaterN false n P2 Q2 →
IntoLaterN false n (P1 ∗ P2) (Q1 ∗ Q2) | 10.
-Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> -> ->. by rewrite laterN_sep. Qed.
-Global Instance into_laterN_sep_r n P P2 Q2 :
+Proof. rewrite /IntoLaterN /MaybeIntoLaterN=> -> ->. by rewrite laterN_sep_2. Qed.
+Global Instance into_laterN_sep_r `{FiniteIndex SI} n P P2 Q2 :
IntoLaterN false n P2 Q2 →
IntoLaterN false n (P ∗ P2) (P ∗ Q2) | 11.
Proof.
diff --git a/theories/proofmode/classes.v b/theories/proofmode/classes.v
index 5362da96ce875de8917c3f398f124cfb769898ef..8a549d01f13cd7cbedc8e63e5313c115b309152f 100644
--- a/theories/proofmode/classes.v
+++ b/theories/proofmode/classes.v
@@ -5,29 +5,29 @@ From stdpp Require Import namespaces.
Set Default Proof Using "Type".
Import bi.
-Class FromAssumption {PROP : bi} (p : bool) (P Q : PROP) :=
+Class FromAssumption {SI} {PROP : bi SI} (p : bool) (P Q : PROP) :=
from_assumption : □?p P ⊢ Q.
-Arguments FromAssumption {_} _ _%I _%I : simpl never.
-Arguments from_assumption {_} _ _%I _%I {_}.
-Hint Mode FromAssumption + + - - : typeclass_instances.
+Arguments FromAssumption {_ _} _ _%I _%I : simpl never.
+Arguments from_assumption {_ _} _ _%I _%I {_}.
+Hint Mode FromAssumption - + + - - : typeclass_instances.
-Class KnownLFromAssumption {PROP : bi} (p : bool) (P Q : PROP) :=
+Class KnownLFromAssumption {SI} {PROP : bi SI} (p : bool) (P Q : PROP) :=
knownl_from_assumption :> FromAssumption p P Q.
-Arguments KnownLFromAssumption {_} _ _%I _%I : simpl never.
-Arguments knownl_from_assumption {_} _ _%I _%I {_}.
-Hint Mode KnownLFromAssumption + + ! - : typeclass_instances.
+Arguments KnownLFromAssumption {_ _} _ _%I _%I : simpl never.
+Arguments knownl_from_assumption {_ _} _ _%I _%I {_}.
+Hint Mode KnownLFromAssumption - + + ! - : typeclass_instances.
-Class KnownRFromAssumption {PROP : bi} (p : bool) (P Q : PROP) :=
+Class KnownRFromAssumption {SI} {PROP : bi SI} (p : bool) (P Q : PROP) :=
knownr_from_assumption :> FromAssumption p P Q.
-Arguments KnownRFromAssumption {_} _ _%I _%I : simpl never.
-Arguments knownr_from_assumption {_} _ _%I _%I {_}.
-Hint Mode KnownRFromAssumption + + - ! : typeclass_instances.
+Arguments KnownRFromAssumption {_ _} _ _%I _%I : simpl never.
+Arguments knownr_from_assumption {_ _} _ _%I _%I {_}.
+Hint Mode KnownRFromAssumption - + + - ! : typeclass_instances.
-Class IntoPure {PROP : bi} (P : PROP) (φ : Prop) :=
+Class IntoPure {SI} {PROP : bi SI} (P : PROP) (φ : Prop) :=
into_pure : P ⊢ ⌜φâŒ.
-Arguments IntoPure {_} _%I _%type_scope : simpl never.
-Arguments into_pure {_} _%I _%type_scope {_}.
-Hint Mode IntoPure + ! - : typeclass_instances.
+Arguments IntoPure {_ _} _%I _%type_scope : simpl never.
+Arguments into_pure {_ _} _%I _%type_scope {_}.
+Hint Mode IntoPure - + ! - : typeclass_instances.
(* [IntoPureT] is a variant of [IntoPure] with the argument in [Type] to avoid
some shortcoming of unification in Coq's type class search. An example where we
@@ -49,9 +49,9 @@ once, and use [IntoPureT] in any instance like [into_exist_and_pure].
TODO: Report this as a Coq bug, or wait for https://github.com/coq/coq/pull/991
to be finished and merged someday. *)
-Class IntoPureT {PROP : bi} (P : PROP) (φ : Type) :=
+Class IntoPureT {SI} {PROP : bi SI} (P : PROP) (φ : Type) :=
into_pureT : ∃ ψ : Prop, φ = ψ ∧ IntoPure P ψ.
-Lemma into_pureT_hint {PROP : bi} (P : PROP) (φ : Prop) : IntoPure P φ → IntoPureT P φ.
+Lemma into_pureT_hint {SI} {PROP : bi SI} (P : PROP) (φ : Prop) : IntoPure P φ → IntoPureT P φ.
Proof. by exists φ. Qed.
Hint Extern 0 (IntoPureT _ _) =>
notypeclasses refine (into_pureT_hint _ _ _) : typeclass_instances.
@@ -65,31 +65,31 @@ the spatial context should be empty or not.
Note that the Boolean [a] is not needed for the (dual) [IntoPure] class, because
there we can just ask that [P] is [Affine]. *)
-Class FromPure {PROP : bi} (a : bool) (P : PROP) (φ : Prop) :=
+Class FromPure {SI} {PROP : bi SI} (a : bool) (P : PROP) (φ : Prop) :=
from_pure : <affine>?a ⌜φ⌠⊢ P.
-Arguments FromPure {_} _ _%I _%type_scope : simpl never.
-Arguments from_pure {_} _ _%I _%type_scope {_}.
-Hint Mode FromPure + - ! - : typeclass_instances.
+Arguments FromPure {_ _} _ _%I _%type_scope : simpl never.
+Arguments from_pure {_ _} _ _%I _%type_scope {_}.
+Hint Mode FromPure - + - ! - : typeclass_instances.
-Class FromPureT {PROP : bi} (a : bool) (P : PROP) (φ : Type) :=
+Class FromPureT {SI} {PROP : bi SI} (a : bool) (P : PROP) (φ : Type) :=
from_pureT : ∃ ψ : Prop, φ = ψ ∧ FromPure a P ψ.
-Lemma from_pureT_hint {PROP : bi} (a : bool) (P : PROP) (φ : Prop) :
+Lemma from_pureT_hint {SI} {PROP : bi SI} (a : bool) (P : PROP) (φ : Prop) :
FromPure a P φ → FromPureT a P φ.
Proof. by exists φ. Qed.
Hint Extern 0 (FromPureT _ _ _) =>
notypeclasses refine (from_pureT_hint _ _ _ _) : typeclass_instances.
-Class IntoInternalEq {PROP : sbi} {A : ofeT} (P : PROP) (x y : A) :=
+Class IntoInternalEq {SI} {PROP : sbi SI} {A : ofeT SI} (P : PROP) (x y : A) :=
into_internal_eq : P ⊢ x ≡ y.
-Arguments IntoInternalEq {_ _} _%I _%type_scope _%type_scope : simpl never.
-Arguments into_internal_eq {_ _} _%I _%type_scope _%type_scope {_}.
-Hint Mode IntoInternalEq + - ! - - : typeclass_instances.
+Arguments IntoInternalEq {_ _ _} _%I _%type_scope _%type_scope : simpl never.
+Arguments into_internal_eq {_ _ _} _%I _%type_scope _%type_scope {_}.
+Hint Mode IntoInternalEq - + - ! - - : typeclass_instances.
-Class IntoPersistent {PROP : bi} (p : bool) (P Q : PROP) :=
+Class IntoPersistent {SI} {PROP : bi SI} (p : bool) (P Q : PROP) :=
into_persistent : <pers>?p P ⊢ <pers> Q.
-Arguments IntoPersistent {_} _ _%I _%I : simpl never.
-Arguments into_persistent {_} _ _%I _%I {_}.
-Hint Mode IntoPersistent + + ! - : typeclass_instances.
+Arguments IntoPersistent {_ _} _ _%I _%I : simpl never.
+Arguments into_persistent {_ _} _ _%I _%I {_}.
+Hint Mode IntoPersistent - + + ! - : typeclass_instances.
(** The [FromModal M P Q] class is used by the [iModIntro] tactic to transform
a goal [P] into a modality [M] and proposition [Q].
@@ -107,32 +107,32 @@ can define an instance [FromModal modality_id (N P) P]. Defining such an
instance only imposes the proof obligation [P ⊢ N P]. Examples of such
modalities [N] are [bupd], [fupd], [except_0], [monPred_subjectively] and
[bi_absorbingly]. *)
-Class FromModal {PROP1 PROP2 : bi} {A}
+Class FromModal {SI} {PROP1 PROP2 : bi SI} {A}
(M : modality PROP1 PROP2) (sel : A) (P : PROP2) (Q : PROP1) :=
from_modal : M Q ⊢ P.
-Arguments FromModal {_ _ _} _ _%I _%I _%I : simpl never.
-Arguments from_modal {_ _ _} _ _ _%I _%I {_}.
-Hint Mode FromModal - + - - - ! - : typeclass_instances.
+Arguments FromModal {_ _ _ _} _ _%I _%I _%I : simpl never.
+Arguments from_modal {_ _ _ _} _ _ _%I _%I {_}.
+Hint Mode FromModal - - + - - - ! - : typeclass_instances.
(** The [FromAffinely P Q] class is used to add an [<affine>] modality to the
proposition [Q].
The input is [Q] and the output is [P]. *)
-Class FromAffinely {PROP : bi} (P Q : PROP) :=
+Class FromAffinely {SI} {PROP : bi SI} (P Q : PROP) :=
from_affinely : <affine> Q ⊢ P.
-Arguments FromAffinely {_} _%I _%I : simpl never.
-Arguments from_affinely {_} _%I _%I {_}.
-Hint Mode FromAffinely + - ! : typeclass_instances.
+Arguments FromAffinely {_ _} _%I _%I : simpl never.
+Arguments from_affinely {_ _} _%I _%I {_}.
+Hint Mode FromAffinely - + - ! : typeclass_instances.
(** The [IntoAbsorbingly P Q] class is used to add an [<absorb>] modality to
the proposition [Q].
The input is [Q] and the output is [P]. *)
-Class IntoAbsorbingly {PROP : bi} (P Q : PROP) :=
+Class IntoAbsorbingly {SI} {PROP : bi SI} (P Q : PROP) :=
into_absorbingly : P ⊢ <absorb> Q.
-Arguments IntoAbsorbingly {_} _%I _%I.
-Arguments into_absorbingly {_} _%I _%I {_}.
-Hint Mode IntoAbsorbingly + - ! : typeclass_instances.
+Arguments IntoAbsorbingly {_ _} _%I _%I.
+Arguments into_absorbingly {_ _} _%I _%I {_}.
+Hint Mode IntoAbsorbingly - + - ! : typeclass_instances.
(*
Converting an assumption [R] into a wand [P -∗ Q] is done in three stages:
@@ -145,90 +145,90 @@ Converting an assumption [R] into a wand [P -∗ Q] is done in three stages:
- Instantiate the premise of the wand or implication.
*)
-Class IntoWand {PROP : bi} (p q : bool) (R P Q : PROP) :=
+Class IntoWand {SI} {PROP : bi SI} (p q : bool) (R P Q : PROP) :=
into_wand : □?p R ⊢ □?q P -∗ Q.
-Arguments IntoWand {_} _ _ _%I _%I _%I : simpl never.
-Arguments into_wand {_} _ _ _%I _%I _%I {_}.
-Hint Mode IntoWand + + + ! - - : typeclass_instances.
+Arguments IntoWand {_ _} _ _ _%I _%I _%I : simpl never.
+Arguments into_wand {_ _} _ _ _%I _%I _%I {_}.
+Hint Mode IntoWand - + + + ! - - : typeclass_instances.
-Class IntoWand' {PROP : bi} (p q : bool) (R P Q : PROP) :=
+Class IntoWand' {SI} {PROP : bi SI} (p q : bool) (R P Q : PROP) :=
into_wand' : IntoWand p q R P Q.
-Arguments IntoWand' {_} _ _ _%I _%I _%I : simpl never.
-Hint Mode IntoWand' + + + ! ! - : typeclass_instances.
-Hint Mode IntoWand' + + + ! - ! : typeclass_instances.
-
-Class FromWand {PROP : bi} (P Q1 Q2 : PROP) := from_wand : (Q1 -∗ Q2) ⊢ P.
-Arguments FromWand {_} _%I _%I _%I : simpl never.
-Arguments from_wand {_} _%I _%I _%I {_}.
-Hint Mode FromWand + ! - - : typeclass_instances.
-
-Class FromImpl {PROP : bi} (P Q1 Q2 : PROP) := from_impl : (Q1 → Q2) ⊢ P.
-Arguments FromImpl {_} _%I _%I _%I : simpl never.
-Arguments from_impl {_} _%I _%I _%I {_}.
-Hint Mode FromImpl + ! - - : typeclass_instances.
-
-Class FromSep {PROP : bi} (P Q1 Q2 : PROP) := from_sep : Q1 ∗ Q2 ⊢ P.
-Arguments FromSep {_} _%I _%I _%I : simpl never.
-Arguments from_sep {_} _%I _%I _%I {_}.
-Hint Mode FromSep + ! - - : typeclass_instances.
-Hint Mode FromSep + - ! ! : typeclass_instances. (* For iCombine *)
-
-Class FromAnd {PROP : bi} (P Q1 Q2 : PROP) := from_and : Q1 ∧ Q2 ⊢ P.
-Arguments FromAnd {_} _%I _%I _%I : simpl never.
-Arguments from_and {_} _%I _%I _%I {_}.
-Hint Mode FromAnd + ! - - : typeclass_instances.
-Hint Mode FromAnd + - ! ! : typeclass_instances. (* For iCombine *)
-
-Class IntoAnd {PROP : bi} (p : bool) (P Q1 Q2 : PROP) :=
+Arguments IntoWand' {_ _} _ _ _%I _%I _%I : simpl never.
+Hint Mode IntoWand' - + + + ! ! - : typeclass_instances.
+Hint Mode IntoWand' - + + + ! - ! : typeclass_instances.
+
+Class FromWand {SI} {PROP : bi SI} (P Q1 Q2 : PROP) := from_wand : (Q1 -∗ Q2) ⊢ P.
+Arguments FromWand {_ _} _%I _%I _%I : simpl never.
+Arguments from_wand {_ _} _%I _%I _%I {_}.
+Hint Mode FromWand - + ! - - : typeclass_instances.
+
+Class FromImpl {SI} {PROP : bi SI} (P Q1 Q2 : PROP) := from_impl : (Q1 → Q2) ⊢ P.
+Arguments FromImpl {_ _} _%I _%I _%I : simpl never.
+Arguments from_impl {_ _} _%I _%I _%I {_}.
+Hint Mode FromImpl - + ! - - : typeclass_instances.
+
+Class FromSep {SI} {PROP : bi SI} (P Q1 Q2 : PROP) := from_sep : Q1 ∗ Q2 ⊢ P.
+Arguments FromSep {_ _} _%I _%I _%I : simpl never.
+Arguments from_sep {_ _} _%I _%I _%I {_}.
+Hint Mode FromSep - + ! - - : typeclass_instances.
+Hint Mode FromSep - + - ! ! : typeclass_instances. (* For iCombine *)
+
+Class FromAnd {SI} {PROP : bi SI} (P Q1 Q2 : PROP) := from_and : Q1 ∧ Q2 ⊢ P.
+Arguments FromAnd {_ _} _%I _%I _%I : simpl never.
+Arguments from_and {_ _} _%I _%I _%I {_}.
+Hint Mode FromAnd - + ! - - : typeclass_instances.
+Hint Mode FromAnd - + - ! ! : typeclass_instances. (* For iCombine *)
+
+Class IntoAnd {SI} {PROP : bi SI} (p : bool) (P Q1 Q2 : PROP) :=
into_and : □?p P ⊢ □?p (Q1 ∧ Q2).
-Arguments IntoAnd {_} _ _%I _%I _%I : simpl never.
-Arguments into_and {_} _ _%I _%I _%I {_}.
-Hint Mode IntoAnd + + ! - - : typeclass_instances.
+Arguments IntoAnd {_ _} _ _%I _%I _%I : simpl never.
+Arguments into_and {_ _} _ _%I _%I _%I {_}.
+Hint Mode IntoAnd - + + ! - - : typeclass_instances.
-Class IntoSep {PROP : bi} (P Q1 Q2 : PROP) :=
+Class IntoSep {SI} {PROP : bi SI} (P Q1 Q2 : PROP) :=
into_sep : P ⊢ Q1 ∗ Q2.
-Arguments IntoSep {_} _%I _%I _%I : simpl never.
-Arguments into_sep {_} _%I _%I _%I {_}.
-Hint Mode IntoSep + ! - - : typeclass_instances.
+Arguments IntoSep {_ _} _%I _%I _%I : simpl never.
+Arguments into_sep {_ _} _%I _%I _%I {_}.
+Hint Mode IntoSep - + ! - - : typeclass_instances.
-Class FromOr {PROP : bi} (P Q1 Q2 : PROP) := from_or : Q1 ∨ Q2 ⊢ P.
-Arguments FromOr {_} _%I _%I _%I : simpl never.
-Arguments from_or {_} _%I _%I _%I {_}.
-Hint Mode FromOr + ! - - : typeclass_instances.
+Class FromOr {SI} {PROP : bi SI} (P Q1 Q2 : PROP) := from_or : Q1 ∨ Q2 ⊢ P.
+Arguments FromOr {_ _} _%I _%I _%I : simpl never.
+Arguments from_or {_ _} _%I _%I _%I {_}.
+Hint Mode FromOr - + ! - - : typeclass_instances.
-Class IntoOr {PROP : bi} (P Q1 Q2 : PROP) := into_or : P ⊢ Q1 ∨ Q2.
-Arguments IntoOr {_} _%I _%I _%I : simpl never.
-Arguments into_or {_} _%I _%I _%I {_}.
-Hint Mode IntoOr + ! - - : typeclass_instances.
+Class IntoOr {SI} {PROP : bi SI} (P Q1 Q2 : PROP) := into_or : P ⊢ Q1 ∨ Q2.
+Arguments IntoOr {_ _} _%I _%I _%I : simpl never.
+Arguments into_or {_ _} _%I _%I _%I {_}.
+Hint Mode IntoOr - + ! - - : typeclass_instances.
-Class FromExist {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :=
+Class FromExist {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :=
from_exist : (∃ x, Φ x) ⊢ P.
-Arguments FromExist {_ _} _%I _%I : simpl never.
-Arguments from_exist {_ _} _%I _%I {_}.
-Hint Mode FromExist + - ! - : typeclass_instances.
+Arguments FromExist {_ _ _} _%I _%I : simpl never.
+Arguments from_exist {_ _ _} _%I _%I {_}.
+Hint Mode FromExist - + - ! - : typeclass_instances.
-Class IntoExist {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :=
+Class IntoExist {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :=
into_exist : P ⊢ ∃ x, Φ x.
-Arguments IntoExist {_ _} _%I _%I : simpl never.
-Arguments into_exist {_ _} _%I _%I {_}.
-Hint Mode IntoExist + - ! - : typeclass_instances.
+Arguments IntoExist {_ _ _} _%I _%I : simpl never.
+Arguments into_exist {_ _ _} _%I _%I {_}.
+Hint Mode IntoExist - + - ! - : typeclass_instances.
-Class IntoForall {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :=
+Class IntoForall {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :=
into_forall : P ⊢ ∀ x, Φ x.
-Arguments IntoForall {_ _} _%I _%I : simpl never.
-Arguments into_forall {_ _} _%I _%I {_}.
-Hint Mode IntoForall + - ! - : typeclass_instances.
+Arguments IntoForall {_ _ _} _%I _%I : simpl never.
+Arguments into_forall {_ _ _} _%I _%I {_}.
+Hint Mode IntoForall - + - ! - : typeclass_instances.
-Class FromForall {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :=
+Class FromForall {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :=
from_forall : (∀ x, Φ x) ⊢ P.
-Arguments FromForall {_ _} _%I _%I : simpl never.
-Arguments from_forall {_ _} _%I _%I {_}.
-Hint Mode FromForall + - ! - : typeclass_instances.
+Arguments FromForall {_ _ _} _%I _%I : simpl never.
+Arguments from_forall {_ _ _} _%I _%I {_}.
+Hint Mode FromForall - + - ! - : typeclass_instances.
-Class IsExcept0 {PROP : sbi} (Q : PROP) := is_except_0 : ◇ Q ⊢ Q.
-Arguments IsExcept0 {_} _%I : simpl never.
-Arguments is_except_0 {_} _%I {_}.
-Hint Mode IsExcept0 + ! : typeclass_instances.
+Class IsExcept0 {SI} {PROP : sbi SI} (Q : PROP) := is_except_0 : ◇ Q ⊢ Q.
+Arguments IsExcept0 {_ _} _%I : simpl never.
+Arguments is_except_0 {_ _} _%I {_}.
+Hint Mode IsExcept0 - + ! : typeclass_instances.
(** The [ElimModal φ p p' P P' Q Q'] class is used by the [iMod] tactic.
@@ -249,21 +249,21 @@ transformed from [|={E1,E3}=> Q] into [|={E2,E3}=> Q], and the resulting
hypothesis is moved into the spatial context (regardless of where it was
originally). A corresponding [ElimModal] instance for the Iris 1/2-style update
modality, would have a side-condition [φ] on the masks. *)
-Class ElimModal {PROP : bi} (φ : Prop) (p p' : bool) (P P' : PROP) (Q Q' : PROP) :=
+Class ElimModal {SI} {PROP : bi SI} (φ : Prop) (p p' : bool) (P P' : PROP) (Q Q' : PROP) :=
elim_modal : φ → □?p P ∗ (□?p' P' -∗ Q') ⊢ Q.
-Arguments ElimModal {_} _ _ _ _%I _%I _%I _%I : simpl never.
-Arguments elim_modal {_} _ _ _ _%I _%I _%I _%I {_}.
-Hint Mode ElimModal + - ! - ! - ! - : typeclass_instances.
+Arguments ElimModal {_ _} _ _ _ _%I _%I _%I _%I : simpl never.
+Arguments elim_modal {_ _} _ _ _ _%I _%I _%I _%I {_}.
+Hint Mode ElimModal - + - ! - ! - ! - : typeclass_instances.
(* Used by the specialization pattern [ > ] in [iSpecialize] and [iAssert] to
add a modality to the goal corresponding to a premise/asserted proposition. *)
-Class AddModal {PROP : bi} (P P' : PROP) (Q : PROP) :=
+Class AddModal {SI} {PROP : bi SI} (P P' : PROP) (Q : PROP) :=
add_modal : P ∗ (P' -∗ Q) ⊢ Q.
-Arguments AddModal {_} _%I _%I _%I : simpl never.
-Arguments add_modal {_} _%I _%I _%I {_}.
-Hint Mode AddModal + - ! ! : typeclass_instances.
+Arguments AddModal {_ _} _%I _%I _%I : simpl never.
+Arguments add_modal {_ _} _%I _%I _%I {_}.
+Hint Mode AddModal - + - ! ! : typeclass_instances.
-Lemma add_modal_id {PROP : bi} (P Q : PROP) : AddModal P P Q.
+Lemma add_modal_id {SI} {PROP : bi SI} (P Q : PROP) : AddModal P P Q.
Proof. by rewrite /AddModal wand_elim_r. Qed.
(** We use the classes [IsCons] and [IsApp] to make sure that instances such as
@@ -279,28 +279,28 @@ Proof. done. Qed.
Instance is_app_app {A} (l1 l2 : list A) : IsApp (l1 ++ l2) l1 l2.
Proof. done. Qed.
-Class Frame {PROP : bi} (p : bool) (R P Q : PROP) := frame : □?p R ∗ Q ⊢ P.
-Arguments Frame {_} _ _%I _%I _%I.
-Arguments frame {_} _ _%I _%I _%I {_}.
-Hint Mode Frame + + ! ! - : typeclass_instances.
+Class Frame {SI} {PROP : bi SI} (p : bool) (R P Q : PROP) := frame : □?p R ∗ Q ⊢ P.
+Arguments Frame {_ _} _ _%I _%I _%I.
+Arguments frame {_ _} _ _%I _%I _%I {_}.
+Hint Mode Frame - + + ! ! - : typeclass_instances.
(* The boolean [progress] indicates whether actual framing has been performed.
If it is [false], then the default instance [maybe_frame_default] below has been
used. *)
-Class MaybeFrame {PROP : bi} (p : bool) (R P Q : PROP) (progress : bool) :=
+Class MaybeFrame {SI} {PROP : bi SI} (p : bool) (R P Q : PROP) (progress : bool) :=
maybe_frame : □?p R ∗ Q ⊢ P.
-Arguments MaybeFrame {_} _ _%I _%I _%I _.
-Arguments maybe_frame {_} _ _%I _%I _%I _ {_}.
-Hint Mode MaybeFrame + + ! - - - : typeclass_instances.
+Arguments MaybeFrame {_ _} _ _%I _%I _%I _.
+Arguments maybe_frame {_ _} _ _%I _%I _%I _ {_}.
+Hint Mode MaybeFrame - + + ! - - - : typeclass_instances.
-Instance maybe_frame_frame {PROP : bi} p (R P Q : PROP) :
+Instance maybe_frame_frame {SI} {PROP : bi SI} p (R P Q : PROP) :
Frame p R P Q → MaybeFrame p R P Q true.
Proof. done. Qed.
-Instance maybe_frame_default_persistent {PROP : bi} (R P : PROP) :
+Instance maybe_frame_default_persistent {SI} {PROP : bi SI} (R P : PROP) :
MaybeFrame true R P P false | 100.
Proof. intros. rewrite /MaybeFrame /=. by rewrite sep_elim_r. Qed.
-Instance maybe_frame_default {PROP : bi} (R P : PROP) :
+Instance maybe_frame_default {SI} {PROP : bi SI} (R P : PROP) :
TCOr (Affine R) (Absorbing P) → MaybeFrame false R P P false | 100.
Proof. intros. rewrite /MaybeFrame /=. apply: sep_elim_r. Qed.
@@ -313,109 +313,110 @@ Proof. intros. rewrite /MaybeFrame /=. apply: sep_elim_r. Qed.
would typically try to instantiate this evar with some arbitrary
logical constructs such as emp or True. Therefore, we use an Hint
Mode to disable all the instances that would have this behavior. *)
-Class MakeEmbed {PROP PROP' : bi} `{BiEmbed PROP PROP'} (P : PROP) (Q : PROP') :=
+
+Class MakeEmbed {SI} {PROP PROP' : bi SI} `{BiEmbed SI PROP PROP'} (P : PROP) (Q : PROP') :=
make_embed : ⎡P⎤ ⊣⊢ Q.
-Arguments MakeEmbed {_ _ _} _%I _%I.
-Hint Mode MakeEmbed + + + - - : typeclass_instances.
-Class KnownMakeEmbed {PROP PROP' : bi} `{BiEmbed PROP PROP'} (P : PROP) (Q : PROP') :=
+Arguments MakeEmbed {_ _ _ _} _%I _%I.
+Hint Mode MakeEmbed - + + + - - : typeclass_instances.
+Class KnownMakeEmbed {SI} {PROP PROP' : bi SI} `{BiEmbed SI PROP PROP'} (P : PROP) (Q : PROP') :=
known_make_embed :> MakeEmbed P Q.
-Arguments KnownMakeEmbed {_ _ _} _%I _%I.
-Hint Mode KnownMakeEmbed + + + ! - : typeclass_instances.
+Arguments KnownMakeEmbed {_ _ _ _} _%I _%I.
+Hint Mode KnownMakeEmbed - + + + ! - : typeclass_instances.
-Class MakeSep {PROP : bi} (P Q PQ : PROP) := make_sep : P ∗ Q ⊣⊢ PQ .
-Arguments MakeSep {_} _%I _%I _%I.
-Hint Mode MakeSep + - - - : typeclass_instances.
-Class KnownLMakeSep {PROP : bi} (P Q PQ : PROP) :=
+Class MakeSep {SI} {PROP : bi SI} (P Q PQ : PROP) := make_sep : P ∗ Q ⊣⊢ PQ .
+Arguments MakeSep {_ _} _%I _%I _%I.
+Hint Mode MakeSep - + - - - : typeclass_instances.
+Class KnownLMakeSep {SI} {PROP : bi SI} (P Q PQ : PROP) :=
knownl_make_sep :> MakeSep P Q PQ.
-Arguments KnownLMakeSep {_} _%I _%I _%I.
-Hint Mode KnownLMakeSep + ! - - : typeclass_instances.
-Class KnownRMakeSep {PROP : bi} (P Q PQ : PROP) :=
+Arguments KnownLMakeSep {_ _} _%I _%I _%I.
+Hint Mode KnownLMakeSep - + ! - - : typeclass_instances.
+Class KnownRMakeSep {SI} {PROP : bi SI} (P Q PQ : PROP) :=
knownr_make_sep :> MakeSep P Q PQ.
-Arguments KnownRMakeSep {_} _%I _%I _%I.
-Hint Mode KnownRMakeSep + - ! - : typeclass_instances.
+Arguments KnownRMakeSep {_ _} _%I _%I _%I.
+Hint Mode KnownRMakeSep - + - ! - : typeclass_instances.
-Class MakeAnd {PROP : bi} (P Q PQ : PROP) := make_and_l : P ∧ Q ⊣⊢ PQ.
-Arguments MakeAnd {_} _%I _%I _%I.
-Hint Mode MakeAnd + - - - : typeclass_instances.
-Class KnownLMakeAnd {PROP : bi} (P Q PQ : PROP) :=
+Class MakeAnd {SI} {PROP : bi SI} (P Q PQ : PROP) := make_and_l : P ∧ Q ⊣⊢ PQ.
+Arguments MakeAnd {_ _} _%I _%I _%I.
+Hint Mode MakeAnd - + - - - : typeclass_instances.
+Class KnownLMakeAnd {SI} {PROP : bi SI} (P Q PQ : PROP) :=
knownl_make_and :> MakeAnd P Q PQ.
-Arguments KnownLMakeAnd {_} _%I _%I _%I.
-Hint Mode KnownLMakeAnd + ! - - : typeclass_instances.
-Class KnownRMakeAnd {PROP : bi} (P Q PQ : PROP) :=
+Arguments KnownLMakeAnd {_ _} _%I _%I _%I.
+Hint Mode KnownLMakeAnd - + ! - - : typeclass_instances.
+Class KnownRMakeAnd {SI} {PROP : bi SI} (P Q PQ : PROP) :=
knownr_make_and :> MakeAnd P Q PQ.
-Arguments KnownRMakeAnd {_} _%I _%I _%I.
-Hint Mode KnownRMakeAnd + - ! - : typeclass_instances.
+Arguments KnownRMakeAnd {_ _} _%I _%I _%I.
+Hint Mode KnownRMakeAnd - + - ! - : typeclass_instances.
-Class MakeOr {PROP : bi} (P Q PQ : PROP) := make_or_l : P ∨ Q ⊣⊢ PQ.
-Arguments MakeOr {_} _%I _%I _%I.
-Hint Mode MakeOr + - - - : typeclass_instances.
-Class KnownLMakeOr {PROP : bi} (P Q PQ : PROP) :=
+Class MakeOr {SI} {PROP : bi SI} (P Q PQ : PROP) := make_or_l : P ∨ Q ⊣⊢ PQ.
+Arguments MakeOr {_ _} _%I _%I _%I.
+Hint Mode MakeOr - + - - - : typeclass_instances.
+Class KnownLMakeOr {SI} {PROP : bi SI} (P Q PQ : PROP) :=
knownl_make_or :> MakeOr P Q PQ.
-Arguments KnownLMakeOr {_} _%I _%I _%I.
-Hint Mode KnownLMakeOr + ! - - : typeclass_instances.
-Class KnownRMakeOr {PROP : bi} (P Q PQ : PROP) := knownr_make_or :> MakeOr P Q PQ.
-Arguments KnownRMakeOr {_} _%I _%I _%I.
-Hint Mode KnownRMakeOr + - ! - : typeclass_instances.
+Arguments KnownLMakeOr {_ _} _%I _%I _%I.
+Hint Mode KnownLMakeOr - + ! - - : typeclass_instances.
+Class KnownRMakeOr {SI} {PROP : bi SI} (P Q PQ : PROP) := knownr_make_or :> MakeOr P Q PQ.
+Arguments KnownRMakeOr {_ _} _%I _%I _%I.
+Hint Mode KnownRMakeOr - + - ! - : typeclass_instances.
-Class MakeAffinely {PROP : bi} (P Q : PROP) :=
+Class MakeAffinely {SI} {PROP : bi SI} (P Q : PROP) :=
make_affinely : <affine> P ⊣⊢ Q.
-Arguments MakeAffinely {_} _%I _%I.
-Hint Mode MakeAffinely + - - : typeclass_instances.
-Class KnownMakeAffinely {PROP : bi} (P Q : PROP) :=
+Arguments MakeAffinely {_ _} _%I _%I.
+Hint Mode MakeAffinely - + - - : typeclass_instances.
+Class KnownMakeAffinely {SI} {PROP : bi SI} (P Q : PROP) :=
known_make_affinely :> MakeAffinely P Q.
-Arguments KnownMakeAffinely {_} _%I _%I.
-Hint Mode KnownMakeAffinely + ! - : typeclass_instances.
+Arguments KnownMakeAffinely {_ _} _%I _%I.
+Hint Mode KnownMakeAffinely - + ! - : typeclass_instances.
-Class MakeIntuitionistically {PROP : bi} (P Q : PROP) :=
+Class MakeIntuitionistically {SI} {PROP : bi SI} (P Q : PROP) :=
make_intuitionistically : □ P ⊣⊢ Q.
-Arguments MakeIntuitionistically {_} _%I _%I.
-Hint Mode MakeIntuitionistically + - - : typeclass_instances.
-Class KnownMakeIntuitionistically {PROP : bi} (P Q : PROP) :=
+Arguments MakeIntuitionistically {_ _} _%I _%I.
+Hint Mode MakeIntuitionistically - + - - : typeclass_instances.
+Class KnownMakeIntuitionistically {SI} {PROP : bi SI} (P Q : PROP) :=
known_make_intuitionistically :> MakeIntuitionistically P Q.
-Arguments KnownMakeIntuitionistically {_} _%I _%I.
-Hint Mode KnownMakeIntuitionistically + ! - : typeclass_instances.
+Arguments KnownMakeIntuitionistically {_ _} _%I _%I.
+Hint Mode KnownMakeIntuitionistically - + ! - : typeclass_instances.
-Class MakeAbsorbingly {PROP : bi} (P Q : PROP) :=
+Class MakeAbsorbingly {SI} {PROP : bi SI} (P Q : PROP) :=
make_absorbingly : <absorb> P ⊣⊢ Q.
-Arguments MakeAbsorbingly {_} _%I _%I.
-Hint Mode MakeAbsorbingly + - - : typeclass_instances.
-Class KnownMakeAbsorbingly {PROP : bi} (P Q : PROP) :=
+Arguments MakeAbsorbingly {_ _} _%I _%I.
+Hint Mode MakeAbsorbingly - + - - : typeclass_instances.
+Class KnownMakeAbsorbingly {SI} {PROP : bi SI} (P Q : PROP) :=
known_make_absorbingly :> MakeAbsorbingly P Q.
-Arguments KnownMakeAbsorbingly {_} _%I _%I.
-Hint Mode KnownMakeAbsorbingly + ! - : typeclass_instances.
+Arguments KnownMakeAbsorbingly {_ _} _%I _%I.
+Hint Mode KnownMakeAbsorbingly - + ! - : typeclass_instances.
-Class MakePersistently {PROP : bi} (P Q : PROP) :=
+Class MakePersistently {SI} {PROP : bi SI} (P Q : PROP) :=
make_persistently : <pers> P ⊣⊢ Q.
-Arguments MakePersistently {_} _%I _%I.
-Hint Mode MakePersistently + - - : typeclass_instances.
-Class KnownMakePersistently {PROP : bi} (P Q : PROP) :=
+Arguments MakePersistently {_ _} _%I _%I.
+Hint Mode MakePersistently - + - - : typeclass_instances.
+Class KnownMakePersistently {SI} {PROP : bi SI} (P Q : PROP) :=
known_make_persistently :> MakePersistently P Q.
-Arguments KnownMakePersistently {_} _%I _%I.
-Hint Mode KnownMakePersistently + ! - : typeclass_instances.
+Arguments KnownMakePersistently {_ _} _%I _%I.
+Hint Mode KnownMakePersistently - + ! - : typeclass_instances.
-Class MakeLaterN {PROP : sbi} (n : nat) (P lP : PROP) :=
+Class MakeLaterN {SI} {PROP : sbi SI} (n : nat) (P lP : PROP) :=
make_laterN : ▷^n P ⊣⊢ lP.
-Arguments MakeLaterN {_} _%nat _%I _%I.
-Hint Mode MakeLaterN + + - - : typeclass_instances.
-Class KnownMakeLaterN {PROP : sbi} (n : nat) (P lP : PROP) :=
+Arguments MakeLaterN {_ _} _%nat _%I _%I.
+Hint Mode MakeLaterN - + + - - : typeclass_instances.
+Class KnownMakeLaterN {SI} {PROP : sbi SI} (n : nat) (P lP : PROP) :=
known_make_laterN :> MakeLaterN n P lP.
-Arguments KnownMakeLaterN {_} _%nat _%I _%I.
-Hint Mode KnownMakeLaterN + + ! - : typeclass_instances.
+Arguments KnownMakeLaterN {_ _} _%nat _%I _%I.
+Hint Mode KnownMakeLaterN - + + ! - : typeclass_instances.
-Class MakeExcept0 {PROP : sbi} (P Q : PROP) :=
+Class MakeExcept0 {SI} {PROP : sbi SI} (P Q : PROP) :=
make_except_0 : sbi_except_0 P ⊣⊢ Q.
-Arguments MakeExcept0 {_} _%I _%I.
-Hint Mode MakeExcept0 + - - : typeclass_instances.
-Class KnownMakeExcept0 {PROP : sbi} (P Q : PROP) :=
+Arguments MakeExcept0 {_ _} _%I _%I.
+Hint Mode MakeExcept0 - + - - : typeclass_instances.
+Class KnownMakeExcept0 {SI} {PROP : sbi SI} (P Q : PROP) :=
known_make_except_0 :> MakeExcept0 P Q.
-Arguments KnownMakeExcept0 {_} _%I _%I.
-Hint Mode KnownMakeExcept0 + ! - : typeclass_instances.
+Arguments KnownMakeExcept0 {_ _} _%I _%I.
+Hint Mode KnownMakeExcept0 - + ! - : typeclass_instances.
-Class IntoExcept0 {PROP : sbi} (P Q : PROP) := into_except_0 : P ⊢ ◇ Q.
-Arguments IntoExcept0 {_} _%I _%I : simpl never.
-Arguments into_except_0 {_} _%I _%I {_}.
-Hint Mode IntoExcept0 + ! - : typeclass_instances.
-Hint Mode IntoExcept0 + - ! : typeclass_instances.
+Class IntoExcept0 {SI} {PROP : sbi SI} (P Q : PROP) := into_except_0 : P ⊢ ◇ Q.
+Arguments IntoExcept0 {_ _} _%I _%I : simpl never.
+Arguments into_except_0 {_ _} _%I _%I {_}.
+Hint Mode IntoExcept0 - + ! - : typeclass_instances.
+Hint Mode IntoExcept0 - + - ! : typeclass_instances.
(* The class [MaybeIntoLaterN] has only two instances:
@@ -451,24 +452,24 @@ Lemma test_iFrame_later_1 P Q : P ∗ ▷ Q -∗ ▷ (P ∗ ▷ Q).
Proof. iIntros "H". iFrame "H". Qed.
>>
*)
-Class MaybeIntoLaterN {PROP : sbi} (only_head : bool) (n : nat) (P Q : PROP) :=
+Class MaybeIntoLaterN {SI} {PROP : sbi SI} (only_head : bool) (n : nat) (P Q : PROP) :=
maybe_into_laterN : P ⊢ ▷^n Q.
-Arguments MaybeIntoLaterN {_} _ _%nat_scope _%I _%I.
-Arguments maybe_into_laterN {_} _ _%nat_scope _%I _%I {_}.
-Hint Mode MaybeIntoLaterN + + + - - : typeclass_instances.
+Arguments MaybeIntoLaterN {_ _} _ _%nat_scope _%I _%I.
+Arguments maybe_into_laterN {_ _} _ _%nat_scope _%I _%I {_}.
+Hint Mode MaybeIntoLaterN - + + + - - : typeclass_instances.
-Class IntoLaterN {PROP : sbi} (only_head : bool) (n : nat) (P Q : PROP) :=
+Class IntoLaterN {SI} {PROP : sbi SI} (only_head : bool) (n : nat) (P Q : PROP) :=
into_laterN :> MaybeIntoLaterN only_head n P Q.
-Arguments IntoLaterN {_} _ _%nat_scope _%I _%I.
-Hint Mode IntoLaterN + + + ! - : typeclass_instances.
+Arguments IntoLaterN {_ _} _ _%nat_scope _%I _%I.
+Hint Mode IntoLaterN - + + + ! - : typeclass_instances.
-Instance maybe_into_laterN_default {PROP : sbi} only_head n (P : PROP) :
+Instance maybe_into_laterN_default {SI} {PROP : sbi SI} only_head n (P : PROP) :
MaybeIntoLaterN only_head n P P | 1000.
Proof. apply laterN_intro. Qed.
(* In the case both parameters are evars and n=0, we have to stop the
search and unify both evars immediately instead of looping using
other instances. *)
-Instance maybe_into_laterN_default_0 {PROP : sbi} only_head (P : PROP) :
+Instance maybe_into_laterN_default_0 {SI} {PROP : sbi SI} only_head (P : PROP) :
MaybeIntoLaterN only_head 0 P P | 0.
Proof. apply _. Qed.
@@ -476,11 +477,12 @@ Proof. apply _. Qed.
embeddings using [iModIntro].
Input: the proposition [P], output: the proposition [Q] so that [P ⊢ ⎡Q⎤]. *)
-Class IntoEmbed {PROP PROP' : bi} `{BiEmbed PROP PROP'} (P : PROP') (Q : PROP) :=
+
+Class IntoEmbed {SI} {PROP PROP' : bi SI} `{BiEmbed SI PROP PROP'} (P : PROP') (Q : PROP) :=
into_embed : P ⊢ ⎡Q⎤.
-Arguments IntoEmbed {_ _ _} _%I _%I.
-Arguments into_embed {_ _ _} _%I _%I {_}.
-Hint Mode IntoEmbed + + + ! - : typeclass_instances.
+Arguments IntoEmbed {_ _ _ _} _%I _%I.
+Arguments into_embed {_ _ _ _} _%I _%I {_}.
+Hint Mode IntoEmbed - + + + ! - : typeclass_instances.
(* We use two type classes for [AsEmpValid], in order to avoid loops in
typeclass search. Indeed, the [as_emp_valid_embed] instance would try
@@ -494,33 +496,33 @@ Hint Mode IntoEmbed + + + ! - : typeclass_instances.
No Hint Modes are declared here. The appropriate one would be
[Hint Mode - ! -], but the fact that Coq ignores primitive
projections for hints modes would make this fail.*)
-Class AsEmpValid {PROP : bi} (φ : Prop) (P : PROP) :=
+Class AsEmpValid {SI} {PROP : bi SI} (φ : Prop) (P : PROP) :=
as_emp_valid : φ ↔ bi_emp_valid P.
-Arguments AsEmpValid {_} _%type _%I.
-Class AsEmpValid0 {PROP : bi} (φ : Prop) (P : PROP) :=
+Arguments AsEmpValid {_ _} _%type _%I.
+Class AsEmpValid0 {SI} {PROP : bi SI} (φ : Prop) (P : PROP) :=
as_emp_valid_here : AsEmpValid φ P.
-Arguments AsEmpValid0 {_} _%type _%I.
+Arguments AsEmpValid0 {_ _} _%type _%I.
Existing Instance as_emp_valid_here | 0.
-Lemma as_emp_valid_1 (φ : Prop) {PROP : bi} (P : PROP) `{!AsEmpValid φ P} :
+Lemma as_emp_valid_1 (φ : Prop) {SI} {PROP : bi SI} (P : PROP) `{!AsEmpValid φ P} :
φ → bi_emp_valid P.
Proof. by apply as_emp_valid. Qed.
-Lemma as_emp_valid_2 (φ : Prop) {PROP : bi} (P : PROP) `{!AsEmpValid φ P} :
+Lemma as_emp_valid_2 (φ : Prop) {SI} {PROP : bi SI} (P : PROP) `{!AsEmpValid φ P} :
bi_emp_valid P → φ.
Proof. by apply as_emp_valid. Qed.
(* Input: [P]; Outputs: [N],
Extracts the namespace associated with an invariant assertion. Used for [iInv]. *)
-Class IntoInv {PROP : bi} (P: PROP) (N: namespace).
-Arguments IntoInv {_} _%I _.
-Hint Mode IntoInv + ! - : typeclass_instances.
+Class IntoInv {SI} {PROP : bi SI} (P: PROP) (N: namespace).
+Arguments IntoInv {_ _} _%I _.
+Hint Mode IntoInv - + ! - : typeclass_instances.
(** Accessors.
This definition only exists for the purpose of the proof mode; a truly
usable and general form would use telescopes and also allow binders for the
closing view shift. [γ] is an [option] to make it easy for ElimAcc
instances to recognize the [emp] case and make it look nicer. *)
-Definition accessor {PROP : bi} {X : Type} (M1 M2 : PROP → PROP)
+Definition accessor {SI} {PROP : bi SI} {X : Type} (M1 M2 : PROP → PROP)
(α β : X → PROP) (mγ : X → option PROP) : PROP :=
M1 (∃ x, α x ∗ (β x -∗ M2 (default emp (mγ x))))%I.
@@ -530,13 +532,13 @@ Definition accessor {PROP : bi} {X : Type} (M1 M2 : PROP → PROP)
Elliminates an accessor [accessor E1 E2 α β γ] in goal [Q'], turning the goal
into [Q'] with a new assumption [α x]. *)
-Class ElimAcc {PROP : bi} {X : Type} (M1 M2 : PROP → PROP)
+Class ElimAcc {SI} {PROP : bi SI} {X : Type} (M1 M2 : PROP → PROP)
(α β : X → PROP) (mγ : X → option PROP)
(Q : PROP) (Q' : X → PROP) :=
elim_acc : ((∀ x, α x -∗ Q' x) -∗ accessor M1 M2 α β mγ -∗ Q).
-Arguments ElimAcc {_} {_} _%I _%I _%I _%I _%I _%I : simpl never.
-Arguments elim_acc {_} {_} _%I _%I _%I _%I _%I _%I {_}.
-Hint Mode ElimAcc + ! ! ! ! ! ! ! - : typeclass_instances.
+Arguments ElimAcc {_ _} {_} _%I _%I _%I _%I _%I _%I : simpl never.
+Arguments elim_acc {_ _} {_} _%I _%I _%I _%I _%I _%I {_}.
+Hint Mode ElimAcc - + ! ! ! ! ! ! ! - : typeclass_instances.
(* Turn [P] into an accessor.
Inputs:
@@ -548,12 +550,12 @@ Hint Mode ElimAcc + ! ! ! ! ! ! ! - : typeclass_instances.
- [M1], [M2]: the two accessor modalities (they will typically still have
some evars though, e.g. for the masks)
*)
-Class IntoAcc {PROP : bi} {X : Type} (Pacc : PROP) (φ : Prop) (Pin : PROP)
+Class IntoAcc {SI} {PROP : bi SI} {X : Type} (Pacc : PROP) (φ : Prop) (Pin : PROP)
(M1 M2 : PROP → PROP) (α β : X → PROP) (mγ : X → option PROP) :=
into_acc : φ → Pacc -∗ Pin -∗ accessor M1 M2 α β mγ.
-Arguments IntoAcc {_} {_} _%I _ _%I _%I _%I _%I _%I _%I : simpl never.
-Arguments into_acc {_} {_} _%I _ _%I _%I _%I _%I _%I _%I {_} : simpl never.
-Hint Mode IntoAcc + - ! - - - - - - - : typeclass_instances.
+Arguments IntoAcc {_ _} {_} _%I _ _%I _%I _%I _%I _%I _%I : simpl never.
+Arguments into_acc {_ _} {_} _%I _ _%I _%I _%I _%I _%I _%I {_} : simpl never.
+Hint Mode IntoAcc - + - ! - - - - - - - : typeclass_instances.
(* The typeclass used for the [iInv] tactic.
Input: [Pinv]
@@ -575,13 +577,13 @@ Hint Mode IntoAcc + - ! - - - - - - - : typeclass_instances.
TODO: Add support for a binder (like accessors have it).
*)
-Class ElimInv {PROP : bi} {X : Type} (φ : Prop)
+Class ElimInv {SI} {PROP : bi SI} {X : Type} (φ : Prop)
(Pinv Pin : PROP) (Pout : X → PROP) (mPclose : option (X → PROP))
(Q : PROP) (Q' : X → PROP) :=
elim_inv : φ → Pinv ∗ Pin ∗ (∀ x, Pout x ∗ (default (λ _, emp) mPclose) x -∗ Q' x) ⊢ Q.
-Arguments ElimInv {_} {_} _ _%I _%I _%I _%I _%I _%I : simpl never.
-Arguments elim_inv {_} {_} _ _%I _%I _%I _%I _%I _%I {_}.
-Hint Mode ElimInv + - - ! - - ! ! - : typeclass_instances.
+Arguments ElimInv {_ _} {_} _ _%I _%I _%I _%I _%I _%I : simpl never.
+Arguments elim_inv {_ _} {_} _ _%I _%I _%I _%I _%I _%I {_}.
+Hint Mode ElimInv - + - - ! - - ! ! - : typeclass_instances.
(** We make sure that tactics that perform actions on *specific* hypotheses or
parts of the goal look through the [tc_opaque] connective, which is used to make
@@ -599,38 +601,38 @@ with the exception of:
- [MaybeIntoLaterN] and [FromLaterN] used by [iNext]
- [IntoPersistent] used by [iIntuitionistic]
*)
-Instance into_pure_tc_opaque {PROP : bi} (P : PROP) φ :
+Instance into_pure_tc_opaque {SI} {PROP : bi SI} (P : PROP) φ :
IntoPure P φ → IntoPure (tc_opaque P) φ := id.
-Instance from_pure_tc_opaque {PROP : bi} (a : bool) (P : PROP) φ :
+Instance from_pure_tc_opaque {SI} {PROP : bi SI} (a : bool) (P : PROP) φ :
FromPure a P φ → FromPure a (tc_opaque P) φ := id.
-Instance from_wand_tc_opaque {PROP : bi} (P Q1 Q2 : PROP) :
+Instance from_wand_tc_opaque {SI} {PROP : bi SI} (P Q1 Q2 : PROP) :
FromWand P Q1 Q2 → FromWand (tc_opaque P) Q1 Q2 := id.
-Instance into_wand_tc_opaque {PROP : bi} p q (R P Q : PROP) :
+Instance into_wand_tc_opaque {SI} {PROP : bi SI} p q (R P Q : PROP) :
IntoWand p q R P Q → IntoWand p q (tc_opaque R) P Q := id.
(* Higher precedence than [from_and_sep] so that [iCombine] does not loop. *)
-Instance from_and_tc_opaque {PROP : bi} (P Q1 Q2 : PROP) :
+Instance from_and_tc_opaque {SI} {PROP : bi SI} (P Q1 Q2 : PROP) :
FromAnd P Q1 Q2 → FromAnd (tc_opaque P) Q1 Q2 | 102 := id.
-Instance into_and_tc_opaque {PROP : bi} p (P Q1 Q2 : PROP) :
+Instance into_and_tc_opaque {SI} {PROP : bi SI} p (P Q1 Q2 : PROP) :
IntoAnd p P Q1 Q2 → IntoAnd p (tc_opaque P) Q1 Q2 := id.
-Instance into_sep_tc_opaque {PROP : bi} (P Q1 Q2 : PROP) :
+Instance into_sep_tc_opaque {SI} {PROP : bi SI} (P Q1 Q2 : PROP) :
IntoSep P Q1 Q2 → IntoSep (tc_opaque P) Q1 Q2 := id.
-Instance from_or_tc_opaque {PROP : bi} (P Q1 Q2 : PROP) :
+Instance from_or_tc_opaque {SI} {PROP : bi SI} (P Q1 Q2 : PROP) :
FromOr P Q1 Q2 → FromOr (tc_opaque P) Q1 Q2 := id.
-Instance into_or_tc_opaque {PROP : bi} (P Q1 Q2 : PROP) :
+Instance into_or_tc_opaque {SI} {PROP : bi SI} (P Q1 Q2 : PROP) :
IntoOr P Q1 Q2 → IntoOr (tc_opaque P) Q1 Q2 := id.
-Instance from_exist_tc_opaque {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :
+Instance from_exist_tc_opaque {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :
FromExist P Φ → FromExist (tc_opaque P) Φ := id.
-Instance into_exist_tc_opaque {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :
+Instance into_exist_tc_opaque {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :
IntoExist P Φ → IntoExist (tc_opaque P) Φ := id.
-Instance into_forall_tc_opaque {PROP : bi} {A} (P : PROP) (Φ : A → PROP) :
+Instance into_forall_tc_opaque {SI} {PROP : bi SI} {A} (P : PROP) (Φ : A → PROP) :
IntoForall P Φ → IntoForall (tc_opaque P) Φ := id.
-Instance from_modal_tc_opaque {PROP1 PROP2 : bi} {A}
+Instance from_modal_tc_opaque {SI} {PROP1 PROP2 : bi SI} {A}
M (sel : A) (P : PROP2) (Q : PROP1) :
FromModal M sel P Q → FromModal M sel (tc_opaque P) Q := id.
-Instance elim_modal_tc_opaque {PROP : bi} φ p p' (P P' Q Q' : PROP) :
+Instance elim_modal_tc_opaque {SI} {PROP : bi SI} φ p p' (P P' Q Q' : PROP) :
ElimModal φ p p' P P' Q Q' → ElimModal φ p p' (tc_opaque P) P' Q Q' := id.
-Instance into_inv_tc_opaque {PROP : bi} (P : PROP) N :
+Instance into_inv_tc_opaque {SI} {PROP : bi SI} (P : PROP) N :
IntoInv P N → IntoInv (tc_opaque P) N := id.
-Instance elim_inv_tc_opaque {PROP : sbi} {X} φ Pinv Pin Pout Pclose Q Q' :
+Instance elim_inv_tc_opaque {SI} {PROP : sbi SI} {X} φ Pinv Pin Pout Pclose Q Q' :
ElimInv (PROP:=PROP) (X:=X) φ Pinv Pin Pout Pclose Q Q' →
ElimInv φ (tc_opaque Pinv) Pin Pout Pclose Q Q' := id.
diff --git a/theories/proofmode/coq_tactics.v b/theories/proofmode/coq_tactics.v
index fbfb2a7ce89453d12370a4e1a5366226ceaefe0a..d804d8221f5d9863ea7cfb383259bf522ac37bd0 100644
--- a/theories/proofmode/coq_tactics.v
+++ b/theories/proofmode/coq_tactics.v
@@ -7,13 +7,13 @@ Import env_notations.
(* Coq versions of the tactics *)
Section bi_tactics.
-Context {PROP : bi}.
+Context {SI} {PROP : bi SI}.
Implicit Types Γ : env PROP.
Implicit Types Δ : envs PROP.
Implicit Types P Q : PROP.
(** * Adequacy *)
-Lemma tac_adequate P : envs_entails (Envs Enil Enil 1) P → P.
+Lemma tac_adequate P : envs_entails (Envs Enil Enil 1) P → emp ⊢ P.
Proof.
rewrite envs_entails_eq !of_envs_eq /=.
rewrite intuitionistically_True_emp left_id=><-.
@@ -51,7 +51,7 @@ Global Instance affine_env_snoc Γ i P :
Proof. by constructor. Qed.
(* If the BI is affine, no need to walk on the whole environment. *)
-Global Instance affine_env_bi `(BiAffine PROP) Γ : AffineEnv Γ | 0.
+Global Instance affine_env_bi `(BiAffine SI PROP) Γ : AffineEnv Γ | 0.
Proof. induction Γ; apply _. Qed.
Instance affine_env_spatial Δ :
@@ -439,7 +439,7 @@ Proof.
Qed.
Lemma tac_pose_proof Δ j P Q :
- P →
+ (emp ⊢ P) →
match envs_app true (Esnoc Enil j P) Δ with
| None => False
| Some Δ' => envs_entails Δ' Q
@@ -498,12 +498,12 @@ Proof.
Qed.
(** * Combining *)
-Class FromSeps {PROP : bi} (P : PROP) (Qs : list PROP) :=
+Class FromSeps {SI} {PROP : bi SI} (P : PROP) (Qs : list PROP) :=
from_seps : [∗] Qs ⊢ P.
-Arguments FromSeps {_} _%I _%I.
-Arguments from_seps {_} _%I _%I {_}.
+Arguments FromSeps {_ _} _%I _%I.
+Arguments from_seps {_ _} _%I _%I {_}.
-Global Instance from_seps_nil : @FromSeps PROP emp [].
+Global Instance from_seps_nil : @FromSeps SI PROP emp [].
Proof. by rewrite /FromSeps. Qed.
Global Instance from_seps_singleton P : FromSeps P [P] | 1.
Proof. by rewrite /FromSeps /= right_id. Qed.
@@ -732,7 +732,7 @@ Inputs:
Outputs:
- [Γout] : the resulting environment. *)
-Class TransformIntuitionisticEnv {PROP1 PROP2} (M : modality PROP1 PROP2)
+Class TransformIntuitionisticEnv {SI} {PROP1 PROP2: bi SI} (M : modality PROP1 PROP2)
(C : PROP2 → PROP1 → Prop) (Γin : env PROP2) (Γout : env PROP1) := {
transform_intuitionistic_env :
(∀ P Q, C P Q → □ P ⊢ M (□ Q)) →
@@ -755,7 +755,7 @@ Inputs:
Outputs:
- [Γout] : the resulting environment.
- [filtered] : a Boolean indicating if non-affine hypotheses have been cleared. *)
-Class TransformSpatialEnv {PROP1 PROP2} (M : modality PROP1 PROP2)
+Class TransformSpatialEnv {SI} {PROP1 PROP2: bi SI} (M : modality PROP1 PROP2)
(C : PROP2 → PROP1 → Prop) (Γin : env PROP2) (Γout : env PROP1)
(filtered : bool) := {
transform_spatial_env :
@@ -777,7 +777,7 @@ Inputs:
Outputs:
- [Γout] : the resulting environment. *)
-Inductive IntoModalIntuitionisticEnv {PROP2} : ∀ {PROP1} (M : modality PROP1 PROP2)
+Inductive IntoModalIntuitionisticEnv {SI} {PROP2: bi SI} : ∀ {PROP1} (M : modality PROP1 PROP2)
(Γin : env PROP2) (Γout : env PROP1), modality_action PROP1 PROP2 → Prop :=
| MIEnvIsEmpty_intuitionistic {PROP1} (M : modality PROP1 PROP2) :
IntoModalIntuitionisticEnv M Enil Enil MIEnvIsEmpty
@@ -788,7 +788,7 @@ Inductive IntoModalIntuitionisticEnv {PROP2} : ∀ {PROP1} (M : modality PROP1 P
(M : modality PROP1 PROP2) (C : PROP2 → PROP1 → Prop) Γin Γout :
TransformIntuitionisticEnv M C Γin Γout →
IntoModalIntuitionisticEnv M Γin Γout (MIEnvTransform C)
- | MIEnvClear_intuitionistic {PROP1 : bi} (M : modality PROP1 PROP2) Γ :
+ | MIEnvClear_intuitionistic {PROP1: bi SI} (M : modality PROP1 PROP2) Γ :
IntoModalIntuitionisticEnv M Γ Enil MIEnvClear
| MIEnvId_intuitionistic (M : modality PROP2 PROP2) Γ :
IntoModalIntuitionisticEnv M Γ Γ MIEnvId.
@@ -809,7 +809,7 @@ Inputs:
Outputs:
- [Γout] : the resulting environment.
- [filtered] : a Boolean indicating if non-affine hypotheses have been cleared. *)
-Inductive IntoModalSpatialEnv {PROP2} : ∀ {PROP1} (M : modality PROP1 PROP2)
+Inductive IntoModalSpatialEnv {SI} {PROP2: bi SI} : ∀ {PROP1} (M : modality PROP1 PROP2)
(Γin : env PROP2) (Γout : env PROP1), modality_action PROP1 PROP2 → bool → Prop :=
| MIEnvIsEmpty_spatial {PROP1} (M : modality PROP1 PROP2) :
IntoModalSpatialEnv M Enil Enil MIEnvIsEmpty false
@@ -820,7 +820,7 @@ Inductive IntoModalSpatialEnv {PROP2} : ∀ {PROP1} (M : modality PROP1 PROP2)
(M : modality PROP1 PROP2) (C : PROP2 → PROP1 → Prop) Γin Γout fi :
TransformSpatialEnv M C Γin Γout fi →
IntoModalSpatialEnv M Γin Γout (MIEnvTransform C) fi
- | MIEnvClear_spatial {PROP1 : bi} (M : modality PROP1 PROP2) Γ :
+ | MIEnvClear_spatial {PROP1 : bi SI} (M : modality PROP1 PROP2) Γ :
IntoModalSpatialEnv M Γ Enil MIEnvClear false
| MIEnvId_spatial (M : modality PROP2 PROP2) Γ :
IntoModalSpatialEnv M Γ Γ MIEnvId false.
@@ -829,7 +829,7 @@ Existing Instances MIEnvIsEmpty_spatial MIEnvForall_spatial
MIEnvTransform_spatial MIEnvClear_spatial MIEnvId_spatial.
Section tac_modal_intro.
- Context {PROP1 PROP2 : bi} (M : modality PROP1 PROP2).
+ Context {SI} {PROP1 PROP2 : bi SI} (M : modality PROP1 PROP2).
Global Instance transform_intuitionistic_env_nil C : TransformIntuitionisticEnv M C Enil Enil.
Proof.
@@ -940,7 +940,7 @@ Section tac_modal_intro.
End tac_modal_intro.
Section sbi_tactics.
-Context {PROP : sbi}.
+Context {SI} {PROP : sbi SI}.
Implicit Types Γ : env PROP.
Implicit Types Δ : envs PROP.
Implicit Types P Q : PROP.
@@ -948,7 +948,7 @@ Implicit Types P Q : PROP.
(** * Rewriting *)
Lemma tac_rewrite Δ i p Pxy d Q :
envs_lookup i Δ = Some (p, Pxy) →
- ∀ {A : ofeT} (x y : A) (Φ : A → PROP),
+ ∀ {A : ofeT SI} (x y : A) (Φ : A → PROP),
IntoInternalEq Pxy x y →
(Q ⊣⊢ Φ (if d is Left then y else x)) →
NonExpansive Φ →
@@ -963,7 +963,7 @@ Qed.
Lemma tac_rewrite_in Δ i p Pxy j q P d Q :
envs_lookup i Δ = Some (p, Pxy) →
envs_lookup j Δ = Some (q, P) →
- ∀ {A : ofeT} (x y : A) (Φ : A → PROP),
+ ∀ {A : ofeT SI} (x y : A) (Φ : A → PROP),
IntoInternalEq Pxy x y →
(P ⊣⊢ Φ (if d is Left then y else x)) →
NonExpansive Φ →
@@ -1006,7 +1006,7 @@ Proof. by split. Qed.
Lemma into_laterN_env_sound n Δ1 Δ2 :
MaybeIntoLaterNEnvs n Δ1 Δ2 → of_envs Δ1 ⊢ ▷^n (of_envs Δ2).
Proof.
- intros [[Hp ??] [Hs ??]]; rewrite !of_envs_eq /= !laterN_and !laterN_sep.
+ intros [[Hp ??] [Hs ??]]; rewrite !of_envs_eq /= !laterN_and -laterN_sep_2.
rewrite -{1}laterN_intro. apply and_mono, sep_mono.
- apply pure_mono; destruct 1; constructor; naive_solver.
- apply Hp; rewrite /= /MaybeIntoLaterN.
diff --git a/theories/proofmode/environments.v b/theories/proofmode/environments.v
index a0e04eb0e7bbbc9affe13f6f0b2f8e2600347d9c..9290d4b7123c5fd5d573179b7eb109b8dfb250ff 100644
--- a/theories/proofmode/environments.v
+++ b/theories/proofmode/environments.v
@@ -212,16 +212,16 @@ Global Instance env_to_list_subenv_proper :
Proof. induction 1; simpl; constructor; auto. Qed.
End env.
-Record envs (PROP : bi) := Envs {
+Record envs {SI} (PROP : bi SI) := Envs {
env_intuitionistic : env PROP;
env_spatial : env PROP;
env_counter : positive (** A counter to generate fresh hypothesis names *)
}.
Add Printing Constructor envs.
-Arguments Envs {_} _ _ _.
-Arguments env_intuitionistic {_} _.
-Arguments env_spatial {_} _.
-Arguments env_counter {_} _.
+Arguments Envs {_ _} _ _ _.
+Arguments env_intuitionistic {_ _} _.
+Arguments env_spatial {_ _} _.
+Arguments env_counter {_ _} _.
(** We now define the judgment [envs_entails Δ Q] for proof mode entailments.
This judgment expresses that [Q] can be proved under the proof mode environment
@@ -242,49 +242,49 @@ For all definitions below, we first define a version that take the two contexts
[env_intuitionistic] and [env_spatial] as its arguments, and then lift these
definitions that take the whole proof mode context [Δ : envs PROP]. This is
crucial to make sure that the counter [env_counter] is not part of the seal. *)
-Record envs_wf' {PROP : bi} (Γp Γs : env PROP) := {
+Record envs_wf' {SI} {PROP : bi SI} (Γp Γs : env PROP) := {
env_intuitionistic_valid : env_wf Γp;
env_spatial_valid : env_wf Γs;
envs_disjoint i : Γp !! i = None ∨ Γs !! i = None
}.
-Definition envs_wf {PROP : bi} (Δ : envs PROP) :=
+Definition envs_wf {SI} {PROP : bi SI} (Δ : envs PROP) :=
envs_wf' (env_intuitionistic Δ) (env_spatial Δ).
-Definition of_envs' {PROP : bi} (Γp Γs : env PROP) : PROP :=
+Definition of_envs' {SI} {PROP : bi SI} (Γp Γs : env PROP) : PROP :=
(⌜envs_wf' Γp Γs⌠∧ □ [∧] Γp ∗ [∗] Γs)%I.
-Instance: Params (@of_envs') 1 := {}.
-Definition of_envs {PROP : bi} (Δ : envs PROP) : PROP :=
+Instance: Params (@of_envs') 2 := {}.
+Definition of_envs {SI} {PROP : bi SI} (Δ : envs PROP) : PROP :=
of_envs' (env_intuitionistic Δ) (env_spatial Δ).
-Instance: Params (@of_envs) 1 := {}.
+Instance: Params (@of_envs) 2 := {}.
Arguments of_envs : simpl never.
Definition envs_entails_aux :
- seal (λ {PROP : bi} (Γp Γs : env PROP) (Q : PROP), of_envs' Γp Γs ⊢ Q).
+ seal (λ {SI} {PROP : bi SI} (Γp Γs : env PROP) (Q : PROP), of_envs' Γp Γs ⊢ Q).
Proof. by eexists. Qed.
-Definition envs_entails {PROP : bi} (Δ : envs PROP) (Q : PROP) : Prop :=
- envs_entails_aux.(unseal) PROP (env_intuitionistic Δ) (env_spatial Δ) Q.
+Definition envs_entails {SI} {PROP : bi SI} (Δ : envs PROP) (Q : PROP) : Prop :=
+ envs_entails_aux.(unseal) SI PROP (env_intuitionistic Δ) (env_spatial Δ) Q.
Definition envs_entails_eq :
- @envs_entails = λ {PROP} (Δ : envs PROP) Q, (of_envs Δ ⊢ Q).
+ @envs_entails = λ {SI PROP} (Δ : envs PROP) Q, (of_envs Δ ⊢ Q).
Proof. by rewrite /envs_entails envs_entails_aux.(seal_eq). Qed.
-Arguments envs_entails {PROP} Δ Q%I : rename.
-Instance: Params (@envs_entails) 1 := {}.
+Arguments envs_entails {SI PROP} Δ Q%I : rename.
+Instance: Params (@envs_entails) 2 := {}.
-Record envs_Forall2 {PROP : bi} (R : relation PROP) (Δ1 Δ2 : envs PROP) := {
+Record envs_Forall2 {SI} {PROP : bi SI} (R : relation PROP) (Δ1 Δ2 : envs PROP) := {
env_intuitionistic_Forall2 : env_Forall2 R (env_intuitionistic Δ1) (env_intuitionistic Δ2);
env_spatial_Forall2 : env_Forall2 R (env_spatial Δ1) (env_spatial Δ2)
}.
-Definition envs_dom {PROP} (Δ : envs PROP) : list ident :=
+Definition envs_dom {SI} {PROP: bi SI} (Δ : envs PROP) : list ident :=
env_dom (env_intuitionistic Δ) ++ env_dom (env_spatial Δ).
-Definition envs_lookup {PROP} (i : ident) (Δ : envs PROP) : option (bool * PROP) :=
+Definition envs_lookup {SI} {PROP: bi SI} (i : ident) (Δ : envs PROP) : option (bool * PROP) :=
let (Γp,Γs,n) := Δ in
match env_lookup i Γp with
| Some P => Some (true, P)
| None => P ↠env_lookup i Γs; Some (false, P)
end.
-Definition envs_delete {PROP} (remove_intuitionistic : bool)
+Definition envs_delete {SI} {PROP: bi SI} (remove_intuitionistic : bool)
(i : ident) (p : bool) (Δ : envs PROP) : envs PROP :=
let (Γp,Γs,n) := Δ in
match p with
@@ -292,7 +292,7 @@ Definition envs_delete {PROP} (remove_intuitionistic : bool)
| false => Envs Γp (env_delete i Γs) n
end.
-Definition envs_lookup_delete {PROP} (remove_intuitionistic : bool)
+Definition envs_lookup_delete {SI} {PROP: bi SI} (remove_intuitionistic : bool)
(i : ident) (Δ : envs PROP) : option (bool * PROP * envs PROP) :=
let (Γp,Γs,n) := Δ in
match env_lookup_delete i Γp with
@@ -300,7 +300,7 @@ Definition envs_lookup_delete {PROP} (remove_intuitionistic : bool)
| None => ''(P,Γs') ↠env_lookup_delete i Γs; Some (false, P, Envs Γp Γs' n)
end.
-Fixpoint envs_lookup_delete_list {PROP} (remove_intuitionistic : bool)
+Fixpoint envs_lookup_delete_list {SI} {PROP: bi SI} (remove_intuitionistic : bool)
(js : list ident) (Δ : envs PROP) : option (bool * list PROP * envs PROP) :=
match js with
| [] => Some (true, [], Δ)
@@ -310,12 +310,12 @@ Fixpoint envs_lookup_delete_list {PROP} (remove_intuitionistic : bool)
Some ((p:bool) && q, P :: Ps, Δ'')
end.
-Definition envs_snoc {PROP} (Δ : envs PROP)
+Definition envs_snoc {SI} {PROP: bi SI} (Δ : envs PROP)
(p : bool) (j : ident) (P : PROP) : envs PROP :=
let (Γp,Γs,n) := Δ in
if p then Envs (Esnoc Γp j P) Γs n else Envs Γp (Esnoc Γs j P) n.
-Definition envs_app {PROP : bi} (p : bool)
+Definition envs_app {SI} {PROP: bi SI} (p : bool)
(Γ : env PROP) (Δ : envs PROP) : option (envs PROP) :=
let (Γp,Γs,n) := Δ in
match p with
@@ -323,7 +323,7 @@ Definition envs_app {PROP : bi} (p : bool)
| false => _ ↠env_app Γ Γp; Γs' ↠env_app Γ Γs; Some (Envs Γp Γs' n)
end.
-Definition envs_simple_replace {PROP : bi} (i : ident) (p : bool)
+Definition envs_simple_replace {SI} {PROP: bi SI} (i : ident) (p : bool)
(Γ : env PROP) (Δ : envs PROP) : option (envs PROP) :=
let (Γp,Γs,n) := Δ in
match p with
@@ -331,24 +331,24 @@ Definition envs_simple_replace {PROP : bi} (i : ident) (p : bool)
| false => _ ↠env_app Γ Γp; Γs' ↠env_replace i Γ Γs; Some (Envs Γp Γs' n)
end.
-Definition envs_replace {PROP : bi} (i : ident) (p q : bool)
+Definition envs_replace {SI} {PROP: bi SI} (i : ident) (p q : bool)
(Γ : env PROP) (Δ : envs PROP) : option (envs PROP) :=
if beq p q then envs_simple_replace i p Γ Δ
else envs_app q Γ (envs_delete true i p Δ).
-Definition env_spatial_is_nil {PROP} (Δ : envs PROP) : bool :=
+Definition env_spatial_is_nil {SI} {PROP: bi SI} (Δ : envs PROP) : bool :=
if env_spatial Δ is Enil then true else false.
-Definition envs_clear_spatial {PROP} (Δ : envs PROP) : envs PROP :=
+Definition envs_clear_spatial {SI} {PROP: bi SI} (Δ : envs PROP) : envs PROP :=
Envs (env_intuitionistic Δ) Enil (env_counter Δ).
-Definition envs_clear_intuitionistic {PROP} (Δ : envs PROP) : envs PROP :=
+Definition envs_clear_intuitionistic {SI} {PROP: bi SI} (Δ : envs PROP) : envs PROP :=
Envs Enil (env_spatial Δ) (env_counter Δ).
-Definition envs_incr_counter {PROP} (Δ : envs PROP) : envs PROP :=
+Definition envs_incr_counter {SI} {PROP: bi SI} (Δ : envs PROP) : envs PROP :=
Envs (env_intuitionistic Δ) (env_spatial Δ) (Pos_succ (env_counter Δ)).
-Fixpoint envs_split_go {PROP}
+Fixpoint envs_split_go {SI} {PROP: bi SI}
(js : list ident) (Δ1 Δ2 : envs PROP) : option (envs PROP * envs PROP) :=
match js with
| [] => Some (Δ1, Δ2)
@@ -359,19 +359,19 @@ Fixpoint envs_split_go {PROP}
end.
(* if [d = Right] then [result = (remaining hyps, hyps named js)] and
if [d = Left] then [result = (hyps named js, remaining hyps)] *)
-Definition envs_split {PROP} (d : direction)
+Definition envs_split {SI} {PROP: bi SI} (d : direction)
(js : list ident) (Δ : envs PROP) : option (envs PROP * envs PROP) :=
''(Δ1,Δ2) ↠envs_split_go js Δ (envs_clear_spatial Δ);
if d is Right then Some (Δ1,Δ2) else Some (Δ2,Δ1).
-Definition env_to_prop {PROP : bi} (Γ : env PROP) : PROP :=
+Definition env_to_prop {SI} {PROP: bi SI} (Γ : env PROP) : PROP :=
let fix aux Γ acc :=
match Γ with Enil => acc | Esnoc Γ _ P => aux Γ (P ∗ acc)%I end
in
match Γ with Enil => emp%I | Esnoc Γ _ P => aux Γ P end.
Section envs.
-Context {PROP : bi}.
+Context {SI} {PROP : bi SI}.
Implicit Types Γ Γp Γs : env PROP.
Implicit Types Δ : envs PROP.
Implicit Types P Q : PROP.
@@ -402,27 +402,27 @@ Lemma envs_Forall2_impl (R R' : relation PROP) Δ1 Δ2 :
Proof. intros [??] ?; constructor; eauto using env_Forall2_impl. Qed.
Global Instance env_intuitionistic_mono :
- Proper (envs_Forall2 (⊢) ==> env_Forall2 (⊢)) (@env_intuitionistic PROP).
+ Proper (envs_Forall2 (⊢) ==> env_Forall2 (⊢)) (@env_intuitionistic SI PROP).
Proof. solve_proper. Qed.
Global Instance env_intuitionistic_flip_mono :
- Proper (flip (envs_Forall2 (⊢)) ==> flip (env_Forall2 (⊢))) (@env_intuitionistic PROP).
+ Proper (flip (envs_Forall2 (⊢)) ==> flip (env_Forall2 (⊢))) (@env_intuitionistic SI PROP).
Proof. solve_proper. Qed.
Global Instance env_intuitionistic_proper :
- Proper (envs_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢)) (@env_intuitionistic PROP).
+ Proper (envs_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢)) (@env_intuitionistic SI PROP).
Proof. solve_proper. Qed.
Global Instance env_spatial_mono :
- Proper (envs_Forall2 (⊢) ==> env_Forall2 (⊢)) (@env_spatial PROP).
+ Proper (envs_Forall2 (⊢) ==> env_Forall2 (⊢)) (@env_spatial SI PROP).
Proof. solve_proper. Qed.
Global Instance env_spatial_flip_mono :
- Proper (flip (envs_Forall2 (⊢)) ==> flip (env_Forall2 (⊢))) (@env_spatial PROP).
+ Proper (flip (envs_Forall2 (⊢)) ==> flip (env_Forall2 (⊢))) (@env_spatial SI PROP).
Proof. solve_proper. Qed.
Global Instance env_spatial_proper :
- Proper (envs_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢)) (@env_spatial PROP).
+ Proper (envs_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢)) (@env_spatial SI PROP).
Proof. solve_proper. Qed.
Global Instance of_envs_mono' :
- Proper (env_Forall2 (⊢) ==> env_Forall2 (⊢) ==> (⊢)) (@of_envs' PROP).
+ Proper (env_Forall2 (⊢) ==> env_Forall2 (⊢) ==> (⊢)) (@of_envs' SI PROP).
Proof.
intros Γp1 Γp2 Hp Γs1 Γs2 Hs; apply and_mono; simpl in *.
- apply pure_mono=> -[???]. constructor;
@@ -430,29 +430,29 @@ Proof.
- by repeat f_equiv.
Qed.
Global Instance of_envs_proper' :
- Proper (env_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢) ==> (⊣⊢)) (@of_envs' PROP).
+ Proper (env_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢) ==> (⊣⊢)) (@of_envs' SI PROP).
Proof.
intros Γp1 Γp2 Hp Γs1 Γs2 Hs; apply (anti_symm (⊢)); apply of_envs_mono';
eapply (env_Forall2_impl (⊣⊢)); by eauto using equiv_entails.
Qed.
-Global Instance of_envs_mono : Proper (envs_Forall2 (⊢) ==> (⊢)) (@of_envs PROP).
+Global Instance of_envs_mono : Proper (envs_Forall2 (⊢) ==> (⊢)) (@of_envs SI PROP).
Proof. solve_proper. Qed.
-Global Instance of_envs_proper : Proper (envs_Forall2 (⊣⊢) ==> (⊣⊢)) (@of_envs PROP).
+Global Instance of_envs_proper : Proper (envs_Forall2 (⊣⊢) ==> (⊣⊢)) (@of_envs SI PROP).
Proof. solve_proper. Qed.
Global Instance Envs_proper (R : relation PROP) :
- Proper (env_Forall2 R ==> env_Forall2 R ==> eq ==> envs_Forall2 R) (@Envs PROP).
+ Proper (env_Forall2 R ==> env_Forall2 R ==> eq ==> envs_Forall2 R) (@Envs SI PROP).
Proof. by constructor. Qed.
Global Instance envs_entails_proper :
- Proper (envs_Forall2 (⊣⊢) ==> (⊣⊢) ==> iff) (@envs_entails PROP).
+ Proper (envs_Forall2 (⊣⊢) ==> (⊣⊢) ==> iff) (@envs_entails SI PROP).
Proof. rewrite envs_entails_eq. solve_proper. Qed.
Global Instance envs_entails_mono :
- Proper (flip (envs_Forall2 (⊢)) ==> (⊢) ==> impl) (@envs_entails PROP).
+ Proper (flip (envs_Forall2 (⊢)) ==> (⊢) ==> impl) (@envs_entails SI PROP).
Proof. rewrite envs_entails_eq=> Δ1 Δ2 ? P1 P2 <- <-. by f_equiv. Qed.
Global Instance envs_entails_flip_mono :
- Proper (envs_Forall2 (⊢) ==> flip (⊢) ==> flip impl) (@envs_entails PROP).
+ Proper (envs_Forall2 (⊢) ==> flip (⊢) ==> flip impl) (@envs_entails SI PROP).
Proof. rewrite envs_entails_eq=> Δ1 Δ2 ? P1 P2 <- <-. by f_equiv. Qed.
Lemma envs_delete_intuitionistic Δ i : envs_delete false i true Δ = Δ.
diff --git a/theories/proofmode/frame_instances.v b/theories/proofmode/frame_instances.v
index f9c8cd9213be92ce632dc3cfcefb06aa15a219be..628968e5653ece8990e9f03cd28be813b5bfd84c 100644
--- a/theories/proofmode/frame_instances.v
+++ b/theories/proofmode/frame_instances.v
@@ -7,7 +7,7 @@ Import bi.
(** This file defines the instances that make up the framing machinery. *)
Section bi.
-Context {PROP : bi}.
+Context {SI} {PROP : bi SI}.
Implicit Types P Q R : PROP.
(* Frame *)
Global Instance frame_here_absorbing p R : Absorbing R → Frame p R R True | 0.
@@ -42,30 +42,30 @@ Proof.
- by rewrite right_id -affinely_affinely_if affine_affinely.
Qed.
-Global Instance make_embed_pure `{BiEmbed PROP PROP'} φ :
+Global Instance make_embed_pure `{BiEmbed SI PROP PROP'} φ :
KnownMakeEmbed (PROP:=PROP) ⌜φ⌠⌜φâŒ.
Proof. apply embed_pure. Qed.
-Global Instance make_embed_emp `{BiEmbedEmp PROP PROP'} :
+Global Instance make_embed_emp `{BiEmbedEmp SI PROP PROP'} :
KnownMakeEmbed (PROP:=PROP) emp emp.
Proof. apply embed_emp. Qed.
-Global Instance make_embed_default `{BiEmbed PROP PROP'} P :
- MakeEmbed P ⎡P⎤ | 100.
+Global Instance make_embed_default `{BiEmbed SI PROP PROP'} P :
+ MakeEmbed P (⎡P⎤)%I | 100.
Proof. by rewrite /MakeEmbed. Qed.
-Global Instance frame_embed `{BiEmbed PROP PROP'} p P Q (Q' : PROP') R :
+Global Instance frame_embed `{BiEmbed SI PROP PROP'} p P Q (Q' : PROP') R :
Frame p R P Q → MakeEmbed Q Q' → Frame p ⎡R⎤ ⎡P⎤ Q'.
Proof.
rewrite /Frame /MakeEmbed => <- <-.
rewrite embed_sep embed_intuitionistically_if_2 => //.
Qed.
-Global Instance frame_pure_embed `{BiEmbed PROP PROP'} p P Q (Q' : PROP') φ :
+Global Instance frame_pure_embed `{BiEmbed SI PROP PROP'} p P Q (Q' : PROP') φ :
Frame p ⌜φ⌠P Q → MakeEmbed Q Q' → Frame p ⌜φ⌠⎡P⎤ Q'.
Proof. rewrite /Frame /MakeEmbed -embed_pure. apply (frame_embed p P Q). Qed.
Global Instance make_sep_emp_l P : KnownLMakeSep emp P P.
Proof. apply left_id, _. Qed.
Global Instance make_sep_emp_r P : KnownRMakeSep P emp P.
-Proof. apply right_id, _. Qed.
+Proof. unfold KnownRMakeSep, MakeSep. eapply right_id, _. Qed.
Global Instance make_sep_true_l P : Absorbing P → KnownLMakeSep True P P.
Proof. intros. apply True_sep, _. Qed.
Global Instance make_sep_true_r P : Absorbing P → KnownRMakeSep P True P.
@@ -188,7 +188,7 @@ Proof.
by rewrite assoc (comm _ P1) -assoc wand_elim_r.
Qed.
-Global Instance make_affinely_True : @KnownMakeAffinely PROP True emp | 0.
+Global Instance make_affinely_True : @KnownMakeAffinely SI PROP True emp | 0.
Proof. by rewrite /KnownMakeAffinely /MakeAffinely affinely_True_emp affinely_emp. Qed.
Global Instance make_affinely_affine P : Affine P → KnownMakeAffinely P P | 1.
Proof. intros. by rewrite /KnownMakeAffinely /MakeAffinely affine_affinely. Qed.
@@ -203,7 +203,7 @@ Proof.
Qed.
Global Instance make_intuitionistically_True :
- @KnownMakeIntuitionistically PROP True emp | 0.
+ @KnownMakeIntuitionistically SI PROP True emp | 0.
Proof.
by rewrite /KnownMakeIntuitionistically /MakeIntuitionistically
intuitionistically_True_emp.
@@ -225,7 +225,7 @@ Proof.
rewrite -intuitionistically_sep_2 intuitionistically_idemp //.
Qed.
-Global Instance make_absorbingly_emp : @KnownMakeAbsorbingly PROP emp True | 0.
+Global Instance make_absorbingly_emp : @KnownMakeAbsorbingly SI PROP emp True | 0.
Proof.
by rewrite /KnownMakeAbsorbingly /MakeAbsorbingly
-absorbingly_True_emp absorbingly_pure.
@@ -242,9 +242,9 @@ Proof.
rewrite /Frame /MakeAbsorbingly=> <- <- /=. by rewrite absorbingly_sep_r.
Qed.
-Global Instance make_persistently_true : @KnownMakePersistently PROP True True.
+Global Instance make_persistently_true : @KnownMakePersistently SI PROP True True.
Proof. by rewrite /KnownMakePersistently /MakePersistently persistently_pure. Qed.
-Global Instance make_persistently_emp : @KnownMakePersistently PROP emp True.
+Global Instance make_persistently_emp : @KnownMakePersistently SI PROP emp True.
Proof.
by rewrite /KnownMakePersistently /MakePersistently
-persistently_True_emp persistently_pure.
@@ -289,18 +289,18 @@ End bi.
(** SBI Framing *)
Section sbi.
-Context {PROP : sbi}.
+Context {SI} {PROP : sbi SI}.
Implicit Types P Q R : PROP.
-Global Instance frame_eq_embed `{SbiEmbed PROP PROP'} p P Q (Q' : PROP')
- {A : ofeT} (a b : A) :
+Global Instance frame_eq_embed `{SbiEmbed SI PROP PROP'} p P Q (Q' : PROP')
+ {A : ofeT SI} (a b : A) :
Frame p (a ≡ b) P Q → MakeEmbed Q Q' → Frame p (a ≡ b) ⎡P⎤ Q'.
Proof. rewrite /Frame /MakeEmbed -embed_internal_eq. apply (frame_embed p P Q). Qed.
-Global Instance make_laterN_true n : @KnownMakeLaterN PROP n True True | 0.
+Global Instance make_laterN_true n : @KnownMakeLaterN SI PROP n True True | 0.
Proof. by rewrite /KnownMakeLaterN /MakeLaterN laterN_True. Qed.
Global Instance make_laterN_emp `{!BiAffine PROP} n :
- @KnownMakeLaterN PROP n emp emp | 0.
+ @KnownMakeLaterN SI PROP n emp emp | 0.
Proof. by rewrite /KnownMakeLaterN /MakeLaterN laterN_emp. Qed.
Global Instance make_laterN_default P : MakeLaterN n P (â–·^n P) | 100.
Proof. by rewrite /MakeLaterN. Qed.
@@ -310,24 +310,24 @@ Global Instance frame_later p R R' P Q Q' :
Frame p R P Q → MakeLaterN 1 Q Q' → Frame p R' (▷ P) Q'.
Proof.
rewrite /Frame /MakeLaterN /MaybeIntoLaterN=>-[->] <- <-.
- by rewrite later_intuitionistically_if_2 later_sep.
+ by rewrite later_intuitionistically_if_2 later_sep_2.
Qed.
Global Instance frame_laterN p n R R' P Q Q' :
TCNoBackTrack (MaybeIntoLaterN true n R' R) →
Frame p R P Q → MakeLaterN n Q Q' → Frame p R' (▷^n P) Q'.
Proof.
rewrite /Frame /MakeLaterN /MaybeIntoLaterN=>-[->] <- <-.
- by rewrite laterN_intuitionistically_if_2 laterN_sep.
+ by rewrite laterN_intuitionistically_if_2 laterN_sep_2.
Qed.
-Global Instance frame_bupd `{BiBUpd PROP} p R P Q :
+Global Instance frame_bupd `{BiBUpd SI PROP} p R P Q :
Frame p R P Q → Frame p R (|==> P) (|==> Q).
Proof. rewrite /Frame=><-. by rewrite bupd_frame_l. Qed.
-Global Instance frame_fupd `{BiFUpd PROP} p E1 E2 R P Q :
+Global Instance frame_fupd `{BiFUpd SI PROP} p E1 E2 R P Q :
Frame p R P Q → Frame p R (|={E1,E2}=> P) (|={E1,E2}=> Q).
Proof. rewrite /Frame=><-. by rewrite fupd_frame_l. Qed.
-Global Instance make_except_0_True : @KnownMakeExcept0 PROP True True.
+Global Instance make_except_0_True : @KnownMakeExcept0 SI PROP True True.
Proof. by rewrite /KnownMakeExcept0 /MakeExcept0 except_0_True. Qed.
Global Instance make_except_0_default P : MakeExcept0 P (â—‡ P) | 100.
Proof. by rewrite /MakeExcept0. Qed.
diff --git a/theories/proofmode/ltac_tactics.v b/theories/proofmode/ltac_tactics.v
index 81e03f9a56d3ff0eaf33933bc8800bd5ab21b900..540b6b3fb84c395b324caf5358483d80b952e560 100644
--- a/theories/proofmode/ltac_tactics.v
+++ b/theories/proofmode/ltac_tactics.v
@@ -58,7 +58,7 @@ Ltac iTypeOf H :=
pm_eval (envs_lookup H Δ).
Ltac iBiOfGoal :=
- match goal with |- @envs_entails ?PROP _ _ => PROP end.
+ match goal with |- @envs_entails _ ?PROP _ _ => PROP end.
Tactic Notation "iMatchHyp" tactic1(tac) :=
match goal with
@@ -80,7 +80,7 @@ Tactic Notation "iStartProof" :=
introduced. *)
Tactic Notation "iStartProof" uconstr(PROP) :=
lazymatch goal with
- | |- @envs_entails ?PROP' _ _ =>
+ | |- @envs_entails ?SI ?PROP' _ _ =>
(* This cannot be shared with the other [iStartProof], because
type_term has a non-negligeable performance impact. *)
let x := type_term (eq_refl : @eq Type PROP PROP') in idtac
@@ -90,7 +90,7 @@ Tactic Notation "iStartProof" uconstr(PROP) :=
this case, typing this expression will end up unifying PROP with
[bi_car _], and hence trigger the canonical structures mechanism
to find the corresponding bi. *)
- | |- ?φ => notypeclasses refine ((λ P : PROP, @as_emp_valid_2 φ _ P) _ _ _);
+ | |- ?φ => notypeclasses refine ((λ P : PROP, @as_emp_valid_2 φ _ _ P) _ _ _);
[iSolveTC || fail "iStartProof: not a BI assertion"
|apply tac_adequate]
end.
@@ -1870,18 +1870,18 @@ Tactic Notation "iRevertIntros" "(" ident(x1) ident(x2) ident(x3) ident(x4)
iRevertIntros (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15) "" with tac.
(** * Destruct tactic *)
-Class CopyDestruct {PROP : bi} (P : PROP).
-Arguments CopyDestruct {_} _%I.
-Hint Mode CopyDestruct + ! : typeclass_instances.
+Class CopyDestruct {SI} {PROP : bi SI} (P : PROP).
+Arguments CopyDestruct {_ _} _%I.
+Hint Mode CopyDestruct - + ! : typeclass_instances.
-Instance copy_destruct_forall {PROP : bi} {A} (Φ : A → PROP) : CopyDestruct (∀ x, Φ x) := {}.
-Instance copy_destruct_impl {PROP : bi} (P Q : PROP) :
+Instance copy_destruct_forall {SI} {PROP : bi SI} {A} (Φ : A → PROP) : CopyDestruct (∀ x, Φ x) := {}.
+Instance copy_destruct_impl {SI} {PROP : bi SI} (P Q : PROP) :
CopyDestruct Q → CopyDestruct (P → Q) := {}.
-Instance copy_destruct_wand {PROP : bi} (P Q : PROP) :
+Instance copy_destruct_wand {SI} {PROP : bi SI} (P Q : PROP) :
CopyDestruct Q → CopyDestruct (P -∗ Q) := {}.
-Instance copy_destruct_affinely {PROP : bi} (P : PROP) :
+Instance copy_destruct_affinely {SI} {PROP : bi SI} (P : PROP) :
CopyDestruct P → CopyDestruct (<affine> P) := {}.
-Instance copy_destruct_persistently {PROP : bi} (P : PROP) :
+Instance copy_destruct_persistently {SI} {PROP : bi SI} (P : PROP) :
CopyDestruct P → CopyDestruct (<pers> P) := {}.
Tactic Notation "iDestructCore" open_constr(lem) "as" constr(p) tactic3(tac) :=
diff --git a/theories/proofmode/modalities.v b/theories/proofmode/modalities.v
index b5b9bcc0a361cbe88704f343ce1a7956a8559676..e44691917c5ef7a7b180065e9ddf6a4fcbf21124 100644
--- a/theories/proofmode/modalities.v
+++ b/theories/proofmode/modalities.v
@@ -49,21 +49,21 @@ it is implemented as an endomapping. On the other hand, the embedding modality
⎡-⎤ is a mapping between propositions of different BI-algebras.
*)
-Inductive modality_action (PROP1 : bi) : bi → Type :=
- | MIEnvIsEmpty {PROP2 : bi} : modality_action PROP1 PROP2
+Inductive modality_action {SI: indexT} (PROP1 : bi SI) : bi SI → Type :=
+ | MIEnvIsEmpty {PROP2 : bi SI} : modality_action PROP1 PROP2
| MIEnvForall (C : PROP1 → Prop) : modality_action PROP1 PROP1
- | MIEnvTransform {PROP2 : bi} (C : PROP2 → PROP1 → Prop) : modality_action PROP1 PROP2
+ | MIEnvTransform {PROP2 : bi SI} (C : PROP2 → PROP1 → Prop) : modality_action PROP1 PROP2
| MIEnvClear {PROP2} : modality_action PROP1 PROP2
| MIEnvId : modality_action PROP1 PROP1.
-Arguments MIEnvIsEmpty {_ _}.
-Arguments MIEnvForall {_} _.
-Arguments MIEnvTransform {_ _} _.
-Arguments MIEnvClear {_ _}.
-Arguments MIEnvId {_}.
+Arguments MIEnvIsEmpty {_ _ _}.
+Arguments MIEnvForall {_ _} _.
+Arguments MIEnvTransform {_ _ _} _.
+Arguments MIEnvClear {_ _ _}.
+Arguments MIEnvId {_ _}.
Notation MIEnvFilter C := (MIEnvTransform (TCDiag C)).
-Definition modality_intuitionistic_action_spec {PROP1 PROP2}
+Definition modality_intuitionistic_action_spec {SI: indexT} {PROP1 PROP2: bi SI}
(s : modality_action PROP1 PROP2) : (PROP1 → PROP2) → Prop :=
match s with
| MIEnvIsEmpty => λ M, True
@@ -77,7 +77,7 @@ Definition modality_intuitionistic_action_spec {PROP1 PROP2}
| MIEnvId => λ M, ∀ P, □ P ⊢ M (□ P)
end.
-Definition modality_spatial_action_spec {PROP1 PROP2}
+Definition modality_spatial_action_spec {SI} {PROP1 PROP2: bi SI}
(s : modality_action PROP1 PROP2) : (PROP1 → PROP2) → Prop :=
match s with
| MIEnvIsEmpty => λ M, True
@@ -89,7 +89,7 @@ Definition modality_spatial_action_spec {PROP1 PROP2}
(* A modality is then a record packing together the modality with the laws it
should satisfy to justify the given actions for both contexts: *)
-Record modality_mixin {PROP1 PROP2 : bi} (M : PROP1 → PROP2)
+Record modality_mixin {SI} {PROP1 PROP2 : bi SI} (M : PROP1 → PROP2)
(iaction saction : modality_action PROP1 PROP2) := {
modality_mixin_intuitionistic : modality_intuitionistic_action_spec iaction M;
modality_mixin_spatial : modality_spatial_action_spec saction M;
@@ -98,19 +98,19 @@ Record modality_mixin {PROP1 PROP2 : bi} (M : PROP1 → PROP2)
modality_mixin_sep P Q : M P ∗ M Q ⊢ M (P ∗ Q)
}.
-Record modality (PROP1 PROP2 : bi) := Modality {
+Record modality {SI} (PROP1 PROP2 : bi SI) := Modality {
modality_car :> PROP1 → PROP2;
modality_intuitionistic_action : modality_action PROP1 PROP2;
modality_spatial_action : modality_action PROP1 PROP2;
modality_mixin_of :
modality_mixin modality_car modality_intuitionistic_action modality_spatial_action
}.
-Arguments Modality {_ _} _ {_ _} _.
-Arguments modality_intuitionistic_action {_ _} _.
-Arguments modality_spatial_action {_ _} _.
+Arguments Modality {_ _ _} _ {_ _} _.
+Arguments modality_intuitionistic_action {_ _ _} _.
+Arguments modality_spatial_action {_ _ _} _.
Section modality.
- Context {PROP1 PROP2} (M : modality PROP1 PROP2).
+ Context {SI: indexT} {PROP1 PROP2: bi SI} (M : modality PROP1 PROP2).
Lemma modality_intuitionistic_transform C P Q :
modality_intuitionistic_action M = MIEnvTransform C → C P Q → □ P ⊢ M (□ Q).
@@ -140,7 +140,7 @@ Section modality.
End modality.
Section modality1.
- Context {PROP} (M : modality PROP PROP).
+ Context {SI: indexT} {PROP: bi SI} (M : modality PROP PROP).
Lemma modality_intuitionistic_forall C P :
modality_intuitionistic_action M = MIEnvForall C → C P → □ P ⊢ M (□ P).
@@ -183,6 +183,6 @@ End modality1.
which will instruct [iModIntro] to introduce the modality without modifying the
proof mode context. Examples of such modalities are [bupd], [fupd], [except_0],
[monPred_subjectively] and [bi_absorbingly]. *)
-Lemma modality_id_mixin {PROP : bi} : modality_mixin (@id PROP) MIEnvId MIEnvId.
+Lemma modality_id_mixin `{PROP : bi SI} : modality_mixin (@id PROP) MIEnvId MIEnvId.
Proof. split; simpl; eauto. Qed.
-Definition modality_id {PROP : bi} := Modality (@id PROP) modality_id_mixin.
+Definition modality_id `{PROP : bi SI} := Modality (@id PROP) modality_id_mixin.
diff --git a/theories/proofmode/modality_instances.v b/theories/proofmode/modality_instances.v
index 2cb4571d58079a36b9aae058a7e4025d6e73718d..23e0a20aa6088fcdd0aaff271ab9149f49885bb8 100644
--- a/theories/proofmode/modality_instances.v
+++ b/theories/proofmode/modality_instances.v
@@ -4,10 +4,10 @@ Set Default Proof Using "Type".
Import bi.
Section bi_modalities.
- Context {PROP : bi}.
+ Context {SI} {PROP : bi SI}.
Lemma modality_persistently_mixin :
- modality_mixin (@bi_persistently PROP) MIEnvId MIEnvClear.
+ modality_mixin (@bi_persistently SI PROP) MIEnvId MIEnvClear.
Proof.
split; simpl; eauto using equiv_entails_sym, persistently_intro,
persistently_mono, persistently_sep_2 with typeclass_instances.
@@ -16,7 +16,7 @@ Section bi_modalities.
Modality _ modality_persistently_mixin.
Lemma modality_affinely_mixin :
- modality_mixin (@bi_affinely PROP) MIEnvId (MIEnvForall Affine).
+ modality_mixin (@bi_affinely SI PROP) MIEnvId (MIEnvForall Affine).
Proof.
split; simpl; eauto using equiv_entails_sym, affinely_intro, affinely_mono,
affinely_sep_2 with typeclass_instances.
@@ -25,7 +25,7 @@ Section bi_modalities.
Modality _ modality_affinely_mixin.
Lemma modality_intuitionistically_mixin :
- modality_mixin (@bi_intuitionistically PROP) MIEnvId MIEnvIsEmpty.
+ modality_mixin (@bi_intuitionistically SI PROP) MIEnvId MIEnvIsEmpty.
Proof.
split; simpl; eauto using equiv_entails_sym, intuitionistically_emp,
affinely_mono, persistently_mono, intuitionistically_idemp,
@@ -34,7 +34,7 @@ Section bi_modalities.
Definition modality_intuitionistically :=
Modality _ modality_intuitionistically_mixin.
- Lemma modality_embed_mixin `{BiEmbed PROP PROP'} :
+ Lemma modality_embed_mixin `{BiEmbed SI PROP PROP'} :
modality_mixin (@embed PROP PROP' _)
(MIEnvTransform IntoEmbed) (MIEnvTransform IntoEmbed).
Proof.
@@ -43,28 +43,28 @@ Section bi_modalities.
- intros P Q. rewrite /IntoEmbed=> ->. by rewrite embed_intuitionistically_2.
- by intros P Q ->.
Qed.
- Definition modality_embed `{BiEmbed PROP PROP'} :=
+ Definition modality_embed `{BiEmbed SI PROP PROP'} :=
Modality _ modality_embed_mixin.
End bi_modalities.
Section sbi_modalities.
- Context {PROP : sbi}.
+ Context {SI} {PROP : sbi SI}.
- Lemma modality_plainly_mixin `{BiPlainly PROP} :
+ Lemma modality_plainly_mixin `{BiPlainly SI PROP} :
modality_mixin (@plainly PROP _) (MIEnvForall Plain) MIEnvClear.
Proof.
split; simpl; split_and?; eauto using equiv_entails_sym, plainly_intro,
plainly_mono, plainly_and, plainly_sep_2 with typeclass_instances.
Qed.
- Definition modality_plainly `{BiPlainly PROP} :=
+ Definition modality_plainly `{BiPlainly SI PROP} :=
Modality _ modality_plainly_mixin.
Lemma modality_laterN_mixin n :
- modality_mixin (@sbi_laterN PROP n)
+ modality_mixin (Nat.iter n (@sbi_later SI PROP))
(MIEnvTransform (MaybeIntoLaterN false n)) (MIEnvTransform (MaybeIntoLaterN false n)).
Proof.
split; simpl; split_and?; eauto using equiv_entails_sym, laterN_intro,
- laterN_mono, laterN_and, laterN_sep with typeclass_instances.
+ laterN_mono, laterN_and, laterN_sep_2 with typeclass_instances.
rewrite /MaybeIntoLaterN=> P Q ->. by rewrite laterN_intuitionistically_2.
Qed.
Definition modality_laterN n :=
diff --git a/theories/proofmode/monpred.v b/theories/proofmode/monpred.v
deleted file mode 100644
index 0c9e1e9f3bbb59971b42981cbfe7bd05836d4414..0000000000000000000000000000000000000000
--- a/theories/proofmode/monpred.v
+++ /dev/null
@@ -1,619 +0,0 @@
-From iris.bi Require Export monpred.
-From iris.bi Require Import plainly.
-From iris.proofmode Require Import tactics modality_instances.
-
-Class MakeMonPredAt {I : biIndex} {PROP : bi} (i : I)
- (P : monPred I PROP) (ð“Ÿ : PROP) :=
- make_monPred_at : P i ⊣⊢ ð“Ÿ.
-Arguments MakeMonPredAt {_ _} _ _%I _%I.
-Hint Mode MakeMonPredAt + + - ! - : typeclass_instances.
-
-Class IsBiIndexRel {I : biIndex} (i j : I) := is_bi_index_rel : i ⊑ j.
-Hint Mode IsBiIndexRel + - - : typeclass_instances.
-Instance is_bi_index_rel_refl {I : biIndex} (i : I) : IsBiIndexRel i i | 0.
-Proof. by rewrite /IsBiIndexRel. Qed.
-Hint Extern 1 (IsBiIndexRel _ _) => unfold IsBiIndexRel; assumption
- : typeclass_instances.
-
-(** Frame [ð“¡] into the goal [monPred_at P i] and determine the remainder [ð“ ].
- Used when framing encounters a monPred_at in the goal. *)
-Class FrameMonPredAt {I : biIndex} {PROP : bi} (p : bool) (i : I)
- (ð“¡ : PROP) (P : monPred I PROP) (ð“ : PROP) :=
- frame_monPred_at : â–¡?p 𓡠∗ ð“ -∗ P i.
-Arguments FrameMonPredAt {_ _} _ _ _%I _%I _%I.
-Hint Mode FrameMonPredAt + + + - ! ! - : typeclass_instances.
-
-Section modalities.
- Context {I : biIndex} {PROP : bi}.
-
- Lemma modality_objectively_mixin :
- modality_mixin (@monPred_objectively I PROP)
- (MIEnvFilter Objective) (MIEnvFilter Objective).
- Proof.
- split; simpl; split_and?; intros;
- try match goal with H : TCDiag _ _ _ |- _ => destruct H end;
- eauto using bi.equiv_entails_sym, objective_objectively,
- monPred_objectively_mono, monPred_objectively_and,
- monPred_objectively_sep_2 with typeclass_instances.
- Qed.
- Definition modality_objectively :=
- Modality _ modality_objectively_mixin.
-End modalities.
-
-Section bi.
-Context {I : biIndex} {PROP : bi}.
-Local Notation monPredI := (monPredI I PROP).
-Local Notation monPred := (monPred I PROP).
-Local Notation MakeMonPredAt := (@MakeMonPredAt I PROP).
-Implicit Types P Q R : monPred.
-Implicit Types ð“Ÿ ð“ ð“¡ : PROP.
-Implicit Types φ : Prop.
-Implicit Types i j : I.
-
-Global Instance from_modal_objectively P :
- FromModal modality_objectively (<obj> P) (<obj> P) P | 1.
-Proof. by rewrite /FromModal. Qed.
-Global Instance from_modal_subjectively P :
- FromModal modality_id (<subj> P) (<subj> P) P | 1.
-Proof. by rewrite /FromModal /= -monPred_subjectively_intro. Qed.
-
-Global Instance from_modal_affinely_monPred_at `(sel : A) P Q ð“ i :
- FromModal modality_affinely sel P Q → MakeMonPredAt i Q ð“ →
- FromModal modality_affinely sel (P i) ð“ | 0.
-Proof.
- rewrite /FromModal /MakeMonPredAt /==> <- <-. by rewrite monPred_at_affinely.
-Qed.
-Global Instance from_modal_persistently_monPred_at `(sel : A) P Q ð“ i :
- FromModal modality_persistently sel P Q → MakeMonPredAt i Q ð“ →
- FromModal modality_persistently sel (P i) ð“ | 0.
-Proof.
- rewrite /FromModal /MakeMonPredAt /==> <- <-. by rewrite monPred_at_persistently.
-Qed.
-Global Instance from_modal_intuitionistically_monPred_at `(sel : A) P Q ð“ i :
- FromModal modality_intuitionistically sel P Q → MakeMonPredAt i Q ð“ →
- FromModal modality_intuitionistically sel (P i) ð“ | 0.
-Proof.
- rewrite /FromModal /MakeMonPredAt /==> <- <-.
- by rewrite monPred_at_affinely monPred_at_persistently.
-Qed.
-Global Instance from_modal_id_monPred_at `(sel : A) P Q ð“ i :
- FromModal modality_id sel P Q → MakeMonPredAt i Q ð“ →
- FromModal modality_id sel (P i) ð“ .
-Proof. by rewrite /FromModal /MakeMonPredAt=> <- <-. Qed.
-
-Global Instance make_monPred_at_pure φ i : MakeMonPredAt i ⌜φ⌠⌜φâŒ.
-Proof. by rewrite /MakeMonPredAt monPred_at_pure. Qed.
-Global Instance make_monPred_at_emp i : MakeMonPredAt i emp emp.
-Proof. by rewrite /MakeMonPredAt monPred_at_emp. Qed.
-Global Instance make_monPred_at_sep i P ð“Ÿ Q ð“ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i Q ð“ →
- MakeMonPredAt i (P ∗ Q) (𓟠∗ ð“ ).
-Proof. by rewrite /MakeMonPredAt monPred_at_sep=><-<-. Qed.
-Global Instance make_monPred_at_and i P ð“Ÿ Q ð“ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i Q ð“ →
- MakeMonPredAt i (P ∧ Q) (𓟠∧ ð“ ).
-Proof. by rewrite /MakeMonPredAt monPred_at_and=><-<-. Qed.
-Global Instance make_monPred_at_or i P ð“Ÿ Q ð“ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i Q ð“ →
- MakeMonPredAt i (P ∨ Q) (𓟠∨ ð“ ).
-Proof. by rewrite /MakeMonPredAt monPred_at_or=><-<-. Qed.
-Global Instance make_monPred_at_forall {A} i (Φ : A → monPred) (Ψ : A → PROP) :
- (∀ a, MakeMonPredAt i (Φ a) (Ψ a)) → MakeMonPredAt i (∀ a, Φ a) (∀ a, Ψ a).
-Proof. rewrite /MakeMonPredAt monPred_at_forall=>H. by setoid_rewrite <- H. Qed.
-Global Instance make_monPred_at_exists {A} i (Φ : A → monPred) (Ψ : A → PROP) :
- (∀ a, MakeMonPredAt i (Φ a) (Ψ a)) → MakeMonPredAt i (∃ a, Φ a) (∃ a, Ψ a).
-Proof. rewrite /MakeMonPredAt monPred_at_exist=>H. by setoid_rewrite <- H. Qed.
-Global Instance make_monPred_at_persistently i P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i (<pers> P) (<pers> ð“Ÿ).
-Proof. by rewrite /MakeMonPredAt monPred_at_persistently=><-. Qed.
-Global Instance make_monPred_at_affinely i P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i (<affine> P) (<affine> ð“Ÿ).
-Proof. by rewrite /MakeMonPredAt monPred_at_affinely=><-. Qed.
-Global Instance make_monPred_at_intuitionistically i P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i (â–¡ P) (â–¡ ð“Ÿ).
-Proof. by rewrite /MakeMonPredAt monPred_at_intuitionistically=><-. Qed.
-Global Instance make_monPred_at_absorbingly i P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i (<absorb> P) (<absorb> ð“Ÿ).
-Proof. by rewrite /MakeMonPredAt monPred_at_absorbingly=><-. Qed.
-Global Instance make_monPred_at_persistently_if i P ð“Ÿ p :
- MakeMonPredAt i P 𓟠→
- MakeMonPredAt i (<pers>?p P) (<pers>?p ð“Ÿ).
-Proof. destruct p; simpl; apply _. Qed.
-Global Instance make_monPred_at_affinely_if i P ð“Ÿ p :
- MakeMonPredAt i P 𓟠→
- MakeMonPredAt i (<affine>?p P) (<affine>?p ð“Ÿ).
-Proof. destruct p; simpl; apply _. Qed.
-Global Instance make_monPred_at_absorbingly_if i P ð“Ÿ p :
- MakeMonPredAt i P 𓟠→
- MakeMonPredAt i (<absorb>?p P) (<absorb>?p ð“Ÿ).
-Proof. destruct p; simpl; apply _. Qed.
-Global Instance make_monPred_at_intuitionistically_if i P ð“Ÿ p :
- MakeMonPredAt i P 𓟠→
- MakeMonPredAt i (â–¡?p P) (â–¡?p ð“Ÿ).
-Proof. destruct p; simpl; apply _. Qed.
-Global Instance make_monPred_at_embed i ð“Ÿ : MakeMonPredAt i ⎡ð“ŸâŽ¤ ð“Ÿ.
-Proof. by rewrite /MakeMonPredAt monPred_at_embed. Qed.
-Global Instance make_monPred_at_in i j : MakeMonPredAt j (monPred_in i) ⌜i ⊑ jâŒ.
-Proof. by rewrite /MakeMonPredAt monPred_at_in. Qed.
-Global Instance make_monPred_at_default i P : MakeMonPredAt i P (P i) | 100.
-Proof. by rewrite /MakeMonPredAt. Qed.
-Global Instance make_monPred_at_bupd `{BiBUpd PROP} i P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i (|==> P)%I (|==> ð“Ÿ)%I.
-Proof. by rewrite /MakeMonPredAt monPred_at_bupd=> <-. Qed.
-
-Global Instance from_assumption_make_monPred_at_l p i j P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ IsBiIndexRel j i → KnownLFromAssumption p (P j) ð“Ÿ.
-Proof.
- rewrite /MakeMonPredAt /KnownLFromAssumption /FromAssumption /IsBiIndexRel=><- ->.
- apply bi.intuitionistically_if_elim.
-Qed.
-Global Instance from_assumption_make_monPred_at_r p i j P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ IsBiIndexRel i j → KnownRFromAssumption p 𓟠(P j).
-Proof.
- rewrite /MakeMonPredAt /KnownRFromAssumption /FromAssumption /IsBiIndexRel=><- ->.
- apply bi.intuitionistically_if_elim.
-Qed.
-
-Global Instance from_assumption_make_monPred_objectively P Q :
- FromAssumption p P Q → KnownLFromAssumption p (<obj> P) Q.
-Proof.
- intros ?.
- by rewrite /KnownLFromAssumption /FromAssumption monPred_objectively_elim.
-Qed.
-Global Instance from_assumption_make_monPred_subjectively P Q :
- FromAssumption p P Q → KnownRFromAssumption p P (<subj> Q).
-Proof.
- intros ?.
- by rewrite /KnownRFromAssumption /FromAssumption -monPred_subjectively_intro.
-Qed.
-
-Global Instance as_emp_valid_monPred_at φ P (Φ : I → PROP) :
- AsEmpValid0 φ P → (∀ i, MakeMonPredAt i P (Φ i)) → AsEmpValid φ (∀ i, Φ i) | 100.
-Proof.
- rewrite /MakeMonPredAt /AsEmpValid0 /AsEmpValid /bi_emp_valid=> -> EQ.
- setoid_rewrite <-EQ. split.
- - move=>[H]. apply bi.forall_intro=>i. rewrite -H. by rewrite monPred_at_emp.
- - move=>HP. split=>i. rewrite monPred_at_emp HP bi.forall_elim //.
-Qed.
-Global Instance as_emp_valid_monPred_at_wand φ P Q (Φ Ψ : I → PROP) :
- AsEmpValid0 φ (P -∗ Q) →
- (∀ i, MakeMonPredAt i P (Φ i)) → (∀ i, MakeMonPredAt i Q (Ψ i)) →
- AsEmpValid φ (∀ i, Φ i -∗ Ψ i).
-Proof.
- rewrite /AsEmpValid0 /AsEmpValid /MakeMonPredAt. intros -> EQ1 EQ2.
- setoid_rewrite <-EQ1. setoid_rewrite <-EQ2. split.
- - move=>/bi.wand_entails HP. setoid_rewrite HP. by iIntros (i) "$".
- - move=>HP. apply bi.entails_wand. split=>i. iIntros "H". by iApply HP.
-Qed.
-Global Instance as_emp_valid_monPred_at_equiv φ P Q (Φ Ψ : I → PROP) :
- AsEmpValid0 φ (P ∗-∗ Q) →
- (∀ i, MakeMonPredAt i P (Φ i)) → (∀ i, MakeMonPredAt i Q (Ψ i)) →
- AsEmpValid φ (∀ i, Φ i ∗-∗ Ψ i).
-Proof.
- rewrite /AsEmpValid0 /AsEmpValid /MakeMonPredAt. intros -> EQ1 EQ2.
- setoid_rewrite <-EQ1. setoid_rewrite <-EQ2. split.
- - move=>/bi.wand_iff_equiv HP. setoid_rewrite HP. iIntros. iSplit; iIntros "$".
- - move=>HP. apply bi.equiv_wand_iff. split=>i. by iSplit; iIntros; iApply HP.
-Qed.
-
-Global Instance into_pure_monPred_at P φ i : IntoPure P φ → IntoPure (P i) φ.
-Proof. rewrite /IntoPure=>->. by rewrite monPred_at_pure. Qed.
-Global Instance from_pure_monPred_at a P φ i : FromPure a P φ → FromPure a (P i) φ.
-Proof. rewrite /FromPure=><-. by rewrite monPred_at_affinely_if monPred_at_pure. Qed.
-Global Instance into_pure_monPred_in i j : @IntoPure PROP (monPred_in i j) (i ⊑ j).
-Proof. by rewrite /IntoPure monPred_at_in. Qed.
-Global Instance from_pure_monPred_in i j : @FromPure PROP false (monPred_in i j) (i ⊑ j).
-Proof. by rewrite /FromPure monPred_at_in. Qed.
-
-Global Instance into_persistent_monPred_at p P Q ð“ i :
- IntoPersistent p P Q → MakeMonPredAt i Q ð“ → IntoPersistent p (P i) ð“ | 0.
-Proof.
- rewrite /IntoPersistent /MakeMonPredAt =>-[/(_ i) ?] <-.
- by rewrite -monPred_at_persistently -monPred_at_persistently_if.
-Qed.
-
-Lemma into_wand_monPred_at_unknown_unknown p q R P ð“Ÿ Q ð“ i :
- IntoWand p q R P Q → MakeMonPredAt i P 𓟠→ MakeMonPredAt i Q ð“ →
- IntoWand p q (R i) ð“Ÿ ð“ .
-Proof.
- rewrite /IntoWand /MakeMonPredAt /bi_affinely_if /bi_persistently_if.
- destruct p, q=> /bi.wand_elim_l' [/(_ i) H] <- <-; apply bi.wand_intro_r;
- revert H; by rewrite monPred_at_sep ?monPred_at_affinely ?monPred_at_persistently.
-Qed.
-Lemma into_wand_monPred_at_unknown_known p q R P ð“Ÿ Q i j :
- IsBiIndexRel i j → IntoWand p q R P Q →
- MakeMonPredAt j P 𓟠→ IntoWand p q (R i) 𓟠(Q j).
-Proof.
- rewrite /IntoWand /IsBiIndexRel /MakeMonPredAt=>-> ? ?.
- eapply into_wand_monPred_at_unknown_unknown=>//. apply _.
-Qed.
-Lemma into_wand_monPred_at_known_unknown_le p q R P Q ð“ i j :
- IsBiIndexRel i j → IntoWand p q R P Q →
- MakeMonPredAt j Q ð“ → IntoWand p q (R i) (P j) ð“ .
-Proof.
- rewrite /IntoWand /IsBiIndexRel /MakeMonPredAt=>-> ? ?.
- eapply into_wand_monPred_at_unknown_unknown=>//. apply _.
-Qed.
-Lemma into_wand_monPred_at_known_unknown_ge p q R P Q ð“ i j :
- IsBiIndexRel i j → IntoWand p q R P Q →
- MakeMonPredAt j Q ð“ → IntoWand p q (R j) (P i) ð“ .
-Proof.
- rewrite /IntoWand /IsBiIndexRel /MakeMonPredAt=>-> ? ?.
- eapply into_wand_monPred_at_unknown_unknown=>//. apply _.
-Qed.
-
-Global Instance into_wand_wand'_monPred p q P Q ð“Ÿ ð“ i :
- IntoWand' p q ((P -∗ Q) i) ð“Ÿ ð“ → IntoWand p q ((P -∗ Q) i) ð“Ÿ ð“ | 100.
-Proof. done. Qed.
-Global Instance into_wand_impl'_monPred p q P Q ð“Ÿ ð“ i :
- IntoWand' p q ((P → Q) i) ð“Ÿ ð“ → IntoWand p q ((P → Q) i) ð“Ÿ ð“ | 100.
-Proof. done. Qed.
-
-Global Instance from_forall_monPred_at_wand P Q (Φ Ψ : I → PROP) i :
- (∀ j, MakeMonPredAt j P (Φ j)) → (∀ j, MakeMonPredAt j Q (Ψ j)) →
- FromForall ((P -∗ Q) i)%I (λ j, ⌜i ⊑ j⌠→ Φ j -∗ Ψ j)%I.
-Proof.
- rewrite /FromForall /MakeMonPredAt monPred_at_wand=> H1 H2. do 2 f_equiv.
- by rewrite H1 H2.
-Qed.
-Global Instance from_forall_monPred_at_impl P Q (Φ Ψ : I → PROP) i :
- (∀ j, MakeMonPredAt j P (Φ j)) → (∀ j, MakeMonPredAt j Q (Ψ j)) →
- FromForall ((P → Q) i)%I (λ j, ⌜i ⊑ j⌠→ Φ j → Ψ j)%I.
-Proof.
- rewrite /FromForall /MakeMonPredAt monPred_at_impl=> H1 H2. do 2 f_equiv.
- by rewrite H1 H2 bi.pure_impl_forall.
-Qed.
-
-Global Instance into_forall_monPred_at_index P i :
- IntoForall (P i) (λ j, ⌜i ⊑ j⌠→ P j)%I | 100.
-Proof.
- rewrite /IntoForall. setoid_rewrite bi.pure_impl_forall.
- do 2 apply bi.forall_intro=>?. by f_equiv.
-Qed.
-
-Global Instance from_and_monPred_at P Q1 ð“ 1 Q2 ð“ 2 i :
- FromAnd P Q1 Q2 → MakeMonPredAt i Q1 ð“ 1 → MakeMonPredAt i Q2 ð“ 2 →
- FromAnd (P i) ð“ 1 ð“ 2.
-Proof.
- rewrite /FromAnd /MakeMonPredAt /MakeMonPredAt=> <- <- <-.
- by rewrite monPred_at_and.
-Qed.
-Global Instance into_and_monPred_at p P Q1 ð“ 1 Q2 ð“ 2 i :
- IntoAnd p P Q1 Q2 → MakeMonPredAt i Q1 ð“ 1 → MakeMonPredAt i Q2 ð“ 2 →
- IntoAnd p (P i) ð“ 1 ð“ 2.
-Proof.
- rewrite /IntoAnd /MakeMonPredAt /bi_affinely_if /bi_persistently_if.
- destruct p=>-[/(_ i) H] <- <-; revert H;
- by rewrite ?monPred_at_affinely ?monPred_at_persistently monPred_at_and.
-Qed.
-
-Global Instance from_sep_monPred_at P Q1 ð“ 1 Q2 ð“ 2 i :
- FromSep P Q1 Q2 → MakeMonPredAt i Q1 ð“ 1 → MakeMonPredAt i Q2 ð“ 2 →
- FromSep (P i) ð“ 1 ð“ 2.
-Proof. rewrite /FromSep /MakeMonPredAt=> <- <- <-. by rewrite monPred_at_sep. Qed.
-Global Instance into_sep_monPred_at P Q1 ð“ 1 Q2 ð“ 2 i :
- IntoSep P Q1 Q2 → MakeMonPredAt i Q1 ð“ 1 → MakeMonPredAt i Q2 ð“ 2 →
- IntoSep (P i) ð“ 1 ð“ 2.
-Proof. rewrite /IntoSep /MakeMonPredAt=> -> <- <-. by rewrite monPred_at_sep. Qed.
-Global Instance from_or_monPred_at P Q1 ð“ 1 Q2 ð“ 2 i :
- FromOr P Q1 Q2 → MakeMonPredAt i Q1 ð“ 1 → MakeMonPredAt i Q2 ð“ 2 →
- FromOr (P i) ð“ 1 ð“ 2.
-Proof. rewrite /FromOr /MakeMonPredAt=> <- <- <-. by rewrite monPred_at_or. Qed.
-Global Instance into_or_monPred_at P Q1 ð“ 1 Q2 ð“ 2 i :
- IntoOr P Q1 Q2 → MakeMonPredAt i Q1 ð“ 1 → MakeMonPredAt i Q2 ð“ 2 →
- IntoOr (P i) ð“ 1 ð“ 2.
-Proof. rewrite /IntoOr /MakeMonPredAt=> -> <- <-. by rewrite monPred_at_or. Qed.
-
-Global Instance from_exist_monPred_at {A} P (Φ : A → monPred) (Ψ : A → PROP) i :
- FromExist P Φ → (∀ a, MakeMonPredAt i (Φ a) (Ψ a)) → FromExist (P i) Ψ.
-Proof.
- rewrite /FromExist /MakeMonPredAt=><- H. setoid_rewrite <- H.
- by rewrite monPred_at_exist.
-Qed.
-Global Instance into_exist_monPred_at {A} P (Φ : A → monPred) (Ψ : A → PROP) i :
- IntoExist P Φ → (∀ a, MakeMonPredAt i (Φ a) (Ψ a)) → IntoExist (P i) Ψ.
-Proof.
- rewrite /IntoExist /MakeMonPredAt=>-> H. setoid_rewrite <- H.
- by rewrite monPred_at_exist.
-Qed.
-
-Global Instance from_forall_monPred_at_objectively P (Φ : I → PROP) i :
- (∀ i, MakeMonPredAt i P (Φ i)) → FromForall ((<obj> P) i)%I Φ.
-Proof.
- rewrite /FromForall /MakeMonPredAt monPred_at_objectively=>H. by setoid_rewrite <- H.
-Qed.
-Global Instance into_forall_monPred_at_objectively P (Φ : I → PROP) i :
- (∀ i, MakeMonPredAt i P (Φ i)) → IntoForall ((<obj> P) i) Φ.
-Proof.
- rewrite /IntoForall /MakeMonPredAt monPred_at_objectively=>H. by setoid_rewrite <- H.
-Qed.
-
-Global Instance from_exist_monPred_at_ex P (Φ : I → PROP) i :
- (∀ i, MakeMonPredAt i P (Φ i)) → FromExist ((<subj> P) i) Φ.
-Proof.
- rewrite /FromExist /MakeMonPredAt monPred_at_subjectively=>H. by setoid_rewrite <- H.
-Qed.
-Global Instance into_exist_monPred_at_ex P (Φ : I → PROP) i :
- (∀ i, MakeMonPredAt i P (Φ i)) → IntoExist ((<subj> P) i) Φ.
-Proof.
- rewrite /IntoExist /MakeMonPredAt monPred_at_subjectively=>H. by setoid_rewrite <- H.
-Qed.
-
-Global Instance from_forall_monPred_at {A} P (Φ : A → monPred) (Ψ : A → PROP) i :
- FromForall P Φ → (∀ a, MakeMonPredAt i (Φ a) (Ψ a)) → FromForall (P i) Ψ.
-Proof.
- rewrite /FromForall /MakeMonPredAt=><- H. setoid_rewrite <- H.
- by rewrite monPred_at_forall.
-Qed.
-Global Instance into_forall_monPred_at {A} P (Φ : A → monPred) (Ψ : A → PROP) i :
- IntoForall P Φ → (∀ a, MakeMonPredAt i (Φ a) (Ψ a)) → IntoForall (P i) Ψ.
-Proof.
- rewrite /IntoForall /MakeMonPredAt=>-> H. setoid_rewrite <- H.
- by rewrite monPred_at_forall.
-Qed.
-
-(* Framing. *)
-Global Instance frame_monPred_at_enter p i ð“¡ P ð“ :
- FrameMonPredAt p i ð“¡ P ð“ → Frame p ð“¡ (P i) ð“ .
-Proof. intros. done. Qed.
-Global Instance frame_monPred_at_here p P i j :
- IsBiIndexRel i j → FrameMonPredAt p j (P i) P emp | 0.
-Proof.
- rewrite /FrameMonPredAt /IsBiIndexRel right_id bi.intuitionistically_if_elim=> -> //.
-Qed.
-
-Global Instance frame_monPred_at_embed p ð“¡ ð“ ð“Ÿ i :
- Frame p ð“¡ ð“Ÿ ð“ → FrameMonPredAt p i ð“¡ (embed (B:=monPredI) ð“Ÿ) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_embed. Qed.
-Global Instance frame_monPred_at_sep p P Q ð“¡ ð“ i :
- Frame p ð“¡ (P i ∗ Q i) ð“ → FrameMonPredAt p i ð“¡ (P ∗ Q) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_sep. Qed.
-Global Instance frame_monPred_at_and p P Q ð“¡ ð“ i :
- Frame p ð“¡ (P i ∧ Q i) ð“ → FrameMonPredAt p i ð“¡ (P ∧ Q) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_and. Qed.
-Global Instance frame_monPred_at_or p P Q ð“¡ ð“ i :
- Frame p ð“¡ (P i ∨ Q i) ð“ → FrameMonPredAt p i ð“¡ (P ∨ Q) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_or. Qed.
-Global Instance frame_monPred_at_wand p P R Q1 Q2 i j :
- IsBiIndexRel i j →
- Frame p R Q1 Q2 →
- FrameMonPredAt p j (R i) (P -∗ Q1) ((P -∗ Q2) i).
-Proof.
- rewrite /Frame /FrameMonPredAt=>-> Hframe.
- rewrite -monPred_at_intuitionistically_if -monPred_at_sep. apply monPred_in_entails.
- change ((□?p R ∗ (P -∗ Q2)) -∗ P -∗ Q1). apply bi.wand_intro_r.
- rewrite -assoc bi.wand_elim_l. done.
-Qed.
-Global Instance frame_monPred_at_impl P R Q1 Q2 i j :
- IsBiIndexRel i j →
- Frame true R Q1 Q2 →
- FrameMonPredAt true j (R i) (P → Q1) ((P → Q2) i).
-Proof.
- rewrite /Frame /FrameMonPredAt=>-> Hframe.
- rewrite -monPred_at_intuitionistically_if -monPred_at_sep. apply monPred_in_entails.
- change ((□ R ∗ (P → Q2)) -∗ P → Q1).
- rewrite -bi.persistently_and_intuitionistically_sep_l. apply bi.impl_intro_r.
- rewrite -assoc bi.impl_elim_l bi.persistently_and_intuitionistically_sep_l. done.
-Qed.
-Global Instance frame_monPred_at_forall {X : Type} p (Ψ : X → monPred) ð“¡ ð“ i :
- Frame p ð“¡ (∀ x, Ψ x i) ð“ → FrameMonPredAt p i ð“¡ (∀ x, Ψ x) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_forall. Qed.
-Global Instance frame_monPred_at_exist {X : Type} p (Ψ : X → monPred) ð“¡ ð“ i :
- Frame p ð“¡ (∃ x, Ψ x i) ð“ → FrameMonPredAt p i ð“¡ (∃ x, Ψ x) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_exist. Qed.
-
-Global Instance frame_monPred_at_absorbingly p P ð“¡ ð“ i :
- Frame p ð“¡ (<absorb> P i) ð“ → FrameMonPredAt p i ð“¡ (<absorb> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_absorbingly. Qed.
-Global Instance frame_monPred_at_affinely p P ð“¡ ð“ i :
- Frame p ð“¡ (<affine> P i) ð“ → FrameMonPredAt p i ð“¡ (<affine> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_affinely. Qed.
-Global Instance frame_monPred_at_persistently p P ð“¡ ð“ i :
- Frame p ð“¡ (<pers> P i) ð“ → FrameMonPredAt p i ð“¡ (<pers> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_persistently. Qed.
-Global Instance frame_monPred_at_intuitionistically p P ð“¡ ð“ i :
- Frame p ð“¡ (â–¡ P i) ð“ → FrameMonPredAt p i ð“¡ (â–¡ P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_intuitionistically. Qed.
-Global Instance frame_monPred_at_objectively p P ð“¡ ð“ i :
- Frame p ð“¡ (∀ i, P i) ð“ → FrameMonPredAt p i ð“¡ (<obj> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_objectively. Qed.
-Global Instance frame_monPred_at_subjectively p P ð“¡ ð“ i :
- Frame p ð“¡ (∃ i, P i) ð“ → FrameMonPredAt p i ð“¡ (<subj> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_subjectively. Qed.
-Global Instance frame_monPred_at_bupd `{BiBUpd PROP} p P ð“¡ ð“ i :
- Frame p ð“¡ (|==> P i) ð“ → FrameMonPredAt p i ð“¡ (|==> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_bupd. Qed.
-
-Global Instance into_embed_objective P :
- Objective P → IntoEmbed P (∀ i, P i).
-Proof.
- rewrite /IntoEmbed=> ?.
- by rewrite {1}(objective_objectively P) monPred_objectively_unfold.
-Qed.
-
-Global Instance elim_modal_at_bupd_goal `{BiBUpd PROP} φ p p' ð“Ÿ ð“Ÿ' Q Q' i :
- ElimModal φ p p' ð“Ÿ ð“Ÿ' (|==> Q i) (|==> Q' i) →
- ElimModal φ p p' ð“Ÿ ð“Ÿ' ((|==> Q) i) ((|==> Q') i).
-Proof. by rewrite /ElimModal !monPred_at_bupd. Qed.
-Global Instance elim_modal_at_bupd_hyp `{BiBUpd PROP} φ p p' P ð“Ÿ ð“Ÿ' ð“ ð“ ' i:
- MakeMonPredAt i P 𓟠→
- ElimModal φ p p' (|==> ð“Ÿ) ð“Ÿ' ð“ ð“ ' →
- ElimModal φ p p' ((|==> P) i) ð“Ÿ' ð“ ð“ '.
-Proof. by rewrite /MakeMonPredAt /ElimModal monPred_at_bupd=><-. Qed.
-
-Global Instance add_modal_at_bupd_goal `{BiBUpd PROP} φ ð“Ÿ ð“Ÿ' Q i :
- AddModal ð“Ÿ ð“Ÿ' (|==> Q i)%I → AddModal ð“Ÿ ð“Ÿ' ((|==> Q) i).
-Proof. by rewrite /AddModal !monPred_at_bupd. Qed.
-End bi.
-
-(* When P and/or Q are evars when doing typeclass search on [IntoWand
- (R i) P Q], we use [MakeMonPredAt] in order to normalize the
- result of unification. However, when they are not evars, we want to
- propagate the known information through typeclass search. Hence, we
- do not want to use [MakeMonPredAt].
-
- As a result, depending on P and Q being evars, we use a different
- version of [into_wand_monPred_at_xx_xx]. *)
-Hint Extern 3 (IntoWand _ _ (monPred_at _ _) ?P ?Q) =>
- is_evar P; is_evar Q;
- eapply @into_wand_monPred_at_unknown_unknown
- : typeclass_instances.
-Hint Extern 2 (IntoWand _ _ (monPred_at _ _) ?P (monPred_at ?Q _)) =>
- eapply @into_wand_monPred_at_unknown_known
- : typeclass_instances.
-Hint Extern 2 (IntoWand _ _ (monPred_at _ _) (monPred_at ?P _) ?Q) =>
- eapply @into_wand_monPred_at_known_unknown_le
- : typeclass_instances.
-Hint Extern 2 (IntoWand _ _ (monPred_at _ _) (monPred_at ?P _) ?Q) =>
- eapply @into_wand_monPred_at_known_unknown_ge
- : typeclass_instances.
-
-Section sbi.
-Context {I : biIndex} {PROP : sbi}.
-Local Notation monPred := (monPred I PROP).
-Implicit Types P Q R : monPred.
-Implicit Types ð“Ÿ ð“ ð“¡ : PROP.
-Implicit Types φ : Prop.
-Implicit Types i j : I.
-
-Global Instance from_forall_monPred_at_plainly `{BiPlainly PROP} i P Φ :
- (∀ i, MakeMonPredAt i P (Φ i)) →
- FromForall ((■P) i) (λ j, ■(Φ j))%I.
-Proof.
- rewrite /FromForall /MakeMonPredAt=>HPΦ. rewrite monPred_at_plainly.
- by setoid_rewrite HPΦ.
-Qed.
-Global Instance into_forall_monPred_at_plainly `{BiPlainly PROP} i P Φ :
- (∀ i, MakeMonPredAt i P (Φ i)) →
- IntoForall ((■P) i) (λ j, ■(Φ j))%I.
-Proof.
- rewrite /IntoForall /MakeMonPredAt=>HPΦ. rewrite monPred_at_plainly.
- by setoid_rewrite HPΦ.
-Qed.
-
-Global Instance is_except_0_monPred_at i P :
- IsExcept0 P → IsExcept0 (P i).
-Proof. rewrite /IsExcept0=>- [/(_ i)]. by rewrite monPred_at_except_0. Qed.
-
-Global Instance make_monPred_at_internal_eq {A : ofeT} (x y : A) i :
- @MakeMonPredAt I PROP i (x ≡ y) (x ≡ y).
-Proof. by rewrite /MakeMonPredAt monPred_at_internal_eq. Qed.
-Global Instance make_monPred_at_except_0 i P ð“ :
- MakeMonPredAt i P ð“ → MakeMonPredAt i (â—‡ P)%I (â—‡ ð“ )%I.
-Proof. by rewrite /MakeMonPredAt monPred_at_except_0=><-. Qed.
-Global Instance make_monPred_at_later i P ð“ :
- MakeMonPredAt i P ð“ → MakeMonPredAt i (â–· P)%I (â–· ð“ )%I.
-Proof. by rewrite /MakeMonPredAt monPred_at_later=><-. Qed.
-Global Instance make_monPred_at_laterN i n P ð“ :
- MakeMonPredAt i P ð“ → MakeMonPredAt i (â–·^n P)%I (â–·^n ð“ )%I.
-Proof. rewrite /MakeMonPredAt=> <-. elim n=>//= ? <-. by rewrite monPred_at_later. Qed.
-Global Instance make_monPred_at_fupd `{BiFUpd PROP} i E1 E2 P ð“Ÿ :
- MakeMonPredAt i P 𓟠→ MakeMonPredAt i (|={E1,E2}=> P)%I (|={E1,E2}=> ð“Ÿ)%I.
-Proof. by rewrite /MakeMonPredAt monPred_at_fupd=> <-. Qed.
-
-Global Instance into_internal_eq_monPred_at {A : ofeT} (x y : A) P i :
- IntoInternalEq P x y → IntoInternalEq (P i) x y.
-Proof. rewrite /IntoInternalEq=> ->. by rewrite monPred_at_internal_eq. Qed.
-
-Global Instance into_except_0_monPred_at_fwd i P Q ð“ :
- IntoExcept0 P Q → MakeMonPredAt i Q ð“ → IntoExcept0 (P i) ð“ .
-Proof. rewrite /IntoExcept0 /MakeMonPredAt=> -> <-. by rewrite monPred_at_except_0. Qed.
-Global Instance into_except_0_monPred_at_bwd i P ð“Ÿ Q :
- IntoExcept0 P Q → MakeMonPredAt i P 𓟠→ IntoExcept0 𓟠(Q i).
-Proof. rewrite /IntoExcept0 /MakeMonPredAt=> H <-. by rewrite H monPred_at_except_0. Qed.
-
-Global Instance maybe_into_later_monPred_at i n P Q ð“ :
- IntoLaterN false n P Q → MakeMonPredAt i Q ð“ →
- IntoLaterN false n (P i) ð“ .
-Proof.
- rewrite /IntoLaterN /MaybeIntoLaterN /MakeMonPredAt=> -> <-. elim n=>//= ? <-.
- by rewrite monPred_at_later.
-Qed.
-Global Instance from_later_monPred_at i `(sel : A) n P Q ð“ :
- FromModal (modality_laterN n) sel P Q → MakeMonPredAt i Q ð“ →
- FromModal (modality_laterN n) sel (P i) ð“ .
-Proof.
- rewrite /FromModal /MakeMonPredAt=> <- <-. elim n=>//= ? ->.
- by rewrite monPred_at_later.
-Qed.
-
-Global Instance frame_monPred_at_later p P ð“¡ ð“ i :
- Frame p ð“¡ (â–· P i) ð“ → FrameMonPredAt p i ð“¡ (â–· P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_later. Qed.
-Global Instance frame_monPred_at_laterN p n P ð“¡ ð“ i :
- Frame p ð“¡ (â–·^n P i) ð“ → FrameMonPredAt p i ð“¡ (â–·^n P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_laterN. Qed.
-Global Instance frame_monPred_at_fupd `{BiFUpd PROP} E1 E2 p P ð“¡ ð“ i :
- Frame p ð“¡ (|={E1,E2}=> P i) ð“ → FrameMonPredAt p i ð“¡ (|={E1,E2}=> P) ð“ .
-Proof. rewrite /Frame /FrameMonPredAt=> ->. by rewrite monPred_at_fupd. Qed.
-
-Global Instance elim_modal_at_fupd_goal `{BiFUpd PROP} φ p p' E1 E2 E3 ð“Ÿ ð“Ÿ' Q Q' i :
- ElimModal φ p p' ð“Ÿ ð“Ÿ' (|={E1,E3}=> Q i) (|={E2,E3}=> Q' i) →
- ElimModal φ p p' ð“Ÿ ð“Ÿ' ((|={E1,E3}=> Q) i) ((|={E2,E3}=> Q') i).
-Proof. by rewrite /ElimModal !monPred_at_fupd. Qed.
-Global Instance elim_modal_at_fupd_hyp `{BiFUpd PROP} φ p p' E1 E2 P ð“Ÿ ð“Ÿ' ð“ ð“ ' i :
- MakeMonPredAt i P 𓟠→
- ElimModal φ p p' (|={E1,E2}=> ð“Ÿ) ð“Ÿ' ð“ ð“ ' →
- ElimModal φ p p' ((|={E1,E2}=> P) i) ð“Ÿ' ð“ ð“ '.
-Proof. by rewrite /MakeMonPredAt /ElimModal monPred_at_fupd=><-. Qed.
-
-(* This instances are awfully specific, but that's what is needed. *)
-Global Instance elim_acc_at_fupd `{BiFUpd PROP} {X : Type} E1 E2 E
- M1 M2 α β (mγ : X → option PROP) Q (Q' : X → monPred) i :
- ElimAcc (X:=X) M1 M2 α β mγ (|={E1,E}=> Q i)
- (λ x, |={E2}=> β x ∗ (mγ x -∗? |={E1,E}=> Q' x i))%I →
- ElimAcc (X:=X) M1 M2 α β mγ ((|={E1,E}=> Q) i)
- (λ x, (|={E2}=> ⎡β x⎤ ∗
- (match mγ x with Some ð“Ÿ => Some ⎡ð“ŸâŽ¤ | None => None end -∗?
- |={E1,E}=> Q' x)) i)%I
- | 1.
-Proof.
- rewrite /ElimAcc monPred_at_fupd=><-. apply bi.forall_mono=>x.
- destruct (mγ x); simpl.
- - rewrite monPred_at_fupd monPred_at_sep monPred_wand_force monPred_at_fupd !monPred_at_embed //.
- - rewrite monPred_at_fupd monPred_at_sep monPred_at_fupd !monPred_at_embed //.
-Qed.
-(* A separate, higher-priority instance for unit because otherwise unification
-fails. *)
-Global Instance elim_acc_at_fupd_unit `{BiFUpd PROP} E1 E2 E
- M1 M2 α β mγ Q Q' i :
- ElimAcc (X:=unit) M1 M2 α β mγ (|={E1,E}=> Q i)
- (λ x, |={E2}=> β x ∗ (mγ x -∗? |={E1,E}=> Q' i))%I →
- ElimAcc (X:=unit) M1 M2 α β mγ ((|={E1,E}=> Q) i)
- (λ x, (|={E2}=> ⎡β x⎤ ∗
- (match mγ x with Some ð“Ÿ => Some ⎡ð“ŸâŽ¤ | None => None end -∗?
- |={E1,E}=> Q')) i)%I
- | 0.
-Proof. exact: elim_acc_at_fupd. Qed.
-
-Global Instance add_modal_at_fupd_goal `{BiFUpd PROP} E1 E2 ð“Ÿ ð“Ÿ' Q i :
- AddModal ð“Ÿ ð“Ÿ' (|={E1,E2}=> Q i) → AddModal ð“Ÿ ð“Ÿ' ((|={E1,E2}=> Q) i).
-Proof. by rewrite /AddModal !monPred_at_fupd. Qed.
-
-(* This hard-codes the fact that ElimInv with_close returns a
- [(λ _, ...)] as Q'. *)
-Global Instance elim_inv_embed_with_close {X : Type} φ
- ð“Ÿinv ð“Ÿin (ð“Ÿout ð“Ÿclose : X → PROP)
- Pin (Pout Pclose : X → monPred)
- Q Q' :
- (∀ i, ElimInv φ ð“Ÿinv ð“Ÿin ð“Ÿout (Some ð“Ÿclose) (Q i) (λ _, Q' i)) →
- MakeEmbed ð“Ÿin Pin → (∀ x, MakeEmbed (ð“Ÿout x) (Pout x)) →
- (∀ x, MakeEmbed (ð“Ÿclose x) (Pclose x)) →
- ElimInv (X:=X) φ ⎡ð“Ÿinv⎤ Pin Pout (Some Pclose) Q (λ _, Q').
-Proof.
- rewrite /MakeEmbed /ElimInv=>H <- Hout Hclose ?. iStartProof PROP.
- setoid_rewrite <-Hout. setoid_rewrite <-Hclose.
- iIntros (?) "(?&?&HQ')". iApply H; [done|]. iFrame. iIntros (x) "?". by iApply "HQ'".
-Qed.
-Global Instance elim_inv_embed_without_close {X : Type}
- φ ð“Ÿinv ð“Ÿin (ð“Ÿout : X → PROP) Pin (Pout : X → monPred) Q (Q' : X → monPred) :
- (∀ i, ElimInv φ ð“Ÿinv ð“Ÿin ð“Ÿout None (Q i) (λ x, Q' x i)) →
- MakeEmbed ð“Ÿin Pin → (∀ x, MakeEmbed (ð“Ÿout x) (Pout x)) →
- ElimInv (X:=X) φ ⎡ð“Ÿinv⎤ Pin Pout None Q Q'.
-Proof.
- rewrite /MakeEmbed /ElimInv=>H <-Hout ?. iStartProof PROP.
- setoid_rewrite <-Hout.
- iIntros (?) "(?&?&HQ')". iApply H; [done|]. iFrame. iIntros (x) "?". by iApply "HQ'".
-Qed.
-
-End sbi.
diff --git a/theories/proofmode/reduction.v b/theories/proofmode/reduction.v
index c126c9bab334a46599d8f2aa03e29513990f0e84..964801ebee022d5a2b326ba7c20fbc828e91a5d8 100644
--- a/theories/proofmode/reduction.v
+++ b/theories/proofmode/reduction.v
@@ -32,7 +32,7 @@ Declare Reduction pm_prettify := cbn [
tele_fold tele_bind tele_app
(* BI connectives *)
bi_persistently_if bi_affinely_if bi_absorbingly_if bi_intuitionistically_if
- bi_wandM sbi_laterN
+ bi_wandM
bi_tforall bi_texist
].
Ltac pm_prettify :=