├── .github
└── workflows
│ └── build.yml
├── .gitignore
├── Dockerfile
├── LICENSE
├── Makefile
├── README.md
├── _CoqProject
├── clutch.opam
├── external
└── proba
│ ├── basic
│ ├── Reals_ext.v
│ ├── Series_Ext.v
│ ├── base.v
│ ├── bigop_ext.v
│ ├── classic_proof_irrel.v
│ ├── exp_ext.v
│ ├── monad.v
│ ├── nify.v
│ ├── order.v
│ ├── seq_ext.v
│ ├── stdpp_ext.v
│ └── sval.v
│ └── prob
│ ├── countable.v
│ ├── double.v
│ └── rearrange.v
├── src
├── hashtableChaining.ml
├── miller-rabin.ml
└── rabin-karp.py
└── theories
├── approxis
├── adequacy.v
├── adequacy_rel.v
├── app_rel_rules.v
├── app_weakestpre.v
├── approxis.v
├── compatibility.v
├── coupling_rules.v
├── derived_laws.v
├── ectx_lifting.v
├── examples
│ ├── ElGamal_closed_ctx.v
│ ├── ElGamal_defs.v
│ ├── ElGamal_semantic.v
│ ├── ElGamal_syntactic.v
│ ├── LR_tac.v
│ ├── advantage_laws.v
│ ├── avoid_collision_rel.v
│ ├── b_tree.v
│ ├── b_tree_adt.v
│ ├── bounded_oracle.v
│ ├── diffie_hellman.v
│ ├── list.v
│ ├── map.v
│ ├── option.v
│ ├── prf.v
│ ├── prf_cpa.v
│ ├── prf_cpa_combined.v
│ ├── prf_cpa_combined_sem_typ.v
│ ├── prp.v
│ ├── prp_prf_adaptive.v
│ ├── prp_prf_test.v
│ ├── prp_prf_weak.v
│ ├── pubkey.v
│ ├── rejection_samplers.v
│ ├── sampling_without_replacement.v
│ ├── security_aux.v
│ ├── sum_seq.v
│ ├── symmetric.v
│ ├── valgroup.v
│ ├── valgroup_Zp.v
│ ├── valgroup_Zpx.v
│ ├── von_neumann_coin.v
│ └── xor.v
├── fundamental.v
├── interp.v
├── lifting.v
├── model.v
├── primitive_laws.v
├── proofmode.v
├── rel_tactics.v
├── reltac2.v
└── soundness.v
├── base_logic
├── error_credits.v
├── spec_auth_markov.v
└── spec_update.v
├── bi
└── weakestpre.v
├── caliper
├── adequacy.v
├── derived_laws.v
├── ectx_lifting.v
├── examples
│ ├── bounded_random_walk.v
│ ├── coin_random_walk.v
│ ├── determinize.v
│ ├── flip.v
│ ├── galton_watson_tree.v
│ ├── lazy_real.v
│ ├── lib
│ │ └── list.v
│ ├── listgen.v
│ ├── nat_random_walk.v
│ └── treap.v
├── lifting.v
├── primitive_laws.v
├── proofmode.v
├── seq_weakestpre.v
└── weakestpre.v
├── clutch.v
├── clutch
├── adequacy.v
├── adequacy_rel.v
├── compatibility.v
├── coupling_rules.v
├── derived_laws.v
├── ectx_lifting.v
├── examples
│ ├── awkward_deterministic.v
│ ├── awkward_lazy_eager_coin.v
│ ├── awkward_probabilistic.ml
│ ├── awkward_probabilistic.v
│ ├── counterexample.v
│ ├── coupon.v
│ ├── crypto
│ │ ├── ElGamal.v
│ │ ├── ElGamal_bijection.v
│ │ ├── ElGamal_closed_ctx.v
│ │ ├── advantage_laws.v
│ │ ├── valgroup.v
│ │ ├── valgroup_Zp.v
│ │ └── valgroup_Zpx.v
│ ├── env_bisim.v
│ ├── erasure.v
│ ├── flip_once_many_synchronised_coin.v
│ ├── geometric.v
│ ├── hash.v
│ ├── id_rec.v
│ ├── in_place_quicksort.v
│ ├── keyed_hash.v
│ ├── lazy_eager_coin.v
│ ├── lazy_eager_nat.v
│ ├── lazy_int.v
│ ├── one_time_pad.v
│ ├── quicksort.v
│ ├── rng.v
│ ├── sample_int.v
│ ├── split_rng.v
│ └── von_neumann_coin.v
├── fundamental.v
├── interp.v
├── lib
│ ├── array.v
│ ├── conversion.v
│ ├── flip.v
│ ├── list.v
│ └── map.v
├── lifting.v
├── model.v
├── primitive_laws.v
├── proofmode.v
├── rel_rules.v
├── rel_tactics.v
├── reltac2.v
├── soundness.v
└── weakestpre.v
├── common
├── con_ectx_language.v
├── con_ectxi_language.v
├── con_inject.v
├── con_language.v
├── ectx_language.v
├── ectxi_language.v
├── erasable.v
├── exec.v
├── inject.v
├── language.v
├── locations.v
└── sch_erasable.v
├── con_prob_lang
├── class_instances.v
├── ctx_subst.v
├── erasure.v
├── lang.v
├── metatheory.v
├── notation.v
├── spec
│ ├── spec_ra.v
│ └── spec_transition.v
├── tactics.v
└── wp_tactics.v
├── coneris
├── README.md
├── adequacy.v
├── atomic.v
├── coneris.v
├── derived_laws.v
├── ectx_lifting.v
├── error_rules.v
├── examples
│ ├── bloom_filter
│ │ ├── bloom_filter.v
│ │ ├── concurrent_bloom_filter.v
│ │ └── concurrent_bloom_filter_alt.v
│ ├── con_two_add.v
│ ├── concurrent_hash.v
│ ├── coneris_examples.v
│ ├── hash.v
│ ├── hash
│ │ ├── coll_free_hash_view_impl.v
│ │ ├── coll_free_hash_view_interface.v
│ │ ├── con_hash_impl0.v
│ │ ├── con_hash_impl1.v
│ │ ├── con_hash_impl2.v
│ │ ├── con_hash_impl3.v
│ │ ├── con_hash_impl4.v
│ │ ├── con_hash_interface0.v
│ │ ├── con_hash_interface1.v
│ │ ├── con_hash_interface2.v
│ │ ├── con_hash_interface3.v
│ │ ├── con_hash_interface4.v
│ │ ├── hash_race.v
│ │ ├── hash_view_impl.v
│ │ ├── hash_view_interface.v
│ │ ├── seq_hash_impl.v
│ │ └── seq_hash_interface.v
│ ├── lazy_rand
│ │ ├── lazy_rand_impl.v
│ │ ├── lazy_rand_interface.v
│ │ └── lazy_rand_race.v
│ ├── message_pass.v
│ ├── parallel_add.v
│ ├── race.v
│ ├── random_counter
│ │ ├── client.v
│ │ ├── client2.v
│ │ ├── impl1.v
│ │ ├── impl2.v
│ │ ├── impl3.v
│ │ └── random_counter.v
│ ├── random_counter2
│ │ ├── client.v
│ │ ├── impl1.v
│ │ ├── impl2.v
│ │ ├── impl3.v
│ │ └── random_counter.v
│ ├── random_counter3
│ │ ├── client.v
│ │ ├── impl1.v
│ │ ├── impl2.v
│ │ ├── impl3.v
│ │ └── random_counter.v
│ └── two_die.v
├── lib
│ ├── abstract_tape.v
│ ├── array.v
│ ├── conversion.v
│ ├── flip.v
│ ├── hocap_flip.v
│ ├── hocap_rand.v
│ ├── hocap_rand_alt.v
│ ├── hocap_rand_atomic.v
│ ├── lazy.v
│ ├── list.v
│ ├── lock.v
│ ├── map.v
│ ├── par.v
│ ├── spawn.v
│ └── spin_lock.v
├── lifting.v
├── primitive_laws.v
├── proofmode.v
├── weakestpre.v
└── wp_update.v
├── eris
├── adequacy.v
├── derived_laws.v
├── ectx_lifting.v
├── eris.v
├── error_rules.v
├── examples
│ ├── approximate_samplers
│ │ ├── approx_higherorder_incremental.v
│ │ ├── approx_higherorder_rejection_sampler.v
│ │ ├── approx_rejection_sampler.v
│ │ ├── approx_rejection_sampler_presampled.v
│ │ ├── approx_sampler_lib.v
│ │ └── approx_walkSAT.v
│ ├── cf_hash.v
│ ├── cf_hashmap.v
│ ├── dynamic_vec.v
│ ├── eris_examples.v
│ ├── fisher_yates.v
│ ├── hash.v
│ ├── merkle
│ │ ├── merkle_tree.v
│ │ └── unreliable.v
│ ├── miller_rabin.v
│ ├── noproph.v
│ └── spline.v
├── lib
│ ├── array.v
│ ├── list.v
│ └── map.v
├── lifting.v
├── primitive_laws.v
├── proofmode.v
├── seq_amplification.v
├── total_adequacy.v
├── total_derived_laws.v
├── total_ectx_lifting.v
├── total_lifting.v
├── total_primitive_laws.v
├── total_weakestpre.v
└── weakestpre.v
├── foxtrot
├── adequacy.v
├── coneris_relate.v
├── ectx_lifting.v
├── full_info.v
├── lifting.v
├── oscheduler.v
├── primitive_laws.v
└── weakestpre.v
├── meas_lang
├── class_instances.v
├── ctx_subst.v
├── ectx_language.v
├── ectxi_language.v
├── erasable.v
├── erasure.v
├── exec.v
├── exec_lang.v
├── lang.v
├── language.v
├── metatheory.v
├── notation.v
├── tactics.v
└── wp_tactics.v
├── prelude
├── Coquelicot_ext.v
├── NNRbar.v
├── Reals_ext.v
├── Series_ext.v
├── asubst.v
├── base.v
├── classical.v
├── fin.v
├── iris_ext.v
├── mc_stdlib.v
├── properness.v
├── stdpp_ext.v
├── tactics.v
├── uniform_list.v
└── zmodp_fin.v
├── prob
├── countable_sum.v
├── couplings.v
├── couplings_app.v
├── couplings_exp.v
├── distribution.v
├── generic_lifting.v
├── graded_predicate_lifting.v
├── markov.v
├── mdp.v
└── monad
│ ├── bind.v
│ ├── compose.v
│ ├── const.v
│ ├── discrete_mapout.v
│ ├── eval.v
│ ├── examples.v
│ ├── extras.v
│ ├── identity.v
│ ├── integrate.v
│ ├── join.v
│ ├── laws.v
│ ├── map.v
│ ├── ret.v
│ ├── types.v
│ ├── uniform.v
│ └── zero.v
├── prob_lang
├── advantage.v
├── class_instances.v
├── ctx_subst.v
├── erasure.v
├── exec_lang.v
├── lang.v
├── metatheory.v
├── notation.v
├── spec
│ ├── spec_ra.v
│ ├── spec_rules.v
│ └── spec_tactics.v
├── tactics.v
├── typing
│ ├── contextual_refinement.v
│ ├── contextual_refinement_alt.v
│ ├── tychk.v
│ └── types.v
└── wp_tactics.v
├── pure_complete
├── eris_ast.v
├── pure.v
├── tachis_ert.v
└── term.v
└── tachis
├── adequacy.v
├── cost_models.v
├── derived_laws.v
├── ectx_lifting.v
├── ert_rules.v
├── ert_weakestpre.v
├── examples
├── amortized_op.v
├── batchsampling.v
├── couponcollector.v
├── expected_val_reference.v
├── fisher_yates.v
├── geometric.v
├── hashmap
│ ├── hash.v
│ ├── hashmap.v
│ ├── linkedlist.v
│ ├── map.v
│ └── rabinkarp.v
├── kway_merge.v
├── lib
│ └── list.v
├── meldable_heap.v
├── min_heap_spec.v
├── quicksort.v
├── race.v
└── simple_loops.v
├── expected_time_credits.v
├── lifting.v
├── primitive_laws.v
├── problang_wp.v
└── proofmode.v
/.github/workflows/build.yml:
--------------------------------------------------------------------------------
1 | name: CI
2 |
3 | on:
4 | push:
5 | branches:
6 | - main
7 | pull_request:
8 | branches:
9 | - '**'
10 |
11 | jobs:
12 | build:
13 | runs-on: ubuntu-latest
14 | strategy:
15 | matrix:
16 | image:
17 | - mathcomp/mathcomp:2.2.0-coq-8.19
18 | max-parallel: 4
19 | # don't cancel all in-progress jobs if one matrix job fails:
20 | fail-fast: false
21 |
22 | steps:
23 | - uses: actions/checkout@v3
24 | - uses: coq-community/docker-coq-action@v1
25 | with:
26 | opam_file: 'clutch.opam'
27 | custom_image: ${{ matrix.image }}
28 | install : |
29 | startGroup "Install dependencies"
30 | sudo apt-get update -y -q
31 | opam repo remove coq-released
32 | opam repo add rocq-released https://rocq-prover.org/opam/released
33 | opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git
34 | opam pin add -n -y -k path $PACKAGE $WORKDIR
35 | opam update -y
36 | opam reinstall --forget-pending --yes
37 | opam install --confirm-level=unsafe-yes -j 2 $PACKAGE --deps-only
38 | endGroup
39 | before_script: |
40 | sudo chown -R coq:coq . # workaround a permission issue
41 | script: |
42 | startGroup Build
43 | make -j2
44 | endGroup
45 | uninstall: |
46 | make clean
47 | - name: Revert permissions
48 | # to avoid a warning at cleanup time
49 | if: ${{ always() }}
50 | run: sudo chown -R 1001:116 .
51 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .*.aux
2 | .*.d
3 | *.a
4 | *.cma
5 | *.cmi
6 | *.cmo
7 | *.cmx
8 | *.cmxa
9 | *.cmxs
10 | *.glob
11 | *.html
12 | *.ml.d
13 | *.ml4.d
14 | *.mli.d
15 | *.mllib.d
16 | *.mlpack.d
17 | *.native
18 | *.o
19 | *.sh
20 | *.v.d
21 | *.vio
22 | *.vo
23 | *.vok
24 | *.vos
25 | .coq-native/
26 | .csdp.cache
27 | .lia.cache
28 | .nia.cache
29 | .nlia.cache
30 | .nra.cache
31 | csdp.cache
32 | lia.cache
33 | nia.cache
34 | nlia.cache
35 | nra.cache
36 | *.pdf
37 | _opam
38 | .DS_Store
39 | *.zip
40 | .vscode
41 |
42 | # Emacs
43 | *~
44 | \#*\#
45 | /.emacs.desktop
46 | /.emacs.desktop.lock
47 | *.elc
48 | auto-save-list
49 | tramp
50 | .\#*
51 |
52 | # Org-mode
53 | .org-id-locations
54 | *_archive
55 |
56 | # flymake-mode
57 | *_flymake.*
58 |
59 | # eshell files
60 | /eshell/history
61 | /eshell/lastdir
62 |
63 | # elpa packages
64 | /elpa/
65 |
66 | # reftex files
67 | *.rel
68 |
69 | # AUCTeX auto folder
70 | /auto/
71 |
72 | # cask packages
73 | .cask/
74 | dist/
75 |
76 | # Flycheck
77 | flycheck_*.el
78 |
79 | # server auth directory
80 | /server/
81 |
82 | # projectiles files
83 | .projectile
84 |
85 | # directory configuration
86 | .dir-locals.el
87 |
88 | # network security
89 | /network-security.data
90 |
--------------------------------------------------------------------------------
/Dockerfile:
--------------------------------------------------------------------------------
1 | FROM "mathcomp/mathcomp:2.2.0-coq-8.19"
2 |
3 | ARG NJOBS=4
4 |
5 | WORKDIR /home/coq/clutch
6 |
7 | COPY . .
8 |
9 | RUN set -x \
10 | && opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git \
11 | && opam update -y \
12 | && opam pin add -n -y -k path clutch . \
13 | && opam install --confirm-level=unsafe-yes -j ${NJOBS} . --deps-only \
14 | && sudo chown -R coq:coq /home/coq/clutch \
15 | && opam clean -a -c -s --logs \
16 | && make -j ${NJOBS}
17 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | MIT License
2 |
3 | Copyright (c) 2023-2025 The Clutch Team
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | SRC_DIRS := 'theories'
2 | EXT_DIRS := 'external'
3 | ALL_VFILES := $(shell find $(EXT_DIRS) $(SRC_DIRS) -name '*.v' -a '!' -name '*'.\#'*')
4 |
5 | BUILD_DIRS := $(SRC_DIRS)
6 | VFILES := $(shell find $(BUILD_DIRS) -name '*.v' -a '!' -name '*'.\#'*')
7 |
8 | COQC := coqc
9 | Q:=@
10 |
11 | # extract global arguments for Coq from _CoqProject
12 | COQPROJECT_ARGS := $(shell sed -E -e '/^\#/d' -e 's/-arg ([^ ]*)/\1/g' _CoqProject)
13 |
14 | all: $(VFILES:.v=.vo)
15 |
16 | .coqdeps.d: $(ALL_VFILES) _CoqProject
17 | @echo "COQDEP $@"
18 | $(Q)coqdep -vos -f _CoqProject $(ALL_VFILES) > $@
19 |
20 | # do not try to build dependencies if cleaning or just building _CoqProject
21 | ifeq ($(filter clean,$(MAKECMDGOALS)),)
22 | include .coqdeps.d
23 | endif
24 |
25 | %.vo: %.v _CoqProject | .coqdeps.d
26 | @echo "COQC $<"
27 | $(Q)$(COQC) $(COQPROJECT_ARGS) $(COQ_ARGS) -o $@ $<
28 |
29 | %.vos: %.v _CoqProject | .coqdeps.d
30 | @echo "COQC -vos $<"
31 | $(Q)$(COQC) $(COQPROJECT_ARGS) -vos $(COQ_ARGS) $< -o $@
32 |
33 | %.vok: %.v _CoqProject | .coqdeps.d
34 | @echo "COQC -vok $<"
35 | $(Q)$(COQC) $(COQPROJECT_ARGS) -vok $(COQ_ARGS) $< -o $@
36 |
37 | clean:
38 | @echo "CLEAN vo glob aux"
39 | $(Q)find $(EXT_DIRS) $(SRC_DIRS) \( -name "*.vo" -o -name "*.vo[sk]" \
40 | -o -name ".*.aux" -o -name ".*.cache" -o -name "*.glob" \) -delete
41 | $(Q)rm -f .lia.cache
42 | rm -f .coqdeps.d
43 |
44 | tar:
45 | git archive --format=tar.gz -o coq-clutch.tar.gz HEAD
46 |
47 | .PHONY: clean zip
48 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Clutch Project
2 |
3 | This repository contains the formal development of multiple higher-order probabilistic separation logics for proving properties of higher-order probabilistic programs.
4 | All of the logics are built using the [Iris](https://iris-project.org) program logic framework and mechanized in the [Coq proof assistant](https://coq.inria.fr/).
5 |
6 | ## Publications
7 |
8 | [**Approximate Relational Reasoning for Higher-Order Probabilistic Programs**](https://dl.acm.org/doi/10.1145/3704877)
9 | *Philipp G. Haselwarter, Kwing Hei Li, Alejandro Aguirre, Simon Oddershede Gregersen, Joseph Tassarotti, Lars Birkedal*
10 | In POPL 2025: ACM SIGPLAN Symposium on Principles of Programming Languages
11 |
12 | [**Tachis: Higher-Order Separation Logic with Credits for Expected Costs**](https://doi.org/10.1145/3689753)
13 | *Philipp G. Haselwarter, Kwing Hei Li, Markus de Medeiros, Simon Oddershede Gregersen, Alejandro Aguirre, Joseph Tassarotti, Lars Birkedal*
14 | In OOPSLA 2024: ACM SIGPLAN Conference on Object-Oriented Programming, Systems, Languages, and Applications
15 |
16 | [**Error Credits: Resourceful Reasoning about Error Bounds for Higher-Order Probabilistic Programs**](https://doi.org/10.1145/3674635)
17 | *Alejandro Aguirre, Philipp G. Haselwarter, Markus de Medeiros, Kwing Hei Li, Simon Oddershede Gregersen, Joseph Tassarotti, Lars Birkedal*
18 | In ICFP 2024: ACM SIGPLAN International Conference on Functional Programming
19 |
20 | [**Almost-Sure Termination by Guarded Refinement**](https://doi.org/10.1145/3674632)
21 | *Simon Oddershede Gregersen, Alejandro Aguirre, Philipp G. Haselwarter, Joseph Tassarotti, Lars Birkedal*
22 | In ICFP 2024: ACM SIGPLAN International Conference on Functional Programming
23 |
24 | [**Asynchronous Probabilistic Couplings in Higher-Order Separation Logic**](https://dl.acm.org/doi/10.1145/3632868)
25 | *Simon Oddershede Gregersen, Alejandro Aguirre, Philipp G. Haselwarter, Joseph Tassarotti, Lars Birkedal*
26 | In POPL 2024: ACM SIGPLAN Symposium on Principles of Programming Languages
27 |
28 | ## Building the development
29 |
30 | The project is known to compile with
31 |
32 | - [Coq](https://coq.inria.fr/) 8.19.1
33 | - [std++](https://gitlab.mpi-sws.org/iris/stdpp) 1.10.0
34 | - [Iris](https://gitlab.mpi-sws.org/iris/iris/) 4.2.0
35 | - [Coquelicot](https://gitlab.inria.fr/coquelicot/coquelicot/) 3.4.1
36 | - [Autosubst](https://github.com/coq-community/autosubst) 1.8
37 | - [Mathcomp-solvable](https://github.com/math-comp/math-comp) 2.2.0
38 |
39 | The recommended way to install the dependencies is through [opam](https://opam.ocaml.org/doc/Install.html).
40 |
41 | 1. Install [opam](https://opam.ocaml.org/doc/Install.html) if not already installed (a version greater than 2.0 is required).
42 | 2. Install a new switch and link it to the project.
43 | ```
44 | opam switch create clutch 4.14.1
45 | opam switch link clutch .
46 | ```
47 | 3. Add the Coq and Iris `opam` repositories.
48 | ```
49 | opam repo add rocq-released https://coq.inria.fr/opam/released
50 | opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git
51 | opam update
52 | ```
53 | 4. Install the right version of the dependencies as specified in the `clutch.opam` file.
54 | ```
55 | opam install . --deps-only
56 | ```
57 |
58 | You should now be able to build the development by using `make -j N` where `N` is the number of cores available on your machine.
59 |
60 | ## Axioms
61 |
62 | The development relies on axioms for classical reasoning and an axiomatization of the reals numbers, both found in Coq's standard library. For example, the following list is produced when executing the command `Print Assumptions eager_lazy_equiv.` in [`theories/clutch/examples/lazy_eager_coin.v`](theories/clutch/examples/lazy_eager_coin.v):
63 |
64 | ```
65 | ClassicalDedekindReals.sig_not_dec : ∀ P : Prop, {¬ ¬ P} + {¬ P}
66 | ClassicalDedekindReals.sig_forall_dec : ∀ P : nat → Prop, (∀ n : nat, {P n} + {¬ P n}) → {n : nat | ¬ P n} + {∀ n : nat, P n}
67 | functional_extensionality_dep : ∀ (A : Type) (B : A → Type) (f g : ∀ x : A, B x), (∀ x : A, f x = g x) → f = g
68 | constructive_indefinite_description : ∀ (A : Type) (P : A → Prop), (∃ x : A, P x) → {x : A | P x}
69 | classic : ∀ P : Prop, P ∨ ¬ P
70 | ```
71 |
72 |
--------------------------------------------------------------------------------
/_CoqProject:
--------------------------------------------------------------------------------
1 | -Q theories clutch
2 | -Q external/proba discprob
3 |
4 | -arg -w -arg -notation-overridden
5 | -arg -w -arg -redundant-canonical-projection
6 | -arg -w -arg -convert_concl_no_check
7 | -arg -w -arg -undeclared-scope
8 | -arg -w -arg -ambiguous-paths
9 | -arg -w -arg -ssr-search-moved
10 |
--------------------------------------------------------------------------------
/clutch.opam:
--------------------------------------------------------------------------------
1 | opam-version: "2.0"
2 | name: "coq-clutch"
3 | synopsis: "Higher-order probabilistic separation logics"
4 | maintainer: "Simon Oddershede Gregersen "
5 | authors: "Simon Oddershede Gregersen,
6 | Alejandro Aguirre,
7 | Philipp G. Haselwarter,
8 | Kwing Hei Li,
9 | Markus de Medeiros,
10 | Joseph Tassarotti,
11 | Lars Birkedal"
12 | license: "MIT"
13 | homepage: "https://github.com/logsem/clutch"
14 | dev-repo: "git+https://github.com:logsem/clutch.git"
15 | bug-reports: "https://github.com/logsem/clutch/issues"
16 | build: [make "-j%{jobs}%"]
17 | install: []
18 | depends: [
19 | "coq" { (>= "8.19" & < "8.20~") | (= "dev") }
20 | "coq-iris" { (= "4.2.0") | (= "dev") }
21 | "coq-stdpp" { (= "1.10.0") | (= "dev") }
22 | "coq-coquelicot" { (= "3.4.1") }
23 | "coq-autosubst" { (= "1.8") | (= "dev") }
24 | "coq-mathcomp-ssreflect" { (= "2.2.0") }
25 | "coq-mathcomp-solvable" { (= "2.2.0") }
26 | "coq-mathcomp-analysis" { (= "1.4.0") }
27 | ]
28 |
--------------------------------------------------------------------------------
/external/proba/basic/base.v:
--------------------------------------------------------------------------------
1 | From mathcomp Require Export ssreflect.
2 | From Coq Require Export Morphisms RelationClasses List Bool Utf8 Setoid.
3 | Set Default Proof Using "Type".
4 | Global Set Bullet Behavior "Strict Subproofs".
5 | Global Open Scope general_if_scope.
--------------------------------------------------------------------------------
/external/proba/basic/classic_proof_irrel.v:
--------------------------------------------------------------------------------
1 | Require Import ClassicalFacts Classical_Prop ProofIrrelevanceFacts.
2 |
3 | Lemma classical_proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2.
4 | Proof. apply proof_irrelevance_cci. intros. apply Classical_Prop.classic. Qed.
5 |
6 | Module PI. Definition proof_irrelevance := classical_proof_irrelevance. End PI.
7 |
8 | Module PIT := ProofIrrelevanceTheory(PI).
9 | Export PIT.
--------------------------------------------------------------------------------
/external/proba/basic/exp_ext.v:
--------------------------------------------------------------------------------
1 | From discprob.basic Require Import base order nify.
2 | From discprob.basic Require Export Reals_ext.
3 | Require Import Ranalysis5.
4 | Require Import Reals Fourier FunctionalExtensionality.
5 | Require Import List.
6 | Require Import Psatz.
7 |
8 | Lemma exp_le_embedding x y:
9 | exp x <= exp y → x <= y.
10 | Proof.
11 | intros Hle. apply Rnot_lt_le => Hlt.
12 | apply exp_increasing in Hlt. nra.
13 | Qed.
14 |
15 | Lemma exp_increasing_le: ∀ x y : R, x <= y → exp x <= exp y.
16 | Proof.
17 | inversion 1.
18 | - left. by apply exp_increasing.
19 | - subst. reflexivity.
20 | Qed.
21 |
22 | Lemma exp_ge_2: 2 <= exp 1.
23 | Proof. apply Rlt_le. apply exp_ineq1. nra. Qed.
24 |
25 | Lemma Rlt_0_ln x: 1 < x → 0 < ln x.
26 | Proof.
27 | intros Hlt; rewrite -ln_1; apply ln_increasing; lra.
28 | Qed.
29 |
30 | Lemma exp_ineq1_le x: 0 <= x → 1 + x <= exp x.
31 | Proof.
32 | intros [Hlt|Heq].
33 | * left. apply exp_ineq1. nra.
34 | * rewrite -Heq exp_0. nra.
35 | Qed.
36 | Lemma exp_fold_plus (l: list R):
37 | exp (fold_right Rplus 0 l) = fold_right Rmult 1 (map exp l).
38 | Proof.
39 | induction l => //=.
40 | - rewrite exp_0; done.
41 | - rewrite exp_plus IHl. done.
42 | Qed.
43 |
--------------------------------------------------------------------------------
/external/proba/basic/monad.v:
--------------------------------------------------------------------------------
1 | From discprob.basic Require Import base.
2 |
3 | (** Some basic type classes/notation for monadic operations from
4 | coq-stdpp which is BSD licensed; see opam listing for details *)
5 |
6 | (* Note: the type classes don't actually stipulate that the appropriate laws hold *)
7 |
8 | From stdpp Require Import base.
9 |
10 | Definition mbind := @stdpp.base.mbind.
11 | Definition mjoin := @stdpp.base.mjoin.
12 | Definition fmap := @stdpp.base.fmap.
13 | Definition mret := @stdpp.base.mret.
14 | Arguments mbind {_ _ _ _} _ _ /.
15 | Arguments fmap {_ _ _ _} _ _ /.
16 | Arguments mjoin {_ _ _} _ /.
17 | Arguments mret {_ _ _} _ /.
18 | Notation MBind := stdpp.base.MBind.
19 | Notation MRet := stdpp.base.MRet.
20 | Notation MJoin := stdpp.base.MJoin.
21 | Notation FMap := stdpp.base.FMap.
22 | Global Open Scope stdpp_scope.
23 | Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : stdpp_scope.
24 | Notation "( m ≫=)" := (λ f, mbind f m) (only parsing) : stdpp_scope.
25 | Notation "(≫= f )" := (mbind f) (only parsing) : stdpp_scope.
26 | Notation "(≫=)" := (λ m f, mbind f m) (only parsing) : stdpp_scope.
27 |
28 | Notation "x ← y ; z" := (y ≫= (λ x : _, z))
29 | (at level 20, y at level 100, z at level 200, only parsing) : stdpp_scope.
30 | Infix "<$>" := fmap (at level 61, left associativity) : stdpp_scope.
31 | Notation "' ( x1 , x2 ) ← y ; z" :=
32 | (y ≫= (λ x : _, let ' (x1, x2) := x in z))
33 | (at level 65, right associativity) : stdpp_scope.
34 | Notation "' ( x1 , x2 , x3 ) ← y ; z" :=
35 | (y ≫= (λ x : _, let ' (x1,x2,x3) := x in z))
36 | (at level 65, only parsing, right associativity) : stdpp_scope.
37 | Notation "' ( x1 , x2 , x3 , x4 ) ← y ; z" :=
38 | (y ≫= (λ x : _, let ' (x1,x2,x3,x4) := x in z))
39 | (at level 65, only parsing, right associativity) : stdpp_scope.
40 | Notation "' ( x1 , x2 , x3 , x4 , x5 ) ← y ; z" :=
41 | (y ≫= (λ x : _, let ' (x1,x2,x3,x4,x5) := x in z))
42 | (at level 65, only parsing, right associativity) : stdpp_scope.
43 | Notation "' ( x1 , x2 , x3 , x4 , x5 , x6 ) ← y ; z" :=
44 | (y ≫= (λ x : _, let ' (x1,x2,x3,x4,x5,x6) := x in z))
45 | (at level 65, only parsing, right associativity) : stdpp_scope.
--------------------------------------------------------------------------------
/external/proba/basic/nify.v:
--------------------------------------------------------------------------------
1 | From mathcomp Require Import ssreflect ssrbool ssrnat div eqtype.
2 | Require Import Lia.
3 |
4 | Ltac nify :=
5 | repeat match goal with
6 | | [ H: is_true (leq _ _) |- _ ] => move /ltP in H
7 | | [ H: is_true (leq _ _) |- _ ] => move /leP in H
8 | | [ |- is_true (leq _ _) ] => apply /ltP
9 | | [ |- is_true (leq _ _) ] => apply /leP
10 | | [ H: ~ (is_true (leq _ _)) |- _ ] => move /negP/leP in H
11 | | [ |- ~ (is_true (leq _ _)) ] => apply /negP/leP
12 | | H: is_true (?a == ?b) |- _ => move /eqP in H
13 | | |- is_true (?a == ?b) => apply /eqP
14 | | H:context [ ?a + ?b ] |- _ => rewrite -plusE in H
15 | | |- context [ ?a + ?b ] => rewrite -plusE
16 | | H:context [ ?a - ?b ] |- _ => rewrite -minusE in H
17 | | |- context [ ?a - ?b ] => rewrite -minusE
18 | | H:context [ ?a * ?b ] |- _ => rewrite -multE in H
19 | | |- context [ ?a * ?b ] => rewrite -multE
20 | | H:context [ ?a %/ ?b ] |- _ => rewrite -multE in H
21 | | |- context [ ?a %/ ?b ] => rewrite -multE
22 | | H:context [ uphalf (double ?a) ] |- _ => rewrite uphalf_double in H
23 | | |- context [ uphalf (double ?a) ] => rewrite uphalf_double
24 | | H:context [ half (double ?a) ] |- _ => rewrite doubleK in H
25 | | |- context [ half (double ?a) ] => rewrite doubleK
26 | | H:context [ double ?a ] |- _ => rewrite -addnn in H
27 | | |- context [ double ?a ] => rewrite -addnn
28 | end.
29 |
30 | Module nify_test.
31 |
32 | Remark test00 a b c: (a + b + c).*2 = (a + a) + (b - b) + (b - b) + (b + b) + (c + c).
33 | Proof. nify. lia. Qed.
34 |
35 | Remark test01 a b c: (a + b + c).*2 * 5 = ((a + a) + (b - b) + (b - b) + (b + b) + (c + c))*5.
36 | Proof. nify. lia. Qed.
37 |
38 | Remark test02 a: (a.*2)./2.*2 = a + a.
39 | Proof. nify. lia. Qed.
40 |
41 | End nify_test.
42 |
--------------------------------------------------------------------------------
/external/proba/basic/order.v:
--------------------------------------------------------------------------------
1 | Require Export RelationClasses Morphisms.
2 | From discprob.basic Require Import base.
3 | From mathcomp Require Import ssreflect ssrbool eqtype.
4 | From Coquelicot Require Import Hierarchy.
5 | From HB Require Import structures.
6 |
7 |
8 | Require Import Reals.
9 | Global Instance Rge_Transitive: Transitive Rge.
10 | Proof. intros ???. eapply Rge_trans. Qed.
11 | Global Instance Rle_Transitive: Transitive Rle.
12 | Proof. intros ???. eapply Rle_trans. Qed.
13 | Global Instance Rge_Reflexive: Reflexive Rge.
14 | Proof. intros ?. eapply Rge_refl. Qed.
15 | Global Instance Rle_Reflexive: Reflexive Rle.
16 | Proof. intros ?. eapply Rle_refl. Qed.
17 | Global Instance Rgt_Transitive: Transitive Rgt.
18 | Proof. intros ???. eapply Rgt_trans. Qed.
19 | Global Instance Rlt_Transitive: Transitive Rlt.
20 | Proof. intros ???. eapply Rlt_trans. Qed.
21 |
22 | Import Rbar.
23 | Global Instance Rbar_le_Transitive: Transitive Rbar_le.
24 | Proof. intros ???. eapply Rbar_le_trans. Qed.
25 | Global Instance Rbar_le_Reflexive: Reflexive Rbar_le.
26 | Proof. intros ?. eapply Rbar_le_refl. Qed.
27 | Global Instance Rbar_lt_Transitive: Transitive Rbar_lt.
28 | Proof. intros ???. eapply Rbar_lt_trans. Qed.
29 |
30 | Global Instance ge_Transitive: Transitive ge.
31 | Proof. intros ???. auto with *. Qed.
32 | Global Instance le_Transitive: Transitive le.
33 | Proof. intros ???. auto with *. Qed.
34 | Global Instance ge_Reflexive: Reflexive ge.
35 | Proof. intros ?. auto with *. Qed.
36 | Global Instance le_Reflexive: Reflexive le.
37 | Proof. intros ?. auto with *. Qed.
38 | Global Instance gt_Transitive: Transitive gt.
39 | Proof. intros ???. auto with *. Qed.
40 | Global Instance lt_Transitive: Transitive lt.
41 | Proof. intros ???. auto with *. Qed.
42 |
43 | (* To be compatible with ssreflect in various ways it's nice to make R
44 | into an eqType *)
45 |
46 | Definition R_eqP : Equality.axiom (fun x y: R => Req_EM_T x y).
47 | Proof. move => x y. apply sumboolP. Qed.
48 |
49 | HB.instance Definition _ := hasDecEq.Build _ R_eqP.
50 |
51 | Require Import Psatz.
52 | Global Instance Rlt_plus_proper: Proper (Rlt ==> Rlt ==> Rlt) Rplus.
53 | Proof.
54 | intros ?? Hle ?? Hle'. apply Rplus_lt_compat; auto.
55 | Qed.
56 | Global Instance Rlt_plus_proper': Proper (Rlt ==> eq ==> Rlt) Rplus.
57 | Proof.
58 | intros ?? Hle ?? Hle'. subst. nra.
59 | Qed.
60 | Global Instance Rlt_plus_proper'': Proper (Rlt ==> Rle ==> Rlt) Rplus.
61 | Proof.
62 | intros ?? Hle ?? Hle'. subst. nra.
63 | Qed.
64 |
65 | Global Instance Rle_plus_proper_left: Proper (Rle ==> eq ==> Rle) Rplus.
66 | Proof. intros ?? Hle ?? Hle'. nra. Qed.
67 | Global Instance Rle_plus_proper_right: Proper (eq ==> Rle ==> Rle) Rplus.
68 | Proof. intros ?? Hle ?? Hle'. nra. Qed.
69 | Global Instance Rle_plus_proper: Proper (Rle ==> Rle ==> Rle) Rplus.
70 | Proof. intros ?? Hle ?? Hle'. nra. Qed.
71 |
72 |
73 | Lemma Rmax_INR a b: Rmax (INR a) (INR b) = INR (max a b).
74 | Proof.
75 | apply Rmax_case_strong; intros ?%INR_le; f_equal;
76 | [ rewrite Nat.max_l // | rewrite Nat.max_r //].
77 | Qed.
78 |
--------------------------------------------------------------------------------
/external/proba/basic/stdpp_ext.v:
--------------------------------------------------------------------------------
1 | From mathcomp Require Import ssreflect seq ssrbool eqtype.
2 | From stdpp Require Import gmap pmap.
3 | From discprob.basic Require Import seq_ext.
4 |
5 | Lemma list_fmap_map {X Y} (f: X → Y) (l: list X):
6 | f <$> l = map f l.
7 | Proof. rewrite //=. Qed.
8 |
9 | Lemma NoDup_uniq {X: eqType} (l: list X):
10 | NoDup l ↔ seq.uniq l.
11 | Proof.
12 | split.
13 | - induction 1 => //=.
14 | * apply /andP; split.
15 | ** apply /negP => Hin.
16 | rewrite mem_seq_legacy -elem_of_list_In in Hin *.
17 | done.
18 | ** auto.
19 | - induction l => //=.
20 | * intros; econstructor.
21 | * move /andP. intros (Hnin&Huniq).
22 | econstructor; last by eauto.
23 | rewrite elem_of_list_In -mem_seq_legacy. move /negP in Hnin.
24 | auto.
25 | Qed.
--------------------------------------------------------------------------------
/external/proba/basic/sval.v:
--------------------------------------------------------------------------------
1 | From mathcomp Require Export ssreflect.
2 | From mathcomp Require eqtype.
3 | From discprob.basic Require Export classic_proof_irrel.
4 |
5 | Lemma sval_inj_pred {A: Type} (P: A -> bool) (a b: {x : A | is_true (P x)}):
6 | proj1_sig a = proj1_sig b -> a = b.
7 | Proof.
8 | destruct a, b. rewrite /proj1_sig. intros. subst; f_equal. eapply eqtype.bool_irrelevance.
9 | Qed.
10 |
11 | Lemma sval_inj_pi {A: Type} (P: A -> Prop) (a b: {x : A | P x}):
12 | proj1_sig a = proj1_sig b -> a = b.
13 | Proof.
14 | destruct a, b. rewrite /proj1_sig. intros. subst; f_equal. apply classical_proof_irrelevance.
15 | Qed.
16 |
--------------------------------------------------------------------------------
/src/miller-rabin.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let rec power_two_decomp n =
4 | if n mod 2 == 1 then (n, 0)
5 | else let (u, t) = power_two_decomp (n/2) in (u, t+1)
6 |
7 |
8 | let rec fast_mod_exp b e m =
9 | if e == 0 then 1
10 | else
11 | let r = fast_mod_exp ((b*b) mod m) (e/2) m in
12 | if e mod 2 == 0 then r
13 | else (b*r) mod m
14 |
15 |
16 | let rec mr_round n t u =
17 | let x = 1 + Random.int(n-1) in
18 | let y = fast_mod_exp x u n in
19 | if y == 1 then true
20 | else
21 | let rec aux y m k =
22 | (if k == 0 then false
23 | else
24 | if y == m-1 then true
25 | else aux ((y*y) mod m) m (k-1)) in
26 | aux y n t
27 |
28 |
29 | let rec isPrime n =
30 | if n == 1 then false
31 | else
32 | let (u, t) = power_two_decomp(n-1) in
33 | let rec g k =
34 | (if k == 0 then true
35 | else (mr_round n t u) && g (k-1)) in
36 | g 50
37 |
38 |
--------------------------------------------------------------------------------
/src/rabin-karp.py:
--------------------------------------------------------------------------------
1 | import random
2 |
3 | MAX = 10000
4 |
5 | d = dict()
6 | # def hashstr(s, d = dict()):
7 | def hashstr(s):
8 | h = d.get(s)
9 | if h is None:
10 | h = random.randint(0, MAX)
11 | d[s] = h
12 | return h
13 |
14 | # Find the first occurance of p in s.
15 | def rk(s, p):
16 | lp = len(p)
17 | hp = hashstr(p)
18 | for i in range(len(s) - lp + 1) :
19 | w = s[i : i+lp]
20 | h = hashstr(w)
21 | if h == hp :
22 | if w == p :
23 | return i
24 | return -1
25 |
26 | # Check if s and t have any shared substrings of length k.
27 | def rkl(s, t, k):
28 | ds = dict()
29 | dt = dict()
30 | for i in range(len(s) - k + 1) :
31 | w = s[i : i+k]
32 | h = hashstr(w)
33 | ds[h] = i
34 | for j in range(len(t) - k + 1) :
35 | w = t[j : j+k]
36 | h = hashstr(w)
37 | i = ds.get(h)
38 | if not (i is None) :
39 | return ((i, s[i : i+k]), (j, t[j : j+k]))
40 | return None
41 |
42 | # Find the longest common substring of s and t.
43 | def rkmax(s, t):
44 | mn, mx = 1, min(len(s), len(t))
45 | r = None
46 | while lim > 0 and mn <= mx :
47 | k = int((mn + mx) / 2)
48 | x = rkl(s, t, k)
49 | if x is None :
50 | mx = k - 1
51 | else :
52 | mn = k + 1
53 | r = x
54 | return r
55 |
--------------------------------------------------------------------------------
/theories/approxis/adequacy_rel.v:
--------------------------------------------------------------------------------
1 | From iris.proofmode Require Import proofmode.
2 | From iris.base_logic.lib Require Import na_invariants.
3 | From clutch.approxis Require Import primitive_laws.
4 | From clutch.approxis Require Import app_weakestpre model adequacy.
5 | From clutch.prob_lang Require Import lang.
6 |
7 | Class approxisRGpreS Σ := ApproxisRGPreS {
8 | approxisRGpreS_approxis :: approxisGpreS Σ;
9 | prelorelGpreS_na_inv :: na_invG Σ;
10 | }.
11 |
12 | Definition approxisRΣ : gFunctors := #[approxisΣ; na_invΣ].
13 | Global Instance subG_approxisRGPreS {Σ} : subG approxisRΣ Σ → approxisRGpreS Σ.
14 | Proof. solve_inG. Qed.
15 |
16 | Theorem approximates_coupling Σ `{approxisRGpreS Σ}
17 | (A : ∀ `{approxisRGS Σ}, lrel Σ) (φ : val → val → Prop) e e' σ σ' ε :
18 | (0 <= ε)%R →
19 | (∀ `{approxisRGS Σ}, ∀ v v', A v v' -∗ ⌜φ v v'⌝) →
20 | (∀ `{approxisRGS Σ}, ↯ ε ⊢ REL e << e' : A) →
21 | ARcoupl (lim_exec (e, σ)) (lim_exec (e', σ')) φ ε.
22 | Proof.
23 | intros Hε HA Hlog.
24 | eapply (wp_adequacy_error_lim Σ); [done|].
25 | intros H0 ε' Hpos.
26 | iIntros "He' Herr".
27 | iMod na_alloc as "[%γ Htok]".
28 | set (HclutchR := ApproxisRGS Σ _ _ γ).
29 | iPoseProof (Hlog _) as "Hlog".
30 | iDestruct ((ec_split_le ε ε') with "Herr") as "[ε ε']" ; [real_solver|].
31 | iSpecialize ("Hlog" with "ε").
32 | rewrite refines_eq /refines_def.
33 | assert (0 < ε' - ε)%R by real_solver.
34 | iSpecialize ("Hlog" $! [] (ε' - ε)%R with "He' Htok ε' [//]").
35 | iApply (wp_mono with "Hlog").
36 | iIntros (?) "H /=".
37 | iDestruct "H" as (??) "(? & ? & ? & ? & ?) /=".
38 | iExists _. iFrame. by iApply HA.
39 | Qed.
40 |
41 | Corollary refines_coupling Σ `{approxisRGpreS Σ}
42 | (A : ∀ `{approxisRGS Σ}, lrel Σ) (φ : val → val → Prop) e e' σ σ' :
43 | (∀ `{approxisRGS Σ}, ∀ v v', A v v' -∗ ⌜φ v v'⌝) →
44 | (∀ `{approxisRGS Σ}, ⊢ REL e << e' : A) →
45 | ARcoupl (lim_exec (e, σ)) (lim_exec (e', σ')) φ 0.
46 | Proof.
47 | intros ? Hlog. intros. eapply approximates_coupling ; eauto. 1: lra.
48 | iIntros.
49 | iApply Hlog.
50 | Qed.
51 |
--------------------------------------------------------------------------------
/theories/approxis/approxis.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import namespaces.
2 | From clutch.prob_lang Require Export notation tactics metatheory.
3 | From clutch.prob_lang Require Export lang.
4 | From clutch.prob_lang.spec Require Export spec_rules spec_tactics.
5 | From clutch.approxis Require Export app_weakestpre lifting ectx_lifting primitive_laws proofmode coupling_rules
6 | model compatibility app_rel_rules rel_tactics interp soundness .
7 |
--------------------------------------------------------------------------------
/theories/approxis/ectx_lifting.v:
--------------------------------------------------------------------------------
1 | (** Some derived lemmas for ectx-based languages *)
2 | From iris.proofmode Require Import proofmode.
3 | From clutch.common Require Import ectx_language.
4 | From clutch.approxis Require Export app_weakestpre lifting.
5 | From iris.prelude Require Import options.
6 |
7 | Local Open Scope R.
8 |
9 | Section ectx_lifting.
10 | Context
11 | {Λ : ectxLanguage} {Hinh : Inhabited (state Λ)}
12 | `{!spec_updateGS (lang_markov Λ) Σ, !approxisWpGS Λ Σ}.
13 |
14 | Implicit Types P : iProp Σ.
15 | Implicit Types Φ : val Λ → iProp Σ.
16 | Implicit Types v : val Λ.
17 | Implicit Types e : expr Λ.
18 | Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
19 | Local Hint Resolve head_stuck_stuck : core.
20 |
21 | Lemma wp_lift_head_step_prog_couple {E Φ} e1 s :
22 | to_val e1 = None →
23 | (∀ σ1 e1' σ1' ε1,
24 | state_interp σ1 ∗ spec_interp (e1', σ1') ∗ err_interp ε1 ={E,∅}=∗
25 | ⌜head_reducible e1 σ1⌝ ∗
26 | prog_coupl e1 σ1 e1' σ1' ε1 (λ e2 σ2 e2' σ2' ε2,
27 | ▷ |={∅,E}=> state_interp σ2 ∗ spec_interp (e2', σ2') ∗
28 | err_interp ε2 ∗ WP e2 @ s; E {{ Φ }}))
29 | ⊢ WP e1 @ s; E {{ Φ }}.
30 | Proof.
31 | iIntros (?) "H". iApply wp_lift_step_prog_couple; [done|].
32 | iIntros (σ1 e1' σ1' ε1) "Hσ".
33 | by iMod ("H" with "Hσ") as "[% H]".
34 | Qed.
35 |
36 | Lemma wp_lift_head_step {E Φ} e1 s :
37 | to_val e1 = None →
38 | (∀ σ1, state_interp σ1 ={E,∅}=∗
39 | ⌜head_reducible e1 σ1⌝ ∗
40 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={∅,E}=∗
41 | state_interp σ2 ∗ WP e2 @ s; E {{ Φ }})
42 | ⊢ WP e1 @ s; E {{ Φ }}.
43 | Proof.
44 | iIntros (?) "H". iApply wp_lift_step_later; [done|]. iIntros (?) "Hσ".
45 | iMod ("H" with "Hσ") as "[% H]"; iModIntro.
46 | iSplit.
47 | { iPureIntro. by apply head_prim_reducible. }
48 | iIntros (???) "!> !>". iApply "H"; auto.
49 | Qed.
50 |
51 | Lemma wp_lift_atomic_head_step_fupd {E1 E2 Φ} e1 s :
52 | to_val e1 = None →
53 | (∀ σ1, state_interp σ1 ={E1}=∗
54 | ⌜head_reducible e1 σ1⌝ ∗
55 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E1}[E2]▷=∗
56 | state_interp σ2 ∗
57 | from_option Φ False (to_val e2))
58 | ⊢ WP e1 @ s; E1 {{ Φ }}.
59 | Proof.
60 | iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
61 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
62 | iSplit.
63 | { iPureIntro. by apply head_prim_reducible. }
64 | iIntros (e2 σ2 Hstep).
65 | iApply "H"; eauto.
66 | Qed.
67 |
68 | Lemma wp_lift_atomic_head_step {E Φ} e1 s :
69 | to_val e1 = None →
70 | (∀ σ1, state_interp σ1 ={E}=∗
71 | ⌜head_reducible e1 σ1⌝ ∗
72 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E}=∗
73 | state_interp σ2 ∗
74 | from_option Φ False (to_val e2))
75 | ⊢ WP e1 @ s; E {{ Φ }}.
76 | Proof.
77 | iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
78 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
79 | iSplit.
80 | { iPureIntro. by apply head_prim_reducible. }
81 | iNext. iIntros (e2 σ2 Hstep).
82 | iApply "H"; eauto.
83 | Qed.
84 |
85 | Lemma wp_lift_pure_det_head_step {E E' Φ} e1 e2 s :
86 | to_val e1 = None →
87 | (∀ σ1, head_reducible e1 σ1) →
88 | (∀ σ1 e2' σ2,
89 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
90 | (|={E}[E']▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
91 | Proof using Hinh.
92 | intros. erewrite !(wp_lift_pure_det_step e1 e2); eauto.
93 | Qed.
94 |
95 | Lemma wp_lift_pure_det_head_step' {E Φ} e1 e2 s :
96 | to_val e1 = None →
97 | (∀ σ1, head_reducible e1 σ1) →
98 | (∀ σ1 e2' σ2,
99 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
100 | ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
101 | Proof using Hinh.
102 | intros. rewrite -[(WP e1 @ _ ; _ {{ _ }})%I]wp_lift_pure_det_head_step //.
103 | rewrite -step_fupd_intro //.
104 | Qed.
105 |
106 | End ectx_lifting.
107 |
--------------------------------------------------------------------------------
/theories/approxis/examples/ElGamal_closed_ctx.v:
--------------------------------------------------------------------------------
1 | From clutch.approxis Require Import approxis.
2 | From clutch.approxis.examples Require Import ElGamal_semantic.
3 | From clutch.approxis.examples Require valgroup_Zp valgroup_Zpx.
4 | Import advantage.
5 |
6 | #[local] Definition rfc3526_id18 : N :=
7 | 0xFFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F24117C4B1FE649286651ECE45B3DC2007CB8A163BF0598DA48361C55D39A69163FA8FD24CF5F83655D23DCA3AD961C62F356208552BB9ED529077096966D670C354E4ABC9804F1746C08CA18217C32905E462E36CE3BE39E772C180E86039B2783A2EC07A28FB5C55DF06F4C52C9DE2BCBF6955817183995497CEA956AE515D2261898FA051015728E5A8AAAC42DAD33170D04507A33A85521ABDF1CBA64ECFB850458DBEF0A8AEA71575D060C7DB3970F85A6E1E4C7ABF5AE8CDB0933D71E8C94E04A25619DCEE3D2261AD2EE6BF12FFA06D98A0864D87602733EC86A64521F2B18177B200CBBE117577A615D6C770988C0BAD946E208E24FA074E5AB3143DB5BFCE0FD108E4B82D120A92108011A723C12A787E6D788719A10BDBA5B2699C327186AF4E23C1A946834B6150BDA2583E9CA2AD44CE8DBBBC2DB04DE8EF92E8EFC141FBECAA6287C59474E6BC05D99B2964FA090C3A2233BA186515BE7ED1F612970CEE2D7AFB81BDD762170481CD0069127D5B05AA993B4EA988D8FDDC186FFB7DC90A6C08F4DF435C93402849236C3FAB4D27C7026C1D4DCB2602646DEC9751E763DBA37BDF8FF9406AD9E530EE5DB382F413001AEB06A53ED9027D831179727B0865A8918DA3EDBEBCF9B14ED44CE6CBACED4BB1BDB7F1447E6CC254B332051512BD7AF426FB8F401378CD2BF5983CA01C64B92ECF032EA15D1721D03F482D7CE6E74FEF6D55E702F46980C82B5A84031900B1C9E59E7C97FBEC7E8F323A97A7E36CC88BE0F1D45B7FF585AC54BD407B22B4154AACC8F6D7EBF48E1D814CC5ED20F8037E0A79715EEF29BE32806A1D58BB7C5DA76F550AA3D8A1FBFF0EB19CCB1A313D55CDA56C9EC2EF29632387FE8D76E3C0468043E8F663F4860EE12BF2D5B0B7474D6E694F91E6DBE115974A3926F12FEE5E438777CB6A932DF8CD8BEC4D073B931BA3BC832B68D9DD300741FA7BF8AFC47ED2576F6936BA424663AAB639C5AE4F5683423B4742BF1C978238F16CBE39D652DE3FDB8BEFC848AD922222E04A4037C0713EB57A81A23F0C73473FC646CEA306B4BCBC8862F8385DDFA9D4B7FA2C087E879683303ED5BDD3A062B3CF5B3A278A66D2A13F83F44F82DDF310EE074AB6A364597E899A0255DC164F31CC50846851DF9AB48195DED7EA1B1D510BD7EE74D73FAF36BC31ECFA268359046F4EB879F924009438B481C6CD7889A002ED5EE382BC9190DA6FC026E479558E4475677E9AA9E3050E2765694DFC81F56E880B96E7160C980DD98EDD3DFFFFFFFFFFFFFFFFF.
8 |
9 | #[local] Definition p''' := (N.to_nat rfc3526_id18 - 3).
10 | #[local] Definition p := S (S (S p''')).
11 |
12 | Fact addSC p m : p = m+3 -> S (S (S (p - 3))) = p.
13 | Proof. intros ->. rewrite Nat.add_sub Nat.add_comm //. Qed.
14 | Fact p_eq_rfc3526_id18 : p = N.to_nat rfc3526_id18.
15 | unfold p, p'''.
16 | eapply (addSC _ (N.to_nat (rfc3526_id18 - 3))%N).
17 | replace 3%nat with (N.to_nat 3%N) ; [|auto].
18 | rewrite -N2Nat.inj_add.
19 | rewrite N.sub_add //.
20 | Qed.
21 |
22 | (* Section additive.
23 | Import valgroup_Zp.
24 | Definition EG_p := pk_ots_rnd_ddh (G:=@cg_p (N.to_nat rfc3526_id18)) (cgg:=cgg_p (N.to_nat rfc3526_id18)).
25 | End additive. *)
26 |
27 | Section multiplicative.
28 | Import valgroup_Zpx.
29 |
30 | Context `{rfc3526_id18_prime : is_true (prime.prime (N.to_nat rfc3526_id18))}.
31 |
32 | Fact p_prime : is_true (prime.prime p).
33 | Proof using rfc3526_id18_prime. by rewrite p_eq_rfc3526_id18. Qed.
34 |
35 | Definition EG_DDH_OTS_Zpx := @ElGamal_DDH_secure (vg_p _) (cgs_p _) _ (@cgg_p _ p_prime) (@cg_p _ p_prime).
36 |
37 | Definition EG_DDH_CPA_Zpx :=
38 | @ElGamal_DDH_CPA (vg_p _) (cgs_p _) _ (@cgg_p _ p_prime) (@cg_p _ p_prime).
39 |
40 | (* Set Printing Implicit.
41 | Check EG_DDH_CPA_Zpx. *)
42 |
43 | End multiplicative.
44 |
45 |
46 | (* Print Assumptions EG_DDH_CPA_Zpx. *)
47 |
--------------------------------------------------------------------------------
/theories/approxis/examples/ElGamal_defs.v:
--------------------------------------------------------------------------------
1 | (* Definitions for ElGamal encryption. *)
2 | From clutch.prob_lang Require Import notation advantage.
3 | From clutch.prob_lang.typing Require Import types tychk.
4 | From clutch.approxis.examples Require Import valgroup.
5 | From clutch.approxis Require approxis option.
6 | Set Default Proof Using "Type*".
7 |
8 | Section ElGamal.
9 |
10 | Import valgroup_notation.
11 |
12 | Context {vg : val_group}. (* A group on a subset of values. *)
13 | Context {cg : clutch_group_struct}. (* Implementations of the vg group operations *)
14 | Context {vgg : @val_group_generator vg}. (* G is generated by g. *)
15 | Context {cgg : @clutch_group_generator vg cg vgg}. (* g is well-typed *)
16 |
17 | #[local] Notation n := (S n'').
18 |
19 | (* ElGamal public key encryption *)
20 | Definition keygen : val :=
21 | λ:<>, let: "sk" := rand #n in
22 | let: "pk" := g^"sk" in
23 | ("sk", "pk").
24 |
25 | Definition enc : val :=
26 | λ: "pk", λ: "msg",
27 | let: "b" := rand #n in
28 | let: "B" := g^"b" in
29 | let: "X" := "msg" · ("pk"^"b") in
30 | ("B", "X").
31 |
32 | Definition dec : val :=
33 | λ:"sk" "BX",
34 | let, ("B", "X") := "BX" in
35 | "X" · ("B"^-"sk").
36 |
37 | Definition rand_cipher : val :=
38 | λ:"msg",
39 | let: "b" := rand #n in
40 | let: "x" := rand #n in
41 | let, ("B", "X") := (g^"b", g^"x") in
42 | ("B", "X").
43 |
44 | (* The syntactic type of the ElGamal game(s). *)
45 | Definition τ_EG := (τG * (TInt → () + τG * τG))%ty.
46 |
47 | Lemma keygen_typed : ⊢ᵥ keygen : (() → TInt * τG).
48 | Proof. rewrite /keygen. type_val 2. 2: apply Subsume_int_nat. all: tychk => //. Qed.
49 |
50 | Lemma enc_typed : ⊢ᵥ enc : (τG → τG → τG * τG).
51 | Proof. rewrite /enc. type_val 3. 2: apply Subsume_int_nat. all: tychk => //. Qed.
52 |
53 | Lemma rand_cipher_typed : ⊢ᵥ rand_cipher : (τG → τG * τG).
54 | Proof.
55 | rewrite /rand_cipher. type_val 2. 2: apply Subsume_int_nat. 2: tychk.
56 | type_expr 2. 2: apply Subsume_int_nat. all: tychk=> //.
57 | Qed.
58 |
59 | Section semantic.
60 |
61 | Import clutch.approxis.approxis.
62 |
63 | Context `{!approxisRGS Σ}.
64 | Context {G : clutch_group (vg:=vg) (cg:=cg)}. (* cg satisfies the group laws. *)
65 |
66 | Definition EG_pkey := lrel_G.
67 | Definition EG_skey := @lrel_int Σ.
68 | Definition EG_msg := lrel_G.
69 | Definition EG_cipher := (lrel_G * lrel_G)%lrel.
70 | Definition T_EG := (EG_pkey * (EG_msg → option.lrel_option EG_cipher))%lrel.
71 |
72 | Import valgroup_tactics.
73 |
74 | Lemma keygen_sem_typed :
75 | ⊢ REL keygen << keygen : () → EG_skey * EG_pkey.
76 | Proof with rel_red.
77 | rewrite /EG_skey /EG_pkey.
78 | rewrite /keygen.
79 | rel_arrow_val ; iIntros (??) "_"...
80 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
81 | iIntros "!> %sk %le_sk_n"...
82 | rel_vals.
83 | Qed.
84 |
85 | Lemma enc_sem_typed :
86 | ⊢ REL enc << enc : EG_pkey → EG_msg → EG_cipher.
87 | Proof with rel_red.
88 | rewrite /enc...
89 | rel_arrow_val ; iIntros (??) "(%&->&->)"...
90 | rel_arrow_val ; iIntros (??) "(%&->&->)"...
91 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
92 | iIntros "!> %b %le_b_n"...
93 | rel_vals.
94 | Qed.
95 |
96 | Lemma rand_cipher_sem_typed :
97 | ⊢ REL rand_cipher << rand_cipher : EG_msg → EG_cipher.
98 | Proof with rel_red.
99 | rewrite /rand_cipher.
100 | rel_arrow_val ; iIntros (??) "(%&->&->)"...
101 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
102 | iIntros "!> %b %le_b_n"...
103 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
104 | iIntros "!> %x %le_x_n"...
105 | rel_vals.
106 | Qed.
107 |
108 | End semantic.
109 |
110 | End ElGamal.
111 |
--------------------------------------------------------------------------------
/theories/approxis/examples/avoid_collision_rel.v:
--------------------------------------------------------------------------------
1 | (* From discussions with Ugo:
2 |
3 | ''' define e := let x = rand n in x = t
4 |
5 | where x : string(n), n sec'ty param, and t arbitrary.
6 |
7 | The program e should be equivalent up to negligible probability to false, so
8 | long as x and t are independent. But since x is randomly sampled, they will
9 | indeed be independent.
10 |
11 | This law is well-known ; it may not be used in EC, but in Squirrel prover, and
12 | shows up in their examples too.
13 | '''
14 |
15 | We would like to show that `e` is feasibly contextually equivalent to `false`.
16 |
17 | We can't reason about feasible contextual equivalence yet, so we instead show
18 | that there is an approximate coupling between the evaluation of `e` and `false`
19 | that lifts equality with error `1/N`, i.e.,
20 |
21 | `e ~ false { m b . m = b } 1/n`
22 |
23 | *)
24 |
25 | From stdpp Require Import namespaces.
26 | From iris.proofmode Require Import proofmode.
27 | From clutch.prob_lang Require Import notation tactics metatheory.
28 | From clutch.approxis Require Import adequacy coupling_rules proofmode.
29 | From clutch.prob_lang Require Import class_instances.
30 | From clutch.prob_lang.spec Require Import spec_tactics.
31 |
32 | Section wp_refinement.
33 | Context `{!approxisGS Σ}.
34 |
35 | Lemma wp_ref_no_coll_l N z (t : nat) :
36 | TCEq N (Z.to_nat z) →
37 | {{{ ↯ (1 / S N) ∗ ⤇ #false }}}
38 | let: "x" := rand #z in "x" = #t
39 | {{{ (b : bool), RET #b; ⤇ #b }}}.
40 | Proof.
41 | iIntros (Nz Ψ) "(ε & hj) HΨ".
42 | wp_bind (rand #z)%E.
43 | wp_apply (wp_rand_avoid_l t with "ε"); [done|].
44 | iIntros (?(?&?)).
45 | wp_pures.
46 | iApply "HΨ".
47 | rewrite bool_decide_eq_false_2 //.
48 | intros ?. simplify_eq.
49 | Qed.
50 |
51 | Lemma wp_ref_no_coll_r N z (t : nat) :
52 | TCEq N (Z.to_nat z) →
53 | ⟨⟨⟨ ↯ (1 / S N) ∗ ⤇ (let: "x" := rand #z in "x" = #t) ⟩⟩⟩
54 | (#false : (language.expr prob_lang))
55 | ⟨⟨⟨ (b : bool), RET #b; ⤇ #b ⟩⟩⟩.
56 | Proof.
57 | iIntros (Nz Ψ) "(ε & hj) HΨ".
58 | tp_bind (rand #z)%E.
59 | unshelve wp_apply (wp_rand_avoid_r t _ _ (#false)%E _ _ (1/S N)%R _ _) ; [|auto | iFrame].
60 | iFrame. iIntros "%n hj %nt %". simpl. tp_pures ; simpl ; auto.
61 | case_bool_decide ; simplify_eq. wp_pures.
62 | by iApply "HΨ".
63 | Qed.
64 |
65 | End wp_refinement.
66 |
67 | Section opsem_refinement.
68 |
69 | Lemma no_coll_l N (ε : nonnegreal) z (t : nat) σ σ' :
70 | N = Z.to_nat z →
71 | ARcoupl
72 | (lim_exec ((let: "x" := rand #z in "x" = #t)%E, σ))
73 | (lim_exec (Val #false, σ'))
74 | (=)
75 | (1 / S N).
76 | Proof.
77 | intros ->.
78 | eapply (wp_adequacy approxisΣ).
79 | { real_solver. }
80 | iIntros (?) "? ?".
81 | iApply (wp_ref_no_coll_l with "[$]").
82 | eauto.
83 | Qed.
84 |
85 | Lemma no_coll_r N (ε : nonnegreal) z (t : nat) σ σ' :
86 | N = Z.to_nat z →
87 | ARcoupl
88 | (lim_exec (Val #false, σ'))
89 | (lim_exec ((let: "x" := rand #z in "x" = #t)%E, σ))
90 | (=)
91 | (1 / S N).
92 | Proof.
93 | intros ->.
94 | eapply (wp_adequacy approxisΣ).
95 | { real_solver. }
96 | iIntros (?) "? ?".
97 | iApply (wp_ref_no_coll_r with "[$]").
98 | eauto.
99 | Qed.
100 |
101 | End opsem_refinement.
102 |
--------------------------------------------------------------------------------
/theories/approxis/examples/diffie_hellman.v:
--------------------------------------------------------------------------------
1 | From clutch.approxis Require Import reltac2 approxis.
2 | From clutch.prob_lang Require Import advantage.
3 | From clutch.prob_lang.typing Require Import tychk.
4 | From clutch.approxis.examples Require Import valgroup advantage_laws.
5 |
6 | Import valgroup_notation.
7 |
8 | Set Default Proof Using "Type*".
9 |
10 | Section DH.
11 |
12 | Context {vg : val_group}. (* A group on a subset of values. *)
13 | Context {cg : clutch_group_struct}. (* Implementations of the vg group operations *)
14 | Context {vgg : @val_group_generator vg}. (* G is generated by g. *)
15 |
16 | #[local] Notation n := (S n'').
17 |
18 | (* The syntactic type of the Decisional Diffie-Hellman game(s). *)
19 | Definition τ_DDH := (τG * τG * τG)%ty.
20 |
21 | (* The Decisional Diffie Hellman assumption says the following two programs are
22 | PPT(n) indistinguishable. *)
23 | Definition DDH_real : expr :=
24 | let: "a" := rand #n in
25 | let: "b" := rand #n in
26 | (g^"a", g^"b", g^("a"*"b")).
27 |
28 | Definition DDH_rand : expr :=
29 | let: "a" := rand #n in
30 | let: "b" := rand #n in
31 | let: "c" := rand #n in
32 | (g^"a", g^"b", g^"c").
33 |
34 | Context {cgg : @clutch_group_generator vg cg vgg}. (* g is well-typed *)
35 |
36 | Lemma DDH_real_typed : ∅ ⊢ₜ DDH_real : τ_DDH.
37 | Proof with tychk.
38 | rewrite /DDH_real.
39 | type_expr 1. 2: apply Subsume_int_nat...
40 | type_expr 2. 2: apply Subsume_int_nat...
41 | tychk => //.
42 | Qed.
43 |
44 | Lemma DDH_rand_typed : ∅ ⊢ₜ DDH_rand : τ_DDH.
45 | Proof with tychk.
46 | rewrite /DDH_rand.
47 | type_expr 1. 2: apply Subsume_int_nat...
48 | type_expr 2. 2: apply Subsume_int_nat...
49 | type_expr 2. 2: apply Subsume_int_nat...
50 | tychk => //.
51 | Qed.
52 |
53 | Section semantic.
54 |
55 | Context `{!approxisRGS Σ}.
56 | Context {G : clutch_group (vg:=vg) (cg:=cg)}. (* cg satisfies the group laws. *)
57 | Context {Δ : listO (lrelC Σ)}.
58 |
59 | (* The semantic type of the Diffie-Hellman game(s). *)
60 | Definition T_DDH : lrel _ := lrel_G * lrel_G * lrel_G.
61 |
62 | Import valgroup_tactics.
63 |
64 | Lemma DDH_real_sem_typed : ⊢ REL DDH_real << DDH_real : T_DDH.
65 | Proof with rel_red.
66 | rewrite /DDH_real...
67 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
68 | iIntros "!> %a %le_a_n"...
69 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
70 | iIntros "!> %b %le_b_n"...
71 | replace (Z.of_nat a * Z.of_nat b)%Z with (Z.of_nat (a * b)) by lia...
72 | rel_vals.
73 | Qed.
74 |
75 | Lemma DDH_rand_sem_typed : ⊢ REL DDH_rand << DDH_rand : T_DDH.
76 | Proof with rel_red.
77 | rewrite /DDH_real...
78 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
79 | iIntros "!> %a %le_a_n"...
80 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
81 | iIntros "!> %b %le_b_n"...
82 | rel_apply (refines_couple_UU n). 1: intuition auto ; lia.
83 | iIntros "!> %c %le_c_n"...
84 | rel_vals.
85 | Qed.
86 |
87 | End semantic.
88 |
89 | End DH.
90 |
--------------------------------------------------------------------------------
/theories/approxis/examples/option.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang.typing Require Import tychk.
2 | From clutch.approxis Require Import approxis.
3 | Set Default Proof Using "Type*".
4 |
5 | Definition TOption (T : type) : type := (TUnit + T)%ty.
6 | Definition lrel_option {Σ} (A : lrel Σ) := (() + A)%lrel.
7 |
8 | Definition opt_mult : val :=
9 | λ:"opt",
10 | match: "opt" with
11 | | NONE => NONE
12 | | SOME "vopt" =>
13 | match: "vopt" with
14 | | NONE => NONE
15 | | SOME "v" => SOME "v"
16 | end
17 | end.
18 |
19 | Fact opt_mult_typed (A : type) : (⊢ᵥ opt_mult : (TOption (TOption A) → TOption A)%ty).
20 | Proof.
21 | rewrite /opt_mult. tychk.
22 | Qed.
23 |
24 | Definition opt_mult_poly : val :=
25 | Λ: λ:"opt",
26 | match: "opt" with
27 | | NONE => NONE
28 | | SOME "vopt" =>
29 | match: "vopt" with
30 | | NONE => NONE
31 | | SOME "v" => SOME "v"
32 | end
33 | end.
34 |
35 | Fact opt_mult_poly_typed : (⊢ᵥ opt_mult_poly : ∀: (TOption (TOption #0) → TOption #0)%ty).
36 | Proof.
37 | rewrite /opt_mult_poly. constructor. tychk.
38 | Qed.
39 |
40 | Fact opt_mult_poly_sem_typed `{!approxisRGS Σ} :
41 | ⊢ (∀ A : lrel Σ, lrel_option (lrel_option A) → lrel_option A)%lrel
42 | opt_mult_poly opt_mult_poly.
43 | Proof.
44 | replace (∀ A : lrel Σ, lrel_option (lrel_option A) → lrel_option A)%lrel
45 | with (interp (∀: TOption (TOption #0) → TOption #0) []) by easy.
46 | iApply fundamental_val.
47 | rewrite /opt_mult_poly. constructor. tychk.
48 | Qed.
49 |
--------------------------------------------------------------------------------
/theories/approxis/examples/sum_seq.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import Reals Psatz.
2 | From clutch Require Import base.
3 | Set Default Proof Using "Type*".
4 |
5 | Definition ε_bday Q N := ((INR Q - 1) * INR Q / (2 * INR N))%R.
6 |
7 | Lemma sum_seq N :
8 | (((INR N - 1) * INR N) / 2)%R = INR (fold_left Nat.add (seq 0 N) 0).
9 | Proof.
10 | symmetry.
11 | cut (Rmult 2%R (INR (fold_left Nat.add (seq 0 N) 0)) = (Rmult ((INR N - 1)) (INR N))).
12 | - intros foo.
13 | rewrite -foo.
14 | rewrite Rmult_comm.
15 | by rewrite Rmult_div_l => //.
16 | - destruct N.
17 | { compute. lra. }
18 | induction N as [|k IH] ; [compute ; lra|].
19 | rewrite seq_S. replace (0+ S k) with (S k) by lia.
20 | rewrite fold_left_app.
21 | rewrite {1}/fold_left.
22 | revert IH.
23 | replace 2%R with (INR 2%nat) => //.
24 | rewrite -mult_INR.
25 | intros IH.
26 | rewrite -mult_INR.
27 | rewrite Nat.mul_add_distr_l.
28 | rewrite plus_INR.
29 | rewrite IH.
30 | replace ((INR (S k)) - 1)%R with (INR k).
31 | 2:{ replace 1%R with (INR 1) by easy. rewrite -minus_INR => //. 2: f_equal ; simpl ; lia.
32 | f_equal. lia. }
33 | rewrite -mult_INR. rewrite -plus_INR.
34 | replace ((INR (S (S k))) - 1)%R with (INR (S k)).
35 | 2:{ replace 1%R with (INR 1) by easy. rewrite -minus_INR => //.
36 | lia. }
37 | rewrite -mult_INR. f_equal. lia.
38 | Qed.
39 |
40 | Lemma bday_sum Q N : ε_bday Q N = (INR (fold_left Nat.add (seq 0 Q) 0%nat) / INR N)%R.
41 | Proof.
42 | by rewrite /ε_bday Rdiv_mult_distr sum_seq.
43 | Qed.
44 |
--------------------------------------------------------------------------------
/theories/approxis/proofmode.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation class_instances tactics.
2 | From clutch.prob_lang Require Export wp_tactics.
3 | From clutch.approxis Require Import app_weakestpre lifting primitive_laws derived_laws.
4 | From iris.prelude Require Import options.
5 |
6 |
7 | #[global] Program Instance approxis_wptactics_base `{!approxisGS Σ} : GwpTacticsBase Σ unit wp.
8 | Next Obligation. intros. by apply wp_value. Qed.
9 | Next Obligation. intros. by apply wp_fupd. Qed.
10 |
11 | #[global] Program Instance approxis_wptactics_bind `{!approxisGS Σ} : GwpTacticsBind Σ unit wp.
12 | Next Obligation. intros. by apply wp_bind. Qed.
13 |
14 | #[global] Program Instance approxis_wptactics_pure `{!approxisGS Σ} : GwpTacticsPure Σ unit true wp.
15 | Next Obligation. intros. by eapply wp_pure_step_later. Qed.
16 |
17 | #[global] Program Instance rel_logic_wptactics_heap `{!approxisGS Σ} : GwpTacticsHeap Σ unit true wp :=
18 | Build_GwpTacticsHeap _ _ _ _ (λ l q v, (l ↦{q} v)%I) (λ l q vs, (l ↦∗{q} vs)%I) _ _ _ _.
19 | Next Obligation. intros. by apply wp_alloc. Qed.
20 | Next Obligation. intros. by apply wp_allocN. Qed.
21 | Next Obligation. intros. by apply wp_load. Qed.
22 | Next Obligation. intros. by apply wp_store. Qed.
23 |
24 |
25 | #[global] Program Instance rel_logic_wptactics_tape `{!approxisGS Σ} : GwpTacticsTapes Σ unit true wp :=
26 | Build_GwpTacticsTapes _ _ _ _ (λ l q N ns, (l ↪N ( N ; ns ))%I) _ _.
27 | Next Obligation. intros. by apply wp_alloc_tape. Qed.
28 | Next Obligation. intros. rewrite (bi.wand_curry (l↪N(N;ns))). by apply wp_rand_tape. Qed.
29 |
30 |
--------------------------------------------------------------------------------
/theories/approxis/soundness.v:
--------------------------------------------------------------------------------
1 | (** Logical relation is sound w.r.t. the contextual refinement. *)
2 | From Coq Require Export Reals.
3 | From iris.proofmode Require Import proofmode.
4 | From clutch.prob_lang Require Import notation metatheory lang.
5 | From clutch.approxis Require Export primitive_laws model adequacy_rel interp fundamental.
6 | From clutch.prob_lang.typing Require Export contextual_refinement.
7 |
8 |
9 | Lemma refines_sound_open Σ `{!approxisRGpreS Σ} Γ e e' τ :
10 | (∀ `{approxisRGS Σ} Δ, ⊢ 〈⊤;Δ;Γ〉 ⊨ e ≤log≤ e' : τ) →
11 | Γ ⊨ e ≤ctx≤ e' : τ.
12 | Proof.
13 | intros Hlog K σ₀ b Htyped.
14 | rewrite <- Rplus_0_r.
15 | eapply ARcoupl_eq_elim.
16 | eapply (refines_coupling Σ (λ _, lrel_bool)); eauto; last first.
17 | - iIntros (?).
18 | iPoseProof (bin_log_related_under_typed_ctx with "[]") as "H"; [done| |].
19 | { iIntros "!>" (?). iApply Hlog. }
20 | iSpecialize ("H" $! [] ∅ with "[]").
21 | { rewrite fmap_empty. iApply env_ltyped2_empty. }
22 | rewrite /interp 2!fmap_empty 2!subst_map_empty /=.
23 | done.
24 | - by iIntros (???) "[%b' [-> ->]]".
25 | Qed.
26 |
27 | Lemma refines_sound Σ `{Hpre : !approxisRGpreS Σ} (e e': expr) τ :
28 | (∀ `{approxisRGS Σ} Δ, ⊢ REL e << e' : (interp τ Δ)) →
29 | ∅ ⊨ e ≤ctx≤ e' : τ.
30 | Proof.
31 | intros Hlog. eapply (refines_sound_open Σ).
32 | iIntros (? Δ vs).
33 | rewrite fmap_empty env_ltyped2_empty_inv.
34 | iIntros (->).
35 | rewrite !fmap_empty !subst_map_empty.
36 | iApply Hlog.
37 | Qed.
38 |
--------------------------------------------------------------------------------
/theories/base_logic/spec_auth_markov.v:
--------------------------------------------------------------------------------
1 | From Coq Require Export Reals Psatz.
2 |
3 | From iris.base_logic.lib Require Export fancy_updates own.
4 | From iris.proofmode Require Import base tactics classes.
5 | From iris.algebra Require Import excl auth.
6 | From iris.prelude Require Import options.
7 |
8 | From clutch.prob Require Import couplings distribution markov.
9 | From clutch.base_logic Require Export spec_update.
10 |
11 | (** The authoritative spec tracking algebra *)
12 | Definition specUR (δ : markov) : ucmra := optionUR (exclR (leibnizO (mstate δ))).
13 | Definition authUR_spec (δ : markov) : ucmra := authUR (specUR δ).
14 |
15 | Class specPreG (δ : markov) (Σ : gFunctors) := SpecPreG {
16 | specG_pre_authUR :: inG Σ (authUR_spec δ);
17 | }.
18 | Definition specΣ (δ : markov) : gFunctors := GFunctor (authUR_spec δ).
19 | Global Instance subG_caliperGPreS {δ Σ} : subG (specΣ δ) Σ → specPreG δ Σ.
20 | Proof. solve_inG. Qed.
21 |
22 | Class specG (δ : markov) (Σ : gFunctors) := SpecG {
23 | specG_authUR :: inG Σ (authUR_spec δ);
24 | specG_gname : gname;
25 | }.
26 |
27 | Section spec_auth.
28 | Context `{specG δ Σ}.
29 | Implicit Types a : mstate δ.
30 |
31 | Definition specA a : iProp Σ :=
32 | own specG_gname (● (Excl' a : specUR _)).
33 | Definition specF a : iProp Σ :=
34 | own specG_gname (◯ (Excl' a : specUR _)).
35 |
36 | Lemma spec_auth_agree a a' :
37 | specA a -∗ specF a' -∗ ⌜a = a'⌝.
38 | Proof.
39 | iIntros "Ha Hf".
40 | iDestruct (own_valid_2 with "Ha Hf") as
41 | %[Hexcl ?]%auth_both_valid_discrete.
42 | rewrite Excl_included in Hexcl.
43 | by apply leibniz_equiv in Hexcl.
44 | Qed.
45 |
46 | Lemma spec_auth_update a'' a a' :
47 | specA a -∗ specF a' ==∗ specA a'' ∗ specF a''.
48 | Proof.
49 | iIntros "Ha Hf".
50 | iDestruct (spec_auth_agree with "Ha Hf") as %->.
51 | iMod (own_update_2 with "Ha Hf") as "[Ha Hf]".
52 | { eapply auth_update .
53 | eapply (@option_local_update _ _ _ (Excl a'' : exclR (leibnizO (mstate δ)))).
54 | by eapply exclusive_local_update. }
55 | by iFrame.
56 | Qed.
57 |
58 | End spec_auth.
59 |
60 | Lemma spec_auth_alloc {δ Σ} a `{!specPreG δ Σ} :
61 | ⊢ |==> ∃ (_ : specG δ Σ), specA a ∗ specF a.
62 | Proof.
63 | iMod (own_alloc ((● (Excl' a : specUR _)) ⋅ (◯ (Excl' a : specUR _))))
64 | as "(%γspec & Hauth & Hfrag)".
65 | { by apply auth_both_valid_discrete. }
66 | set (HspecG := SpecG δ Σ _ γspec).
67 | iModIntro. iExists HspecG. iFrame.
68 | Qed.
69 |
70 | #[global] Instance spec_auth_spec_update {δ Σ} `{specG δ Σ} : spec_updateGS δ Σ := Spec_updateGS specA.
71 |
--------------------------------------------------------------------------------
/theories/caliper/examples/flip.v:
--------------------------------------------------------------------------------
1 | From clutch.prob Require Import distribution markov.
2 | From clutch.prob_lang Require Import lang notation.
3 | From clutch.caliper Require Import weakestpre primitive_laws derived_laws proofmode.
4 |
5 | Section coupl.
6 | Context `{!caliperG δ Σ}.
7 |
8 | Definition int_to_bool : val :=
9 | λ: "z", ~ ("z" = #0).
10 | Definition flip : expr := (int_to_bool (rand #1))%E.
11 |
12 | Lemma rwp_couple_flip E R a1 :
13 | Rcoupl fair_coin (step a1) R →
14 | {{{ specF a1 }}} flip @ E {{{ (b : bool) a2, RET #b; specF a2 ∗ ⌜R b a2⌝ }}}.
15 | Proof.
16 | iIntros (? Φ) "Ha HΦ". rewrite /flip.
17 | wp_pures.
18 | wp_apply (rwp_couple with "Ha").
19 | { eapply Rcoupl_mass_eq in H. rewrite fair_coin_mass in H.
20 | eapply mass_pos_reducible. lra. }
21 | { by eapply Rcoupl_refRcoupl, Rcoupl_swap, Rcoupl_fair_coin_dunifP. }
22 | iIntros (n a2) "[Ha %HR]". rewrite /int_to_bool.
23 | wp_pures.
24 | case_bool_decide.
25 | - iApply "HΦ". iFrame. inv_fin n; eauto.
26 | - iApply ("HΦ"). iFrame. inv_fin n; eauto.
27 | Qed.
28 |
29 | Lemma rwp_flip E :
30 | ⟨⟨⟨ True ⟩⟩⟩ flip @ E ⟨⟨⟨ (b : bool), RET #(LitBool b); True ⟩⟩⟩.
31 | Proof.
32 | iIntros (Φ) "_ HΦ". rewrite /flip.
33 | wp_bind (rand(_) _)%E.
34 | wp_apply (rwp_rand 1 with "[//]").
35 | iIntros (?) "_ /=". rewrite /int_to_bool.
36 | wp_pures.
37 | case_bool_decide.
38 | - iApply "HΦ". iFrame. inv_fin n; eauto.
39 | - iApply ("HΦ"). iFrame. inv_fin n; eauto.
40 | Qed.
41 |
42 | End coupl.
43 |
--------------------------------------------------------------------------------
/theories/caliper/proofmode.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation class_instances tactics.
2 | From clutch.prob_lang Require Export wp_tactics.
3 | From clutch.caliper Require Import weakestpre primitive_laws derived_laws.
4 | From iris.prelude Require Import options.
5 |
6 | #[global] Program Instance rel_logic_wptactics_base `{!caliperG δ Σ} :
7 | GwpTacticsBase Σ unit wp.
8 | Next Obligation. intros. by apply rwp_value. Qed.
9 | Next Obligation. intros. by apply rwp_fupd. Qed.
10 |
11 | #[global] Program Instance rel_logic_wptactics_bind `{!caliperG δ Σ} :
12 | GwpTacticsBind Σ unit wp.
13 | Next Obligation. intros. by apply rwp_bind. Qed.
14 |
15 | #[global] Program Instance rel_logic_wptactics_pure `{!caliperG δ Σ} :
16 | GwpTacticsPure Σ unit false wp.
17 | Next Obligation. intros. by eapply lifting.rwp_pure_step. Qed.
18 |
19 | #[global] Program Instance rel_logic_wptactics_heap `{!caliperG δ Σ} : GwpTacticsHeap Σ unit false wp :=
20 | Build_GwpTacticsHeap _ _ _ _ (λ l q v, (l ↦{q} v)%I) (λ l q vs, (l ↦∗{q} vs)%I) _ _ _ _.
21 | Next Obligation. intros. by apply rwp_alloc. Qed.
22 | Next Obligation. intros. by apply rwp_allocN. Qed.
23 | Next Obligation. intros. by apply rwp_load. Qed.
24 | Next Obligation. intros. by apply rwp_store. Qed.
25 |
--------------------------------------------------------------------------------
/theories/caliper/seq_weakestpre.v:
--------------------------------------------------------------------------------
1 | From iris.proofmode Require Import base proofmode.
2 | From iris.base_logic.lib Require Export na_invariants.
3 | From clutch.caliper Require Export weakestpre.
4 |
5 |
6 | Class seqG (Σ: gFunctors) := {
7 | seqG_na_invG :: na_invG Σ;
8 | seqG_name: gname;
9 | }.
10 |
11 | Definition seq `{!spec_updateGS δ Σ, !caliperWpG δ Λ Σ} `{!seqG Σ} E (e : expr Λ) (Φ : val Λ → iProp Σ) : iProp Σ :=
12 | (na_own seqG_name E -∗ WP e {{ v, na_own seqG_name E ∗ Φ v }})%I.
13 |
14 | Definition seq_inv `{!invGS_gen HasNoLc Σ} `{!seqG Σ} (N : namespace) (P : iProp Σ) := na_inv seqG_name N P.
15 |
16 | Notation "'SEQ' e @ E {{ Φ } }" := (seq E e%E Φ)
17 | (at level 20, e, Φ at level 200, only parsing) : bi_scope.
18 | Notation "'SEQ' e @ E {{ Φ } }" := (seq E e%E Φ)
19 | (at level 20, e, Φ at level 200, only parsing) : bi_scope.
20 | Notation "'SEQ' e {{ Φ } }" := (seq ⊤ e%E Φ)
21 | (at level 20, e, Φ at level 200, only parsing) : bi_scope.
22 |
23 | Notation "'SEQ' e @ E {{ v , Q } }" := (seq E e%E (λ v, Q))
24 | (at level 20, e, Q at level 200,
25 | format "'[hv' 'SEQ' e '/' @ '[' '/' E ']' '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope.
26 | Notation "'SEQ' e {{ v , Q } }" := (seq ⊤ e%E (λ v, Q))
27 | (at level 20, e, Q at level 200,
28 | format "'[hv' 'SEQ' e '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope.
29 |
30 | Lemma seq_value `{!spec_updateGS δ Σ, !caliperWpG δ Λ Σ} `{!seqG Σ} Φ E (v : val Λ) e `{!IntoVal e v} :
31 | Φ v ⊢ SEQ e @ E {{ v, Φ v }}.
32 | Proof. iIntros "Hv Hna". iApply rwp_value. iFrame. Qed.
33 |
34 |
--------------------------------------------------------------------------------
/theories/clutch.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import namespaces.
2 | From clutch.prob_lang Require Export lang notation tactics.
3 | From iris.proofmode Require Export proofmode.
4 | From clutch.prob_lang.spec Require Export spec_tactics spec_rules.
5 | From clutch.clutch Require Export
6 | primitive_laws derived_laws proofmode
7 | coupling_rules model compatibility rel_rules rel_tactics reltac2 interp soundness.
8 |
--------------------------------------------------------------------------------
/theories/clutch/adequacy_rel.v:
--------------------------------------------------------------------------------
1 | From iris.proofmode Require Import proofmode.
2 | From iris.base_logic.lib Require Import na_invariants.
3 | From clutch.clutch Require Import weakestpre model primitive_laws adequacy.
4 | From clutch.prob_lang Require Import lang.
5 |
6 | Class clutchRGpreS Σ := ClutchRGPreS {
7 | clutchRGpreS_clutch :: clutchGpreS Σ;
8 | prelorelGpreS_na_inv :: na_invG Σ;
9 | }.
10 |
11 | Definition clutchRΣ : gFunctors := #[clutchΣ; na_invΣ].
12 | Global Instance subG_clutchRGPreS {Σ} : subG clutchRΣ Σ → clutchRGpreS Σ.
13 | Proof. solve_inG. Qed.
14 |
15 | Theorem refines_coupling Σ `{clutchRGpreS Σ}
16 | (A : ∀ `{clutchRGS Σ}, lrel Σ) (φ : val → val → Prop) e e' σ σ' n :
17 | (∀ `{clutchRGS Σ}, ∀ v v', A v v' -∗ ⌜φ v v'⌝) →
18 | (∀ `{clutchRGS Σ}, ⊢ REL e << e' : A) →
19 | refRcoupl (exec n (e, σ)) (lim_exec (e', σ')) φ.
20 | Proof.
21 | intros HA Hlog.
22 | apply (wp_refRcoupl Σ); auto.
23 | intros ?.
24 | iIntros "He'".
25 | iMod na_alloc as "[%γ Htok]".
26 | set (HclutchR := ClutchRGS Σ _ _ γ).
27 | iPoseProof (Hlog _) as "Hlog".
28 | rewrite refines_eq /refines_def.
29 | iSpecialize ("Hlog" $! [] with "He' Htok").
30 | iApply (wp_mono with "Hlog").
31 | iIntros (?) "H /=".
32 | iDestruct "H" as (?) "(? & ? & ?) /=".
33 | iExists _. iFrame. by iApply HA.
34 | Qed.
35 |
--------------------------------------------------------------------------------
/theories/clutch/ectx_lifting.v:
--------------------------------------------------------------------------------
1 | (** Some derived lemmas for ectx-based languages *)
2 | From iris.proofmode Require Import proofmode.
3 | From clutch.common Require Import ectx_language.
4 | From clutch.clutch Require Import weakestpre lifting.
5 | From iris.prelude Require Import options.
6 |
7 | Local Open Scope R.
8 |
9 | Section wp.
10 | Context {Λ : ectxLanguage} `{!spec_updateGS (lang_markov Λ) Σ, !clutchWpGS Λ Σ} {Hinh : Inhabited (state Λ)}.
11 | Implicit Types P : iProp Σ.
12 | Implicit Types Φ : val Λ → iProp Σ.
13 | Implicit Types v : val Λ.
14 | Implicit Types e : expr Λ.
15 | Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
16 | Local Hint Resolve head_stuck_stuck : core.
17 |
18 | Lemma wp_lift_head_step_prog_couple {E Φ} e1 s :
19 | to_val e1 = None →
20 | (∀ σ1 e1' σ1',
21 | state_interp σ1 ∗ spec_interp (e1', σ1') ={E,∅}=∗
22 | ⌜head_reducible e1 σ1⌝ ∗
23 | prog_coupl e1 σ1 e1' σ1' (λ e2 σ2 e2' σ2',
24 | ▷ |={∅,E}=> state_interp σ2 ∗ spec_interp (e2', σ2') ∗ WP e2 @ s; E {{ Φ }}))
25 | ⊢ WP e1 @ s; E {{ Φ }}.
26 | Proof.
27 | iIntros (?) "H". iApply wp_lift_step_prog_couple; [done|].
28 | iIntros (σ1 e1' σ1') "Hσ".
29 | by iMod ("H" with "Hσ") as "[% H]".
30 | Qed.
31 |
32 | Lemma wp_lift_head_step {E Φ} e1 s :
33 | to_val e1 = None →
34 | (∀ σ1, state_interp σ1 ={E,∅}=∗
35 | ⌜head_reducible e1 σ1⌝ ∗
36 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={∅,E}=∗
37 | state_interp σ2 ∗ WP e2 @ s; E {{ Φ }})
38 | ⊢ WP e1 @ s; E {{ Φ }}.
39 | Proof.
40 | iIntros (?) "H". iApply wp_lift_step_later; [done|]. iIntros (?) "Hσ".
41 | iMod ("H" with "Hσ") as "[% H]"; iModIntro.
42 | iSplit.
43 | { iPureIntro. by apply head_prim_reducible. }
44 | iIntros (???) "!> !>". iApply "H"; auto.
45 | Qed.
46 |
47 | Lemma wp_lift_atomic_head_step_fupd {E1 E2 Φ} e1 s :
48 | to_val e1 = None →
49 | (∀ σ1, state_interp σ1 ={E1}=∗
50 | ⌜head_reducible e1 σ1⌝ ∗
51 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E1}[E2]▷=∗
52 | state_interp σ2 ∗
53 | from_option Φ False (to_val e2))
54 | ⊢ WP e1 @ s; E1 {{ Φ }}.
55 | Proof.
56 | iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
57 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
58 | iSplit.
59 | { iPureIntro. by apply head_prim_reducible. }
60 | iIntros (e2 σ2 Hstep).
61 | iApply "H"; eauto.
62 | Qed.
63 |
64 | Lemma wp_lift_atomic_head_step {E Φ} e1 s :
65 | to_val e1 = None →
66 | (∀ σ1, state_interp σ1 ={E}=∗
67 | ⌜head_reducible e1 σ1⌝ ∗
68 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E}=∗
69 | state_interp σ2 ∗
70 | from_option Φ False (to_val e2))
71 | ⊢ WP e1 @ s; E {{ Φ }}.
72 | Proof.
73 | iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
74 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
75 | iSplit.
76 | { iPureIntro. by apply head_prim_reducible. }
77 | iNext. iIntros (e2 σ2 Hstep).
78 | iApply "H"; eauto.
79 | Qed.
80 |
81 | Lemma wp_lift_pure_det_head_step {E E' Φ} e1 e2 s :
82 | to_val e1 = None →
83 | (∀ σ1, head_reducible e1 σ1) →
84 | (∀ σ1 e2' σ2,
85 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
86 | (|={E}[E']▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
87 | Proof using Hinh.
88 | intros. erewrite !(wp_lift_pure_det_step e1 e2); eauto.
89 | Qed.
90 |
91 | Lemma wp_lift_pure_det_head_step' {E Φ} e1 e2 s :
92 | to_val e1 = None →
93 | (∀ σ1, head_reducible e1 σ1) →
94 | (∀ σ1 e2' σ2,
95 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
96 | ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
97 | Proof using Hinh.
98 | intros. rewrite -[(WP e1 @ _ ; _ {{ _ }})%I]wp_lift_pure_det_head_step //.
99 | rewrite -step_fupd_intro //.
100 | Qed.
101 | End wp.
102 |
--------------------------------------------------------------------------------
/theories/clutch/examples/awkward_probabilistic.ml:
--------------------------------------------------------------------------------
1 | (* Companion file to [awkward_probabilistic.v]. We construct a context that
2 | compares the functions considered in the lemma `refinement_prob_resample`.
3 | Load this file in OCaml, and run `test rhs_id` or `test rhs_xor`. *)
4 |
5 | let () = Random.init 0
6 | let flip = Random.bool
7 | let xor x y = if x then not y else y
8 |
9 | let lhs h = h () ; flip ()
10 |
11 | let rhs_template k =
12 | let x = ref true in
13 | fun f -> let b = flip () in
14 | x := b ;
15 | f () ;
16 | k !x
17 |
18 | let rhs_id = rhs_template (fun x -> x)
19 | let rhs_xor = rhs_template (fun x -> xor (flip ()) x)
20 |
21 | (* Call `lhs_or_rhs` with a thunk `f_obs` that records and reveals the result
22 | of running `f` as `obs`, then compare the result of `lhs_or_rhs` to `obs`.
23 | For `rhs_id`, `!obs` will always equal `v`, while for `rhs_xor` and for
24 | `lhs`, `!obs` and `v` are independently sampled. *)
25 | let ctx_template lhs_or_rhs f =
26 | let obs = ref false in
27 | let f_obs () =
28 | let res = f (fun x -> x) in
29 | obs := res in
30 | let v = lhs_or_rhs f_obs in
31 | v = !obs
32 |
33 | let ctx f = ctx_template f f
34 |
35 | let n = ref 10_000
36 | (* Print the distribution of observing f for n times. *)
37 | let observe f =
38 | let c = ref 0 in
39 | for x = 1 to !n do if f () then incr c done ;
40 | let t = (100 * !c / !n) in
41 | Printf.printf "true : %d%% \tfalse : %d%%\n" t (100 - t)
42 |
43 | (* Compare rhs (should be rhs_id or rhs_xor) and lhs using ctx. *)
44 | let test rhs =
45 | print_endline "testing rhs:" ;
46 | observe (fun () -> ctx rhs) ;
47 | print_endline "testing lhs:" ;
48 | observe (fun () -> ctx lhs) ;
49 |
--------------------------------------------------------------------------------
/theories/clutch/examples/crypto/ElGamal_closed_ctx.v:
--------------------------------------------------------------------------------
1 | From clutch Require Import clutch.
2 | From clutch.clutch.examples.crypto Require Import ElGamal.
3 | From clutch.clutch.examples.crypto Require valgroup_Zp valgroup_Zpx.
4 |
5 | #[local] Definition rfc3526_id18 : N :=
6 | 0xFFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F24117C4B1FE649286651ECE45B3DC2007CB8A163BF0598DA48361C55D39A69163FA8FD24CF5F83655D23DCA3AD961C62F356208552BB9ED529077096966D670C354E4ABC9804F1746C08CA18217C32905E462E36CE3BE39E772C180E86039B2783A2EC07A28FB5C55DF06F4C52C9DE2BCBF6955817183995497CEA956AE515D2261898FA051015728E5A8AAAC42DAD33170D04507A33A85521ABDF1CBA64ECFB850458DBEF0A8AEA71575D060C7DB3970F85A6E1E4C7ABF5AE8CDB0933D71E8C94E04A25619DCEE3D2261AD2EE6BF12FFA06D98A0864D87602733EC86A64521F2B18177B200CBBE117577A615D6C770988C0BAD946E208E24FA074E5AB3143DB5BFCE0FD108E4B82D120A92108011A723C12A787E6D788719A10BDBA5B2699C327186AF4E23C1A946834B6150BDA2583E9CA2AD44CE8DBBBC2DB04DE8EF92E8EFC141FBECAA6287C59474E6BC05D99B2964FA090C3A2233BA186515BE7ED1F612970CEE2D7AFB81BDD762170481CD0069127D5B05AA993B4EA988D8FDDC186FFB7DC90A6C08F4DF435C93402849236C3FAB4D27C7026C1D4DCB2602646DEC9751E763DBA37BDF8FF9406AD9E530EE5DB382F413001AEB06A53ED9027D831179727B0865A8918DA3EDBEBCF9B14ED44CE6CBACED4BB1BDB7F1447E6CC254B332051512BD7AF426FB8F401378CD2BF5983CA01C64B92ECF032EA15D1721D03F482D7CE6E74FEF6D55E702F46980C82B5A84031900B1C9E59E7C97FBEC7E8F323A97A7E36CC88BE0F1D45B7FF585AC54BD407B22B4154AACC8F6D7EBF48E1D814CC5ED20F8037E0A79715EEF29BE32806A1D58BB7C5DA76F550AA3D8A1FBFF0EB19CCB1A313D55CDA56C9EC2EF29632387FE8D76E3C0468043E8F663F4860EE12BF2D5B0B7474D6E694F91E6DBE115974A3926F12FEE5E438777CB6A932DF8CD8BEC4D073B931BA3BC832B68D9DD300741FA7BF8AFC47ED2576F6936BA424663AAB639C5AE4F5683423B4742BF1C978238F16CBE39D652DE3FDB8BEFC848AD922222E04A4037C0713EB57A81A23F0C73473FC646CEA306B4BCBC8862F8385DDFA9D4B7FA2C087E879683303ED5BDD3A062B3CF5B3A278A66D2A13F83F44F82DDF310EE074AB6A364597E899A0255DC164F31CC50846851DF9AB48195DED7EA1B1D510BD7EE74D73FAF36BC31ECFA268359046F4EB879F924009438B481C6CD7889A002ED5EE382BC9190DA6FC026E479558E4475677E9AA9E3050E2765694DFC81F56E880B96E7160C980DD98EDD3DFFFFFFFFFFFFFFFFF.
7 |
8 | #[local] Definition p''' := (N.to_nat rfc3526_id18 - 3).
9 | #[local] Definition p := S (S (S p''')).
10 |
11 | Fact addSC p m : p = m+3 -> S (S (S (p - 3))) = p.
12 | Proof. intros ->. rewrite Nat.add_sub Nat.add_comm //. Qed.
13 | Fact p_eq_rfc3526_id18 : p = N.to_nat rfc3526_id18.
14 | unfold p, p'''.
15 | eapply (addSC _ (N.to_nat (rfc3526_id18 - 3))%N).
16 | replace 3%nat with (N.to_nat 3%N) ; [|auto].
17 | rewrite -N2Nat.inj_add.
18 | rewrite N.sub_add //.
19 | Qed.
20 |
21 | Section additive.
22 | Import valgroup_Zp.
23 | Definition EG_p := pk_ots_rnd_ddh (G:=@cg_p (N.to_nat rfc3526_id18)) (cgg:=cgg_p (N.to_nat rfc3526_id18)).
24 | End additive.
25 |
26 | Section multiplicative.
27 | Import valgroup_Zpx.
28 |
29 | Context `{rfc3526_id18_prime : is_true (prime.prime (N.to_nat rfc3526_id18))}.
30 |
31 | Fact p_prime : is_true (prime.prime p).
32 | Proof using rfc3526_id18_prime. by rewrite p_eq_rfc3526_id18. Qed.
33 |
34 | Definition EG_px := Eval hnf in pk_ots_rnd_ddh (G:=@cg_p _ p_prime) (cgg:=@cgg_p _ p_prime).
35 |
36 | Definition EG_DH := @ElGamal_DH_secure (vg_p _) (cgs_p _) _ (@cgg_p _ p_prime) (@cg_p _ p_prime).
37 |
38 | (* Set Printing Implicit.
39 | Check EG_DH. *)
40 |
41 | End multiplicative.
42 |
43 |
44 | (* Print Assumptions EG_DH. *)
45 |
--------------------------------------------------------------------------------
/theories/clutch/examples/erasure.v:
--------------------------------------------------------------------------------
1 | From clutch Require Export clutch.
2 | Set Default Proof Using "Type*".
3 |
4 | Lemma rand_erasure_l (x : string) (N : nat) :
5 | {[x := TTape]} ⊨ rand(x) #N ≤ctx≤ rand #N : TNat.
6 | Proof.
7 | eapply (refines_sound_open clutchRΣ).
8 | iIntros (??).
9 | rewrite /bin_log_related.
10 | iIntros (vs) "H /=".
11 | rewrite (env_ltyped2_lookup _ _ x) //; last first.
12 | { rewrite fmap_insert lookup_insert //. }
13 | iDestruct "H" as (v1 v2 ?) "#H"; simplify_map_eq.
14 | rewrite /lrel_car/=.
15 | iDestruct "H" as (α1 α2 M -> ->) "Hinv".
16 | destruct (decide (N = M)); simplify_eq.
17 | - (* We unpack the definition of [REL] because the tapes are owned by the
18 | invariant—the rules of [REL] do not support nice high-level invariant
19 | access patterns as of now. *)
20 | iApply (refines_atomic_l _ _ []).
21 | iIntros (?) "Hr !>".
22 | iInv (logN.@(α1, α2)) as "[>Hα1 >Hα2]".
23 | iApply (wp_couple_rand_lbl_rand_eq with "[$Hα1 $Hr]").
24 | iIntros "!>" (n) "[Hα Hr]".
25 | iModIntro. iFrame. rel_values.
26 | - iApply (refines_atomic_l _ _ []).
27 | iIntros (?) "Hr !>".
28 | iInv (logN.@(α1, α2)) as "[>Hα1 >Hα2]".
29 | iApply (wp_couple_rand_lbl_rand_wrong with "[$Hα1 $Hr]"); [done|].
30 | iIntros "!>" (m) "[Hα1 Hr] !>".
31 | iFrame. rel_values.
32 | Qed.
33 |
34 | Lemma rand_erasure_r (x : string) (N : nat) :
35 | {[x := TTape]} ⊨ rand #N ≤ctx≤ rand(x) #N : TNat.
36 | Proof.
37 | eapply (refines_sound_open clutchRΣ).
38 | iIntros (??).
39 | rewrite /bin_log_related.
40 | iIntros (vs) "H /=".
41 | rewrite (env_ltyped2_lookup _ _ x) //; last first.
42 | { rewrite fmap_insert lookup_insert //. }
43 | iDestruct "H" as (v1 v2 ?) "H"; simplify_map_eq.
44 | rewrite /lrel_car/=.
45 | iDestruct "H" as (α1 α2 M -> ->) "Hinv".
46 | destruct (decide (N = M)); simplify_eq.
47 | - iApply (refines_atomic_l _ _ []).
48 | iIntros (?) "Hr !>".
49 | iInv (logN.@(α1, α2)) as "[>Hα1 >Hα2]".
50 | iApply (wp_couple_rand_rand_lbl_eq with "[$Hα2 $Hr]").
51 | iIntros "!>" (b) "[Hα2 Hr]".
52 | iModIntro. iFrame. rel_values.
53 | - iApply (refines_atomic_l _ _ []).
54 | iIntros (?) "Hr !>".
55 | iInv (logN.@(α1, α2)) as "[>Hα1 >Hα2]".
56 | iApply (wp_couple_rand_rand_lbl_wrong with "[$Hα2 $Hr]"); [done|].
57 | iIntros "!>" (m) "[Hα2 Hr] !>".
58 | iFrame. rel_values.
59 | Qed.
60 |
61 | Lemma rand_erasure_ctx (x : string) (N : nat) :
62 | {[ x := TTape ]} ⊨ rand(x) #N =ctx= rand #N : TNat.
63 | Proof.
64 | split.
65 | - apply rand_erasure_l.
66 | - apply rand_erasure_r.
67 | Qed.
68 |
--------------------------------------------------------------------------------
/theories/clutch/examples/geometric.v:
--------------------------------------------------------------------------------
1 | (* Small demo that Clutch can prove equivalence of recursively defined procedures. *)
2 |
3 | From clutch Require Export clutch clutch.lib.flip.
4 | Set Default Proof Using "Type*".
5 |
6 | Definition geo_true : val := rec: "f" "n" := if: flip then "n" else "f" ("n" + #1).
7 | Definition geo_false : val := rec: "f" "n" := if: flip then "f" ("n" + #1) else "n".
8 |
9 | Section logical_ref.
10 | Context `{!clutchRGS Σ}.
11 |
12 | Lemma true_false :
13 | ⊢ REL geo_true << geo_false : lrel_int → lrel_int.
14 | Proof with rel_pures_l ; rel_pures_r.
15 | auto...
16 | iLöb as "HH".
17 | rewrite /geo_true /geo_false.
18 | rel_arrow_val.
19 | iIntros (??) "[%n [-> ->]]"...
20 | rel_apply (refines_couple_flip_flip negb) => /=.
21 | iIntros "!>" ([]).
22 | - auto... rel_values.
23 | - rel_pure_r. rel_pure_l.
24 | fold geo_true. fold geo_false.
25 | rel_apply refines_app.
26 | + iAssumption.
27 | + auto... rel_values.
28 | Qed.
29 |
30 | Lemma false_true :
31 | ⊢ REL geo_false << geo_true : lrel_int → lrel_int.
32 | Proof with rel_pures_l ; rel_pures_r.
33 | auto...
34 | iLöb as "HH".
35 | rewrite /geo_true /geo_false.
36 | rel_arrow_val.
37 | iIntros (??) "[%n [-> ->]]"...
38 | rel_apply (refines_couple_flip_flip negb) => /=.
39 | iIntros "!>" ([]).
40 | - rel_pure_r. rel_pure_l.
41 | fold geo_true. fold geo_false.
42 | rel_apply refines_app.
43 | + iAssumption.
44 | + auto... rel_values.
45 | - auto... rel_values.
46 | Qed.
47 | End logical_ref.
48 |
--------------------------------------------------------------------------------
/theories/clutch/examples/id_rec.v:
--------------------------------------------------------------------------------
1 | From clutch Require Export clutch clutch.lib.flip.
2 | Set Default Proof Using "Type*".
3 |
4 | Section proofs.
5 | Context `{!clutchRGS Σ}.
6 |
7 | Definition idrecN := nroot.@"idrec".
8 |
9 | (* Warmup: λx.x refines the function that recurses once before returning its
10 | argument. Nothing probabilistic, just recursion and state. *)
11 | Lemma id_rec_det : ⊢ REL
12 | (λ: "x", "x")
13 | <<
14 | (let: "c" := ref #0 in
15 | (rec: "f" "x" := if: !"c" = #1 then "x" else "c" <- #1 ;; "f" "x"))
16 | : (lrel_bool → lrel_bool).
17 | Proof with try rel_pures_l ; try rel_pures_r.
18 | rel_alloc_r c as "c"...
19 | set (P := (REL (λ: "x", "x")%V
20 | <<
21 | (rec: "f" "x" := if: ! #c = #1 then "x" else #c <- #1;; "f" "x")%V :
22 | lrel_bool → lrel_bool)).
23 | iApply (refines_na_alloc (c ↦ₛ #0 ∨ ((c ↦ₛ #1) ∗ P)) idrecN).
24 | iSplitL ; iFrame.
25 | iIntros "#Hinv".
26 | iApply refines_arrow_val.
27 | iIntros "!#" (??) "#(%b&->&->)".
28 | iRevert (b).
29 | iLöb as "HH".
30 | iIntros (b).
31 | rel_rec_r.
32 | iApply (refines_na_inv with "[$Hinv]") ; [done|].
33 | iIntros "[HHH Hclose]".
34 | rel_pure_l.
35 | iDestruct "HHH" as "[c0 | c1]".
36 | - (* First call: Set the counter and unfold the rec. def. once more. *)
37 | rel_load_r. subst. rel_pures_r. rel_store_r. do 2 rel_pure_r.
38 | rel_pures_r. rel_load_r...
39 | iApply (refines_na_close with "[- $Hclose]") ; iSplitL.
40 | {
41 | iNext. iRight. iSplitL ; iFrame.
42 | unfold P.
43 | iApply refines_arrow_val.
44 | iIntros "!#" (??) "#(%b'&->&->)".
45 | iApply "HH".
46 | }
47 | rel_values.
48 | - (* Not first call: Actually act like the identity. *)
49 | subst...
50 | iDestruct "c1" as "(c1 & p)".
51 | rel_load_r...
52 | iApply (refines_na_close with "[- $Hclose]") ;
53 | iSplitL. { iRight. iFrame. }
54 | rel_values.
55 | Qed.
56 |
57 | Lemma rec_id :
58 | ⊢ REL
59 | let: "α" := allocB in
60 | (rec: "f" "x" := if: flipL "α" then "x" else "f" "x")
61 | <<
62 | (λ: "x", "x")
63 | : (lrel_bool → lrel_bool).
64 | Proof with try rel_pures_l ; try rel_pures_r.
65 | rel_alloctape_l α as "α"...
66 | iApply (refines_na_alloc (α ↪B []) idrecN) ; iFrame.
67 | iIntros "#Hinv".
68 | iApply refines_arrow_val.
69 | iIntros "!#" (??) "#(%b&->&->)".
70 | iLöb as "HH".
71 | rel_rec_l.
72 | iApply (refines_na_inv with "[$Hinv]") ; [done|].
73 | iIntros "[> α Hclose]".
74 | rel_apply_l refines_flipL_empty_l ; iFrame.
75 | iIntros ([]) "α".
76 | 1: iApply (refines_na_close with "[- $Hclose]") ; iFrame... 1: rel_values.
77 | rel_pure_l.
78 | iApply (refines_na_close with "[- $Hclose]") ; iFrame.
79 | iApply "HH".
80 | Qed.
81 |
82 | Lemma id_rec :
83 | ⊢ REL
84 | (λ: "x", "x")
85 | <<
86 | (let: "c" := ref #0 in
87 | (rec: "f" "x" := if: !"c" = #1 then "x" else "c" <- #1 ;; "f" "x"))
88 | : (lrel_bool → lrel_bool).
89 | Proof with try rel_pures_l ; try rel_pures_r.
90 | rel_alloc_r c as "c"...
91 | iApply (refines_na_alloc (∃ n, c ↦ₛ #n ∗ ⌜(n = 0 ∨ n = 1)⌝) idrecN).
92 | iSplitL ; [iExists _ ; iFrame ; eauto|].
93 | iIntros "#Hinv".
94 | iApply refines_arrow_val.
95 | iIntros "!#" (??) "#(%b&->&->)".
96 | iLöb as "HH".
97 | rel_rec_r.
98 | iApply (refines_na_inv with "[$Hinv]") ; [done|].
99 | iIntros "[>[%b' [c %hb']] Hclose]".
100 | rel_load_r.
101 | destruct hb'.
102 | - subst. rel_pures_r. rel_store_r. do 2 rel_pure_r.
103 | iApply (refines_na_close with "[- $Hclose]") ;
104 | iSplitL ; [iExists _ ; iFrame ; eauto|].
105 | rel_pure_l.
106 | (* Not clear how to proceed, so we *)
107 | give_up.
108 | - subst... iApply (refines_na_close with "[- $Hclose]") ;
109 | iSplitL ; [iExists _ ; iFrame ; eauto|].
110 | rel_values.
111 | Abort.
112 |
113 | End proofs.
114 |
--------------------------------------------------------------------------------
/theories/clutch/lib/conversion.v:
--------------------------------------------------------------------------------
1 | From clutch Require Import clutch.
2 |
3 | Definition bool_to_int : val :=
4 | λ: "b",
5 | if: "b" = #false then
6 | #0
7 | else #1.
8 |
9 | Definition int_to_bool : val :=
10 | λ: "z",
11 | if: "z" = #0 then #false
12 | else #true.
13 |
14 | Section specs.
15 | Context `{!clutchRGS Σ}.
16 |
17 | Lemma wp_bool_to_int (b: bool) E :
18 | {{{ True }}}
19 | bool_to_int #b @ E
20 | {{{ RET #(Z.b2z b); True%I}}}.
21 | Proof.
22 | iIntros (Φ) "_ HΦ".
23 | rewrite /bool_to_int.
24 | wp_pures. destruct b; case_bool_decide as Heq; try congruence; wp_pures; by iApply "HΦ".
25 | Qed.
26 |
27 | Lemma spec_bool_to_int E K (b : bool) :
28 | ⤇ fill K (bool_to_int #b) -∗ spec_update E (⤇ fill K (of_val #(Z.b2z b))).
29 | Proof.
30 | rewrite /bool_to_int.
31 | iIntros "HK".
32 | tp_pures; [solve_vals_compare_safe|].
33 | destruct b; case_bool_decide as Heq; try congruence; tp_pures; by iModIntro.
34 | Qed.
35 |
36 | Lemma wp_int_to_bool (z : Z) E :
37 | {{{ True }}}
38 | int_to_bool #z @ E
39 | {{{ RET #(Z_to_bool z); True%I}}}.
40 | Proof.
41 | iIntros (Φ) "_ HΦ".
42 | rewrite /int_to_bool.
43 | wp_pures.
44 | case_bool_decide as Heq; simplify_eq; wp_pures.
45 | - by iApply "HΦ".
46 | - rewrite Z_to_bool_neq_0; [|by intros ->].
47 | by iApply "HΦ".
48 | Qed.
49 |
50 | Lemma spec_int_to_bool E K (z : Z) :
51 | ⤇ fill K (int_to_bool #z) -∗ spec_update E (⤇ fill K (of_val #(Z_to_bool z))).
52 | Proof.
53 | rewrite /int_to_bool.
54 | iIntros "HK".
55 | tp_pures; [solve_vals_compare_safe|].
56 | case_bool_decide as Heq; simplify_eq; tp_pures.
57 | - by iModIntro.
58 | - iModIntro. by rewrite Z_to_bool_neq_0; [|by intros ->].
59 | Qed.
60 |
61 | End specs.
62 |
--------------------------------------------------------------------------------
/theories/clutch/proofmode.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation class_instances tactics.
2 | From clutch.prob_lang Require Export wp_tactics.
3 | From clutch.clutch Require Import primitive_laws derived_laws.
4 | From iris.prelude Require Import options.
5 |
6 | #[global] Program Instance rel_logic_wptactics_base `{!clutchGS Σ} : GwpTacticsBase Σ unit wp.
7 | Next Obligation. intros. by apply wp_value. Qed.
8 | Next Obligation. intros. by apply wp_fupd. Qed.
9 |
10 | #[global] Program Instance rel_logic_wptactics_bind `{!clutchGS Σ} : GwpTacticsBind Σ unit wp.
11 | Next Obligation. intros. by apply wp_bind. Qed.
12 |
13 | #[global] Program Instance rel_logic_wptactics_pure `{!clutchGS Σ} : GwpTacticsPure Σ unit true wp.
14 | Next Obligation. intros. by eapply lifting.wp_pure_step_later. Qed.
15 |
16 | #[global] Program Instance rel_logic_wptactics_heap `{!clutchGS Σ} : GwpTacticsHeap Σ unit true wp :=
17 | Build_GwpTacticsHeap _ _ _ _ (λ l q v, (l ↦{q} v)%I) (λ l q vs, (l ↦∗{q} vs)%I) _ _ _ _.
18 | Next Obligation. intros. by apply wp_alloc. Qed.
19 | Next Obligation. intros. by apply wp_allocN. Qed.
20 | Next Obligation. intros. by apply wp_load. Qed.
21 | Next Obligation. intros. by apply wp_store. Qed.
22 |
--------------------------------------------------------------------------------
/theories/clutch/soundness.v:
--------------------------------------------------------------------------------
1 | (** Logical relation is sound w.r.t. the contextual refinement. *)
2 | From Coq Require Export Reals.
3 | From iris.proofmode Require Import proofmode.
4 | From clutch.prob_lang Require Import notation metatheory lang.
5 | From clutch.clutch Require Export primitive_laws model adequacy_rel interp fundamental.
6 | From clutch.prob_lang.typing Require Export contextual_refinement.
7 |
8 | Lemma refines_sound_open Σ `{!clutchRGpreS Σ} Γ e e' τ :
9 | (∀ `{clutchRGS Σ} Δ, ⊢ 〈⊤;Δ;Γ〉 ⊨ e ≤log≤ e' : τ) →
10 | Γ ⊨ e ≤ctx≤ e' : τ.
11 | Proof.
12 | intros Hlog K σ₀ b Htyped.
13 | cut (∀ n, ((exec n (fill_ctx K e, σ₀)) (LitV (LitBool b)) <=
14 | (lim_exec (fill_ctx K e', σ₀)) (LitV (LitBool b)))%R).
15 | { intros Hn. by eapply lim_exec_leq. }
16 | intros n.
17 | eapply refRcoupl_eq_elim.
18 | eapply (refines_coupling Σ (λ _, lrel_bool)); auto; last first.
19 | - iIntros (?).
20 | iPoseProof (bin_log_related_under_typed_ctx with "[]") as "H"; [done| |].
21 | { iIntros "!>" (?). iApply Hlog. }
22 | iSpecialize ("H" $! [] ∅ with "[]").
23 | { rewrite fmap_empty. iApply env_ltyped2_empty. }
24 | rewrite /interp 2!fmap_empty 2!subst_map_empty /=.
25 | done.
26 | - by iIntros (???) "[%b' [-> ->]]".
27 | Qed.
28 |
29 | Lemma refines_sound Σ `{Hpre : !clutchRGpreS Σ} (e e': expr) τ :
30 | (∀ `{clutchRGS Σ} Δ, ⊢ REL e << e' : (interp τ Δ)) →
31 | ∅ ⊨ e ≤ctx≤ e' : τ.
32 | Proof.
33 | intros Hlog. eapply (refines_sound_open Σ).
34 | iIntros (? Δ vs).
35 | rewrite fmap_empty env_ltyped2_empty_inv.
36 | iIntros (->).
37 | rewrite !fmap_empty !subst_map_empty.
38 | iApply Hlog.
39 | Qed.
40 |
--------------------------------------------------------------------------------
/theories/common/con_inject.v:
--------------------------------------------------------------------------------
1 | From clutch.con_prob_lang Require Import lang notation.
2 | From clutch.prelude Require Import base.
3 | Set Default Proof Using "Type*".
4 |
5 | Section inject.
6 | Class Inject (A B : Type) := {
7 | inject : A → B;
8 | inject_inj : Inj (=) (=) inject;
9 | }.
10 |
11 | Notation "$ x" := (inject x) (at level 8).
12 | #[global] Existing Instance inject_inj.
13 |
14 | #[global] Program Instance Inject_option `{!Inject T val} : Inject (option T) val :=
15 | {| inject := λ o, if o is Some t then SOMEV $t else NONEV |}.
16 | Next Obligation. auto. Qed.
17 | Next Obligation.
18 | intros ? [] [] [] [=]; [|done]. f_equal. by eapply (inj _).
19 | Qed.
20 |
21 | #[global] Program Instance Inject_prod `{!Inject A val, !Inject B val} :
22 | Inject (A * B) val := {| inject := (λ '(t1, t2), PairV $t1 $t2) |}.
23 | Next Obligation. intros ? [] ? [] [] [] [=]. f_equal; by apply (inj _). Qed.
24 |
25 | #[global] Program Instance Inject_sum `{!Inject A val, !Inject B val} : Inject (A + B) val
26 | := {| inject := λ s, match s with
27 | | inl v => InjLV $v
28 | | inr v => InjRV $v
29 | end |}.
30 | Next Obligation. by intros ? [] ? [] [] [] [= ->%(inj _)]. Qed.
31 |
32 | #[global] Program Instance : Inject Z val := {| inject := LitV ∘ LitInt |}.
33 | Next Obligation. by intros ?? [=]. Qed.
34 |
35 | #[global] Program Instance : Inject nat val := {| inject := inject ∘ Z.of_nat |}.
36 |
37 | #[global] Program Instance : Inject bool val := {| inject := LitV ∘ LitBool |}.
38 | Next Obligation. by intros ?? [=]. Qed.
39 |
40 | #[global] Program Instance : Inject unit val := {| inject := λ _, #() |}.
41 | Next Obligation. by intros [] []. Qed.
42 |
43 | #[global] Program Instance : Inject loc val := {| inject := LitV ∘ LitLoc |}.
44 | Next Obligation. by intros ?? [=]. Qed.
45 |
46 | #[global] Program Instance Inject_expr `{!Inject A val} : Inject A expr :=
47 | {| inject := Val ∘ inject |}.
48 |
49 | #[global] Program Instance : Inject val val := {| inject := λ v, v |}.
50 | End inject.
51 |
--------------------------------------------------------------------------------
/theories/common/inject.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation.
2 | From clutch.prelude Require Import base.
3 | Set Default Proof Using "Type*".
4 |
5 | Section inject.
6 | Class Inject (A B : Type) := {
7 | inject : A → B;
8 | inject_inj : Inj (=) (=) inject;
9 | }.
10 |
11 | Notation "$ x" := (inject x) (at level 8).
12 | #[global] Existing Instance inject_inj.
13 |
14 | #[global] Program Instance Inject_option `{!Inject T val} : Inject (option T) val :=
15 | {| inject := λ o, if o is Some t then SOMEV $t else NONEV |}.
16 | Next Obligation. auto. Qed.
17 | Next Obligation.
18 | intros ? [] [] [] [=]; [|done]. f_equal. by eapply (inj _).
19 | Qed.
20 |
21 | #[global] Program Instance Inject_prod `{!Inject A val, !Inject B val} :
22 | Inject (A * B) val := {| inject := (λ '(t1, t2), PairV $t1 $t2) |}.
23 | Next Obligation. intros ? [] ? [] [] [] [=]. f_equal; by apply (inj _). Qed.
24 |
25 | #[global] Program Instance Inject_sum `{!Inject A val, !Inject B val} : Inject (A + B) val
26 | := {| inject := λ s, match s with
27 | | inl v => InjLV $v
28 | | inr v => InjRV $v
29 | end |}.
30 | Next Obligation. by intros ? [] ? [] [] [] [= ->%(inj _)]. Qed.
31 |
32 | #[global] Program Instance : Inject Z val := {| inject := LitV ∘ LitInt |}.
33 | Next Obligation. by intros ?? [=]. Qed.
34 |
35 | #[global] Program Instance : Inject nat val := {| inject := inject ∘ Z.of_nat |}.
36 |
37 | #[global] Program Instance : Inject bool val := {| inject := LitV ∘ LitBool |}.
38 | Next Obligation. by intros ?? [=]. Qed.
39 |
40 | #[global] Program Instance : Inject unit val := {| inject := λ _, #() |}.
41 | Next Obligation. by intros [] []. Qed.
42 |
43 | #[global] Program Instance : Inject loc val := {| inject := LitV ∘ LitLoc |}.
44 | Next Obligation. by intros ?? [=]. Qed.
45 |
46 | #[global] Program Instance Inject_expr `{!Inject A val} : Inject A expr :=
47 | {| inject := Val ∘ inject |}.
48 |
49 | #[global] Program Instance : Inject val val := {| inject := λ v, v |}.
50 | End inject.
51 |
--------------------------------------------------------------------------------
/theories/con_prob_lang/ctx_subst.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import base stringmap fin_sets fin_map_dom.
2 | From clutch.common Require Export con_ectx_language con_ectxi_language.
3 | From clutch.con_prob_lang Require Export lang metatheory.
4 |
5 | (** Substitution in the contexts *)
6 | Definition subst_map_ctx_item (es : stringmap val) (K : ectx_item) :=
7 | match K with
8 | | AppLCtx v2 => AppLCtx v2
9 | | AppRCtx e1 => AppRCtx (subst_map es e1)
10 | | UnOpCtx op => UnOpCtx op
11 | | BinOpLCtx op v2 => BinOpLCtx op v2
12 | | BinOpRCtx op e1 => BinOpRCtx op (subst_map es e1)
13 | | IfCtx e1 e2 => IfCtx (subst_map es e1) (subst_map es e2)
14 | | PairLCtx v2 => PairLCtx v2
15 | | PairRCtx e1 => PairRCtx (subst_map es e1)
16 | | FstCtx => FstCtx
17 | | SndCtx => SndCtx
18 | | InjLCtx => InjLCtx
19 | | InjRCtx => InjRCtx
20 | | CaseCtx e1 e2 => CaseCtx (subst_map es e1) (subst_map es e2)
21 | | AllocNLCtx v2 => AllocNLCtx v2
22 | | AllocNRCtx e1 => AllocNRCtx (subst_map es e1)
23 | | LoadCtx => LoadCtx
24 | | StoreLCtx v2 => StoreLCtx v2
25 | | StoreRCtx e1 => StoreRCtx (subst_map es e1)
26 | | AllocTapeCtx => AllocTapeCtx
27 | | RandLCtx v2 => RandLCtx v2
28 | | RandRCtx e1 => RandRCtx (subst_map es e1)
29 | | TickCtx => TickCtx
30 | | CmpXchgLCtx v1 v2 => CmpXchgLCtx v1 v2
31 | | CmpXchgMCtx e0 v2 => CmpXchgMCtx (subst_map es e0) v2
32 | | CmpXchgRCtx e0 e1 => CmpXchgRCtx (subst_map es e0) (subst_map es e1)
33 | | XchgLCtx v2 => XchgLCtx v2
34 | | XchgRCtx e1 => XchgRCtx (subst_map es e1)
35 | | FaaLCtx v2 => FaaLCtx v2
36 | | FaaRCtx e1 => FaaRCtx (subst_map es e1)
37 | end.
38 |
39 | Definition subst_map_ctx (es : stringmap val) (K : list ectx_item) :=
40 | map (subst_map_ctx_item es) K.
41 |
42 | Lemma subst_map_fill_item (vs : stringmap val) (Ki : ectx_item) (e : expr) :
43 | subst_map vs (fill_item Ki e) =
44 | fill_item (subst_map_ctx_item vs Ki) (subst_map vs e).
45 | Proof. induction Ki; simpl; eauto with f_equal. Qed.
46 |
47 | Lemma subst_map_fill (vs : stringmap val) (K : list ectx_item) (e : expr) :
48 | subst_map vs (fill K e) = fill (subst_map_ctx vs K) (subst_map vs e).
49 | Proof.
50 | generalize dependent e. generalize dependent vs.
51 | induction K as [|Ki K]; eauto.
52 | intros es e. simpl.
53 | by rewrite IHK subst_map_fill_item.
54 | Qed.
55 |
--------------------------------------------------------------------------------
/theories/con_prob_lang/spec/spec_transition.v:
--------------------------------------------------------------------------------
1 | (* From Coq Require Import Reals Psatz. *)
2 | (* From clutch.con_prob_lang Require Import lang. *)
3 | (* From clutch.common Require Export con_language. *)
4 | (* From clutch.prob Require Export distribution. *)
5 |
6 | (* Set Default Proof Using "Type*". *)
7 |
8 | (* Section spec_transition. *)
9 | (* Definition spec_transition_compress (ρ: cfg con_prob_lang) (μ : distr nat) *)
10 | (* (f: nat -> cfg con_prob_lang -> distr (cfg con_prob_lang)) *)
11 | (* : distr (cfg con_prob_lang) := *)
12 | (* (μ ≫= (λ tid, (dbind (λ ρ', f tid ρ') (step tid ρ)))). *)
13 |
14 | (* Inductive spec_transition (ρ:cfg con_prob_lang) : distr (cfg con_prob_lang) -> Prop := *)
15 | (* | spec_transition_dret : spec_transition ρ (dret ρ) *)
16 | (* | spec_transition_step (μ : distr nat) *)
17 | (* (f: nat -> cfg con_prob_lang -> distr (cfg con_prob_lang)): *)
18 | (* (∀ (tid:nat), (μ tid > 0)%R -> *)
19 | (* (forall ρ', step tid ρ ρ' > 0 -> spec_transition ρ' (f tid ρ'))) -> *)
20 | (* spec_transition ρ (spec_transition_compress ρ μ f ) *)
21 | (* . *)
22 |
23 | (* Lemma spec_transition_step' ρ μ μ1 f : *)
24 | (* μ=spec_transition_compress ρ μ1 f -> *)
25 | (* (∀ (tid:nat), (μ1 tid > 0)%R -> *)
26 | (* (forall ρ', step tid ρ ρ' > 0 -> spec_transition ρ' (f tid ρ'))) -> *)
27 | (* spec_transition ρ μ. *)
28 | (* Proof. *)
29 | (* intros -> ?. *)
30 | (* by apply spec_transition_step. *)
31 | (* Qed. *)
32 |
33 | (* Lemma spec_transition_bind ρ μ f: *)
34 | (* spec_transition ρ μ -> *)
35 | (* (∀ ρ', (μ ρ'> 0)%R -> spec_transition ρ' (f ρ')) -> *)
36 | (* spec_transition ρ (μ≫=f). *)
37 | (* Proof. *)
38 | (* intros H. *)
39 | (* revert f. *)
40 | (* induction H as [|H μ f IH1 IH2]. *)
41 | (* - intros. rewrite dret_id_left. *)
42 | (* apply H. solve_distr. *)
43 | (* - intros f' Hf'. *)
44 | (* rewrite /spec_transition_compress. *)
45 | (* rewrite -!dbind_assoc. *)
46 | (* eapply (spec_transition_step' _ _ μ). *)
47 | (* + rewrite /spec_transition_compress. *)
48 | (* apply dbind_ext_right. *)
49 | (* intros. by rewrite -dbind_assoc. *)
50 | (* + simpl. intros. apply IH2; try done. *)
51 | (* intros. apply Hf'. *)
52 | (* rewrite /spec_transition_compress. *)
53 | (* apply dbind_pos. eexists _; split; last done. *)
54 | (* apply dbind_pos. eexists _; by split. *)
55 | (* Qed. *)
56 | (* End spec_transition. *)
57 |
--------------------------------------------------------------------------------
/theories/con_prob_lang/tactics.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import Reals Psatz.
2 | From stdpp Require Import fin_maps.
3 | From iris.proofmode Require Import environments proofmode.
4 | From clutch.prob Require Import distribution.
5 | From clutch.common Require Import con_ectx_language.
6 | From clutch.con_prob_lang Require Import lang.
7 | From iris.prelude Require Import options.
8 | Import con_prob_lang.
9 |
10 | (** The tactic [reshape_expr e tac] decomposes the expression [e] into an
11 | evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e']
12 | for each possible decomposition until [tac] succeeds. *)
13 | Ltac reshape_expr e tac :=
14 | let rec go K e :=
15 | match e with
16 | | _ => tac K e
17 | | App ?e (Val ?v) => go (AppLCtx v :: K) e
18 | | App ?e1 ?e2 => go (AppRCtx e1 :: K) e2
19 | | UnOp ?op ?e => go (UnOpCtx op :: K) e
20 | | BinOp ?op ?e (Val ?v) => go (BinOpLCtx op v :: K) e
21 | | BinOp ?op ?e1 ?e2 => go (BinOpRCtx op e1 :: K) e2
22 | | If ?e0 ?e1 ?e2 => go (IfCtx e1 e2 :: K) e0
23 | | Pair ?e (Val ?v) => go (PairLCtx v :: K) e
24 | | Pair ?e1 ?e2 => go (PairRCtx e1 :: K) e2
25 | | Fst ?e => go (FstCtx :: K) e
26 | | Snd ?e => go (SndCtx :: K) e
27 | | InjL ?e => go (InjLCtx :: K) e
28 | | InjR ?e => go (InjRCtx :: K) e
29 | | Case ?e0 ?e1 ?e2 => go (CaseCtx e1 e2 :: K) e0
30 | | AllocN ?e (Val ?v) => go (AllocNLCtx v :: K) e
31 | | AllocN ?e1 ?e2 => go (AllocNRCtx e1 :: K) e2
32 | | Load ?e => go (LoadCtx :: K) e
33 | | Store ?e (Val ?v) => go (StoreLCtx v :: K) e
34 | | Store ?e1 ?e2 => go (StoreRCtx e1 :: K) e2
35 | | AllocTape ?e => go (AllocTapeCtx :: K) e
36 | | Rand ?e (Val ?v) => go (RandLCtx v :: K) e
37 | | Rand ?e1 ?e2 => go (RandRCtx e1 :: K) e2
38 | | Tick ?e => go (TickCtx :: K) e
39 | | CmpXchg ?e0 (Val ?v1) (Val ?v2) => go (CmpXchgLCtx v1 v2 :: K) e0
40 | | CmpXchg ?e0 ?e1 (Val ?v2) => go (CmpXchgMCtx e0 v2 :: K) e1
41 | | CmpXchg ?e0 ?e1 ?e2 => go (CmpXchgRCtx e0 e1 :: K) e2
42 | | Xchg ?e1 (Val ?v2) => go (XchgLCtx v2 :: K) e1
43 | | Xchg ?e1 ?e2 => go (XchgRCtx e1 :: K) e2
44 | | FAA ?e1 (Val ?v2) => go (FaaLCtx v2 :: K) e1
45 | | FAA ?e1 ?e2 => go (FaaRCtx e1 :: K) e2
46 | end in go (@nil ectx_item) e.
47 |
48 | Local Open Scope R.
49 |
50 | Lemma head_step_support_eq e1 e2 σ1 σ2 efs r :
51 | r > 0 → head_step e1 σ1 (e2, σ2, efs) = r → head_step_rel e1 σ1 e2 σ2 efs.
52 | Proof. intros ? <-. by eapply head_step_support_equiv_rel. Qed.
53 |
54 | Lemma head_step_support_eq_1 e1 e2 σ1 σ2 efs :
55 | head_step e1 σ1 (e2, σ2, efs) = 1 → head_step_rel e1 σ1 e2 σ2 efs.
56 | Proof. eapply head_step_support_eq; lra. Qed.
57 |
58 | (** The tactic [inv_head_step] performs inversion on hypotheses of the shape
59 | [head_step]. The tactic will discharge head-reductions starting from values,
60 | and simplifies hypothesis related to conversions from and to values, and
61 | finite map operations. This tactic is slightly ad-hoc and tuned for proving
62 | our lifting lemmas. *)
63 |
64 | Global Hint Extern 0 (head_reducible _ _) =>
65 | eexists (_, _); eapply head_step_support_equiv_rel : head_step.
66 | Global Hint Extern 1 (head_step _ _ _ > 0) =>
67 | eapply head_step_support_equiv_rel; econstructor : head_step.
68 |
69 | Global Hint Extern 2 (head_reducible _ _) =>
70 | by eauto with head_step : typeclass_instances.
71 |
72 | Ltac solve_step :=
73 | simpl;
74 | match goal with
75 | | |- (prim_step _ _).(pmf) _ = 1%R =>
76 | rewrite head_prim_step_eq /= ;
77 | simplify_map_eq ; solve_distr
78 | | |- (head_step _ _).(pmf) _ = 1%R => simplify_map_eq; solve_distr
79 | | |- (head_step _ _).(pmf) _ > 0%R => eauto with head_step
80 | end.
81 |
82 | Ltac solve_red :=
83 | match goal with
84 | | |- (environments.envs_entails _ ( ⌜ _ ⌝ ∗ _)) =>
85 | iSplitR ; [ by (iPureIntro ; solve_red) | ]
86 | | |- (environments.envs_entails _ ( _ ∗ ⌜ _ ⌝)) =>
87 | iSplitL ; [ by (iPureIntro ; solve_red) | ]
88 | | |- reducible ((fill _ _), _) =>
89 | apply reducible_fill ; solve_red
90 | | |- reducible _ =>
91 | apply head_prim_reducible ; solve_red
92 | | |- (head_reducible _ _) =>
93 | by eauto with head_step
94 | end.
95 |
--------------------------------------------------------------------------------
/theories/coneris/coneris.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import namespaces.
2 | From clutch.con_prob_lang Require Export notation tactics metatheory.
3 | From clutch.con_prob_lang Require Export lang.
4 | From clutch.coneris Require Export lifting ectx_lifting primitive_laws derived_laws
5 | proofmode error_rules.
6 |
--------------------------------------------------------------------------------
/theories/coneris/examples/hash/coll_free_hash_view_interface.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris.
2 |
3 | Set Default Proof Using "Type*".
4 |
5 | (** An interface of a collision-free hash view*)
6 |
7 | (* A hash function is collision free if the partial map it
8 | implements is an injective function *)
9 | Definition coll_free (m : gmap nat nat) :=
10 | forall k1 k2,
11 | is_Some (m !! k1) ->
12 | is_Some (m !! k2) ->
13 | m !!! k1 = m !!! k2 ->
14 | k1 = k2.
15 |
16 | Class hash_view `{!conerisGS Σ} := Hash_View
17 | {
18 | hvG : gFunctors -> Type;
19 | hv_name : Type;
20 | hv_auth {L:hvG Σ} : gmap nat nat -> hv_name -> iProp Σ;
21 | hv_frag {L:hvG Σ} : nat -> nat -> hv_name -> iProp Σ;
22 |
23 | hv_auth_timeless {L:hvG Σ} m γ::
24 | Timeless (hv_auth (L:=L) m γ);
25 | hv_frag_timeless {L:hvG Σ} k v γ::
26 | Timeless (hv_frag (L:=L) k v γ);
27 | hv_frag_persistent {L:hvG Σ} k v γ::
28 | Persistent (hv_frag (L:=L) k v γ);
29 |
30 | hv_auth_exclusive {L:hvG Σ} m m' γ:
31 | hv_auth (L:=L) m γ -∗ hv_auth (L:=L) m' γ -∗ False;
32 | hv_auth_init {L:hvG Σ}:
33 | (⊢|==> (∃ γ, hv_auth (L:=L) ∅ γ))%I;
34 | hv_auth_coll_free {L:hvG Σ} m γ: hv_auth (L:=L) m γ -∗ ⌜coll_free m⌝;
35 | hv_auth_duplicate_frag {L:hvG Σ} m n b γ:
36 | m!!n=Some b -> hv_auth (L:=L) m γ -∗ hv_auth (L:=L) m γ ∗ hv_frag (L:=L) n b γ;
37 | hv_auth_frag_agree {L:hvG Σ} m γ k v:
38 | hv_auth (L:=L) m γ ∗ hv_frag (L:=L) k v γ -∗
39 | ⌜m!!k=Some v⌝;
40 | hv_frag_frag_agree {L:hvG Σ} k1 k2 v1 v2 γ:
41 | hv_frag (L:=L) k1 v1 γ -∗ hv_frag (L:=L) k2 v2 γ -∗
42 | ⌜k1 = k2 <-> v1 = v2 ⌝;
43 | hv_auth_insert {L:hvG Σ} m n x γ:
44 | m!!n=None ->
45 | Forall (λ m : nat, x ≠ m) (map (λ p : nat * nat, p.2) (map_to_list m)) ->
46 | hv_auth (L:=L) m γ ==∗
47 | hv_auth (L:=L) (<[n:=x]> m) γ ∗ hv_frag (L:=L) n x γ
48 | }.
49 |
--------------------------------------------------------------------------------
/theories/coneris/examples/hash/con_hash_interface0.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris .
2 |
3 | Set Default Proof Using "Type*".
4 |
5 |
6 | Class con_hash0 `{!conerisGS Σ} (val_size:nat):= Con_Hash0
7 | {
8 | (** * Operations *)
9 | init_hash0 : val;
10 | allocate_tape0 : val;
11 | compute_hash0 : val;
12 | (** * Ghost state *)
13 |
14 | (** [name] is used to associate [locked] with [is_lock] *)
15 | hash_tape_gname: Type;
16 | hash_lock_gname:Type;
17 |
18 | (** * Predicates *)
19 | con_hash_inv0 (N:namespace) (f l hm: val) (R:gmap nat nat -> iProp Σ) {HR: ∀ m, Timeless (R m )} (γ:hash_tape_gname) (γ_lock:hash_lock_gname): iProp Σ;
20 | hash_tape0 (α:val) (ns:list nat) (γ:hash_tape_gname): iProp Σ;
21 |
22 | (** * General properties of the predicates *)
23 | #[global] hash_tape_timeless α ns γ::
24 | Timeless (hash_tape0 α ns γ);
25 | #[global] con_hash_inv_persistent N f l hm R {HR: ∀ m, Timeless (R m )} γ_tape γ_lock ::
26 | Persistent (con_hash_inv0 N f l hm R γ_tape γ_lock);
27 |
28 | hash_tape_valid α ns γ:
29 | hash_tape0 α ns γ-∗ ⌜Forall (λ x, x<=val_size)%nat ns⌝;
30 | hash_tape_exclusive α ns ns' γ:
31 | hash_tape0 α ns γ-∗ hash_tape0 α ns' γ-∗ False;
32 | hash_tape_presample N γ γ_lock f l hm R {HR: ∀ m, Timeless (R m )} α ns ε ε2 E:
33 | ↑(N)⊆E ->
34 | (∀ x : fin (S val_size), (0 <= ε2 x)%R)->
35 | (SeriesC (λ n : fin (S val_size), 1 / S val_size * ε2 n) <= ε)%R ->
36 | con_hash_inv0 N f l hm R γ γ_lock -∗
37 | hash_tape0 α ns γ -∗ ↯ ε -∗
38 | state_update E E (∃ n,
39 | ↯ (ε2 n) ∗
40 | hash_tape0 α (ns++[fin_to_nat n]) γ);
41 |
42 | con_hash_init0 N R {HR: ∀ m, Timeless (R m )} :
43 | {{{ R ∅}}}
44 | init_hash0 #()
45 | {{{ (f:val), RET f; ∃ l hm γ_tape γ_lock, con_hash_inv0 N f l hm R γ_tape γ_lock }}};
46 |
47 | con_hash_alloc_tape0 N f l hm R {HR: ∀ m, Timeless (R m )} γ_tape γ_lock:
48 | {{{ con_hash_inv0 N f l hm R γ_tape γ_lock
49 | }}}
50 | allocate_tape0 #()
51 | {{{ (α: val), RET α; hash_tape0 α [] γ_tape }}};
52 |
53 | con_hash_spec0 N f l hm R {HR: ∀ m, Timeless (R m )} γ_tape γ_lock Q1 Q2 α (v:nat):
54 | {{{ con_hash_inv0 N f l hm R γ_tape γ_lock ∗
55 | ( ∀ m , R m -∗ state_update (⊤) (⊤)
56 | match m!!v with
57 | | Some res => R m ∗ Q1 res
58 | | None => ∃ n ns, hash_tape0 α (n::ns) γ_tape ∗
59 | (hash_tape0 α (ns) γ_tape ={⊤}=∗ R (<[v:=n]> m) ∗ Q2 n ns)
60 | end
61 | )
62 | }}}
63 | f #v α
64 | {{{ (res:nat), RET (#res); (Q1 res ∨
65 | ∃ ns, Q2 res ns
66 | )
67 | }}};
68 |
69 | }.
70 |
--------------------------------------------------------------------------------
/theories/coneris/examples/hash/con_hash_interface4.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris.
2 |
3 | Set Default Proof Using "Type*".
4 |
5 | (** A concurrent interface for hash functions with presampling for individual keys *)
6 | Class con_hash4 Σ `{!conerisGS Σ} := Con_Hash4
7 | {
8 | (** * Operations *)
9 | init_con_hash : val;
10 |
11 | (** * Predicates *)
12 | conhashfun (γs : gname * gname * gname) (val_size : nat) (f : val) : iProp Σ;
13 | hashkey (γs : gname * gname * gname) (k : nat) (v : option nat) : iProp Σ;
14 |
15 | (** * General properties of the predicates *)
16 | #[global] hashkey_timeless γs k v :: Timeless (hashkey γs k v);
17 | #[global] conhashfun_persistent γs vs f :: Persistent (conhashfun γs vs f);
18 | #[global] hashkey_Some_persistent γs k v :: Persistent (hashkey γs k (Some v));
19 |
20 | hashkey_presample k (bad : gset nat) (ε εI εO: nonnegreal) γs val_size f :
21 | (∀ x, x ∈ bad → x < S val_size) →
22 | (εI * size bad + εO * (val_size + 1 - size bad) <= ε * (val_size + 1))%R →
23 | conhashfun γs val_size f -∗
24 | hashkey γs k None -∗
25 | ↯ ε -∗
26 | state_update ⊤ ⊤ (∃ (n : fin (S val_size)),
27 | ((⌜fin_to_nat n ∉ bad⌝ ∗ ↯ εO) ∨ (⌜fin_to_nat n ∈ bad⌝ ∗ ↯ εI)) ∗
28 | hashkey γs k (Some (fin_to_nat n)));
29 |
30 | conhash_init val_size max :
31 | {{{ True }}}
32 | init_con_hash #val_size #max
33 | {{{ γs conhash, RET conhash;
34 | conhashfun γs val_size conhash ∗
35 | ([∗ set] k ∈ (set_seq 0 (S max)), hashkey γs k None) }}} ;
36 |
37 | wp_conhashfun_prev f (k n : nat) γs val_size :
38 | {{{ conhashfun γs val_size f ∗ hashkey γs k (Some n) }}}
39 | f #k
40 | {{{ RET #n; True }}}
41 | }.
42 |
43 | Section derived_lemmas.
44 | Context `{conerisGS Σ, !con_hash4 Σ}.
45 |
46 | Lemma wp_hash_lookup_safe k f γs val_size :
47 | {{{ hashkey γs k None ∗ conhashfun γs val_size f }}}
48 | f #k
49 | {{{ (v : nat), RET #v; ⌜(v ≤ val_size)%nat⌝ ∗ hashkey γs k (Some v) }}}.
50 | Proof.
51 | iIntros (Φ) "(HNone & #Hinv) HΦ".
52 | iMod (ec_zero) as "Herr".
53 | iApply state_update_pgl_wp.
54 | iMod (hashkey_presample _ ∅ nnreal_zero nnreal_zero nnreal_zero with "Hinv HNone [Herr]")
55 | as "(%v & _ & #Hkey)"; auto.
56 | - set_solver.
57 | - rewrite size_empty /=. lra.
58 | - iModIntro.
59 | wp_apply (wp_conhashfun_prev with "[-HΦ]"); auto.
60 | iIntros "_". iApply "HΦ". iFrame "#". iPureIntro.
61 | pose proof (fin_to_nat_lt v). lia.
62 | Qed.
63 |
64 | Lemma wp_hash_lookup_avoid_set k f γs (bad : gset nat)(ε εI εO:nonnegreal) val_size :
65 | (∀ x : nat, x ∈ bad → (x < S val_size)%nat) →
66 | (εI * (size bad) + εO * (val_size + 1 - size bad) <= ε * (val_size + 1))%R →
67 | {{{ ↯ ε ∗ hashkey γs k None ∗ conhashfun γs val_size f }}}
68 | f #k
69 | {{{ (v : nat), RET #v;
70 | ⌜(v ≤ val_size)%nat⌝ ∗
71 | ((⌜v ∈ bad⌝) ∗ ↯ εI ∨ (⌜v ∉ bad⌝) ∗ ↯ εO) ∗
72 | hashkey γs k (Some v) }}}.
73 | Proof.
74 | iIntros (Hbad Hdistr Φ) "(Herr & Hnone & #Hinv) HΦ".
75 | iApply state_update_pgl_wp.
76 | iMod (hashkey_presample _ bad ε εI εO with "Hinv Hnone [Herr]")
77 | as "(%v & Hv & #Hhauth)"; auto.
78 | iModIntro.
79 | wp_apply (wp_conhashfun_prev with "[$]").
80 | iIntros "Hf".
81 | iApply "HΦ". iFrame.
82 | iSplit; [iPureIntro|].
83 | { pose proof (fin_to_nat_lt v). lia. }
84 | iDestruct "Hv" as "[?|?]"; auto.
85 | Qed.
86 |
87 | End derived_lemmas.
88 |
--------------------------------------------------------------------------------
/theories/coneris/examples/hash/hash_view_impl.v:
--------------------------------------------------------------------------------
1 | From iris Require Import ghost_map.
2 | From clutch.coneris Require Export coneris hash_view_interface.
3 |
4 | Set Default Proof Using "Type*".
5 |
6 | (** An implementation of a hash view*)
7 |
8 | Section hash_view_impl.
9 | Context `{Hcon:conerisGS Σ,
10 | HinG: ghost_mapG Σ nat nat}.
11 |
12 | Definition hash_view_auth m γ := (ghost_map_auth γ 1 m ∗
13 | [∗ map] k↦v ∈m, (k ↪[γ]□ v))%I
14 | .
15 | Definition hash_view_frag k v γ := (k ↪[γ]□ v)%I.
16 |
17 | Lemma hash_view_auth_duplicate_frag m n b γ2:
18 | m!!n=Some b -> hash_view_auth m γ2 -∗ hash_view_auth m γ2 ∗ hash_view_frag n b γ2.
19 | Proof.
20 | iIntros (Hsome) "[Hauth #Hauth']".
21 | rewrite /hash_view_auth/hash_view_frag.
22 | iFrame "Hauth Hauth'".
23 | by iDestruct (big_sepM_lookup_acc with "[$]") as "[$ K]".
24 | Qed.
25 |
26 | Lemma hash_view_auth_frag_agree m γ2 k v:
27 | hash_view_auth m γ2 ∗ hash_view_frag k v γ2 -∗
28 | ⌜m!!k=Some v⌝.
29 | Proof.
30 | rewrite /hash_view_auth/hash_view_frag.
31 | iIntros "[[H1 ?]H2]".
32 | by iCombine "H1 H2" gives "%".
33 | Qed.
34 |
35 | Lemma hash_view_auth_insert m n x γ:
36 | m!!n=None ->
37 | hash_view_auth m γ ==∗
38 | hash_view_auth (<[n:=x]> m) γ ∗ hash_view_frag n x γ.
39 | Proof.
40 | iIntros (H1) "[Hauth Hauth']".
41 | rewrite /hash_view_auth/hash_view_frag.
42 | iMod (ghost_map_insert_persist with "[$]") as "[$ #$]"; first done.
43 | iModIntro. rewrite big_sepM_insert; last done. by iFrame.
44 | Qed.
45 | End hash_view_impl.
46 |
47 |
48 | Class hvG1 Σ := {hvG1_ghost_mapG :: ghost_mapG Σ nat nat}.
49 | Program Definition hv_impl `{!conerisGS Σ} : hash_view :=
50 | {|
51 | hvG := hvG1;
52 | hv_name := gname;
53 | hv_auth _ m γ := hash_view_auth m γ;
54 | hv_frag _ k v γ := hash_view_frag k v γ
55 | |}.
56 | Next Obligation.
57 | rewrite /hash_view_auth.
58 | iIntros (??????) "[H1 ?][H2?]".
59 | iDestruct (ghost_map_auth_valid_2 with "[$][$]") as "[%%]".
60 | done.
61 | Qed.
62 | Next Obligation.
63 | rewrite /hash_view_auth.
64 | iIntros. iMod ghost_map_alloc_empty as "[% ?]".
65 | iFrame. by rewrite big_sepM_empty.
66 | Qed.
67 | Next Obligation.
68 | simpl. iIntros.
69 | by iApply hash_view_auth_duplicate_frag.
70 | Qed.
71 | Next Obligation.
72 | simpl. iIntros.
73 | by iApply hash_view_auth_frag_agree.
74 | Qed.
75 | Next Obligation.
76 | simpl.
77 | iIntros (???????) "H1 H2".
78 | rewrite /hash_view_frag.
79 | by iCombine "H1 H2" gives "[? ->]".
80 | Qed.
81 | Next Obligation.
82 | simpl.
83 | iIntros.
84 | by iApply hash_view_auth_insert.
85 | Qed.
86 |
--------------------------------------------------------------------------------
/theories/coneris/examples/hash/hash_view_interface.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris.
2 |
3 | Set Default Proof Using "Type*".
4 |
5 | (** An interface of a simple hash view*)
6 |
7 | (* A hash function is collision free if the partial map it
8 | implements is an injective function *)
9 | (* Definition coll_free (m : gmap nat nat) := *)
10 | (* forall k1 k2, *)
11 | (* is_Some (m !! k1) -> *)
12 | (* is_Some (m !! k2) -> *)
13 | (* m !!! k1 = m !!! k2 -> *)
14 | (* k1 = k2. *)
15 |
16 | Class hash_view `{!conerisGS Σ} := Hash_View
17 | {
18 | hvG : gFunctors -> Type;
19 | hv_name : Type;
20 | hv_auth {L:hvG Σ} : gmap nat nat -> hv_name -> iProp Σ;
21 | hv_frag {L:hvG Σ} : nat -> nat -> hv_name -> iProp Σ;
22 |
23 | hv_auth_timeless {L:hvG Σ} m γ::
24 | Timeless (hv_auth (L:=L) m γ);
25 | hv_frag_timeless {L:hvG Σ} k v γ::
26 | Timeless (hv_frag (L:=L) k v γ);
27 | hv_frag_persistent {L:hvG Σ} k v γ::
28 | Persistent (hv_frag (L:=L) k v γ);
29 |
30 |
31 | hv_auth_exclusive {L:hvG Σ} m m' γ:
32 | hv_auth (L:=L) m γ -∗ hv_auth (L:=L) m' γ -∗ False;
33 | hv_auth_init {L:hvG Σ}:
34 | (⊢|==> (∃ γ, hv_auth (L:=L) ∅ γ))%I;
35 | hv_auth_duplicate_frag {L:hvG Σ} m n b γ:
36 | m!!n=Some b -> hv_auth (L:=L) m γ -∗ hv_auth (L:=L) m γ ∗ hv_frag (L:=L) n b γ;
37 | hv_auth_frag_agree {L:hvG Σ} m γ k v:
38 | hv_auth (L:=L) m γ ∗ hv_frag (L:=L) k v γ -∗
39 | ⌜m!!k=Some v⌝;
40 | hv_frag_frag_agree {L:hvG Σ} γ k v1 v2:
41 | hv_frag (L:=L) k v1 γ -∗ hv_frag (L:=L) k v2 γ -∗ ⌜v1=v2⌝;
42 | hv_auth_insert {L:hvG Σ} m n x γ:
43 | m!!n=None ->
44 | hv_auth (L:=L) m γ ==∗
45 | hv_auth (L:=L) (<[n:=x]> m) γ ∗ hv_frag (L:=L) n x γ
46 | }.
47 |
--------------------------------------------------------------------------------
/theories/coneris/examples/hash/seq_hash_interface.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris coll_free_hash_view_interface.
2 |
3 | Set Default Proof Using "Type*".
4 | (** * seq hash interface. Not completed. To be deleted *)
5 |
6 | Definition tape_m_elements (tape_m : gmap val (list nat)) :=
7 | concat (map_to_list tape_m).*2.
8 |
9 | Class seq_hash `{!conerisGS Σ} {h:hash_view} `{!hvG Σ} (val_size:nat):= Seq_Hash
10 | {
11 | (** * Operations *)
12 | init_hash : val;
13 | (* incr_counter : val; *)
14 | allocate_tape : val;
15 | compute_hash : val;
16 | (** * Ghost state *)
17 | (** The assumptions about [Σ] *)
18 | seq_hashG : gFunctors → Type;
19 | (** [name] is used to associate [locked] with [is_lock] *)
20 | (* tape_name: Type; *)
21 | seq_hash_tape_gname: Type;
22 |
23 | (** * Predicates *)
24 | abstract_seq_hash {L : seq_hashG Σ} (f: val) (m:gmap nat nat) (tape_m : gmap val (list nat)) (γ1:seq_hash_tape_gname) (γ2: hv_name): iProp Σ;
25 | (* concrete_seq_hash {L:seq_hashG Σ} (f:val) (m:gmap nat nat) : iProp Σ; *)
26 | seq_hash_tape {L : seq_hashG Σ} (α:val) (ns:list nat) (γ: seq_hash_tape_gname) : iProp Σ;
27 |
28 | (** * General properties of the predicates *)
29 | (* #[global] concrete_seq_hash_timeless {L : seq_hashG Σ} f m :: *)
30 | (* Timeless (concrete_seq_hash (L:=L) f m); *)
31 | #[global] seq_hash_tape_timeless {L : seq_hashG Σ} α ns γ ::
32 | Timeless (seq_hash_tape (L:=L) α ns γ);
33 | abstract_seq_hash_coll_free {L : seq_hashG Σ} f m tape_m γ1 γ2:
34 | abstract_seq_hash (L:=L) f m tape_m γ1 γ2 -∗ ⌜coll_free m⌝;
35 |
36 |
37 |
38 | seq_hash_presample {L : seq_hashG Σ} f m tape_m γ1 γ2 α E (ε:nonnegreal) ns:
39 | abstract_seq_hash (L:=L) f m tape_m γ1 γ2 -∗
40 | seq_hash_tape (L:=L) α ns γ1 -∗
41 | ↯ (nnreal_div (nnreal_nat (length (map_to_list m) + length (tape_m_elements tape_m))) (nnreal_nat(val_size+1))) -∗
42 | ↯ ε -∗
43 | state_update E E (∃ (n:nat),
44 | ↯ ((nnreal_div (nnreal_nat(val_size+1)) (nnreal_nat (S val_size - (length (map_to_list m) + length (tape_m_elements tape_m))))) *ε) ∗
45 | seq_hash_tape (L:=L) α ns γ1 ∗
46 | abstract_seq_hash (L:=L) f m tape_m γ1 γ2)
47 | }.
48 |
49 |
--------------------------------------------------------------------------------
/theories/coneris/examples/lazy_rand/lazy_rand_interface.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris .
2 |
3 | Set Default Proof Using "Type*".
4 |
5 | Class lazy_rand `{!conerisGS Σ} (val_size:nat):= Lazy_Rand
6 | {
7 | (** * Operations *)
8 | init_lazy_rand : val;
9 | allocate_tape : val;
10 | lazy_read_rand : val;
11 | (** * Ghost state *)
12 | rand_tape_gname: Type;
13 | rand_view_gname: Type;
14 | rand_lock_gname:Type;
15 |
16 | (** * Predicates *)
17 | rand_inv (N:namespace) (c: val) (P: option (nat*nat) -> iProp Σ) {HP: ∀ n, Timeless (P n)}
18 | (γ:rand_tape_gname) (γ':rand_view_gname) (γ_lock:rand_lock_gname): iProp Σ;
19 | rand_tape_frag (α:val) (n:option nat) (γ:rand_tape_gname): iProp Σ;
20 | rand_auth (m:option (nat*nat)) (γ:rand_view_gname) : iProp Σ;
21 | rand_frag (res:nat) (tid:nat) (γ:rand_view_gname) : iProp Σ;
22 |
23 | (** * General properties of the predicates *)
24 | #[global] rand_tape_frag_timeless α ns γ::
25 | Timeless (rand_tape_frag α ns γ);
26 | #[global] rand_auth_timeless n γ::
27 | Timeless (rand_auth n γ);
28 | #[global] rand_frag_timeless n tid γ::
29 | Timeless (rand_frag n tid γ);
30 | rand_tape_frag_valid α ns γ:
31 | rand_tape_frag α (Some ns) γ-∗ ⌜(ns<=val_size)%nat⌝;
32 |
33 | #[global] rand_inv_persistent N c P {HP: ∀ n, Timeless (P n)} γ_tape γ_view γ_lock ::
34 | Persistent (rand_inv N c P γ_tape γ_view γ_lock);
35 | #[global] rand_frag_persistent v res γ ::
36 | Persistent (rand_frag v res γ);
37 |
38 | rand_tape_frag_exclusive α ns ns' γ:
39 | rand_tape_frag α ns γ-∗ rand_tape_frag α ns' γ-∗ False;
40 |
41 | rand_auth_exclusive n n' γ:
42 | rand_auth n γ -∗ rand_auth n' γ -∗ False;
43 | rand_auth_frag_agree n n' tid γ:
44 | rand_auth n γ -∗ rand_frag n' tid γ -∗ ⌜n=Some (n', tid)⌝;
45 | rand_auth_duplicate n γ:
46 | rand_auth (Some n) γ -∗ rand_frag n.1 n.2 γ;
47 | rand_auth_valid n tid γ:
48 | rand_auth (Some (n, tid)) γ -∗ ⌜(n<=val_size)%nat⌝;
49 | rand_frag_valid n tid γ:
50 | rand_frag n tid γ -∗ ⌜(n<=val_size)%nat⌝;
51 | rand_frag_frag_agree v1 v2 tid1 tid2 γ :
52 | rand_frag v1 tid1 γ -∗ rand_frag v2 tid2 γ-∗ ⌜v1=v2∧tid1=tid2⌝;
53 | rand_auth_update n γ:
54 | (n.1<=val_size)%nat -> rand_auth None γ ==∗ rand_auth (Some n) γ;
55 |
56 |
57 | (* rand_tape_auth_alloc m α γ: *)
58 | (* m!!α=None -> rand_tape_auth m γ ==∗ rand_tape_auth (<[α:=[]]> m) γ ∗ rand_tape α [] γ; *)
59 | rand_tape_presample N c P {HP:∀ n, Timeless (P n)} γ γ_view γ_lock E α ε (ε2:fin (S val_size) -> R):
60 | ↑(N)⊆E ->
61 | (∀ x, (0 <= ε2 x)%R)->
62 | (SeriesC (λ n : fin (S val_size), 1 / S val_size * ε2 n) <= ε)%R ->
63 | rand_inv N c P γ γ_view γ_lock -∗
64 | rand_tape_frag α None γ -∗ ↯ ε -∗
65 | state_update E E (∃ n,
66 | ↯ (ε2 n) ∗
67 | rand_tape_frag α (Some (fin_to_nat n)) γ);
68 |
69 | lazy_rand_init N P {HP: ∀ n, Timeless (P n)} :
70 | {{{ P None }}}
71 | init_lazy_rand #()
72 | {{{ (c:val), RET c;
73 | ∃ γ γ_view γ_lock,
74 | rand_inv N c P γ γ_view γ_lock }}};
75 |
76 | lazy_rand_alloc_tape N c P {HP: ∀ n, Timeless (P n)} γ_tape γ_view γ_lock:
77 | {{{ rand_inv N c P γ_tape γ_view γ_lock
78 | }}}
79 | allocate_tape #()
80 | {{{ (α: val), RET α; rand_tape_frag α None γ_tape }}};
81 |
82 | lazy_rand_spec N c P {HP: ∀ n, Timeless (P n)} γ_tape γ_view γ_lock Q1 Q2 α (tid:nat):
83 | {{{ rand_inv N c P γ_tape γ_view γ_lock ∗
84 | ( ∀ n, P n -∗ rand_auth n γ_view -∗ state_update (⊤) (⊤)
85 | match n with
86 | | Some (res, tid') => P n ∗ rand_auth n γ_view ∗ Q1 res tid'
87 | | None => ∃ n', rand_tape_frag α (Some n') γ_tape ∗
88 | ( rand_tape_frag α None γ_tape
89 | ={⊤}=∗ P (Some (n', tid)) ∗ rand_auth (Some (n', tid)) γ_view ∗ Q2 n' tid)
90 | end
91 | )
92 | }}}
93 | lazy_read_rand c α #tid
94 | {{{ (res' tid':nat), RET (#res', #tid')%V; (Q1 res' tid' ∨
95 | Q2 res' tid'
96 | )
97 | }}};
98 | }.
99 |
--------------------------------------------------------------------------------
/theories/coneris/examples/message_pass.v:
--------------------------------------------------------------------------------
1 | From iris.algebra Require Import excl_auth.
2 | From iris.base_logic.lib Require Export invariants cancelable_invariants.
3 | From clutch.coneris Require Import coneris par spawn lib.flip.
4 |
5 | Local Open Scope Z.
6 |
7 | Set Default Proof Using "Type*".
8 |
9 | Definition prog (l:loc) : expr:=
10 | #l <- #(-1);;
11 | ((if: flip then #l <- #0 else #l <- #1) |||
12 | ((rec: "f" "y":=
13 | if: "y"=#(-1)
14 | then "f" !(#l)
15 | else "y"
16 | )%V !(#l))
17 |
18 | ).
19 |
20 | Section proof.
21 | Context `{!conerisGS Σ, !spawnG Σ, inG Σ (excl_authR boolO), cinvG Σ}.
22 | Lemma prog_spec l:
23 | {{{ ↯(/2)%R ∗ ∃ v, l↦v }}}
24 | prog l
25 | {{{
26 | v, RET v; l↦#0
27 | }}}.
28 | Proof.
29 | iIntros (Φ) "[Herr [%v Hl]] HΦ".
30 | rewrite /prog.
31 | wp_store.
32 | iMod (own_alloc (●E false ⋅ ◯E false)) as (γ) "[Hauth Hfrag]".
33 | { by apply excl_auth_valid. }
34 | iMod (cinv_alloc _ nroot (l↦#0 ∗ own γ (●E true) ∨ l↦ #(-1) ∗ own γ (●E false))%I with "[Hl Hauth]") as "[%γ1 [#I Hc]]"; first (iRight; iFrame).
35 | wp_pures.
36 | iDestruct "Hc" as "[Hc Hc']".
37 | iApply pgl_wp_fupd.
38 | wp_apply (wp_par (λ _, own γ (◯E true) ∗ cinv_own γ1 (1/2)%Qp)%I (λ _, cinv_own γ1 (1/2)%Qp)%I with "[Herr Hfrag Hc][Hc']").
39 | - wp_apply (wp_flip_adv _ _ (λ x, if x then 0 else 1)%R with "[$]").
40 | + intros []; lra.
41 | + lra.
42 | + iIntros ([]) "Herr"; last by iDestruct (ec_contradict with "[$]") as "%".
43 | wp_pures.
44 | iMod (cinv_acc_strong with "[I] [$]") as "K"; [done|done|..].
45 | iDestruct "K" as "[>[[H Hauth]|[H Hauth]] [Hc Hclose]]".
46 | * iCombine "Hauth Hfrag" gives "%K". by apply excl_auth_agree_L in K.
47 | * wp_store.
48 | iMod (own_update_2 _ _ _ (●E true ⋅ ◯E true) with "Hauth Hfrag") as "[Hauth Hfrag]".
49 | { by apply excl_auth_update. }
50 | iMod ("Hclose" with "[H Hauth]"); first (iLeft; iLeft; iFrame).
51 | iFrame.
52 | by rewrite -union_difference_L.
53 | - iLöb as "IH".
54 | wp_bind (!_)%E.
55 | iMod (cinv_acc_strong with "[I] [$]") as "K"; [done|done|..].
56 | iDestruct "K" as "[>[[H Hauth]|[H Hauth]] [Hc Hclose]]".
57 | + wp_load.
58 | iMod ("Hclose" with "[-Hc]"); first (iLeft; iLeft; iFrame).
59 | rewrite -union_difference_L; last done.
60 | iModIntro.
61 | by wp_pures.
62 | + wp_load.
63 | iMod ("Hclose" with "[-Hc]"); first (iLeft; iRight; iFrame).
64 | rewrite -union_difference_L; last done.
65 | iModIntro. wp_pures. by iApply "IH".
66 | - iIntros (??) "[[Hfrag Hc] Hc']".
67 | iCombine "Hc Hc'" as "Hc".
68 | iNext.
69 | iMod (cinv_cancel with "[][$]") as "H"; [done|done|].
70 | iDestruct "H" as ">[[H Hauth]|[H Hauth]]".
71 | + iModIntro. by iApply "HΦ".
72 | + iCombine "Hauth Hfrag" gives "%K". by apply excl_auth_agree_L in K.
73 | Qed.
74 |
75 | End proof.
76 |
--------------------------------------------------------------------------------
/theories/coneris/lib/abstract_tape.v:
--------------------------------------------------------------------------------
1 | (** * Abstract tapes *)
2 | (** This file describes an auth frag resource algebra specialized for tapes *)
3 | From stdpp Require Import namespaces.
4 | From iris Require Import excl_auth invariants list.
5 | From clutch.coneris Require Import coneris.
6 |
7 | Set Default Proof Using "Type*".
8 |
9 | Class abstract_tapesGS (Σ : gFunctors) := Abstract_tapesGS {
10 | abstract_tapesGS_inG :: ghost_mapG Σ val (nat*list nat)
11 | }.
12 | Definition abstract_tapesΣ := ghost_mapΣ val (nat*list nat).
13 |
14 | Notation "α ◯↪N ( M ; ns ) @ γ":= (α ↪[ γ ] (M,ns))%I
15 | (at level 20, format "α ◯↪N ( M ; ns ) @ γ") : bi_scope.
16 |
17 | Notation "● m @ γ" := (ghost_map_auth γ 1 m) (at level 20) : bi_scope.
18 |
19 | Section tapes_lemmas.
20 | Context `{!conerisGS Σ, !abstract_tapesGS Σ}.
21 |
22 | Lemma abstract_tapes_alloc m:
23 | ⊢ |==>∃ γ, (● m @ γ) ∗ [∗ map] k↦v ∈ m, (k ◯↪N (v.1; v.2) @ γ).
24 | Proof.
25 | iMod ghost_map_alloc as (γ) "[??]".
26 | iFrame. iModIntro.
27 | iApply big_sepM_mono; last done.
28 | by iIntros (?[??]).
29 | Qed.
30 |
31 | Lemma abstract_tapes_agree m γ k N ns:
32 | (● m @ γ) -∗ (k ◯↪N (N; ns) @ γ) -∗ ⌜ m!!k = Some (N, ns) ⌝.
33 | Proof.
34 | iIntros "H1 H2".
35 | by iCombine "H1 H2" gives "%".
36 | Qed.
37 |
38 | Lemma abstract_tapes_new γ m k N ns :
39 | m!!k=None -> ⊢ (● m @ γ) ==∗ (● (<[k:=(N,ns)]>m) @ γ) ∗ (k ◯↪N (N; ns) @ γ).
40 | Proof.
41 | iIntros (Hlookup) "H".
42 | by iApply ghost_map_insert.
43 | Qed.
44 |
45 | Lemma abstract_tapes_presample γ m k N ns n:
46 | (● m @ γ) -∗ (k ◯↪N (N; ns) @ γ) ==∗ (● (<[k:=(N,ns++[n])]>m) @ γ) ∗ (k ◯↪N (N; ns++[n]) @ γ).
47 | Proof.
48 | iIntros "H1 H2".
49 | iApply (ghost_map_update with "[$][$]").
50 | Qed.
51 |
52 | Lemma abstract_tapes_pop γ m k N ns n:
53 | (● m @ γ) -∗ (k ◯↪N (N; n::ns) @ γ) ==∗ (● (<[k:=(N,ns)]>m) @ γ) ∗ (k ◯↪N (N; ns) @ γ).
54 | Proof.
55 | iIntros "H1 H2".
56 | iApply (ghost_map_update with "[$][$]").
57 | Qed.
58 |
59 | Lemma abstract_tapes_notin α N ns m (f:(nat*list nat)-> nat) g:
60 | α ↪N (N; ns) -∗ ([∗ map] α0↦t ∈ m, α0 ↪N (f t; g t)) -∗ ⌜m!!α=None ⌝.
61 | Proof.
62 | destruct (m!!α) eqn:Heqn; last by iIntros.
63 | iIntros "Hα Hmap".
64 | iDestruct (big_sepM_lookup with "[$]") as "?"; first done.
65 | iExFalso.
66 | iApply (tapeN_tapeN_contradict with "[$][$]").
67 | Qed.
68 |
69 | Lemma abstract_tapes_auth_exclusive m m' γ:
70 | (● m @ γ) -∗ (● m' @ γ)-∗ False.
71 | Proof.
72 | iIntros "H1 H2".
73 | iDestruct (ghost_map_auth_valid_2 with "[$][$]") as "%".
74 | cbv in H.
75 | destruct H. done.
76 | Qed.
77 |
78 | Lemma abstract_tapes_frag_exclusive k N N' ns ns' γ:
79 | (k ◯↪N (N; ns) @ γ) -∗ (k ◯↪N (N'; ns') @ γ)-∗ False.
80 | Proof.
81 | iIntros "H1 H2".
82 | iCombine "H1 H2" gives "%".
83 | cbv in H.
84 | destruct H. done.
85 | Qed.
86 | (** * TODO add*)
87 | End tapes_lemmas.
88 |
--------------------------------------------------------------------------------
/theories/coneris/lib/conversion.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris.
2 |
3 | Definition bool_to_int : val :=
4 | λ: "b",
5 | if: "b" = #false then
6 | #0
7 | else #1.
8 |
9 | Definition int_to_bool : val :=
10 | λ: "z",
11 | if: "z" = #0 then #false
12 | else #true.
13 |
14 | Section specs.
15 | Context `{!conerisGS Σ}.
16 |
17 | Lemma wp_bool_to_int (b: bool) E :
18 | {{{ True }}}
19 | bool_to_int #b @ E
20 | {{{ RET #(Z.b2z b); True%I}}}.
21 | Proof.
22 | iIntros (Φ) "_ HΦ".
23 | rewrite /bool_to_int.
24 | wp_pures. destruct b; case_bool_decide as Heq; try congruence; wp_pures; by iApply "HΦ".
25 | Qed.
26 |
27 | Lemma wp_int_to_bool (z : Z) E :
28 | {{{ True }}}
29 | int_to_bool #z @ E
30 | {{{ RET #(Z_to_bool z); True%I}}}.
31 | Proof.
32 | iIntros (Φ) "_ HΦ".
33 | rewrite /int_to_bool.
34 | wp_pures.
35 | case_bool_decide as Heq; simplify_eq; wp_pures.
36 | - by iApply "HΦ".
37 | - rewrite Z_to_bool_neq_0; [|by intros ->].
38 | by iApply "HΦ".
39 | Qed.
40 |
41 | End specs.
42 |
--------------------------------------------------------------------------------
/theories/coneris/lib/hocap_flip.v:
--------------------------------------------------------------------------------
1 | From clutch.coneris Require Import coneris.
2 | From clutch.coneris Require Import flip hocap_rand.
3 |
4 | (* An abstract spec for a flip module that allows presampling tapes *)
5 |
6 | Set Default Proof Using "Type*".
7 |
8 | Class flip_spec `{!conerisGS Σ} := FlipSpec
9 | {
10 | (** * Operations *)
11 | flip_allocate_tape : val;
12 | flip_tape : val;
13 | (** * Ghost state *)
14 | (** The assumptions about [Σ] *)
15 | flipG : gFunctors → Type;
16 | (** [name] is used to associate [locked] with [is_lock] *)
17 | (** * Predicates *)
18 | flip_tapes {L : flipG Σ} (α:val) (ns:list bool): iProp Σ;
19 | (** * General properties of the predicates *)
20 | #[global] flip_tapes_timeless {L : flipG Σ} α ns ::
21 | Timeless (flip_tapes (L:=L) α ns);
22 | flip_tapes_exclusive {L : flipG Σ} α ns ns':
23 | flip_tapes (L:=L) α ns -∗ flip_tapes (L:=L) α ns' -∗ False;
24 | flip_tapes_presample {L:flipG Σ} E α ns ε (ε2 : bool -> R):
25 | (∀ x, 0<=ε2 x)%R ->
26 | ((ε2 true + ε2 false)/2 <= ε)%R ->
27 | (* is_flip (L:=L) N γ -∗ *)
28 | flip_tapes (L:=L) α (ns) -∗
29 | ↯ ε -∗
30 | state_update E E (∃ n, ↯ (ε2 n) ∗ flip_tapes (L:=L) α (ns ++ [n]));
31 |
32 | (** * Program specs *)
33 |
34 | flip_allocate_tape_spec {L: flipG Σ} E:
35 | {{{ True }}}
36 | flip_allocate_tape #() @ E
37 | {{{ (v:val), RET v; flip_tapes (L:=L) v []
38 | }}};
39 |
40 | flip_tape_spec_some {L: flipG Σ} E α n ns:
41 | {{{ flip_tapes (L:=L) α (n::ns)
42 | }}}
43 | flip_tape α @ E
44 | {{{ RET #n; flip_tapes (L:=L) α ns }}};
45 |
46 | }.
47 |
48 |
49 | (** Instantiate flip *)
50 | Section instantiate_flip.
51 | Context `{H: conerisGS Σ, r1:@rand_spec Σ H}.
52 |
53 | #[local] Program Definition flip_spec1 : flip_spec :=
54 | {| flip_allocate_tape:= (λ: <>, rand_allocate_tape #1%nat);
55 | flip_tape:= (λ: "α", conversion.int_to_bool (rand_tape "α" #1%nat));
56 | flipG := randG;
57 | flip_tapes L α ns := rand_tapes (L:=L) α (1, (fmap (FMap:=list_fmap) bool_to_nat ns));
58 | |}.
59 | Next Obligation.
60 | simpl.
61 | iIntros (????) "H1 H2".
62 | by iDestruct (rand_tapes_exclusive with "[$][$]") as "?".
63 | Qed.
64 | Next Obligation.
65 | simpl.
66 | iIntros (????????) "Hfrag Hε".
67 | iMod (rand_tapes_presample _ _ _ _ _ (λ x, ε2 (nat_to_bool (fin_to_nat x)))with "[$][$]") as "(%n&?&?)"; try done.
68 | - rewrite SeriesC_finite_foldr/=.
69 | rewrite nat_to_bool_eq_0 nat_to_bool_neq_0; last lia.
70 | lra.
71 | - iFrame.
72 | iModIntro.
73 | rewrite fmap_app.
74 | by repeat (inv_fin n; try (intros n)); simpl.
75 | Qed.
76 | Next Obligation.
77 | simpl.
78 | iIntros.
79 | wp_pures.
80 | wp_apply rand_allocate_tape_spec; [exact|done..].
81 | Qed.
82 | Next Obligation.
83 | simpl.
84 | iIntros (??? ?? Φ) "Hfrag HΦ".
85 | wp_pures.
86 | wp_apply (rand_tape_spec_some with "[-HΦ]"); first done.
87 | iIntros "Hfrag".
88 | wp_apply conversion.wp_int_to_bool as "_"; first done.
89 | replace (Z_to_bool _) with n; first by iApply "HΦ".
90 | destruct n; simpl.
91 | - rewrite Z_to_bool_neq_0; lia.
92 | - rewrite Z_to_bool_eq_0; lia.
93 | Qed.
94 |
95 | End instantiate_flip.
96 |
97 | Section test.
98 | Context `{F:flip_spec}.
99 | Lemma flip_presample_spec_simple {L: flipG Σ} E α ns ε ε2:
100 | (∀ n, 0<=ε2 n)%R ->
101 | ((ε2 true + ε2 false)/2<=ε)%R ->
102 | (* is_flip (L:=L) NS γ1 -∗ *)
103 | flip_tapes (L:=L) α ns -∗
104 | ↯ ε -∗
105 | wp_update E (∃ b, flip_tapes (L:=L) α (ns ++ [b]) ∗ ↯ (ε2 b)).
106 | Proof.
107 | iIntros (Hpos Hineq) "Hfrag Herr".
108 | iApply wp_update_state_update.
109 | iMod (flip_tapes_presample with "[$][$]") as "(%&?&?)"; try done.
110 | by iFrame.
111 | Qed.
112 | End test.
113 |
--------------------------------------------------------------------------------
/theories/coneris/lib/lock.v:
--------------------------------------------------------------------------------
1 | From iris.base_logic.lib Require Export invariants.
2 | From clutch.coneris Require Import coneris.
3 | From clutch.con_prob_lang Require Import notation.
4 | From iris.prelude Require Import options.
5 | (** Taken from the Iris development *)
6 | (** A general interface for a lock.
7 |
8 | All parameters are implicit, since it is expected that there is only one
9 | [heapGS_gen] in scope that could possibly apply.
10 |
11 | Only one instance of this class should ever be in scope. To write a library that
12 | is generic over the lock, just add a [`{!lock}] implicit parameter around the
13 | code and [`{!lockG Σ}] around the proofs. To use a particular lock instance, use
14 | [Local Existing Instance ].
15 |
16 | When writing an instance of this class, please take care not to shadow the class
17 | projections (e.g., either use [Local Definition newlock] or avoid the name
18 | [newlock] altogether), and do not register an instance -- just make it a
19 | [Definition] that others can register later. *)
20 | Class lock := Lock {
21 | (** * Operations *)
22 | newlock : val;
23 | acquire : val;
24 | release : val;
25 | (** * Ghost state *)
26 | (** The assumptions about [Σ] *)
27 | lockG : gFunctors → Type;
28 | (** [name] is used to associate [locked] with [is_lock] *)
29 | lock_name : Type;
30 | (** * Predicates *)
31 | (** No namespace [N] parameter because we only expose program specs, which
32 | anyway have the full mask. *)
33 | is_lock `{!conerisGS Σ} {L : lockG Σ} (γ: lock_name) (lock: val) (R: iProp Σ) : iProp Σ;
34 | locked `{!conerisGS Σ} {L : lockG Σ} (γ: lock_name) : iProp Σ;
35 | (** * General properties of the predicates *)
36 | #[global] is_lock_persistent `{!conerisGS Σ} {L : lockG Σ} γ lk R ::
37 | Persistent (is_lock (L:=L) γ lk R);
38 | is_lock_iff `{!conerisGS Σ} {L : lockG Σ} γ lk R1 R2 :
39 | is_lock (L:=L) γ lk R1 -∗ ▷ □ (R1 ∗-∗ R2) -∗ is_lock (L:=L) γ lk R2;
40 | #[global] locked_timeless `{!conerisGS Σ} {L : lockG Σ} γ ::
41 | Timeless (locked (L:=L) γ);
42 | locked_exclusive `{!conerisGS Σ} {L : lockG Σ} γ :
43 | locked (L:=L) γ -∗ locked (L:=L) γ -∗ False;
44 | (** * Program specs *)
45 | newlock_spec `{!conerisGS Σ} {L : lockG Σ} (R : iProp Σ):
46 | {{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock (L:=L) γ lk R }}};
47 | acquire_spec `{!conerisGS Σ} {L : lockG Σ} γ lk R :
48 | {{{ is_lock (L:=L) γ lk R }}} acquire lk {{{ RET #(); locked (L:=L) γ ∗ R }}};
49 | release_spec `{!conerisGS Σ} {L : lockG Σ} γ lk R :
50 | {{{ is_lock (L:=L) γ lk R ∗ locked (L:=L) γ ∗ R }}} release lk {{{ RET #(); True }}}
51 | }.
52 |
53 | Global Arguments newlock : simpl never.
54 | Global Arguments acquire : simpl never.
55 | Global Arguments release : simpl never.
56 | Global Arguments is_lock : simpl never.
57 | Global Arguments locked : simpl never.
58 |
59 | Existing Class lockG.
60 | Global Hint Mode lockG + + : typeclass_instances.
61 | Global Hint Extern 0 (lockG _) => progress simpl : typeclass_instances.
62 |
63 | Global Instance is_lock_contractive `{!conerisGS Σ, !lock, !lockG Σ} γ lk :
64 | Contractive (is_lock γ lk).
65 | Proof.
66 | apply (uPred.contractive_internal_eq (M:=iResUR Σ)).
67 | iIntros (P Q) "#HPQ". iApply prop_ext. iIntros "!>".
68 | iSplit; iIntros "H"; iApply (is_lock_iff with "H");
69 | iNext; iRewrite "HPQ"; auto.
70 | Qed.
71 |
72 | Global Instance is_lock_proper `{!conerisGS Σ, !lock, !lockG Σ} γ lk :
73 | Proper ((≡) ==> (≡)) (is_lock γ lk) := ne_proper _.
74 |
--------------------------------------------------------------------------------
/theories/coneris/lib/par.v:
--------------------------------------------------------------------------------
1 | From iris.prelude Require Import options.
2 | From clutch.coneris Require Import coneris spawn.
3 |
4 | Definition parN : namespace := nroot .@ "par".
5 |
6 | Definition par : val :=
7 | λ: "e1" "e2",
8 | let: "handle" := spawn "e1" in
9 | let: "v2" := "e2" #() in
10 | let: "v1" := join "handle" in
11 | ("v1", "v2").
12 | Notation "e1 ||| e2" := (par (λ: <>, e1)%E (λ: <>, e2)%E) : expr_scope.
13 | Notation "e1 ||| e2" := (par (λ: <>, e1)%V (λ: <>, e2)%V) : val_scope.
14 |
15 | Section proof.
16 | Local Set Default Proof Using "Type*".
17 | Context `{!conerisGS Σ, !spawnG Σ}.
18 |
19 | (* Notice that this allows us to strip a later *after* the two Ψ have been
20 | brought together. That is strictly stronger than first stripping a later
21 | and then merging them, as demonstrated by [tests/joining_existentials.v].
22 | This is why these are not Texan triples. *)
23 | Lemma par_spec (Ψ1 Ψ2 : val → iProp Σ) (f1 f2 : val) (Φ : val → iProp Σ) :
24 | WP f1 #() {{ Ψ1 }} -∗ WP f2 #() {{ Ψ2 }} -∗
25 | (▷ ∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
26 | WP par f1 f2 {{ Φ }}.
27 | Proof.
28 | iIntros "Hf1 Hf2 HΦ". wp_lam. wp_let.
29 | wp_apply (spawn_spec parN with "Hf1"). iIntros (l) "Hl".
30 | wp_let. wp_bind (f2 _).
31 | wp_apply (pgl_wp_wand with "Hf2") as (v) "H2". wp_let.
32 | wp_apply (join_spec with "[$Hl]") as (w) "H1".
33 | iSpecialize ("HΦ" with "[$H1 $H2]"). by wp_pures.
34 | Qed.
35 |
36 | Lemma wp_par (Ψ1 Ψ2 : val → iProp Σ) (e1 e2 : expr) (Φ : val → iProp Σ) :
37 | WP e1 {{ Ψ1 }} -∗ WP e2 {{ Ψ2 }} -∗
38 | (∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
39 | WP (e1 ||| e2)%V {{ Φ }}.
40 | Proof.
41 | iIntros "H1 H2 H".
42 | wp_apply (par_spec Ψ1 Ψ2 with "[H1] [H2] [H]"); [by wp_lam..|auto].
43 | Qed.
44 | End proof.
45 |
--------------------------------------------------------------------------------
/theories/coneris/lib/spawn.v:
--------------------------------------------------------------------------------
1 | From iris.prelude Require Import options.
2 | From clutch.coneris Require Import coneris.
3 | From iris.algebra Require Import excl.
4 | From iris.base_logic.lib Require Export invariants.
5 | From iris.proofmode Require Import proofmode.
6 |
7 | Definition spawn : val :=
8 | λ: "f",
9 | let: "c" := ref NONE in
10 | Fork ("c" <- SOME ("f" #())) ;; "c".
11 | Definition join : val :=
12 | rec: "join" "c" :=
13 | match: !"c" with
14 | SOME "x" => "x"
15 | | NONE => "join" "c"
16 | end.
17 |
18 | (** The CMRA & functor we need. *)
19 | (* Not bundling heapGS, as it may be shared with other users. *)
20 | Class spawnG Σ := SpawnG { spawn_tokG : inG Σ (exclR unitO) }.
21 | Local Existing Instance spawn_tokG.
22 |
23 | Definition spawnΣ : gFunctors := #[GFunctor (exclR unitO)].
24 |
25 | Global Instance subG_spawnΣ {Σ} : subG spawnΣ Σ → spawnG Σ.
26 | Proof. solve_inG. Qed.
27 |
28 | (** Now we come to the Iris part of the proof. *)
29 | Section proof.
30 | Context `{!conerisGS Σ, !spawnG Σ} (N : namespace).
31 |
32 | Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
33 | ∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌝ ∨
34 | ∃ w, ⌜lv = SOMEV w⌝ ∗ (Ψ w ∨ own γ (Excl ()))).
35 |
36 | Definition join_handle (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
37 | ∃ γ, own γ (Excl ()) ∗ inv N (spawn_inv γ l Ψ).
38 |
39 | Global Instance spawn_inv_ne n γ l :
40 | Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
41 | Proof. solve_proper. Qed.
42 | Global Instance join_handle_ne n l :
43 | Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
44 | Proof. solve_proper. Qed.
45 |
46 | (** The main proofs. *)
47 | Lemma spawn_spec (Ψ : val → iProp Σ) (f : val) :
48 | {{{ WP f #() {{ Ψ }} }}} spawn f {{{ l, RET #l; join_handle l Ψ }}}.
49 | Proof.
50 | iIntros (Φ) "Hf HΦ". rewrite /spawn /=. wp_lam.
51 | wp_alloc l as "Hl".
52 | iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
53 | iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
54 | { iNext. iExists NONEV. iFrame; eauto. }
55 | wp_smart_apply (wp_fork with "[Hf]").
56 | - iNext. wp_bind (f _). iApply (pgl_wp_wand with "Hf"); iIntros (v) "Hv".
57 | wp_inj. iInv N as (v') "[Hl _]".
58 | wp_store. iSplitL; last done. iIntros "!> !>". iExists (SOMEV v). iFrame. eauto.
59 | - wp_pures. iApply "HΦ". rewrite /join_handle. eauto.
60 | Qed.
61 |
62 | Lemma join_spec (Ψ : val → iProp Σ) l :
63 | {{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
64 | Proof.
65 | iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
66 | iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]".
67 | wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
68 | - iModIntro. iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
69 | wp_smart_apply ("IH" with "Hγ [HΦ]"). auto.
70 | - iDestruct "Hinv" as (v' ->) "[HΨ|Hγ']".
71 | + iModIntro. iSplitL "Hl Hγ"; [iNext; iExists _; iFrame; eauto|].
72 | wp_pures. by iApply "HΦ".
73 | + iCombine "Hγ Hγ'" gives %[].
74 | Qed.
75 | End proof.
76 |
77 | Global Typeclasses Opaque join_handle.
78 |
--------------------------------------------------------------------------------
/theories/coneris/lib/spin_lock.v:
--------------------------------------------------------------------------------
1 | From iris.proofmode Require Import proofmode.
2 | From iris.base_logic Require Import lib.token.
3 | From clutch Require Import coneris.
4 | From clutch.coneris.lib Require Export lock.
5 | From iris.prelude Require Import options.
6 |
7 | Local Definition newlock : val := λ: <>, ref #false.
8 | Local Definition try_acquire : val := λ: "l", CAS "l" #false #true.
9 | Local Definition acquire : val :=
10 | rec: "acquire" "l" := if: try_acquire "l" then #() else "acquire" "l".
11 | Local Definition release : val := λ: "l", "l" <- #false.
12 | (** The CMRA we need. *)
13 | Class spin_lockG Σ := LockG { lock_tokG : tokenG Σ }.
14 | Local Existing Instance lock_tokG.
15 | Definition spin_lockΣ : gFunctors := #[tokenΣ].
16 | Global Instance subG_spin_lockΣ {Σ} : subG spin_lockΣ Σ → spin_lockG Σ.
17 | Proof. solve_inG. Qed.
18 | Section proof.
19 | Context `{!conerisGS Σ, !spin_lockG Σ}.
20 | Let N := nroot .@ "spin_lock".
21 | Local Definition lock_inv (γ : gname) (l : loc) (R : iProp Σ) : iProp Σ :=
22 | ∃ b : bool, l ↦ #b ∗ if b then True else token γ ∗ R.
23 | Local Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
24 | ∃ l: loc, ⌜lk = #l⌝ ∧ inv N (lock_inv γ l R).
25 | Local Definition locked (γ : gname) : iProp Σ := token γ.
26 | Local Lemma locked_exclusive (γ : gname) : locked γ -∗ locked γ -∗ False.
27 | Proof. iIntros "H1 H2". by iCombine "H1 H2" gives %?. Qed.
28 | (** The main proofs. *)
29 | Local Lemma is_lock_iff γ lk R1 R2 :
30 | is_lock γ lk R1 -∗ ▷ □ (R1 ∗-∗ R2) -∗ is_lock γ lk R2.
31 | Proof.
32 | iDestruct 1 as (l ->) "#Hinv"; iIntros "#HR".
33 | iExists l; iSplit; [done|]. iApply (inv_iff with "Hinv").
34 | iIntros "!> !>"; iSplit; iDestruct 1 as (b) "[Hl H]";
35 | iExists b; iFrame "Hl"; destruct b;
36 | first [done|iDestruct "H" as "[$ ?]"; by iApply "HR"].
37 | Qed.
38 | Local Lemma newlock_spec (R : iProp Σ):
39 | {{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
40 | Proof.
41 | iIntros (Φ) "HR HΦ". rewrite /newlock /=.
42 | wp_lam. wp_alloc l as "Hl".
43 | iMod token_alloc as (γ) "Hγ".
44 | iMod (inv_alloc N _ (lock_inv γ l R) with "[-HΦ]") as "#?".
45 | { iIntros "!>". iExists false. by iFrame. }
46 | iModIntro. iApply "HΦ". iExists l. eauto.
47 | Qed.
48 | Local Lemma try_acquire_spec γ lk R :
49 | {{{ is_lock γ lk R }}} try_acquire lk
50 | {{{ b, RET #b; if b is true then locked γ ∗ R else True }}}.
51 | Proof.
52 | iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l ->) "#Hinv".
53 | wp_rec. wp_bind (CmpXchg _ _ _). iInv N as ([]) "[Hl HR]".
54 | - wp_cmpxchg_fail. iModIntro. iSplitL "Hl". { iNext. iExists true; eauto. }
55 | wp_pures. iApply ("HΦ" $! false). done.
56 | - wp_cmpxchg_suc. iDestruct "HR" as "[Hγ HR]".
57 | iModIntro. iSplitL "Hl". { iNext; iExists true; eauto. }
58 | rewrite /locked. wp_pures. by iApply ("HΦ" $! true with "[$Hγ $HR]").
59 | Qed.
60 | Local Lemma acquire_spec γ lk R :
61 | {{{ is_lock γ lk R }}} acquire lk {{{ RET #(); locked γ ∗ R }}}.
62 | Proof.
63 | iIntros (Φ) "#Hl HΦ". iLöb as "IH". wp_rec.
64 | wp_apply (try_acquire_spec with "Hl"). iIntros ([]).
65 | - iIntros "[Hlked HR]". wp_if. iApply "HΦ"; auto with iFrame.
66 | - iIntros "_". wp_if. iApply ("IH" with "[HΦ]"). auto.
67 | Qed.
68 | Local Lemma release_spec γ lk R :
69 | {{{ is_lock γ lk R ∗ locked γ ∗ R }}} release lk {{{ RET #(); True }}}.
70 | Proof.
71 | iIntros (Φ) "(Hlock & Hlocked & HR) HΦ".
72 | iDestruct "Hlock" as (l ->) "#Hinv".
73 | rewrite /release /=. wp_lam. iInv N as (b) "[Hl _]".
74 | wp_store. iSplitR "HΦ"; last by iApply "HΦ".
75 | iModIntro. iNext. iExists false. by iFrame.
76 | Qed.
77 | End proof.
78 | (* NOT an instance because users should choose explicitly to use it
79 | (using [Explicit Instance]). *)
80 | Definition spin_lock : lock :=
81 | {| lock.lockG := spin_lockG;
82 | lock.locked_exclusive _ _ _ := locked_exclusive;
83 | lock.is_lock_iff _ _ _ := is_lock_iff;
84 | lock.newlock_spec _ _ _ := newlock_spec;
85 | lock.acquire_spec _ _ _ := acquire_spec;
86 | lock.release_spec _ _ _ := release_spec |}.
87 |
--------------------------------------------------------------------------------
/theories/coneris/proofmode.v:
--------------------------------------------------------------------------------
1 | From clutch.con_prob_lang Require Import lang notation class_instances tactics.
2 | From clutch.con_prob_lang Require Export wp_tactics.
3 | From clutch.coneris Require Import weakestpre primitive_laws derived_laws.
4 | From iris.prelude Require Import options.
5 |
6 | #[global] Program Instance rel_logic_wptactics_base `{!conerisGS Σ} : GwpTacticsBase Σ unit wp.
7 | Next Obligation. intros. by apply pgl_wp_value. Qed.
8 | Next Obligation. intros. by apply pgl_wp_fupd. Qed.
9 |
10 | #[global] Program Instance rel_logic_wptactics_bind `{!conerisGS Σ} : GwpTacticsBind Σ unit wp.
11 | Next Obligation. intros. by apply pgl_wp_bind. Qed.
12 |
13 | #[global] Program Instance rel_logic_wptactics_pure `{!conerisGS Σ} : GwpTacticsPure Σ unit true wp.
14 | Next Obligation. intros. by eapply lifting.wp_pure_step_later. Qed.
15 |
16 | #[global] Program Instance rel_logic_wptactics_heap `{!conerisGS Σ} : GwpTacticsHeap Σ unit true wp :=
17 | Build_GwpTacticsHeap _ _ _ _ (λ l q v, (l ↦{q} v)%I) (λ l q vs, (l ↦∗{q} vs)%I) _ _ _ _.
18 | Next Obligation. intros. by apply wp_alloc. Qed.
19 | Next Obligation. intros. by apply wp_allocN. Qed.
20 | Next Obligation. intros. by apply wp_load. Qed.
21 | Next Obligation. intros. by apply wp_store. Qed.
22 |
23 | #[global] Program Instance rel_logic_wptactics_tape `{!conerisGS Σ} : GwpTacticsTapes Σ unit true wp :=
24 | Build_GwpTacticsTapes _ _ _ _ (λ l q N ns, (l ↪N ( N ; ns ))%I) _ _.
25 | Next Obligation. intros. by apply wp_alloc_tape. Qed.
26 | Next Obligation. intros. rewrite (bi.wand_curry (l↪N(N;ns))). by apply wp_rand_tape. Qed.
27 |
28 | #[global] Program Instance rel_logic_wptactics_atomic_concurrency `{!conerisGS Σ} : GwpTacticsAtomicConcurrency Σ unit true wp :=
29 | Build_GwpTacticsAtomicConcurrency _ _ _ _ (λ l q v, (l ↦{q} v)%I) _ _ _ _.
30 | Next Obligation. intros. by apply wp_cmpxchg_fail. Qed.
31 | Next Obligation. intros. by apply wp_cmpxchg_suc. Qed.
32 | Next Obligation. intros. by apply wp_xchg. Qed.
33 | Next Obligation. intros. by apply wp_faa. Qed.
34 |
35 |
36 | #[global] Program Instance rel_logic_wptactics_frame_wand `{!conerisGS Σ} : GwpTacticsFrameWand Σ unit true wp :=
37 | Build_GwpTacticsFrameWand _ _ _ _ _.
38 | Next Obligation. iIntros (???????) "H1 H2". by iApply (pgl_wp_frame_wand with "[H1][$]"). Qed.
39 |
--------------------------------------------------------------------------------
/theories/eris/ectx_lifting.v:
--------------------------------------------------------------------------------
1 | (** Some derived lemmas for ectx-based languages *)
2 | From iris.proofmode Require Import proofmode.
3 | From clutch.common Require Import ectx_language.
4 | From clutch.eris Require Import weakestpre lifting.
5 | From iris.prelude Require Import options.
6 |
7 | Local Open Scope R.
8 |
9 | Section wp.
10 | Context {Λ : ectxLanguage} `{!erisWpGS Λ Σ} {Hinh : Inhabited (state Λ)}.
11 | Implicit Types P : iProp Σ.
12 | Implicit Types Φ : val Λ → iProp Σ.
13 | Implicit Types v : val Λ.
14 | Implicit Types e : expr Λ.
15 | Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
16 | Local Hint Resolve head_stuck_stuck : core.
17 |
18 | Lemma wp_lift_head_step_fupd_couple {E Φ} e1 s :
19 | to_val e1 = None →
20 | (∀ σ1 ε1,
21 | state_interp σ1 ∗ err_interp ε1
22 | ={E,∅}=∗
23 | ⌜head_reducible e1 σ1⌝ ∗
24 | glm e1 σ1 ε1 (λ '(e2, σ2) ε2,
25 | ▷ |={∅,E}=> state_interp σ2 ∗ err_interp ε2 ∗ WP e2 @ s; E {{ Φ }}))
26 | ⊢ WP e1 @ s; E {{ Φ }}.
27 | Proof.
28 | iIntros (?) "H". iApply wp_lift_step_fupd_glm; [done|].
29 | iIntros (σ1 ε) "Hσε".
30 | iMod ("H" with "Hσε") as "[% H]"; iModIntro; auto.
31 | Qed.
32 |
33 | Lemma wp_lift_head_step {E Φ} e1 s :
34 | to_val e1 = None →
35 | (∀ σ1, state_interp σ1 ={E,∅}=∗
36 | ⌜head_reducible e1 σ1⌝ ∗
37 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={∅,E}=∗
38 | state_interp σ2 ∗ WP e2 @ s; E {{ Φ }})
39 | ⊢ WP e1 @ s; E {{ Φ }}.
40 | Proof.
41 | iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (?) "Hσ".
42 | iMod ("H" with "Hσ") as "[% H]"; iModIntro.
43 | iSplit.
44 | { iPureIntro. by eapply head_prim_reducible. }
45 | iIntros (???) "!> !>". iApply "H"; auto.
46 | Qed.
47 |
48 | Lemma wp_lift_atomic_head_step_fupd {E1 E2 Φ} e1 s :
49 | to_val e1 = None →
50 | (∀ σ1, state_interp σ1 ={E1}=∗
51 | ⌜head_reducible e1 σ1⌝ ∗
52 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E1}[E2]▷=∗
53 | state_interp σ2 ∗
54 | from_option Φ False (to_val e2))
55 | ⊢ WP e1 @ s; E1 {{ Φ }}.
56 | Proof.
57 | iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
58 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
59 | iSplit.
60 | { iPureIntro. by apply head_prim_reducible. }
61 | iIntros (e2 σ2 Hstep).
62 | iApply "H"; eauto.
63 | Qed.
64 |
65 | Lemma wp_lift_atomic_head_step {E Φ} e1 s :
66 | to_val e1 = None →
67 | (∀ σ1, state_interp σ1 ={E}=∗
68 | ⌜head_reducible e1 σ1⌝ ∗
69 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E}=∗
70 | state_interp σ2 ∗
71 | from_option Φ False (to_val e2))
72 | ⊢ WP e1 @ s; E {{ Φ }}.
73 | Proof.
74 | iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
75 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
76 | iSplit.
77 | { iPureIntro. by apply head_prim_reducible. }
78 | iNext. iIntros (e2 σ2 Hstep).
79 | iApply "H"; eauto.
80 | Qed.
81 |
82 | Lemma wp_lift_pure_det_head_step {E E' Φ} e1 e2 s :
83 | to_val e1 = None →
84 | (∀ σ1, head_reducible e1 σ1) →
85 | (∀ σ1 e2' σ2,
86 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
87 | (|={E}[E']▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
88 | Proof using Hinh.
89 | intros. erewrite !(wp_lift_pure_det_step e1 e2); eauto.
90 | all: intros. all: by apply head_prim_reducible.
91 | Qed.
92 |
93 | Lemma wp_lift_pure_det_head_step' {E Φ} e1 e2 s :
94 | to_val e1 = None →
95 | (∀ σ1, head_reducible e1 σ1) →
96 | (∀ σ1 e2' σ2,
97 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
98 | ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
99 | Proof using Hinh.
100 | intros. rewrite -[(WP e1 @ _; _ {{ _ }})%I]wp_lift_pure_det_head_step //.
101 | rewrite -step_fupd_intro //.
102 | Qed.
103 | End wp.
104 |
--------------------------------------------------------------------------------
/theories/eris/eris.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import namespaces.
2 | From clutch.prob_lang Require Export notation tactics metatheory.
3 | From clutch.prob_lang Require Export lang.
4 | From clutch.eris Require Export lifting ectx_lifting primitive_laws derived_laws
5 | total_primitive_laws total_derived_laws proofmode error_rules.
6 |
--------------------------------------------------------------------------------
/theories/eris/examples/approximate_samplers/approx_rejection_sampler_presampled.v:
--------------------------------------------------------------------------------
1 | (** * Examples related to rejection samplers with a bounded number of attempts *)
2 | From clutch.eris Require Export eris error_rules.
3 | From clutch.eris Require Export examples.approximate_samplers.approx_sampler_lib.
4 | From Coquelicot Require Import Series.
5 | Require Import Lra.
6 |
7 | Set Default Proof Using "Type*".
8 |
9 | Section presampled_flip2.
10 | (** Demonstration of using the planner rule instead of the higher-order spec *)
11 | (** This proof is fairly idiomatic Iris and does not need to do manual credit accounting *)
12 | Local Open Scope R.
13 | Context `{!erisGS Σ}.
14 |
15 | Lemma tapes_flip2_safe (ε : nonnegreal) E :
16 | 0 < ε ->
17 | ⊢ ↯ε -∗
18 | WP
19 | let: "α" := (alloc #(Z.succ 0)) in
20 | gen_rejection_sampler
21 | (λ: "_", Pair (rand("α")#1) (rand("α") #1))
22 | (λ: "sample", (((Fst "sample") = #1) && ((Snd "sample") = #1)))
23 | @ E [{ v, ⌜ v = (#1%Z, #1%Z)%V ⌝ }].
24 | Proof.
25 | iIntros (?) "Hcr".
26 | wp_bind (alloc _)%I.
27 | wp_apply (twp_alloc_tape); auto.
28 | iIntros (α) "Hα".
29 | rewrite Z2Nat.inj_succ; try lia.
30 | wp_apply (twp_presample_planner_aligned _ _ _ _ _ _ _ _ [1%fin; 1%fin]); auto; [apply H|].
31 | iFrame.
32 | iIntros "[%junk Hα] /=".
33 | pose flip2_junk_inv k s : iProp Σ := (∃ j, α ↪ (S (Z.to_nat 0); j ++ s) ∗ ⌜length j = (2 * k)%nat ⌝)%I.
34 | iAssert (flip2_junk_inv _ _ _ (length (junk ++ block_pad (Z.to_nat 0) 2 junk) `div` 2) _) with "[Hα]" as "Hinv".
35 | { rewrite /flip2_junk_inv app_assoc.
36 | iExists _; iFrame; iPureIntro.
37 | apply Nat.Div0.div_exact.
38 | rewrite app_length.
39 | apply (blocks_aligned (Z.to_nat 0%nat) 2%nat).
40 | lia.
41 | }
42 | do 11 wp_pure.
43 | iInduction (length (junk ++ block_pad (Z.to_nat 0) 2 junk) `div` 2) as [|k'] "IH".
44 | - rewrite /flip2_junk_inv /=.
45 | iDestruct "Hinv" as "[%j (Hα & %Hl)] /=".
46 | rewrite (nil_length_inv _ Hl) /=.
47 | wp_pures.
48 | wp_bind (Rand _ _); wp_apply (twp_rand_tape with "Hα"); iIntros "Hα".
49 | wp_bind (Rand _ _); wp_apply (twp_rand_tape with "Hα"); iIntros "Hα".
50 | wp_pures.
51 | iModIntro; eauto.
52 | - rewrite /flip2_junk_inv.
53 | iDestruct "Hinv" as "[%j (Hα & %Hl)] /=".
54 | rewrite Nat.mul_succ_r Nat.add_comm /= in Hl.
55 | destruct j as [| s0 j0]. { simpl in Hl. exfalso; lia. }
56 | destruct j0 as [| s1 j']. { simpl in Hl. exfalso; lia. }
57 | wp_pures.
58 | wp_bind (Rand _ _); wp_apply (twp_rand_tape with "Hα"); iIntros "Hα".
59 | wp_bind (Rand _ _); wp_apply (twp_rand_tape with "Hα"); iIntros "Hα".
60 | iSpecialize ("IH" with "[Hα]").
61 | { iExists _; iFrame; iPureIntro. do 2 rewrite cons_length in Hl. congruence. }
62 | wp_pures.
63 | case_bool_decide; [wp_pures; case_bool_decide|].
64 | + wp_pures. iModIntro; iPureIntro.
65 | rewrite H0 H1. done.
66 | + wp_pure. iApply "IH".
67 | + do 2 wp_pure; iApply "IH".
68 | Qed.
69 | End presampled_flip2.
70 |
--------------------------------------------------------------------------------
/theories/eris/examples/noproph.v:
--------------------------------------------------------------------------------
1 | From clutch.eris Require Export eris lib.map.
2 | Set Default Proof Using "Type*".
3 |
4 | (* Prophecy variables are unsound with up-to-bad reasoning *)
5 |
6 | Module counter_example.
7 | Context `{!erisGS Σ}.
8 |
9 | Axiom NewProph : val.
10 | Axiom ResolveProph : val.
11 | Axiom proph_id : Set.
12 | Axiom proph : proph_id → list (val * val) → iProp Σ.
13 | Axiom LitProphecy : proph_id → base_lit.
14 |
15 | Axiom wp_new_proph :
16 | {{{ True }}}
17 | NewProph #()
18 | {{{ pvs p, RET (LitV (LitProphecy p)); proph p pvs }}}.
19 |
20 | Axiom wp_resolve_proph :
21 | ∀ s E (p : proph_id) (pvs : list (val * val)) v,
22 | {{{ proph p pvs }}}
23 | ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
24 | {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
25 |
26 | Definition bad : expr :=
27 | let: "p" := NewProph #() in
28 | let: "x" := (rand #99) in
29 | (ResolveProph "p" "x").
30 |
31 | Lemma falso :
32 | ↯ (nnreal_inv(nnreal_nat(100))) ⊢ WP bad {{ _, False%I }}.
33 | Proof.
34 | iIntros "Hcred".
35 | rewrite /bad.
36 | wp_apply (wp_new_proph with "[//]").
37 | iIntros (pvs p) "Hproph".
38 | wp_pures.
39 | destruct pvs as [|(?&v) ?].
40 | { wp_apply (wp_rand with "[//]").
41 | iIntros (?) "_". wp_pures.
42 | wp_apply (wp_resolve_proph with "[$]").
43 | iIntros (?) "(%Hbad&?)". congruence.
44 | }
45 | assert ((∃ z : Z, v = LitV $ LitInt $ z) ∨ (∀ z : Z, v ≠ LitV $ LitInt $ z)) as Hcases.
46 | { destruct v; firstorder. destruct l; firstorder. eauto. }
47 | destruct Hcases as [Hz|Hnz]; last first.
48 | {
49 | wp_apply (wp_rand with "[//]").
50 | iIntros (?) "_". wp_pures.
51 | wp_apply (wp_resolve_proph with "[$]").
52 | iIntros (?) "(%Hbad&?)". congruence.
53 | }
54 |
55 | destruct Hz as (z&->).
56 | wp_apply (wp_rand_err_nat 99 _ (Z.to_nat z)); iFrame "Hcred".
57 | iIntros (x Hneq). wp_pures.
58 | wp_apply (wp_resolve_proph with "[$]").
59 | iIntros (?) "(%Heq&Hproph)".
60 | inversion Heq. subst. lia.
61 | Qed.
62 |
63 | End counter_example.
64 |
--------------------------------------------------------------------------------
/theories/eris/proofmode.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation class_instances tactics.
2 | From clutch.prob_lang Require Export wp_tactics.
3 | From clutch.eris Require Import weakestpre primitive_laws derived_laws.
4 | From clutch.eris Require Import total_weakestpre total_primitive_laws total_derived_laws.
5 | From iris.prelude Require Import options.
6 |
7 | #[global] Program Instance rel_logic_wptactics_base `{!erisGS Σ} : GwpTacticsBase Σ unit wp.
8 | Next Obligation. intros. by apply pgl_wp_value. Qed.
9 | Next Obligation. intros. by apply pgl_wp_fupd. Qed.
10 |
11 | #[global] Program Instance rel_logic_wptactics_bind `{!erisGS Σ} : GwpTacticsBind Σ unit wp.
12 | Next Obligation. intros. by apply pgl_wp_bind. Qed.
13 |
14 | #[global] Program Instance rel_logic_wptactics_pure `{!erisGS Σ} : GwpTacticsPure Σ unit true wp.
15 | Next Obligation. intros. by eapply lifting.wp_pure_step_later. Qed.
16 |
17 | #[global] Program Instance rel_logic_wptactics_heap `{!erisGS Σ} : GwpTacticsHeap Σ unit true wp :=
18 | Build_GwpTacticsHeap _ _ _ _ (λ l q v, (l ↦{q} v)%I) (λ l q vs, (l ↦∗{q} vs)%I) _ _ _ _.
19 | Next Obligation. intros. by apply wp_alloc. Qed.
20 | Next Obligation. intros. by apply wp_allocN. Qed.
21 | Next Obligation. intros. by apply wp_load. Qed.
22 | Next Obligation. intros. by apply wp_store. Qed.
23 |
24 | #[global] Program Instance rel_logic_twptactics_base `{!erisGS Σ} : GwpTacticsBase Σ unit twp.
25 | Next Obligation. intros. by apply tgl_wp_value. Qed.
26 | Next Obligation. intros. by apply tgl_wp_fupd. Qed.
27 |
28 | #[global] Program Instance rel_logic_twptactics_bind `{!erisGS Σ} : GwpTacticsBind Σ unit twp.
29 | Next Obligation. intros. by apply tgl_wp_bind. Qed.
30 |
31 | #[global] Program Instance rel_logic_twptactics_pure `{!erisGS Σ} : GwpTacticsPure Σ unit false twp.
32 | Next Obligation. intros. by eapply total_lifting.twp_pure_step_fupd. Qed.
33 |
34 | #[global] Program Instance rel_logic_twptactics_heap `{!erisGS Σ} : GwpTacticsHeap Σ unit false twp :=
35 | Build_GwpTacticsHeap _ _ _ _ (λ l q v, (l ↦{q} v)%I) (λ l q vs, (l ↦∗{q} vs)%I) _ _ _ _.
36 | Next Obligation. intros. by apply twp_alloc. Qed.
37 | Next Obligation. intros. by apply twp_allocN. Qed.
38 | Next Obligation. intros. iIntros ">H H2". iApply (twp_load with "[H //] [H2 //]"). Qed.
39 | Next Obligation. intros. iIntros ">H H2". iApply (twp_store with "[H //] [H2 //]"). Qed.
40 |
--------------------------------------------------------------------------------
/theories/eris/total_ectx_lifting.v:
--------------------------------------------------------------------------------
1 | From iris.proofmode Require Import proofmode.
2 | From clutch.common Require Import ectx_language.
3 | From clutch.eris Require Import total_weakestpre total_lifting.
4 |
5 | Local Open Scope R.
6 |
7 | Section twp.
8 | Context {Λ : ectxLanguage} `{!erisWpGS Λ Σ} {Hinh : Inhabited (state Λ)}.
9 | Implicit Types P : iProp Σ.
10 | Implicit Types Φ : val Λ → iProp Σ.
11 | Implicit Types v : val Λ.
12 | Implicit Types e : expr Λ.
13 | Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
14 | Local Hint Resolve head_stuck_stuck : core.
15 |
16 | Lemma twp_lift_head_step_glm {E Φ} e1 s :
17 | to_val e1 = None →
18 | (∀ σ1 ε1,
19 | state_interp σ1 ∗ err_interp ε1
20 | ={E,∅}=∗
21 | ⌜head_reducible e1 σ1⌝ ∗
22 | glm e1 σ1 ε1 (λ '(e2, σ2) ε2,
23 | |={∅,E}=> state_interp σ2 ∗ err_interp ε2 ∗ WP e2 @ s; E [{ Φ }]))
24 | ⊢ WP e1 @ s; E [{ Φ }].
25 | Proof.
26 | iIntros (?) "H". iApply twp_lift_step_fupd_glm; [done|].
27 | iIntros (σ1 ε1) "Hσε".
28 | iMod ("H" with "Hσε") as "[% H]"; iModIntro; auto.
29 | Qed.
30 |
31 | Lemma twp_lift_head_step {E Φ} e1 s :
32 | to_val e1 = None →
33 | (∀ σ1, state_interp σ1 ={E,∅}=∗
34 | ⌜head_reducible e1 σ1⌝ ∗
35 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={∅,E}=∗
36 | state_interp σ2 ∗ WP e2 @ s; E [{ Φ }])
37 | ⊢ WP e1 @ s; E [{ Φ }].
38 | Proof.
39 | iIntros (?) "H". iApply twp_lift_step_fupd; [done|]. iIntros (?) "Hσ".
40 | iMod ("H" with "Hσ") as "[% H]"; iModIntro.
41 | iSplit.
42 | { iPureIntro. by apply head_prim_reducible. }
43 | iIntros (???) "!>". iApply "H"; auto.
44 | Qed.
45 |
46 | Lemma twp_lift_atomic_head_step_fupd {E1 Φ} e1 s :
47 | to_val e1 = None →
48 | (∀ σ1, state_interp σ1 ={E1}=∗
49 | ⌜head_reducible e1 σ1⌝ ∗
50 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E1}=∗
51 | state_interp σ2 ∗
52 | from_option Φ False (to_val e2))
53 | ⊢ WP e1 @ s; E1 [{ Φ }].
54 | Proof.
55 | iIntros (?) "H". iApply twp_lift_atomic_step_fupd; [done|].
56 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
57 | iSplit.
58 | { iPureIntro. by apply head_prim_reducible. }
59 | iIntros (e2 σ2 Hstep).
60 | iApply "H"; eauto.
61 | Qed.
62 |
63 | Lemma twp_lift_atomic_head_step {E Φ} e1 s :
64 | to_val e1 = None →
65 | (∀ σ1, state_interp σ1 ={E}=∗
66 | ⌜head_reducible e1 σ1⌝ ∗
67 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E}=∗
68 | state_interp σ2 ∗
69 | from_option Φ False (to_val e2))
70 | ⊢ WP e1 @ s; E [{ Φ }].
71 | Proof.
72 | iIntros (?) "H". iApply twp_lift_atomic_step; eauto.
73 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
74 | iSplit.
75 | { iPureIntro. by apply head_prim_reducible. }
76 | iIntros (e2 σ2 Hstep).
77 | iApply "H"; eauto.
78 | Qed.
79 |
80 | Lemma twp_lift_pure_det_head_step {E Φ} e1 e2 s :
81 | to_val e1 = None →
82 | (∀ σ1, head_reducible e1 σ1) →
83 | (∀ σ1 e2' σ2,
84 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
85 | (|={E}=> WP e2 @ s; E [{ Φ }]) ⊢ WP e1 @ s; E [{ Φ }].
86 | Proof using Hinh.
87 | intros. erewrite !(twp_lift_pure_det_step e1 e2); eauto.
88 | all: intros. all: by apply head_prim_reducible.
89 | Qed.
90 |
91 | Lemma twp_lift_pure_det_head_step' {E Φ} e1 e2 s :
92 | to_val e1 = None →
93 | (∀ σ1, head_reducible e1 σ1) →
94 | (∀ σ1 e2' σ2,
95 | head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
96 | WP e2 @ s; E [{ Φ }] ⊢ WP e1 @ s; E [{ Φ }].
97 | Proof using Hinh.
98 | intros. rewrite -[(WP e1 @ _; _ [{ _ }])%I] twp_lift_pure_det_head_step //.
99 | iIntros. by iModIntro.
100 | Qed.
101 |
102 |
103 | End twp.
104 |
--------------------------------------------------------------------------------
/theories/foxtrot/ectx_lifting.v:
--------------------------------------------------------------------------------
1 | (** Some derived lemmas for ectx-based languages *)
2 | From iris.proofmode Require Import proofmode.
3 | From clutch.common Require Import con_ectx_language.
4 | From clutch.con_prob_lang Require Import lang.
5 | From clutch.foxtrot Require Import weakestpre lifting.
6 | From iris.prelude Require Import options.
7 |
8 | Local Open Scope R.
9 |
10 | Section ectx_lifting.
11 | Context `{!foxtrotWpGS con_prob_lang Σ}.
12 | Implicit Types P : iProp Σ.
13 | Implicit Types Φ : val con_prob_lang → iProp Σ.
14 | Implicit Types v : val con_prob_lang.
15 | Implicit Types e : expr con_prob_lang.
16 | Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
17 | Local Hint Resolve head_stuck_stuck : core.
18 |
19 |
20 | Lemma wp_lift_head_step_prog_couple {E Φ} e1 s :
21 | to_val e1 = None →
22 | (∀ σ1 ρ1 ε1,
23 | state_interp σ1 ∗ spec_interp ρ1 ∗ err_interp ε1 ={E,∅}=∗
24 | ⌜head_reducible e1 σ1⌝ ∗
25 | prog_coupl e1 σ1 ρ1 ε1 (λ e2 σ2 efs ρ2 ε2,
26 | ▷ |={∅,E}=> state_interp σ2 ∗ spec_interp ρ2 ∗
27 | err_interp ε2 ∗ WP e2 @ s; E {{ Φ }} ∗
28 | [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }}
29 | ))
30 | ⊢ WP e1 @ s; E {{ Φ }}.
31 | Proof.
32 | iIntros (?) "H". iApply wp_lift_step_prog_couple; [done|].
33 | iIntros (σ1 ρ1 ε1) "Hσ".
34 | by iMod ("H" with "Hσ") as "[% H]".
35 | Qed.
36 |
37 | Lemma wp_lift_head_step {E Φ} e1 s :
38 | to_val e1 = None →
39 | (∀ σ1, state_interp σ1 ={E,∅}=∗
40 | ⌜head_reducible e1 σ1⌝ ∗
41 | ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 (e2, σ2, efs) > 0⌝ ={∅,E}=∗
42 | state_interp σ2 ∗ WP e2 @ s; E {{ Φ }} ∗
43 | [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }})
44 | ⊢ WP e1 @ s; E {{ Φ }}.
45 | Proof.
46 | iIntros (?) "H". iApply wp_lift_step_later; [done|]. iIntros (?) "Hσ".
47 | iMod ("H" with "Hσ") as "[% H]"; iModIntro.
48 | iSplit.
49 | { iPureIntro. by apply head_prim_reducible. }
50 | iIntros (????) "!> !>". iApply "H"; auto.
51 | Qed.
52 |
53 | Lemma wp_lift_atomic_head_step_fupd {E1 E2 Φ} e1 s :
54 | to_val e1 = None →
55 | (∀ σ1, state_interp σ1 ={E1}=∗
56 | ⌜head_reducible e1 σ1⌝ ∗
57 | ∀ e2 σ2 efs, ⌜head_step e1 σ1 (e2, σ2, efs) > 0⌝ ={E1}[E2]▷=∗
58 | state_interp σ2 ∗
59 | from_option Φ False (to_val e2) ∗
60 | [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }}
61 | )
62 | ⊢ WP e1 @ s; E1 {{ Φ }}.
63 | Proof.
64 | iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
65 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
66 | iSplit.
67 | { iPureIntro. by apply head_prim_reducible. }
68 | iIntros (e2 σ2 efs Hstep).
69 | iApply "H"; eauto.
70 | Qed.
71 |
72 | Lemma wp_lift_atomic_head_step {E Φ} e1 s :
73 | to_val e1 = None →
74 | (∀ σ1, state_interp σ1 ={E}=∗
75 | ⌜head_reducible e1 σ1⌝ ∗
76 | ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 (e2, σ2, efs) > 0⌝ ={E}=∗
77 | state_interp σ2 ∗
78 | from_option Φ False (to_val e2) ∗
79 | [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ fork_post }} )
80 | ⊢ WP e1 @ s; E {{ Φ }}.
81 | Proof.
82 | iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
83 | iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
84 | iSplit.
85 | { iPureIntro. by apply head_prim_reducible. }
86 | iNext. iIntros (e2 σ2 efs Hstep).
87 | iApply "H"; eauto.
88 | Qed.
89 |
90 | Lemma wp_lift_pure_det_head_step_no_fork {E E' Φ} e1 e2 s :
91 | to_val e1 = None →
92 | (∀ σ1, head_reducible e1 σ1) →
93 | (∀ σ1 e2' σ2 efs,
94 | head_step e1 σ1 (e2', σ2, efs) > 0 → σ2 = σ1 ∧ e2' = e2 /\ efs = []) →
95 | (|={E}[E']▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
96 | Proof.
97 | simpl.
98 | intros. erewrite !(wp_lift_pure_det_step_no_fork e1 e2); eauto.
99 | all: intros. all: by apply head_prim_reducible.
100 | Qed.
101 |
102 | Lemma wp_lift_pure_det_head_step_no_fork' {E Φ} e1 e2 s :
103 | to_val e1 = None →
104 | (∀ σ1, head_reducible e1 σ1) →
105 | (∀ σ1 e2' σ2 efs,
106 | head_step e1 σ1 (e2', σ2, efs) > 0 → σ2 = σ1 ∧ e2' = e2 /\ efs = []) →
107 | ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
108 | Proof.
109 | intros. rewrite -[(WP e1 @ _ ; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //.
110 | rewrite -step_fupd_intro //.
111 | Qed.
112 |
113 | End ectx_lifting.
114 |
--------------------------------------------------------------------------------
/theories/foxtrot/primitive_laws.v:
--------------------------------------------------------------------------------
1 | (** This file proves the basic laws of the ProbLang weakest precondition by
2 | applying the lifting lemmas. *)
3 | From iris.proofmode Require Import proofmode.
4 | From iris.base_logic.lib Require Export ghost_map.
5 | From clutch.base_logic Require Export error_credits.
6 | From clutch.foxtrot Require Export weakestpre ectx_lifting.
7 | From clutch.con_prob_lang Require Export class_instances.
8 | From clutch.con_prob_lang Require Import tactics lang notation metatheory.
9 | From clutch.con_prob_lang.spec Require Export spec_ra.
10 | From iris.prelude Require Import options.
11 |
12 | Class foxtrotGS Σ := HeapG {
13 | foxtrotGS_invG : invGS_gen HasNoLc Σ;
14 | (* CMRA for the state *)
15 | foxtrotGS_heap : ghost_mapG Σ loc val;
16 | foxtrotGS_tapes : ghost_mapG Σ loc tape;
17 | (* ghost names for the state *)
18 | foxtrotGS_heap_name : gname;
19 | foxtrotGS_tapes_name : gname;
20 | (* CMRA and ghost name for the spec *)
21 | foxtrotGS_spec :: specG_con_prob_lang Σ;
22 | (* CMRA and ghost name for the error *)
23 | foxtrotGS_error :: ecGS Σ;
24 | }.
25 |
26 | Class foxtrotGpreS Σ := FoxtrotGpreS {
27 | foxtrotGpreS_iris :: invGpreS Σ;
28 | foxtrotGpreS_heap :: ghost_mapG Σ loc val;
29 | foxtrotGpreS_tapes :: ghost_mapG Σ loc tape;
30 | foxtrotGpreS_spec :: specGpreS Σ;
31 | foxtrotGpreS_err :: ecGpreS Σ;
32 | }.
33 |
34 | Definition foxtrotΣ : gFunctors :=
35 | #[invΣ;
36 | ghost_mapΣ loc val;
37 | ghost_mapΣ loc tape;
38 | specΣ;
39 | ecΣ].
40 | Global Instance subG_foxtrotGPreS {Σ} : subG foxtrotΣ Σ → foxtrotGpreS Σ.
41 | Proof. solve_inG. Qed.
42 |
43 | Definition heap_auth `{foxtrotGS Σ} :=
44 | @ghost_map_auth _ _ _ _ _ foxtrotGS_heap foxtrotGS_heap_name.
45 | Definition tapes_auth `{foxtrotGS Σ} :=
46 | @ghost_map_auth _ _ _ _ _ foxtrotGS_tapes foxtrotGS_tapes_name.
47 |
48 | Global Instance foxtrotGS_irisGS `{!foxtrotGS Σ} : foxtrotWpGS con_prob_lang Σ := {
49 | foxtrotWpGS_invGS := foxtrotGS_invG;
50 | state_interp σ := (heap_auth 1 σ.(heap) ∗ tapes_auth 1 σ.(tapes))%I;
51 | spec_interp ρ := spec_auth ρ;
52 | fork_post v := True%I;
53 | err_interp := ec_supply;
54 | }.
55 |
56 | (** Heap *)
57 | Notation "l ↦{ dq } v" := (@ghost_map_elem _ _ _ _ _ foxtrotGS_heap foxtrotGS_heap_name l dq v)
58 | (at level 20, format "l ↦{ dq } v") : bi_scope.
59 | Notation "l ↦□ v" := (l ↦{ DfracDiscarded } v)%I
60 | (at level 20, format "l ↦□ v") : bi_scope.
61 | Notation "l ↦{# q } v" := (l ↦{ DfracOwn q } v)%I
62 | (at level 20, format "l ↦{# q } v") : bi_scope.
63 | Notation "l ↦ v" := (l ↦{ DfracOwn 1 } v)%I
64 | (at level 20, format "l ↦ v") : bi_scope.
65 |
66 | (** Tapes *)
67 | Notation "l ↪{ dq } v" := (@ghost_map_elem _ _ tape _ _ foxtrotGS_tapes foxtrotGS_tapes_name l dq v)
68 | (at level 20, format "l ↪{ dq } v") : bi_scope.
69 | Notation "l ↪□ v" := (l ↪{ DfracDiscarded } v)%I
70 | (at level 20, format "l ↪□ v") : bi_scope.
71 | Notation "l ↪{# q } v" := (l ↪{ DfracOwn q } v)%I
72 | (at level 20, format "l ↪{# q } v") : bi_scope.
73 | Notation "l ↪ v" := (l ↪{ DfracOwn 1 } v)%I
74 | (at level 20, format "l ↪ v") : bi_scope.
75 |
76 | (** User-level tapes *)
77 | Definition nat_tape `{foxtrotGS Σ} l (N : nat) (ns : list nat) : iProp Σ :=
78 | ∃ (fs : list (fin (S N))), ⌜fin_to_nat <$> fs = ns⌝ ∗ l ↪ (N; fs).
79 |
80 | Notation "l ↪N ( M ; ns )" := (nat_tape l M ns)%I
81 | (at level 20, format "l ↪N ( M ; ns )") : bi_scope.
82 |
--------------------------------------------------------------------------------
/theories/meas_lang/ctx_subst.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import base stringmap fin_sets fin_map_dom.
2 | From clutch.meas_lang Require Export lang metatheory ectx_language ectxi_language.
3 |
4 | (*
5 | (** Substitution in the contexts *)
6 | Definition subst_map_ctx_item (es : stringmap val) (K : ectx_item) :=
7 | match K with
8 | | AppLCtx v2 => AppLCtx v2
9 | | AppRCtx e1 => AppRCtx (subst_map es e1)
10 | | UnOpCtx op => UnOpCtx op
11 | | BinOpLCtx op v2 => BinOpLCtx op v2
12 | | BinOpRCtx op e1 => BinOpRCtx op (subst_map es e1)
13 | | IfCtx e1 e2 => IfCtx (subst_map es e1) (subst_map es e2)
14 | | PairLCtx v2 => PairLCtx v2
15 | | PairRCtx e1 => PairRCtx (subst_map es e1)
16 | | FstCtx => FstCtx
17 | | SndCtx => SndCtx
18 | | InjLCtx => InjLCtx
19 | | InjRCtx => InjRCtx
20 | | CaseCtx e1 e2 => CaseCtx (subst_map es e1) (subst_map es e2)
21 | | AllocNLCtx v2 => AllocNLCtx v2
22 | | AllocNRCtx e1 => AllocNRCtx (subst_map es e1)
23 | | LoadCtx => LoadCtx
24 | | StoreLCtx v2 => StoreLCtx v2
25 | | StoreRCtx e1 => StoreRCtx (subst_map es e1)
26 | | AllocTapeCtx => AllocTapeCtx
27 | | RandLCtx v2 => RandLCtx v2
28 | | RandRCtx e1 => RandRCtx (subst_map es e1)
29 | | TickCtx => TickCtx
30 | end.
31 |
32 | Definition subst_map_ctx (es : stringmap val) (K : list ectx_item) :=
33 | map (subst_map_ctx_item es) K.
34 |
35 | Lemma subst_map_fill_item (vs : stringmap val) (Ki : ectx_item) (e : expr) :
36 | subst_map vs (fill_item Ki e) =
37 | fill_item (subst_map_ctx_item vs Ki) (subst_map vs e).
38 | Proof. induction Ki; simpl; eauto with f_equal. Qed.
39 |
40 | Lemma subst_map_fill (vs : stringmap val) (K : list ectx_item) (e : expr) :
41 | subst_map vs (fill K e) = fill (subst_map_ctx vs K) (subst_map vs e).
42 | Proof.
43 | generalize dependent e. generalize dependent vs.
44 | induction K as [|Ki K]; eauto.
45 | intros es e. simpl.
46 | by rewrite IHK subst_map_fill_item.
47 | Qed.
48 | *)
49 |
--------------------------------------------------------------------------------
/theories/meas_lang/exec_lang.v:
--------------------------------------------------------------------------------
1 | (* TODO move into metatheory.v ? *)
2 |
3 | From Coq Require Export Reals Psatz.
4 | From clutch.meas_lang Require Import lang.
5 |
6 | (*
7 | Lemma exec_det_step_ctx K `{!LanguageCtx K} n ρ (e1 e2 : expr) σ1 σ2 :
8 | prim_step e1 σ1 (e2, σ2) = 1%R →
9 | pexec n ρ (K e1, σ1) = 1%R →
10 | pexec (S n) ρ (K e2, σ2) = 1%R.
11 | Proof.
12 | intros. eapply pexec_det_step; [|done].
13 | rewrite -fill_step_prob //.
14 | eapply (val_stuck _ σ1 (e2, σ2)).
15 | rewrite H. lra.
16 | Qed.
17 |
18 | Lemma exec_PureExec_ctx K `{!LanguageCtx K} (P : Prop) m n ρ (e e' : expr) σ :
19 | P →
20 | PureExec P n e e' →
21 | pexec m ρ (K e, σ) = 1 →
22 | pexec (m + n) ρ (K e', σ) = 1.
23 | Proof.
24 | move=> HP /(_ HP).
25 | destruct ρ as [e0 σ0].
26 | revert e e' m. induction n=> e e' m.
27 | { rewrite -plus_n_O. by inversion 1. }
28 | intros (e'' & Hsteps & Hpstep)%nsteps_inv_r Hdet.
29 | specialize (IHn _ _ m Hsteps Hdet).
30 | rewrite -plus_n_Sm.
31 | eapply exec_det_step_ctx; [done| |done].
32 | apply Hpstep.
33 | Qed.
34 |
35 | Lemma stepN_det_step_ctx K `{!LanguageCtx K} n ρ (e1 e2 : expr) σ1 σ2 :
36 | prim_step e1 σ1 (e2, σ2) = 1%R →
37 | stepN n ρ (K e1, σ1) = 1%R →
38 | stepN (S n) ρ (K e2, σ2) = 1%R.
39 | Proof.
40 | intros.
41 | rewrite -Nat.add_1_r.
42 | erewrite (stepN_det_trans n 1); [done|done|].
43 | rewrite stepN_Sn /=.
44 | rewrite dret_id_right.
45 | rewrite -fill_step_prob //.
46 | eapply (val_stuck _ σ1 (e2, σ2)).
47 | rewrite H. lra.
48 | Qed.
49 |
50 | Lemma stepN_PureExec_ctx K `{!LanguageCtx K} (P : Prop) m n ρ (e e' : expr) σ :
51 | P →
52 | PureExec P n e e' →
53 | stepN m ρ (K e, σ) = 1 →
54 | stepN (m + n) ρ (K e', σ) = 1.
55 | Proof.
56 | move=> HP /(_ HP).
57 | destruct ρ as [e0 σ0].
58 | revert e e' m. induction n=> e e' m.
59 | { rewrite -plus_n_O. by inversion 1. }
60 | intros (e'' & Hsteps & Hpstep)%nsteps_inv_r Hdet.
61 | specialize (IHn _ _ m Hsteps Hdet).
62 | rewrite -plus_n_Sm.
63 | eapply stepN_det_step_ctx; [done| |done].
64 | apply Hpstep.
65 | Qed.
66 | *)
67 |
--------------------------------------------------------------------------------
/theories/meas_lang/tactics.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import Reals Psatz.
2 | From stdpp Require Import fin_maps.
3 | From iris.proofmode Require Import environments proofmode.
4 | From clutch.meas_lang Require Import lang ectx_language.
5 | From iris.prelude Require Import options.
6 | Import meas_lang.
7 |
8 | (*
9 | (** The tactic [reshape_expr e tac] decomposes the expression [e] into an
10 | evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e']
11 | for each possible decomposition until [tac] succeeds. *)
12 | Ltac reshape_expr e tac :=
13 | let rec go K e :=
14 | match e with
15 | | _ => tac K e
16 | | App ?e (Val ?v) => go (AppLCtx v :: K) e
17 | | App ?e1 ?e2 => go (AppRCtx e1 :: K) e2
18 | | UnOp ?op ?e => go (UnOpCtx op :: K) e
19 | | BinOp ?op ?e (Val ?v) => go (BinOpLCtx op v :: K) e
20 | | BinOp ?op ?e1 ?e2 => go (BinOpRCtx op e1 :: K) e2
21 | | If ?e0 ?e1 ?e2 => go (IfCtx e1 e2 :: K) e0
22 | | Pair ?e (Val ?v) => go (PairLCtx v :: K) e
23 | | Pair ?e1 ?e2 => go (PairRCtx e1 :: K) e2
24 | | Fst ?e => go (FstCtx :: K) e
25 | | Snd ?e => go (SndCtx :: K) e
26 | | InjL ?e => go (InjLCtx :: K) e
27 | | InjR ?e => go (InjRCtx :: K) e
28 | | Case ?e0 ?e1 ?e2 => go (CaseCtx e1 e2 :: K) e0
29 | | AllocN ?e (Val ?v) => go (AllocNLCtx v :: K) e
30 | | AllocN ?e1 ?e2 => go (AllocNRCtx e1 :: K) e2
31 | | Load ?e => go (LoadCtx :: K) e
32 | | Store ?e (Val ?v) => go (StoreLCtx v :: K) e
33 | | Store ?e1 ?e2 => go (StoreRCtx e1 :: K) e2
34 | | AllocTape ?e => go (AllocTapeCtx :: K) e
35 | | Rand ?e (Val ?v) => go (RandLCtx v :: K) e
36 | | Rand ?e1 ?e2 => go (RandRCtx e1 :: K) e2
37 | | Tick ?e => go (TickCtx :: K) e
38 | end in go (@nil ectx_item) e.
39 |
40 | Local Open Scope R.
41 |
42 | Lemma head_step_support_eq e1 e2 σ1 σ2 r :
43 | r > 0 → head_step e1 σ1 (e2, σ2) = r → head_step_rel e1 σ1 e2 σ2.
44 | Proof. intros ? <-. by eapply head_step_support_equiv_rel. Qed.
45 |
46 | Lemma head_step_support_eq_1 e1 e2 σ1 σ2 :
47 | head_step e1 σ1 (e2, σ2) = 1 → head_step_rel e1 σ1 e2 σ2.
48 | Proof. eapply head_step_support_eq; lra. Qed.
49 |
50 | (** The tactic [inv_head_step] performs inversion on hypotheses of the shape
51 | [head_step]. The tactic will discharge head-reductions starting from values,
52 | and simplifies hypothesis related to conversions from and to values, and
53 | finite map operations. This tactic is slightly ad-hoc and tuned for proving
54 | our lifting lemmas. *)
55 |
56 | Global Hint Extern 0 (head_reducible _ _) =>
57 | eexists (_, _); eapply head_step_support_equiv_rel : head_step.
58 | Global Hint Extern 1 (head_step _ _ _ > 0) =>
59 | eapply head_step_support_equiv_rel; econstructor : head_step.
60 |
61 | Global Hint Extern 2 (head_reducible _ _) =>
62 | by eauto with head_step : typeclass_instances.
63 |
64 | Ltac solve_step :=
65 | simpl;
66 | match goal with
67 | | |- (prim_step _ _).(pmf) _ = 1%R =>
68 | rewrite head_prim_step_eq /= ;
69 | simplify_map_eq ; solve_distr
70 | | |- (head_step _ _).(pmf) _ = 1%R => simplify_map_eq; solve_distr
71 | | |- (head_step _ _).(pmf) _ > 0%R => eauto with head_step
72 | end.
73 |
74 | Ltac solve_red :=
75 | match goal with
76 | | |- (environments.envs_entails _ ( ⌜ _ ⌝ ∗ _)) =>
77 | iSplitR ; [ by (iPureIntro ; solve_red) | ]
78 | | |- (environments.envs_entails _ ( _ ∗ ⌜ _ ⌝)) =>
79 | iSplitL ; [ by (iPureIntro ; solve_red) | ]
80 | | |- reducible ((fill _ _), _) =>
81 | apply reducible_fill ; solve_red
82 | | |- reducible _ =>
83 | apply head_prim_reducible ; solve_red
84 | | |- (head_reducible _ _) =>
85 | by eauto with head_step
86 | end.
87 | *)
88 |
--------------------------------------------------------------------------------
/theories/prelude/asubst.v:
--------------------------------------------------------------------------------
1 | (** Autosubst helper lemmata *)
2 | From Autosubst Require Export Autosubst.
3 | From iris.prelude Require Export prelude.
4 |
5 | Section Autosubst_Lemmas.
6 | Context {term : Type} {Ids_term : Ids term}
7 | {Rename_term : Rename term} {Subst_term : Subst term}
8 | {SubstLemmas_term : SubstLemmas term}.
9 |
10 | Lemma iter_up (m x : nat) (f : var → term) :
11 | upn m f x = if decide (x < m) then ids x else rename (+m) (f (x - m)).
12 | Proof.
13 | revert x; induction m as [|m IH]=> -[|x];
14 | repeat (case_match || asimpl || rewrite IH); auto with lia.
15 | Qed.
16 | End Autosubst_Lemmas.
17 |
--------------------------------------------------------------------------------
/theories/prelude/base.v:
--------------------------------------------------------------------------------
1 | (* The Export'ed settings in this file are somewhat opinionated. A user loading
2 | Clutch might not want these. We should therefore be careful to
3 | only Require Import, and not Require Export this file. This unfortunately
4 | means that every single one of our files has to Require Import these
5 | settings. Currently we do not follow this practice, but if Clutch is
6 | released more widely we should. *)
7 |
8 | Global Set Default Proof Using "Type".
9 | #[export] Set Suggest Proof Using. (* also warns about forgotten [Proof.] *)
10 |
11 | (* Enforces that every tactic is executed with a single focused goal, meaning
12 | that bullets and curly braces must be used to structure the proof. *)
13 | #[export] Set Default Goal Selector "!".
14 | Global Set Bullet Behavior "Strict Subproofs".
15 |
16 | From Coq.Unicode Require Export Utf8.
17 | From Coq.Classes Require Export Morphisms RelationClasses.
18 | From Coq.ssr Require Export ssreflect.
19 | From stdpp Require Export base tactics countable.
20 |
21 | (* TODO: find a better solution *)
22 | (* see [https://gitlab.mpi-sws.org/iris/stdpp/-/issues/182] *)
23 | #[global] Remove Hints bool_countable fin_countable : typeclass_instances.
24 |
25 |
--------------------------------------------------------------------------------
/theories/prelude/classical.v:
--------------------------------------------------------------------------------
1 | From Coq.Logic Require Import ClassicalEpsilon.
2 | From Coq.Logic Require Export FunctionalExtensionality PropExtensionality.
3 | From stdpp Require Import prelude.
4 |
5 | Lemma ExcludedMiddle (P : Prop) : P ∨ ¬ P.
6 | Proof. destruct (excluded_middle_informative P); auto. Qed.
7 |
8 | Lemma make_proof_irrel (P : Prop) : ProofIrrel P.
9 | Proof. intros ??; apply proof_irrelevance. Qed.
10 |
11 | Lemma make_decision P : Decision P.
12 | Proof.
13 | assert (∃ x : Decision P, True) as Hdecex.
14 | { destruct (ExcludedMiddle P) as [HP|HnP].
15 | - exists (left HP); done.
16 | - exists (right HnP); done. }
17 | apply constructive_indefinite_description in Hdecex.
18 | exact (proj1_sig Hdecex).
19 | Qed.
20 |
21 | Lemma make_decision_fun {A : Type} (P : A -> Prop) : (∀ a, Decision (P a)).
22 | Proof.
23 | intros.
24 | apply make_decision.
25 | Qed.
26 |
27 | Lemma make_decision_rel {A B : Type} (R : A -> B -> Prop) : (∀ a b, Decision (R a b)).
28 | Proof.
29 | intros.
30 | apply make_decision.
31 | Qed.
32 |
33 | Lemma NNP_P : ∀ P : Prop, ¬ ¬ P → P.
34 | Proof.
35 | intros P NNP.
36 | destruct (ExcludedMiddle P); [trivial; fail|].
37 | exfalso; apply NNP; trivial.
38 | Qed.
39 |
40 | Lemma P_NNP : ∀ P : Prop, P → ¬ ¬ P.
41 | Proof.
42 | intros P HP HnP; apply HnP; trivial.
43 | Qed.
44 |
45 | Lemma contrapositive : ∀ P Q : Prop, (¬ Q → ¬ P) → P → Q.
46 | Proof.
47 | intros P Q Hcontra HP.
48 | destruct (ExcludedMiddle Q); [trivial; fail|].
49 | exfalso; apply Hcontra; trivial.
50 | Qed.
51 |
52 | Lemma not_exists_forall_not :
53 | ∀ (A : Type) (P : A → Prop), ¬ (∃ x, P x) → ∀ x, ¬ P x.
54 | Proof. intros A P Hnex x HP; apply Hnex; eauto. Qed.
55 |
56 | Lemma not_forall_exists_not :
57 | ∀ (A : Type) (P : A → Prop), ¬ (∀ x, P x) → ∃ x, ¬ P x.
58 | Proof.
59 | intros A P.
60 | apply contrapositive.
61 | intros Hnex; apply P_NNP.
62 | intros x; apply NNP_P; revert x.
63 | apply not_exists_forall_not; trivial.
64 | Qed.
65 |
66 | Lemma not_and_or_not P Q :
67 | ¬ (P ∧ Q) → ¬ P ∨ ¬ Q.
68 | Proof.
69 | intros Hand.
70 | destruct (ExcludedMiddle P) as [HP|HnP]; [|auto].
71 | destruct (ExcludedMiddle Q) as [HQ|HnQ]; [|auto].
72 | tauto.
73 | Qed.
74 |
75 | (* resurrected some old classical facts in the Great Merge of 2023 to fix
76 | compatibility issues. Prove choice as a lemma instead of an additional axiom
77 | though. *)
78 | Lemma Choice :
79 | ∀ A B (R : A → B → Prop), (∀ x, ∃ y, R x y) → {f : A → B | ∀ x, R x (f x)}.
80 | Proof.
81 | intros ??? H.
82 | exists (fun x => proj1_sig (constructive_indefinite_description _ (H x))).
83 | intro x.
84 | apply (proj2_sig (constructive_indefinite_description _ (H x))).
85 | Qed.
86 |
87 | Definition epsilon {A : Type} {P : A → Prop} (Hex : ∃ x, P x) : A :=
88 | proj1_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt.
89 |
90 | Lemma epsilon_correct {A : Type} (P : A → Prop) (Hex : ∃ x, P x) :
91 | P (epsilon Hex).
92 | Proof.
93 | exact (proj2_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt).
94 | Qed.
95 |
96 | Definition f_inv {A B} f `{Surj A B (=) f} : B → A := λ b, epsilon (surj f b).
97 |
98 | Lemma f_inv_cancel_r {A B} f `{Surj A B (=) f} b :
99 | f (f_inv f b) = b.
100 | Proof.
101 | unfold f_inv; simpl.
102 | by rewrite (epsilon_correct _ (surj f b)).
103 | Qed.
104 |
105 | Lemma f_inv_cancel_l {A B} f `{Inj A B (=) (=) f, Surj A B (=) f} b :
106 | f_inv f (f b) = b.
107 | Proof. apply (inj f), (epsilon_correct _ (surj f (f b))). Qed.
108 |
109 | Lemma partial_inv_fun {A B : Type} (f : A -> B) :
110 | {f_inv : B → option A | (∀ b a, (f_inv b = Some a → f a = b) ∧ (f_inv b = None → f a ≠ b)) }.
111 | Proof.
112 | epose proof (Choice B (option A) (λ b o, forall a, (o = Some a -> f a = b) /\ (o = None -> f a ≠ b)) _) as (g & Hg).
113 | by exists g.
114 | Unshelve.
115 | intros b.
116 | destruct (ExcludedMiddle (exists a, f a = b)) as [ (a &Ha) | Hb].
117 | - exists (Some a).
118 | intros a'; split; intros HS; try done.
119 | inversion HS.
120 | rewrite <- Ha.
121 | f_equal; auto.
122 | - exists None.
123 | intros a'; split; intros HS; try done.
124 | intro. apply Hb. by exists a'.
125 | Qed.
126 |
--------------------------------------------------------------------------------
/theories/prelude/mc_stdlib.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import ZArith.
2 | From clutch.prelude Require Import base.
3 |
4 | #[warning="-hiding-delimiting-key,-overwriting-delimiting-key"] From mathcomp Require Import ssrnat.
5 | From mathcomp Require Import fintype ssrbool zmodp.
6 |
7 | Fact rem_modn (x p : nat) (_ : p <> 0) :
8 | (Z.rem (Z.of_nat x) (Z.of_nat p))%Z = Z.of_nat (div.modn x p).
9 | Proof.
10 | rewrite Z.rem_mod => //. 2: lia.
11 | set (x' := Z.of_nat x). set (p' := Z.of_nat p).
12 | move hx : x => [|n] .
13 | { rewrite div.mod0n. lia. }
14 | rewrite -hx.
15 | replace (Z.sgn x') with 1%Z by lia.
16 | replace (Z.abs x') with x' by lia.
17 | replace (Z.abs p') with p' by lia.
18 | rewrite Z.mul_1_l.
19 | rewrite -Nat2Z.inj_mod.
20 | rewrite {2}(PeanoNat.Nat.div_mod_eq x p).
21 | set (q := Z.div x' p'). set (r := x mod p).
22 | rewrite ssrnat.plusE ssrnat.multE ssrnat.mulnC div.modnMDl.
23 | rewrite div.modn_small ; [reflexivity|].
24 | unshelve epose proof (PeanoNat.Nat.mod_upper_bound x p _) ; [lia|].
25 | apply /leP ; lia.
26 | Qed.
27 |
28 | Fact leq_zmodp p'' : ∀ (x : 'Z_(S (S p''))), @nat_of_ord (S (S p'')) x ≤ S (S p'').
29 | Proof. rewrite ?Zp_cast // ; intros. move /leP : (leq_ord x). lia. Qed.
30 |
--------------------------------------------------------------------------------
/theories/prelude/properness.v:
--------------------------------------------------------------------------------
1 | (** Tactics and lemmas for properness and non-expansiveness. *)
2 | From stdpp Require Export tactics.
3 | From iris.algebra Require Export ofe gmap.
4 | From iris.base_logic Require Export base_logic lib.invariants.
5 | From iris.program_logic Require Import weakestpre.
6 | Import uPred.
7 |
8 | (* Hmmm *)
9 | Ltac my_prepare :=
10 | intros;
11 | repeat lazymatch goal with
12 | | |- Proper _ _ => intros ???
13 | | |- (_ ==> _)%signature _ _ => intros ???
14 | | |- pointwise_relation _ _ _ _ => intros ?
15 | end; simplify_eq.
16 |
17 | Ltac solve_proper_from_ne :=
18 | my_prepare;
19 | solve [repeat first [done | eassumption | apply equiv_dist=>? |
20 | match goal with
21 | | [H : _ ≡ _ |- _] => setoid_rewrite equiv_dist in H; rewrite H
22 | end] ].
23 |
24 | Ltac properness :=
25 | repeat match goal with
26 | | |- (∃ _: _, _)%I ≡ (∃ _: _, _)%I => apply exist_proper =>?
27 | | |- (∀ _: _, _)%I ≡ (∀ _: _, _)%I => apply forall_proper =>?
28 | | |- (_ ∧ _)%I ≡ (_ ∧ _)%I => apply and_proper
29 | | |- (_ ∨ _)%I ≡ (_ ∨ _)%I => apply or_proper
30 | | |- (_ → _)%I ≡ (_ → _)%I => apply impl_proper
31 | | |- (_ -∗ _)%I ≡ (_ -∗ _)%I => apply wand_proper
32 | | |- (WP _ @ _ {{ _ }})%I ≡ (WP _ @ _ {{ _ }})%I => apply wp_proper =>?
33 | | |- (▷ _)%I ≡ (▷ _)%I => apply later_proper
34 | | |- (□ _)%I ≡ (□ _)%I => apply intuitionistically_proper
35 | | |- (|={_,_}=> _ )%I ≡ (|={_,_}=> _ )%I => apply fupd_proper
36 | | |- (_ ∗ _)%I ≡ (_ ∗ _)%I => apply sep_proper
37 | | |- (inv _ _)%I ≡ (inv _ _)%I => apply (contractive_proper _)
38 | end.
39 |
--------------------------------------------------------------------------------
/theories/prelude/zmodp_fin.v:
--------------------------------------------------------------------------------
1 | From mathcomp Require Import all_ssreflect ssrnat zmodp.
2 |
3 | From stdpp Require fin.
4 |
5 | Set Default Proof Using "Type*".
6 |
7 | Section zmodp_fin.
8 |
9 | Context {n : nat}.
10 | Local Notation "'p'" := (S (S n)).
11 |
12 | Definition ord_of_fin (c : Fin.t p) : 'Z_p :=
13 | (Ordinal (n:=(Zp_trunc p).+2)
14 | (m:=fin.fin_to_nat c)
15 | ((introT leP (fin.fin_to_nat_lt c)))).
16 |
17 | Definition fin_of_ord (c : 'Z_p) : Fin.t p :=
18 | @Fin.of_nat_lt (nat_of_ord c) p (elimTF leP (ltn_ord c)).
19 |
20 | Fact fin_of_ord_of_fin x : fin_of_ord (ord_of_fin x) = x.
21 | Proof. unfold fin_of_ord, ord_of_fin. apply fin.fin_to_nat_inj.
22 | by rewrite fin.nat_to_fin_to_nat. Qed.
23 |
24 | Fact ord_of_fin_of_ord (x : 'Z_p) : ord_of_fin (fin_of_ord x) = x.
25 | Proof. unfold fin_of_ord, ord_of_fin. apply ord_inj.
26 | by rewrite /nat_of_ord fin.fin_to_nat_to_fin. Qed.
27 |
28 | End zmodp_fin.
29 |
--------------------------------------------------------------------------------
/theories/prob/generic_lifting.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import Reals Psatz.
2 | From Coq.ssr Require Import ssreflect ssrfun.
3 | From Coquelicot Require Import Rcomplements.
4 | From stdpp Require Export countable.
5 | From clutch.prelude Require Export base Coquelicot_ext Reals_ext stdpp_ext.
6 | From clutch.prob Require Export countable_sum distribution.
7 |
8 | Open Scope R.
9 |
10 |
11 | Record mlift := MkMLift {
12 | mlift_funct :> forall {A : Type} `{Countable A}, distr A -> (A → Prop) -> Prop;
13 | mlift_unit : ∀ A `{Countable A} (P : A → Prop) (a : A), P a -> mlift_funct (dret a) P;
14 | mlift_bind : ∀ A B `{Countable A, Countable B} (P : A → Prop) (Q : B -> Prop) (m : distr A) (f : A -> distr B),
15 | mlift_funct m P -> (forall a, P a -> mlift_funct (f a) Q) -> mlift_funct (dbind f m) Q;
16 | mlift_mono : ∀ A `{Countable A} (P Q : A → Prop) (m : distr A), (forall a, P a -> Q a) -> mlift_funct m P -> mlift_funct m Q;
17 | mlift_posR : ∀ A `{Countable A} (P : A → Prop) (m : distr A), mlift_funct m P -> mlift_funct m (λ a, P a /\ m a > 0);
18 | mlift_dzero : ∀ A `{Countable A} (P : A → Prop), mlift_funct dzero P;
19 | }.
20 |
21 | Record ord_monoid {A : Type} (e : A) (op : A -> A -> A) (leq : A -> A -> Prop) := MkOrdMonoid {
22 | ord_refl : forall (a : A), leq a a;
23 | ord_antisym : forall (a b : A), leq a b -> leq b a -> a = b;
24 | ord_trans : forall (a b c : A), leq a b -> leq b c -> leq a c;
25 | op_unit_l : forall (a : A), op e a = a;
26 | op_unit_r : forall (a : A), op a e = a;
27 | op_assoc : forall (a b c : A), op a (op b c) = op (op a b) c;
28 | op_mono : forall (a b c d : A), leq a c -> leq b d -> leq (op a b) (op c d);
29 | }.
30 |
31 | Record graded_mlift {M : Type} `{M_ord_mon : @ord_monoid M e op leq} := MkGradedMLift {
32 | gmlift_funct :> forall {A : Type} `{Countable A}, M -> distr A -> (A → Prop) -> Prop;
33 | gmlift_unit : ∀ A `{Countable A} (P : A → Prop) (a : A), P a -> gmlift_funct e (dret a) P;
34 | gmlift_bind : ∀ A B `{Countable A, Countable B} (m1 m2 : M) (P : A → Prop) (Q : B -> Prop) (μ : distr A) (f : A -> distr B),
35 | gmlift_funct m1 μ P -> (forall a, P a -> gmlift_funct m2 (f a) Q) -> gmlift_funct (op m1 m2) (dbind f μ) Q;
36 | gmlift_mono : ∀ A `{Countable A} (m1 m2 : M) (P Q : A → Prop) (μ : distr A), (leq m1 m2) -> (forall a, P a -> Q a) ->
37 | gmlift_funct m1 μ P -> gmlift_funct m2 μ Q;
38 | gmlift_posR : ∀ A `{Countable A} (m : M) (P : A → Prop) (μ : distr A), gmlift_funct m μ P -> gmlift_funct m μ (λ a, P a /\ μ a > 0);
39 | gmlift_dzero : ∀ A `{Countable A} (m : M) (P : A → Prop), gmlift_funct m dzero P;
40 | }.
41 |
--------------------------------------------------------------------------------
/theories/prob/monad/bind.v:
--------------------------------------------------------------------------------
1 | (** Bind *)
2 |
3 | From mathcomp Require Import all_ssreflect all_algebra finmap.
4 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
5 | From mathcomp Require Import cardinality fsbigop.
6 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
7 | From HB Require Import structures.
8 |
9 | From clutch.prob.monad Require Export types compose join map.
10 |
11 | Import Coq.Logic.FunctionalExtensionality.
12 |
13 | Set Implicit Arguments.
14 | Unset Strict Implicit.
15 | Unset Printing Implicit Defensive.
16 |
17 | Set Default Proof Using "Type".
18 |
19 |
20 |
21 | Definition giryM_bind {R : realType} {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2}
22 | (f : measurable_map T1 (giryM T2)) : measurable_map (@giryM R _ T1) (@giryM R _ T2)
23 | := m_cmp giryM_join (giryM_map f).
24 |
--------------------------------------------------------------------------------
/theories/prob/monad/compose.v:
--------------------------------------------------------------------------------
1 | (** Composition of measurable maps *)
2 | From mathcomp Require Import all_ssreflect all_algebra finmap.
3 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
4 | From mathcomp Require Import cardinality fsbigop.
5 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
6 | From HB Require Import structures.
7 |
8 | From clutch.prob.monad Require Export types.
9 |
10 | Import Coq.Logic.FunctionalExtensionality.
11 |
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Unset Printing Implicit Defensive.
15 |
16 | Set Default Proof Using "Type".
17 |
18 | Section MeasurableMap_compose.
19 | Context {d1 d2 d3} {T1 : measurableType d1} {T2 : measurableType d2} {T3 : measurableType d3}.
20 | Local Open Scope classical_set_scope.
21 |
22 | Local Definition m_cmp_def (f : measurable_map T2 T3) (g : measurable_map T1 T2) := comp f g.
23 |
24 | Lemma m_cmp_def_measurable (f : measurable_map T2 T3) (g : measurable_map T1 T2) :
25 | @measurable_fun _ _ T1 T3 setT (m_cmp_def f g).
26 | Proof.
27 | apply (@measurable_comp _ _ _ _ _ _ setT).
28 | - apply (@measurableT _ T2).
29 | - apply subsetT.
30 | - apply measurable_mapP.
31 | - apply measurable_mapP.
32 | Qed.
33 |
34 | HB.instance Definition _ (f : measurable_map T2 T3) (g : measurable_map T1 T2) :=
35 | isMeasurableMap.Build _ _ T1 T3 (m_cmp_def f g) (m_cmp_def_measurable f g).
36 |
37 | End MeasurableMap_compose.
38 |
39 |
40 | (** Public definition for composed function *)
41 | Definition m_cmp {d1 d2 d3} {T1 : measurableType d1} {T2 : measurableType d2} {T3 : measurableType d3}
42 | (f : measurable_map T2 T3) (g : measurable_map T1 T2) : measurable_map T1 T3 :=
43 | m_cmp_def f g.
44 |
45 | (** Public equality for composition *)
46 | Definition m_cmp_eval {d1 d2 d3} {T1 : measurableType d1} {T2 : measurableType d2} {T3 : measurableType d3}
47 | (f : measurable_map T2 T3) (g : measurable_map T1 T2) : forall t : T1, m_cmp f g t = (comp f g) t.
48 | Proof. done. Qed.
49 |
--------------------------------------------------------------------------------
/theories/prob/monad/const.v:
--------------------------------------------------------------------------------
1 | (** Constant function measurable map *)
2 | From mathcomp Require Import all_ssreflect all_algebra finmap.
3 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
4 | From mathcomp Require Import cardinality fsbigop.
5 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
6 | From HB Require Import structures.
7 |
8 | From clutch.prob.monad Require Export types.
9 |
10 | Import Coq.Logic.FunctionalExtensionality.
11 |
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Unset Printing Implicit Defensive.
15 |
16 | Set Default Proof Using "Type".
17 |
18 | Section MeasurableMap_const.
19 | Context {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2}.
20 | Local Open Scope classical_set_scope.
21 |
22 | Local Definition m_cst_def (t : T2) : T1 -> T2 := cst t.
23 |
24 | Local Lemma m_cst_def_measurable (t : T2):
25 | @measurable_fun _ _ T1 T2 setT (m_cst_def t).
26 | Proof. apply measurable_cst. Qed.
27 |
28 | HB.instance Definition _ (t : T2) :=
29 | isMeasurableMap.Build _ _ T1 T2 (m_cst_def t) (m_cst_def_measurable t).
30 | End MeasurableMap_const.
31 |
32 |
33 | (** Public definition for constant function *)
34 | Definition m_cst {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} (v : T2) : measurable_map T1 T2 :=
35 | m_cst_def v.
36 |
37 | (** Public equality for cst *)
38 | Definition m_cst_eval {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} (v : T2) :
39 | forall t : T1, m_cst v t = cst v t.
40 | Proof. done. Qed.
41 |
--------------------------------------------------------------------------------
/theories/prob/monad/discrete_mapout.v:
--------------------------------------------------------------------------------
1 | (** A function from a discrete space is a measurable map *)
2 | From mathcomp Require Import all_ssreflect all_algebra finmap.
3 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
4 | From mathcomp Require Import cardinality fsbigop.
5 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
6 | From HB Require Import structures.
7 |
8 | From clutch.prob.monad Require Export types.
9 |
10 | Import Coq.Logic.FunctionalExtensionality.
11 |
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Unset Printing Implicit Defensive.
15 |
16 | Set Default Proof Using "Type".
17 |
18 | Section discrete_space_mapout.
19 | Context {d2} {T1 : pointedType} {T2 : measurableType d2}.
20 | Local Open Scope classical_set_scope.
21 |
22 | Local Definition m_mapout_def (f : T1 -> T2) : <> -> T2 := f.
23 |
24 | Lemma discr_mapout_measurable (f : T1 -> T2) : (measurable_fun setT (m_mapout_def f)).
25 | Proof. rewrite /measurable_fun. intros. by rewrite /measurable/=/discr_meas/=. Qed.
26 |
27 | HB.instance Definition _ (f : T1 -> T2) :=
28 | isMeasurableMap.Build _ _ <> T2 (m_mapout_def f) (discr_mapout_measurable f).
29 | End discrete_space_mapout.
30 |
31 | (** Public definition for identity function *)
32 | Local Open Scope classical_set_scope.
33 | Definition m_discr {d} {T1 : pointedType} {T2 : measurableType d} (f : T1 -> T2) : measurable_map <> T2 :=
34 | m_mapout_def f.
35 |
36 | (** Public equality for id *)
37 | Definition m_discr_eval {d} {T1 : pointedType} {T2 : measurableType d} (f : T1 -> T2) :
38 | forall t : T1, m_discr f t = f t.
39 | Proof. done. Qed.
40 |
--------------------------------------------------------------------------------
/theories/prob/monad/extras.v:
--------------------------------------------------------------------------------
1 | (** Misc shared results *)
2 | From mathcomp Require Import all_ssreflect all_algebra finmap.
3 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
4 | From mathcomp Require Import cardinality fsbigop.
5 | From mathcomp.analysis Require Import normedtype.
6 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
7 | From HB Require Import structures.
8 |
9 | From clutch.prob.monad Require Export types.
10 |
11 | Import Coq.Logic.FunctionalExtensionality.
12 |
13 | Set Implicit Arguments.
14 | Unset Strict Implicit.
15 | Unset Printing Implicit Defensive.
16 |
17 | Set Default Proof Using "Type".
18 |
19 | Section Lib.
20 | Local Open Scope classical_set_scope.
21 | Lemma measurable_if_pushfowrard_subset {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} (f : T1 -> T2) :
22 | (d2.-measurable `<=` [set s : set T2 | d1.-measurable ( f@^-1` s )]) -> (measurable_fun setT f). Proof.
23 | intro HS.
24 | rewrite /measurable_fun.
25 | rewrite /subset in HS.
26 | intros X Y HY.
27 | specialize (HS Y HY).
28 | simpl in HS.
29 | rewrite setTI.
30 | apply HS.
31 | Qed.
32 | End Lib.
33 |
--------------------------------------------------------------------------------
/theories/prob/monad/identity.v:
--------------------------------------------------------------------------------
1 | (** Identity function measurable map *)
2 | From mathcomp Require Import all_ssreflect all_algebra finmap.
3 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
4 | From mathcomp Require Import cardinality fsbigop.
5 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
6 | From HB Require Import structures.
7 |
8 | From clutch.prob.monad Require Export types.
9 |
10 | Import Coq.Logic.FunctionalExtensionality.
11 |
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Unset Printing Implicit Defensive.
15 |
16 | Set Default Proof Using "Type".
17 |
18 | Section MeasurableMap_id.
19 | Context {d} {T : measurableType d}.
20 | Local Open Scope classical_set_scope.
21 |
22 | Local Definition m_id_def : T -> T := id.
23 |
24 | Local Lemma m_id_def_measurable :
25 | @measurable_fun _ _ T T setT m_id_def.
26 | Proof. apply measurable_id. Qed.
27 |
28 | HB.instance Definition _ :=
29 | isMeasurableMap.Build _ _ T T m_id_def m_id_def_measurable.
30 | End MeasurableMap_id.
31 |
32 |
33 | (** Public definition for identity function *)
34 | Definition m_id {d} {T : measurableType d} : measurable_map T T :=
35 | m_id_def.
36 |
37 | (** Public equality for id *)
38 | Definition m_id_eval {d} {T : measurableType d} :
39 | forall t : T, m_id t = t.
40 | Proof. done. Qed.
41 |
--------------------------------------------------------------------------------
/theories/prob/monad/ret.v:
--------------------------------------------------------------------------------
1 | (** return *)
2 |
3 | From mathcomp Require Import all_ssreflect all_algebra finmap.
4 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
5 | From mathcomp Require Import cardinality fsbigop.
6 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
7 | From HB Require Import structures.
8 |
9 | From clutch.prob.monad Require Export types eval.
10 |
11 | Import Coq.Logic.FunctionalExtensionality.
12 |
13 | Set Implicit Arguments.
14 | Unset Strict Implicit.
15 | Unset Printing Implicit Defensive.
16 |
17 | Set Default Proof Using "Type".
18 |
19 |
20 | Section giry_ret.
21 | Context `{R : realType}.
22 | Notation giryM := (giryM (R := R)).
23 | Context {d} {T : measurableType d}.
24 |
25 | Local Definition giryM_ret_def : T -> giryM T := fun t0 => @dirac _ T t0 _.
26 |
27 | Local Lemma giry_ret_measurable : @measurable_fun _ _ T (giryM T) setT giryM_ret_def.
28 | Proof.
29 | apply measurable_evals_iff_measurable.
30 | rewrite /measurable_evaluations.
31 | intros S SMeas.
32 | rewrite /measurable_fun/= .
33 | intros ? Y HY.
34 | (* NOTE: Since its using 'measurable, it seems that Borel or Lebesgue doesn't matter here. *)
35 | remember (fun x : T => (\d_x)%R S) as f.
36 | rewrite /dirac in Heqf.
37 | have W : f = (comp EFin (indic S)).
38 | { apply functional_extensionality. intro. by rewrite Heqf/=. }
39 | rewrite W.
40 | rewrite setTI.
41 | rewrite comp_preimage.
42 | rewrite preimage_indic.
43 | remember (in_mem GRing.zero (mem (preimage EFin Y))) as B1; rewrite -HeqB1.
44 | remember (in_mem (GRing.one R) (mem (preimage EFin Y))) as B2; rewrite -HeqB2.
45 | destruct B1; destruct B2; simpl.
46 | - apply H.
47 | - apply measurableC, SMeas.
48 | - apply SMeas.
49 | - apply measurable0.
50 | Qed.
51 |
52 | HB.instance Definition _ :=
53 | isMeasurableMap.Build _ _ T (giryM T) giryM_ret_def giry_ret_measurable.
54 |
55 | End giry_ret.
56 |
57 | (** Public definition for ret *)
58 | Definition giryM_ret (R : realType) {d} {T : measurableType d} : measurable_map T (@giryM R _ T) := giryM_ret_def.
59 |
60 | (** Public equality for ret *)
61 | Lemma giryM_ret_eval (R : realType) {d} {T : measurableType d} (t : T) : forall z, giryM_ret R t z = dirac t z.
62 | Proof. auto. Qed.
63 |
--------------------------------------------------------------------------------
/theories/prob/monad/uniform.v:
--------------------------------------------------------------------------------
1 | (** uniform spaces on finite types *)
2 |
3 | From mathcomp Require Import all_ssreflect all_algebra finmap.
4 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
5 | From mathcomp Require Import cardinality fsbigop.
6 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
7 | From HB Require Import structures.
8 |
9 | From clutch.prob.monad Require Export types eval compose integrate.
10 |
11 | Import Coq.Logic.FunctionalExtensionality.
12 |
13 | Set Implicit Arguments.
14 | Unset Strict Implicit.
15 | Unset Printing Implicit Defensive.
16 |
17 | Set Default Proof Using "Type".
18 |
19 | Section unif_fin_space.
20 | Local Open Scope ereal_scope.
21 | Local Open Scope classical_set_scope.
22 | Context {R : realType}.
23 | Variable (m : nat).
24 |
25 | (* The finite type of > 0 elements is inhabited *)
26 | Program Definition Ism_inhabitant : 'I_(S m). eapply (@Ordinal _), leqnn. Defined.
27 |
28 | HB.instance Definition _ := gen_eqMixin ('I_m).
29 | HB.instance Definition _ := gen_choiceMixin ('I_m).
30 | HB.instance Definition _ N := isPointed.Build ('I_(S m)) Ism_inhabitant.
31 |
32 | Definition giryM_unif_def (X : set <>) : \bar R
33 | := if `[< finite_set X >] then ((#|` fset_set X |)%:R / (S m)%:R)%:E else +oo.
34 |
35 | Lemma unifM0 : giryM_unif_def set0 = 0.
36 | Proof. Admitted.
37 |
38 | Lemma unifM_ge0 (A : set <>) : 0 <= giryM_unif_def A.
39 | Proof. Admitted.
40 |
41 | Lemma unifM_sigma_additive : semi_sigma_additive giryM_unif_def.
42 | Proof. Admitted.
43 |
44 | HB.instance Definition _ :=
45 | isMeasure.Build _ _ _ giryM_unif_def unifM0 unifM_ge0 unifM_sigma_additive.
46 |
47 | Lemma unifM_T : giryM_unif_def setT <= 1%E.
48 | Proof. Admitted.
49 |
50 | HB.instance Definition _ := Measure_isSubProbability.Build _ _ _ giryM_unif_def unifM_T.
51 |
52 | End unif_fin_space.
53 |
54 | Local Open Scope classical_set_scope.
55 | Local Open Scope ereal_scope.
56 |
57 | (** Public definition for the zero function *)
58 | Definition giryM_unif {R : realType} (m : nat) : @giryM R _ <> :=
59 | @giryM_unif_def R m.
60 |
61 | (** Public equality for the zero function *)
62 | Definition giryM_unif_eval {R : realType} (m : nat) :
63 | forall X : set <>,
64 | (@giryM_unif R m) X = if `[< finite_set X >] then ((#|` fset_set X |)%:R / (S m)%:R)%:E else +oo.
65 | Proof. done. Qed.
66 |
--------------------------------------------------------------------------------
/theories/prob/monad/zero.v:
--------------------------------------------------------------------------------
1 | (** Zero distibution *)
2 | From mathcomp Require Import all_ssreflect all_algebra finmap.
3 | From mathcomp Require Import mathcomp_extra boolp classical_sets functions.
4 | From mathcomp Require Import cardinality fsbigop.
5 | From mathcomp.analysis Require Import reals ereal signed (* topology *) normedtype esum numfun measure lebesgue_measure lebesgue_integral.
6 | From HB Require Import structures.
7 |
8 | From clutch.prob.monad Require Export types.
9 |
10 | Import Coq.Logic.FunctionalExtensionality.
11 |
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Unset Printing Implicit Defensive.
15 |
16 | Set Default Proof Using "Type".
17 |
18 | Section giryM_zero.
19 | Context {d} {T : measurableType d}.
20 | Context `{R : realType}.
21 | Notation giryM := (giryM (R := R)).
22 | Local Open Scope classical_set_scope.
23 |
24 | Local Definition giryM_zero_def : giryM T := mzero.
25 |
26 | End giryM_zero.
27 |
28 |
29 | (** Public definition for the zero function *)
30 | Definition giryM_zero {R : realType} {d} {T : measurableType d} : @giryM R _ T :=
31 | giryM_zero_def.
32 |
33 | (** Public equality for the zero function *)
34 | Definition giryM_zero_eval {R : realType} {d} {T : measurableType d} :
35 | forall t : set T, @giryM_zero R _ _ t = 0%R.
36 | Proof. done. Qed.
37 |
--------------------------------------------------------------------------------
/theories/prob_lang/ctx_subst.v:
--------------------------------------------------------------------------------
1 | From stdpp Require Import base stringmap fin_sets fin_map_dom.
2 | From clutch.common Require Export ectx_language ectxi_language.
3 | From clutch.prob_lang Require Export lang metatheory.
4 |
5 | (** Substitution in the contexts *)
6 | Definition subst_map_ctx_item (es : stringmap val) (K : ectx_item) :=
7 | match K with
8 | | AppLCtx v2 => AppLCtx v2
9 | | AppRCtx e1 => AppRCtx (subst_map es e1)
10 | | UnOpCtx op => UnOpCtx op
11 | | BinOpLCtx op v2 => BinOpLCtx op v2
12 | | BinOpRCtx op e1 => BinOpRCtx op (subst_map es e1)
13 | | IfCtx e1 e2 => IfCtx (subst_map es e1) (subst_map es e2)
14 | | PairLCtx v2 => PairLCtx v2
15 | | PairRCtx e1 => PairRCtx (subst_map es e1)
16 | | FstCtx => FstCtx
17 | | SndCtx => SndCtx
18 | | InjLCtx => InjLCtx
19 | | InjRCtx => InjRCtx
20 | | CaseCtx e1 e2 => CaseCtx (subst_map es e1) (subst_map es e2)
21 | | AllocNLCtx v2 => AllocNLCtx v2
22 | | AllocNRCtx e1 => AllocNRCtx (subst_map es e1)
23 | | LoadCtx => LoadCtx
24 | | StoreLCtx v2 => StoreLCtx v2
25 | | StoreRCtx e1 => StoreRCtx (subst_map es e1)
26 | | AllocTapeCtx => AllocTapeCtx
27 | | RandLCtx v2 => RandLCtx v2
28 | | RandRCtx e1 => RandRCtx (subst_map es e1)
29 | | TickCtx => TickCtx
30 | end.
31 |
32 | Definition subst_map_ctx (es : stringmap val) (K : list ectx_item) :=
33 | map (subst_map_ctx_item es) K.
34 |
35 | Lemma subst_map_fill_item (vs : stringmap val) (Ki : ectx_item) (e : expr) :
36 | subst_map vs (fill_item Ki e) =
37 | fill_item (subst_map_ctx_item vs Ki) (subst_map vs e).
38 | Proof. induction Ki; simpl; eauto with f_equal. Qed.
39 |
40 | Lemma subst_map_fill (vs : stringmap val) (K : list ectx_item) (e : expr) :
41 | subst_map vs (fill K e) = fill (subst_map_ctx vs K) (subst_map vs e).
42 | Proof.
43 | generalize dependent e. generalize dependent vs.
44 | induction K as [|Ki K]; eauto.
45 | intros es e. simpl.
46 | by rewrite IHK subst_map_fill_item.
47 | Qed.
48 |
--------------------------------------------------------------------------------
/theories/prob_lang/exec_lang.v:
--------------------------------------------------------------------------------
1 | (* TODO move into metatheory.v ? *)
2 |
3 | From Coq Require Export Reals Psatz.
4 | From clutch.prob_lang Require Import lang.
5 |
6 | Lemma exec_det_step_ctx K `{!LanguageCtx K} n ρ (e1 e2 : expr) σ1 σ2 :
7 | prim_step e1 σ1 (e2, σ2) = 1%R →
8 | pexec n ρ (K e1, σ1) = 1%R →
9 | pexec (S n) ρ (K e2, σ2) = 1%R.
10 | Proof.
11 | intros. eapply pexec_det_step; [|done].
12 | rewrite -fill_step_prob //.
13 | eapply (val_stuck _ σ1 (e2, σ2)).
14 | rewrite H. lra.
15 | Qed.
16 |
17 | Lemma exec_PureExec_ctx K `{!LanguageCtx K} (P : Prop) m n ρ (e e' : expr) σ :
18 | P →
19 | PureExec P n e e' →
20 | pexec m ρ (K e, σ) = 1 →
21 | pexec (m + n) ρ (K e', σ) = 1.
22 | Proof.
23 | move=> HP /(_ HP).
24 | destruct ρ as [e0 σ0].
25 | revert e e' m. induction n=> e e' m.
26 | { rewrite -plus_n_O. by inversion 1. }
27 | intros (e'' & Hsteps & Hpstep)%nsteps_inv_r Hdet.
28 | specialize (IHn _ _ m Hsteps Hdet).
29 | rewrite -plus_n_Sm.
30 | eapply exec_det_step_ctx; [done| |done].
31 | apply Hpstep.
32 | Qed.
33 |
34 | Lemma stepN_det_step_ctx K `{!LanguageCtx K} n ρ (e1 e2 : expr) σ1 σ2 :
35 | prim_step e1 σ1 (e2, σ2) = 1%R →
36 | stepN n ρ (K e1, σ1) = 1%R →
37 | stepN (S n) ρ (K e2, σ2) = 1%R.
38 | Proof.
39 | intros.
40 | rewrite -Nat.add_1_r.
41 | erewrite (stepN_det_trans n 1); [done|done|].
42 | rewrite stepN_Sn /=.
43 | rewrite dret_id_right.
44 | rewrite -fill_step_prob //.
45 | eapply (val_stuck _ σ1 (e2, σ2)).
46 | rewrite H. lra.
47 | Qed.
48 |
49 | Lemma stepN_PureExec_ctx K `{!LanguageCtx K} (P : Prop) m n ρ (e e' : expr) σ :
50 | P →
51 | PureExec P n e e' →
52 | stepN m ρ (K e, σ) = 1 →
53 | stepN (m + n) ρ (K e', σ) = 1.
54 | Proof.
55 | move=> HP /(_ HP).
56 | destruct ρ as [e0 σ0].
57 | revert e e' m. induction n=> e e' m.
58 | { rewrite -plus_n_O. by inversion 1. }
59 | intros (e'' & Hsteps & Hpstep)%nsteps_inv_r Hdet.
60 | specialize (IHn _ _ m Hsteps Hdet).
61 | rewrite -plus_n_Sm.
62 | eapply stepN_det_step_ctx; [done| |done].
63 | apply Hpstep.
64 | Qed.
65 |
--------------------------------------------------------------------------------
/theories/prob_lang/tactics.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import Reals Psatz.
2 | From stdpp Require Import fin_maps.
3 | From iris.proofmode Require Import environments proofmode.
4 | From clutch.prob Require Import distribution.
5 | From clutch.common Require Import ectx_language.
6 | From clutch.prob_lang Require Import lang.
7 | From iris.prelude Require Import options.
8 | Import prob_lang.
9 |
10 | (** The tactic [reshape_expr e tac] decomposes the expression [e] into an
11 | evaluation context [K] and a subexpression [e']. It calls the tactic [tac K e']
12 | for each possible decomposition until [tac] succeeds. *)
13 | Ltac reshape_expr e tac :=
14 | let rec go K e :=
15 | match e with
16 | | _ => tac K e
17 | | App ?e (Val ?v) => go (AppLCtx v :: K) e
18 | | App ?e1 ?e2 => go (AppRCtx e1 :: K) e2
19 | | UnOp ?op ?e => go (UnOpCtx op :: K) e
20 | | BinOp ?op ?e (Val ?v) => go (BinOpLCtx op v :: K) e
21 | | BinOp ?op ?e1 ?e2 => go (BinOpRCtx op e1 :: K) e2
22 | | If ?e0 ?e1 ?e2 => go (IfCtx e1 e2 :: K) e0
23 | | Pair ?e (Val ?v) => go (PairLCtx v :: K) e
24 | | Pair ?e1 ?e2 => go (PairRCtx e1 :: K) e2
25 | | Fst ?e => go (FstCtx :: K) e
26 | | Snd ?e => go (SndCtx :: K) e
27 | | InjL ?e => go (InjLCtx :: K) e
28 | | InjR ?e => go (InjRCtx :: K) e
29 | | Case ?e0 ?e1 ?e2 => go (CaseCtx e1 e2 :: K) e0
30 | | AllocN ?e (Val ?v) => go (AllocNLCtx v :: K) e
31 | | AllocN ?e1 ?e2 => go (AllocNRCtx e1 :: K) e2
32 | | Load ?e => go (LoadCtx :: K) e
33 | | Store ?e (Val ?v) => go (StoreLCtx v :: K) e
34 | | Store ?e1 ?e2 => go (StoreRCtx e1 :: K) e2
35 | | AllocTape ?e => go (AllocTapeCtx :: K) e
36 | | Rand ?e (Val ?v) => go (RandLCtx v :: K) e
37 | | Rand ?e1 ?e2 => go (RandRCtx e1 :: K) e2
38 | | Tick ?e => go (TickCtx :: K) e
39 | end in go (@nil ectx_item) e.
40 |
41 | Local Open Scope R.
42 |
43 | Lemma head_step_support_eq e1 e2 σ1 σ2 r :
44 | r > 0 → head_step e1 σ1 (e2, σ2) = r → head_step_rel e1 σ1 e2 σ2.
45 | Proof. intros ? <-. by eapply head_step_support_equiv_rel. Qed.
46 |
47 | Lemma head_step_support_eq_1 e1 e2 σ1 σ2 :
48 | head_step e1 σ1 (e2, σ2) = 1 → head_step_rel e1 σ1 e2 σ2.
49 | Proof. eapply head_step_support_eq; lra. Qed.
50 |
51 | (** The tactic [inv_head_step] performs inversion on hypotheses of the shape
52 | [head_step]. The tactic will discharge head-reductions starting from values,
53 | and simplifies hypothesis related to conversions from and to values, and
54 | finite map operations. This tactic is slightly ad-hoc and tuned for proving
55 | our lifting lemmas. *)
56 |
57 | Global Hint Extern 0 (head_reducible _ _) =>
58 | eexists (_, _); eapply head_step_support_equiv_rel : head_step.
59 | Global Hint Extern 1 (head_step _ _ _ > 0) =>
60 | eapply head_step_support_equiv_rel; econstructor : head_step.
61 |
62 | Global Hint Extern 2 (head_reducible _ _) =>
63 | by eauto with head_step : typeclass_instances.
64 |
65 | Ltac solve_step :=
66 | simpl;
67 | match goal with
68 | | |- (prim_step _ _).(pmf) _ = 1%R =>
69 | rewrite head_prim_step_eq /= ;
70 | simplify_map_eq ; solve_distr
71 | | |- (head_step _ _).(pmf) _ = 1%R => simplify_map_eq; solve_distr
72 | | |- (head_step _ _).(pmf) _ > 0%R => eauto with head_step
73 | end.
74 |
75 | Ltac solve_red :=
76 | match goal with
77 | | |- (environments.envs_entails _ ( ⌜ _ ⌝ ∗ _)) =>
78 | iSplitR ; [ by (iPureIntro ; solve_red) | ]
79 | | |- (environments.envs_entails _ ( _ ∗ ⌜ _ ⌝)) =>
80 | iSplitL ; [ by (iPureIntro ; solve_red) | ]
81 | | |- reducible ((fill _ _), _) =>
82 | apply reducible_fill ; solve_red
83 | | |- reducible _ =>
84 | apply head_prim_reducible ; solve_red
85 | | |- (head_reducible _ _) =>
86 | by eauto with head_step
87 | end.
88 |
--------------------------------------------------------------------------------
/theories/pure_complete/term.v:
--------------------------------------------------------------------------------
1 | From Coq Require Import Reals Psatz.
2 | From clutch.common Require Import ectx_language.
3 | From clutch.prob_lang Require Import notation tactics metatheory.
4 | From clutch.prob_lang Require Export lang.
5 | From clutch.prelude Require Import base Coquelicot_ext Reals_ext stdpp_ext classical.
6 |
7 | Local Open Scope R.
8 |
9 | Section term.
10 |
11 | Context `{Λ : language}.
12 |
13 | Implicit Types ρ : language.cfg Λ.
14 |
15 | Definition pterm (n : nat) ρ := SeriesC (exec n ρ).
16 |
17 | Definition pterm_nnr (n : nat) ρ := mknonnegreal (pterm n ρ) (pmf_SeriesC_ge_0 _).
18 |
19 | Lemma pterm_le1 (n : nat) ρ : (0 <= 1 - pterm n ρ)%R.
20 | Proof.
21 | specialize (pmf_SeriesC (exec n ρ)) as he.
22 | rewrite /pterm. apply -> Rcomplements.Rminus_le_0. auto.
23 | Qed.
24 |
25 | Definition pterm_comp (n : nat) ρ := mknonnegreal (1 - pterm n ρ) (pterm_le1 _ _).
26 |
27 | Lemma pterm_rec (n : nat) ρ :
28 | language.to_val ρ.1 = None ->
29 | pterm (S n) ρ = Expval (step ρ) (pterm n).
30 | Proof.
31 | intros.
32 | rewrite /pterm exec_Sn dbind_mass /Expval.
33 | apply SeriesC_ext. intros.
34 | rewrite /step_or_final.
35 | rewrite /to_final. simpl. rewrite H.
36 | auto.
37 | Qed.
38 |
39 | Lemma AST_pt_lim m ε :
40 | SeriesC (lim_exec m) = 1 ->
41 | ε < 1 -> ∃ n, ε < pterm n m.
42 | Proof.
43 | intros Hst?.
44 | rewrite lim_exec_Sup_seq in Hst. intros.
45 | assert (Lim_seq.is_sup_seq (λ n : nat, Rbar.Finite (SeriesC (exec n m))) (Rbar.Finite 1)). {
46 | rewrite <- Hst. rewrite rbar_finite_real_eq. 2: {
47 | apply is_finite_Sup_seq_SeriesC_exec.
48 | }
49 | apply Lim_seq.Sup_seq_correct.
50 | }
51 | unfold Lim_seq.is_sup_seq in H0.
52 | assert (0 < 1 - ε). { lra. }
53 | specialize H0 with (mkposreal (1 - ε) H1).
54 | simpl in H0. destruct H0 as [H0 [n H2]].
55 | exists n. rewrite /pterm. field_simplify in H2. apply H2.
56 | Qed.
57 |
58 | Lemma pterm_reducible (n : nat) ρ :
59 | language.to_val ρ.1 = None ->
60 | 0 < pterm n ρ ->
61 | reducible ρ.
62 | Proof.
63 | rewrite /pterm.
64 | intros. apply SeriesC_gtz_ex in H0.
65 | 2: apply pmf_pos.
66 | induction n.
67 | - destruct H0. rewrite /exec /to_final in H0. simpl in H0.
68 | rewrite H in H0.
69 | rewrite dzero_0 in H0. lra.
70 | - apply mass_pos_reducible.
71 | destruct H0.
72 | simpl in H0.
73 | rewrite H in H0.
74 | apply dbind_pos in H0.
75 | destruct H0 as [ρ' [H0 H1]].
76 | simpl.
77 | apply (SeriesC_pos _ ρ').
78 | + apply pmf_pos.
79 | + apply pmf_ex_seriesC.
80 | + apply H1.
81 | Qed.
82 |
83 | End term.
--------------------------------------------------------------------------------
/theories/tachis/ectx_lifting.v:
--------------------------------------------------------------------------------
1 | (** Some derived lemmas for ectx-based languages *)
2 | From iris.proofmode Require Import proofmode.
3 | From clutch.common Require Import ectx_language.
4 | From clutch.tachis Require Import ert_weakestpre lifting.
5 | From clutch.prelude Require Import NNRbar.
6 | From iris.prelude Require Import options.
7 |
8 | Local Open Scope R.
9 |
10 | Section wp.
11 | Context {Λ : ectxLanguage} `{!tachisWpGS Λ Σ} {Hinh : Inhabited (state Λ)}.
12 | Implicit Types P : iProp Σ.
13 | Implicit Types Φ : val Λ → iProp Σ.
14 | Implicit Types v : val Λ.
15 | Implicit Types e : expr Λ.
16 | Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
17 | Local Hint Resolve head_stuck_stuck : core.
18 |
19 | Lemma wp_lift_head_step_fupd_ERM {E Φ} e1 s :
20 | to_val e1 = None →
21 | (∀ σ1 x1,
22 | state_interp σ1 ∗ etc_supply x1
23 | ={E,∅}=∗
24 | ⌜head_reducible e1 σ1⌝ ∗
25 | ERM e1 σ1 x1 (λ '(e2, σ2) x2,
26 | ▷ |={∅,E}=> state_interp σ2 ∗ etc_supply x2 ∗ WP e2 @ s; E {{ Φ }}))
27 | ⊢ WP e1 @ s; E {{ Φ }}.
28 | Proof.
29 | iIntros (?) "H". iApply wp_lift_step_fupd_ERM; [done|].
30 | iIntros (σ1 ε) "Hσε".
31 | iMod ("H" with "Hσε") as "[% H]"; iModIntro; auto.
32 | Qed.
33 |
34 | Lemma wp_lift_head_step {E Φ} e1 s :
35 | to_val e1 = None →
36 | (∀ σ1, state_interp σ1 ={E,∅}=∗
37 | ⌜head_reducible e1 σ1⌝ ∗
38 | ⧖ (cost e1) ∗
39 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={∅,E}=∗ state_interp σ2 ∗ WP e2 @ s; E {{ Φ }})
40 | ⊢ WP e1 @ s; E {{ Φ }}.
41 | Proof.
42 | iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (?) "Hσ".
43 | iMod ("H" with "[$]") as "(% & $ & H)"; iModIntro.
44 | iSplit.
45 | { iPureIntro. by eapply head_prim_reducible. }
46 | iIntros (???) "!> !>". iApply "H"; eauto.
47 | Qed.
48 |
49 | Lemma wp_lift_atomic_head_step_fupd {E1 E2 Φ} e1 s :
50 | to_val e1 = None →
51 | (∀ σ1, state_interp σ1 ={E1}=∗
52 | ⌜head_reducible e1 σ1⌝ ∗
53 | ⧖ (cost e1) ∗
54 | ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E1}[E2]▷=∗ state_interp σ2 ∗ from_option Φ False (to_val e2))
55 | ⊢ WP e1 @ s; E1 {{ Φ }}.
56 | Proof.
57 | iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
58 | iIntros (σ1) "Hσ1". iMod ("H" with "[$]") as "(% & $ & H)"; iModIntro.
59 | iSplit.
60 | { iPureIntro. by apply head_prim_reducible. }
61 | iIntros (e2 σ2 Hstep).
62 | iApply "H"; eauto.
63 | Qed.
64 |
65 | Lemma wp_lift_atomic_head_step {E Φ} e1 s :
66 | to_val e1 = None →
67 | (∀ σ1, state_interp σ1 ={E}=∗
68 | ⌜head_reducible e1 σ1⌝ ∗
69 | ⧖ (cost e1) ∗
70 | ▷ ∀ e2 σ2, ⌜head_step e1 σ1 (e2, σ2) > 0⌝ ={E}=∗ state_interp σ2 ∗ from_option Φ False (to_val e2))
71 | ⊢ WP e1 @ s; E {{ Φ }}.
72 | Proof.
73 | iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
74 | iIntros (σ1) "Hσ1". iMod ("H" with "[$]") as "(% & $ & H)"; iModIntro.
75 | iSplit.
76 | { iPureIntro. by apply head_prim_reducible. }
77 | iIntros "!>" (e2 σ2 Hstep).
78 | iApply "H"; eauto.
79 | Qed.
80 |
81 | Lemma wp_lift_pure_det_head_step {E E' Φ} e1 e2 s :
82 | to_val e1 = None →
83 | (∀ σ1, head_reducible e1 σ1) →
84 | (∀ σ1 e2' σ2, head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
85 | ⧖ (cost e1) ∗
86 | (|={E}[E']▷=> WP e2 @ s; E {{ Φ }}) ⊢ WP e1 @ s; E {{ Φ }}.
87 | Proof using Hinh.
88 | intros. erewrite !(wp_lift_pure_det_step e1 e2); eauto.
89 | Qed.
90 |
91 | Lemma wp_lift_pure_det_head_step' {E Φ} e1 e2 s :
92 | to_val e1 = None →
93 | (∀ σ1, head_reducible e1 σ1) →
94 | (∀ σ1 e2' σ2, head_step e1 σ1 (e2', σ2) > 0 → σ2 = σ1 ∧ e2' = e2) →
95 | ⧖ (cost e1) ∗
96 | ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
97 | Proof using Hinh.
98 | intros. rewrite -[(WP e1 @ _; _ {{ _ }})%I]wp_lift_pure_det_head_step //.
99 | rewrite -step_fupd_intro //.
100 | Qed.
101 | End wp.
102 |
--------------------------------------------------------------------------------
/theories/tachis/examples/expected_val_reference.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation tactics metatheory.
2 | From clutch.tachis Require Export adequacy expected_time_credits ert_weakestpre problang_wp proofmode
3 | derived_laws cost_models ert_rules.
4 | From iris.proofmode Require Export proofmode.
5 | From Coquelicot Require Import Rbar.
6 | Set Default Proof Using "Type*".
7 | Open Scope R.
8 |
9 | (** * Lohse & Garg 2024, Section 7 *)
10 | Section loc_cost.
11 |
12 | Definition toss l : expr := if: rand #1 = #1 then #()
13 | else l <- !l + #1.
14 |
15 | Lemma wp_op_ert `{!tachisGS Σ CostTick} :
16 | {{{ ⧖ (1/2) }}}
17 | let: "l" := ref #0 in toss "l";; tick (! "l")
18 | {{{ RET #(); True }}}.
19 | Proof with (try iIntros ; wp_pures).
20 | iIntros (Φ) "n HΦ".
21 | wp_alloc...
22 | iSpecialize ("HΦ" $! I).
23 | wp_apply (wp_couple_rand_adv_comp' _ _ _ _ _
24 | (λ x, if bool_decide (x = 1%fin) then 0 else 1)%R with "n").
25 | 1: intros ; case_bool_decide ; lra.
26 | 1: { rewrite SeriesC_finite_foldr /=. lra. }
27 | repeat (try iIntros (n) ; inv_fin n)...
28 | - wp_load... wp_store... wp_load ; iIntros. by wp_pure_cost.
29 | - wp_load ; iIntros. by wp_pure_cost.
30 | Qed.
31 |
32 | End loc_cost.
33 |
34 | Fact op_ert : ∀ σ,
35 | @lim_ERT CostTick ((let: "l" := ref #0 in toss "l";; tick (! "l"))%E, σ) <= (1/2)%NNR.
36 | Proof.
37 | intros.
38 | eapply (wp_ERT_lim CostTick tachisΣ _ _ _ (λ _, True)).
39 | iIntros (?) "tc". by iApply (wp_op_ert with "[$tc]").
40 | Qed.
41 |
--------------------------------------------------------------------------------
/theories/tachis/examples/hashmap/rabinkarp.v:
--------------------------------------------------------------------------------
1 | (** * Rabin Karp string detection *)
2 | From clutch.tachis Require Export expected_time_credits ert_weakestpre problang_wp proofmode
3 | derived_laws cost_models ert_rules.
4 | From clutch.prob_lang Require Import notation tactics metatheory lang.
5 | From iris.proofmode Require Export proofmode.
6 | From Coq Require Export Reals Psatz.
7 | From Coquelicot Require Export Hierarchy.
8 | Require Import Lra.
9 | From clutch.tachis.examples.hashmap Require Export hash.
10 | From clutch.tachis.examples.lib Require Export list.
11 |
12 |
13 | Set Default Proof Using "Type*".
14 |
15 | Section rabin_karp.
16 |
17 | Context`{!tachisGS Σ CostTick}.
18 |
19 | Variable string_to_nat: val.
20 | Variable string_to_nat_specialized: val->nat.
21 | Axiom wp_string_to_nat:
22 | ∀ (v:val) E,
23 | {{{ True }}}
24 | string_to_nat v @ E
25 | {{{ (n:nat), RET #n; ⌜n=string_to_nat_specialized v⌝}}}.
26 | Hypothesis (string_to_nat_inj: Inj (=) (=) string_to_nat_specialized).
27 |
28 | Definition rk_helper : val :=
29 | (rec: "helper" "s" "p" "hf" "lp" "hp" "idx":=
30 | if: "idx" < list_length "s" - "lp" + #1
31 | then
32 | let: "w":= list_inf "idx" ("idx"+"lp") "s" in
33 | let: "h":= "hf" (string_to_nat "w") in
34 | tick #1 ;;
35 | if: "h" = "hp"
36 | then if: (tick "lp";; "w" = "p")
37 | then SOME "idx"
38 | else "helper" "s" "p" "hf" "lp" "hp" ("idx" + #1)
39 | else "helper" "s" "p" "hf" "lp" "hp" ("idx" + #1)
40 | else NONE
41 | ).
42 |
43 | Definition rk : val :=
44 | λ: "s" "p" "hf",
45 | let: "lp" := list_length "p" in
46 | tick #1;;
47 | let: "hp" := "hf" (string_to_nat "p") in
48 | match: rk_helper "s" "p" "hf" "lp" "hp" #0
49 | with
50 | | SOME "x" => "x"
51 | | NONE => #(-1)
52 | end
53 | .
54 |
55 | Variables p s:list nat.
56 | Definition p_len := length p.
57 | Definition s_len:= length s.
58 | Hypothesis (Hineq:p_len <= s_len).
59 | Definition val_size := s_len * s_len.
60 |
61 | Lemma wp_rk pv sv f E:
62 | is_list p pv -> is_list s sv ->
63 | {{{ ⧖ (1+2*s_len) ∗ hashfun val_size f ∅ }}}
64 | rk sv pv f@E
65 | {{{ (z:Z), RET #z; ∃ m, hashfun val_size f m ∗ if bool_decide (z=-1)%Z then True else ⌜p=take p_len (drop (Z.to_nat z) s)⌝}}}.
66 | Proof.
67 | iIntros (Hp Hs Φ) "[Hx Hhf] HΦ".
68 | rewrite /rk.
69 | wp_pures.
70 | wp_apply wp_list_length; first done.
71 | iIntros (?) "->".
72 | replace (length _) with p_len; last done.
73 | wp_pures.
74 | wp_pure.
75 | { pose proof pos_INR s_len. lra. } wp_pures.
76 | replace (_+_-_)%R with (2*s_len)%R; last lra.
77 | wp_apply wp_string_to_nat; first done.
78 | iIntros (?) "->".
79 | wp_apply (wp_insert with "[$Hhf]").
80 | { set_solver. }
81 | iIntros (hp) "Hhf".
82 | wp_pures.
83 | Abort.
84 |
85 |
86 | End rabin_karp.
87 |
--------------------------------------------------------------------------------
/theories/tachis/examples/min_heap_spec.v:
--------------------------------------------------------------------------------
1 | From clutch.prob_lang Require Import lang notation.
2 | From clutch.tachis Require Export problang_wp.
3 | Set Default Proof Using "Type*".
4 |
5 | Record comparator (K : Type) (c : Costfun prob_lang) := Comparator {
6 | cmp :> val;
7 | cmp_rel : relation K;
8 | cmp_rel_dec :: RelDecision cmp_rel;
9 | cmp_rel_preorder :: PreOrder cmp_rel;
10 | cmp_rel_total :: Total cmp_rel;
11 |
12 | cmp_cost : R;
13 |
14 | cmp_nonneg : (0 <= cmp_cost)%R ;
15 |
16 | cmp_has_key `{!tachisGS Σ c} : K → val → iProp Σ;
17 |
18 | wp_cmp `{!tachisGS Σ c} k1 k2 v1 v2 :
19 | {{{ cmp_has_key k1 v1 ∗ cmp_has_key k2 v2 ∗ ⧖ cmp_cost }}}
20 | cmp v1 v2
21 | {{{ RET #(bool_decide (cmp_rel k1 k2)); cmp_has_key k1 v1 ∗ cmp_has_key k2 v2 }}};
22 | }.
23 | Arguments Comparator {_ _} _ _ {_ _} _ _ _.
24 | Arguments cmp_rel {_ _}.
25 | Arguments cmp_cost {_ _}.
26 | Arguments cmp_has_key {_ _} _ {_ _}.
27 | Arguments wp_cmp {_ _ _ _ _ _}.
28 |
29 | Class min_heap {K c} (cmp : comparator K c) := MinHeap {
30 | heap_new : val;
31 | heap_insert : val;
32 | heap_remove : val;
33 |
34 | heap_insert_cost : nat → R;
35 | heap_remove_cost : nat → R;
36 |
37 | heap_insert_cost_nonneg n : (0 <= heap_insert_cost n)%R;
38 | heap_remove_cost_nonneg n : (0 <= heap_remove_cost n)%R;
39 | heap_insert_cost_mono n m :
40 | n ≤ m → (heap_insert_cost n <= heap_insert_cost m)%R;
41 | heap_remove_cost_mono n m :
42 | n ≤ m → (heap_remove_cost n <= heap_remove_cost m)%R;
43 |
44 | is_min_heap `{!tachisGS Σ c} (l : list K) (v : val) : iProp Σ;
45 | is_min_heap_proper `{!tachisGS Σ c} ::
46 | Proper ((≡ₚ) ==> (=) ==> (≡)) is_min_heap;
47 |
48 | wp_heap_new `{!tachisGS Σ c} :
49 | {{{ True }}}
50 | heap_new #()
51 | {{{ v, RET v; is_min_heap [] v }}};
52 |
53 | wp_heap_insert `{!tachisGS Σ c} l k v w :
54 | {{{ is_min_heap l v ∗ cmp.(cmp_has_key) k w ∗ ⧖ (heap_insert_cost (length l)) }}}
55 | heap_insert v w
56 | {{{ l', RET #(); is_min_heap l' v ∗ ⌜l' ≡ₚ k :: l⌝ }}};
57 |
58 | wp_heap_remove `{!tachisGS Σ c} l v :
59 | {{{ is_min_heap l v ∗ ⧖ (heap_remove_cost (length l)) }}}
60 | heap_remove v
61 | {{{ w, RET w;
62 | (⌜w = NONEV⌝ ∗ ⌜l = []⌝ ∗ is_min_heap [] v) ∨
63 | (∃ k u l',
64 | ⌜w = SOMEV u⌝ ∗ ⌜l ≡ₚ k :: l'⌝ ∗ cmp.(cmp_has_key) k u ∗
65 | ⌜Forall (cmp.(cmp_rel) k) l⌝ ∗ is_min_heap l' v) }}};
66 | }.
67 |
68 | Arguments heap_new {_ _ _ _}.
69 | Arguments heap_insert {_ _ _ _}.
70 | Arguments heap_remove {_ _ _ _}.
71 | Arguments heap_insert_cost {_ _ _ _}.
72 | Arguments heap_remove_cost {_ _ _ _}.
73 | Arguments is_min_heap {_ _ _ _ _ _}.
74 | Arguments wp_heap_new {_ _ _ _ _ _}.
75 | Arguments wp_heap_insert {_ _ _ _ _ _}.
76 | Arguments wp_heap_remove {_ _ _ _ _ _}.
77 |
--------------------------------------------------------------------------------
/theories/tachis/problang_wp.v:
--------------------------------------------------------------------------------
1 | (** This file proves the basic laws of the ProbLang weakest precondition by
2 | applying the lifting lemmas. *)
3 | From iris.proofmode Require Import proofmode.
4 | From iris.algebra Require Import auth excl.
5 | From iris.base_logic.lib Require Export ghost_map.
6 | From clutch.tachis Require Export expected_time_credits ert_weakestpre (* ectx_lifting *).
7 | From clutch.prob_lang Require Export class_instances.
8 | From clutch.prob_lang Require Export tactics lang notation.
9 | From iris.prelude Require Import options.
10 |
11 | Class tachisGS Σ (cost : Costfun prob_lang) := HeapG {
12 | tachisGS_invG : invGS_gen HasNoLc Σ;
13 | (* CMRA for the state *)
14 | tachisGS_heap : ghost_mapG Σ loc val;
15 | tachisGS_tapes : ghost_mapG Σ loc tape;
16 | (* ghost names for the state *)
17 | tachisGS_heap_name : gname;
18 | tachisGS_tapes_name : gname;
19 | (* CMRA and ghost name for the ERT *)
20 | tachisGS_etc : etcGS Σ;
21 | }.
22 |
23 | Definition progUR : ucmra := optionUR (exclR exprO).
24 | Definition cfgO : ofe := prodO exprO stateO.
25 | Definition cfgUR : ucmra := optionUR (exclR cfgO).
26 |
27 | Definition heap_auth `{tachisGS Σ} :=
28 | @ghost_map_auth _ _ _ _ _ tachisGS_heap tachisGS_heap_name.
29 | Definition tapes_auth `{tachisGS Σ} :=
30 | @ghost_map_auth _ _ _ _ _ tachisGS_tapes tachisGS_tapes_name.
31 |
32 | Global Instance tachisGS_tachisWpGSS `{!tachisGS Σ F} : tachisWpGS prob_lang Σ := {
33 | tachisWpGS_invGS := tachisGS_invG;
34 | tachisWpGS_etcGS := tachisGS_etc;
35 |
36 | state_interp σ := (heap_auth 1 σ.(heap) ∗ tapes_auth 1 σ.(tapes))%I;
37 | costfun := F
38 | }.
39 |
40 | (** Heap *)
41 | Notation "l ↦{ dq } v" := (@ghost_map_elem _ _ _ _ _ tachisGS_heap tachisGS_heap_name l dq v)
42 | (at level 20, format "l ↦{ dq } v") : bi_scope.
43 | Notation "l ↦□ v" := (l ↦{ DfracDiscarded } v)%I
44 | (at level 20, format "l ↦□ v") : bi_scope.
45 | Notation "l ↦{# q } v" := (l ↦{ DfracOwn q } v)%I
46 | (at level 20, format "l ↦{# q } v") : bi_scope.
47 | Notation "l ↦ v" := (l ↦{ DfracOwn 1 } v)%I
48 | (at level 20, format "l ↦ v") : bi_scope.
49 |
50 | (** Tapes *)
51 | Notation "l ↪{ dq } v" := (@ghost_map_elem _ _ _ _ _ tachisGS_tapes tachisGS_tapes_name l dq (v : tape))
52 | (at level 20, format "l ↪{ dq } v") : bi_scope.
53 | Notation "l ↪□ v" := (l ↪{ DfracDiscarded } v)%I
54 | (at level 20, format "l ↪□ v") : bi_scope.
55 | Notation "l ↪{# q } v" := (l ↪{ DfracOwn q } v)%I
56 | (at level 20, format "l ↪{# q } v") : bi_scope.
57 | Notation "l ↪ v" := (l ↪{ DfracOwn 1 } v)%I
58 | (at level 20, format "l ↪ v") : bi_scope.
59 |
--------------------------------------------------------------------------------