pax_global_header00006660000000000000000000000064145115334150014514gustar00rootroot0000000000000052 comment=9084203eddd4d8dc26ff8146434a7597c67d826c stdpp-coq-stdpp-1.9.0/000077500000000000000000000000001451153341500145655ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/.gitattributes000066400000000000000000000002451451153341500174610ustar00rootroot00000000000000# Enable syntax highlighting. *.v gitlab-language=coq # Convert to native line endings on checkout. *.ref text # Shell scripts need Linux line endings. *.sh eol=lf stdpp-coq-stdpp-1.9.0/.gitignore000066400000000000000000000003461451153341500165600ustar00rootroot00000000000000*.vo *.vos *.vok *.vio *.v.d .coqdeps.d .Makefile.coq.d *.glob *.cache *.aux \#*\# .\#* *~ *.bak .coq-native/ Makefile.coq Makefile.coq.conf _CoqProject.* Makefile.package.* .Makefile.package.* *.crashcoqide html/ builddep/ _opam stdpp-coq-stdpp-1.9.0/.gitlab-ci.yml000066400000000000000000000031001451153341500172130ustar00rootroot00000000000000image: ralfjung/opam-ci:opam2 stages: - build variables: CPU_CORES: "10" OCAML: "ocaml-variants.4.14.0+options ocaml-option-flambda" # Avoid needlessly increasing our TCB with native_compute COQEXTRAFLAGS: "-native-compiler no" .only_branches: &only_branches only: - /^master/@iris/stdpp - /^ci/@iris/stdpp .only_mr: &only_mr only: - merge_requests .branches_and_mr: &branches_and_mr only: - /^master/@iris/stdpp - /^ci/@iris/stdpp - merge_requests .template: &template <<: *only_branches stage: build interruptible: true tags: - fp script: - git clone https://gitlab.mpi-sws.org/iris/ci.git ci -b opam2 - ci/buildjob cache: key: "$CI_JOB_NAME" paths: - _opam/ except: - triggers - schedules - api ## Build jobs # The newest version runs with timing. build-coq.8.18.0: <<: *template variables: OPAM_PINS: "coq version 8.18.0" DENY_WARNINGS: "1" MANGLE_NAMES: "1" CI_COQCHK: "1" OPAM_PKG: "1" DOC_DIR: "coqdoc@center.mpi-sws.org:stdpp" tags: - fp-timing interruptible: false # The newest version also runs in MRs, without timing. build-coq.8.18.0-mr: <<: *template <<: *only_mr variables: OPAM_PINS: "coq version 8.18.0" DENY_WARNINGS: "1" MANGLE_NAMES: "1" build-coq.8.17.1: <<: *template variables: OPAM_PINS: "coq version 8.17.1" DENY_WARNINGS: "1" MANGLE_NAMES: "1" # The oldest version runs in MRs, without name mangling. build-coq.8.16.1: <<: *template <<: *branches_and_mr variables: OPAM_PINS: "coq version 8.16.1" DENY_WARNINGS: "1" stdpp-coq-stdpp-1.9.0/CHANGELOG.md000066400000000000000000001413611451153341500164040ustar00rootroot00000000000000This file lists "large-ish" changes to the std++ Coq library, but not every API-breaking change is listed. ## std++ 1.9.0 (2023-10-11) This highlights of this release are: * `gmap` and related types are re-implemented based on Appel and Leroy's [Efficient Extensional Binary Tries](https://inria.hal.science/hal-03372247), making them usable in nested inductive definitions and improving extensionality. More information can be found in Robbert Krebbers' Coq Workshop talk, see https://coq-workshop.gitlab.io/2023/ * New tactics `ospecialize`, `odestruct`, `oinversion` etc are added. These tactics improve upon `efeed` / `edestruct` by allowing one to leave more terms open when specializing arguments. For instance, `odestruct (H _ x)` will turn the `_` into an evar rather than trying to infer it immediately, making it usable in many situations where `edestruct` fails. This can significantly shorten the overhead involved in forward reasoning proofs. For more information, see the test cases provided here: https://gitlab.mpi-sws.org/iris/stdpp/-/blob/master/tests/tactics.v#L114 Coq 8.18 is newly supported by this release, and Coq 8.16 and 8.17 remain supported. Coq 8.12 to 8.15 are no longer supported. This release of std++ was managed by Ralf Jung, Robbert Krebbers, and Johannes Hostert, with contributions from Dorian Lesbre, Herman Bergwerf, Ike Mulder, Isaak van Bakel, Jan-Oliver Kaiser, Jonas Kastberg, Marijn van Wezel, Michael Sammler, Paolo Giarrusso, Tej Chajed, and Thibaut Pérami. Thanks a lot to everyone involved! **Detailed list of changes:** - Rename `difference_difference` → `difference_difference_l` and `difference_difference_L` → `difference_difference_l_L`, add `difference_difference_r` and `difference_difference_r_L`. - Let `set_solver` use `eauto` (instead of `idtac`) as its default solver. - Add tactic `tc_solve` (this was `iSolveTC` in Iris). - Change `f_equiv` to use `reflexivity` in a way similar to `f_equal`. That is, let `f_equiv` solve goals and subgoals of the form `R x x`. However, we use a restricted `fast_reflexivity` as full `reflexivity` can be quite expensive. - Rename `loopup_total_empty` → `lookup_total_empty`. - Let `naive_solver tac` fail if `tac` creates new evars. Before it would succeed with a proof that contains unresolved evars/shelved goals. - Add lemmas `Nat.mul_reg_{l,r}` for cancellation of multiplication on `nat`. (Names are analogous to the `Z.` lemmas for Coq's standard library.) - Rename `map_preimage` into `map_preimg` to be consistent with `dom`. - Improve `bijective_finite`: do not require an inverse, do not unnecessarily remove duplicates. - Add operation `*:` for "scalar" multiplication of multisets. - Add `by` parameter to `multiset_solver`, which defaults to `eauto`. - Add `map_img` operator for map image/codomain and some lemmas about it. (by Dorian Lesbre) - Remove `Permutation_alt`, `submseteq_Permutation_length_le`, and `submseteq_Permutation_length_eq`; use `submseteq_length_Permutation` instead. - Remove `map_to_list_length` (which seemed to be an unneeded auxiliary lemma); use `map_subset_size` instead. - Rename `prefix_lookup` → `prefix_lookup_Some`. - Extend `set_solver` with support for `set_Forall` and `set_Exists`. - Change `lookup_union` lemma statement to use `∪` on maps instead of `union_with`. - Add `set_omap` function for finite sets and associated lemmas. (by Dorian Lesbre) - Add proof that `vec` is `Finite`. (by Herman Bergwerf.) - Add `min` and `max` infix notations for `positive`. - Add lemma `map_zip_fst_snd`. - Add `stdpp.ssreflect` to provide compatibility with the ssreflect tactics. - Set `simpl never` for `Pos` and `N` operations (similar to `Z`). - Add `Intersection` instance for `option`. (by Marijn van Wezel) - Add `lookup_intersection` lemma for the distributivity of lookup on an intersection. (by Marijn van Wezel) - Add lemmas `map_filter_or` and `map_filter_and` for the union and intersection of filters on maps. (by Marijn van Wezel) - Set `Hint Mode Equiv !`; this might need some type annotations for ambiguous uses of `≡`. - Set `intuition_solver ::= auto` (the default is `auto with *`) instead of redeclaring `intuition`. - Rename `option_union_Some` → `union_Some`, and strengthen it to become a biimplication. - Provide new implementations of `gmap`/`gset`, `Pmap`/`Pset`, `Nmap`/`Nset` and `Zmap`/`Zset` based on the "canonical" version of binary tries by Appel and Leroy (see https://inria.hal.science/hal-03372247) that avoid the use of Sigma types. This has several benefits: + Maps enjoy more definitional equalities, because they are no longer equipped with a proof of canonicity. This means more equalities can be proved by `reflexivity` or even by conversion as part of unification. For example, `{[ 1 := 1; 2 := 2 ]} = {[ 2 := 2; 1 := 1 ]}` and `{[ 1 ]} ∖ {[ 1 ]} = ∅` hold definitionally. + Maps can be used in nested recursive definitions. For example, `Inductive gtest := GTest : gmap nat gtest → gtest`. (The old map types would violate Coq's strict positivity condition due to the Sigma type.) - Make `map_fold` a primitive of the `FinMap`, and derive `map_to_list` from it. (`map_fold` used to be derived from `map_to_list`.) This makes it possible to use `map_fold` in nested-recursive definitions on maps. For example, `Fixpoint f (t : gtest) := let 'GTest ts := t in map_fold (λ _ t', plus (f t')) 1 ts`. - Make `fin` number literal notations work with numbers above 10. (by Thibaut Pérami) - Bind `fin` type to `fin` scope, so function taking a `fin` as argument will implicitly parse it in `fin` scope. (by Thibaut Pérami) - Change premise `Equivalence` into `PreOrder` for `set_fold_proper`. - Weaken `Proper` premises of `set_ind`, `set_fold_ind`, `set_fold_proper`. If you use `solve_proper` to solve these premises, no change should be needed. If you use a manual proof, you have to remove some `intros` and/or a `split`. - Change `Params` of `lookup` and `lookup_total` from 4 to 5 to disable setoid rewriting in the key argument. If you have `Proper ((=) ==> R ==> S) lookup`, you should change that to `∀ k, Proper (R ==> S) (lookup k)`. - Add lemmas for moving functions in and out of fold operations across data structures: new lemmas exist for sets, gmultisets, finite maps, and lists. (by Isaac van Bakel) + For the above structures, added lemmas which allow rewriting between `g (fold f x s)` and `fold f (g x) s` for appropriately-chosen functions `f`, `g` which commute. + For the above structures, add strong versions of the above lemmas that relate `g (fold f x s)` and `fold f (g x) s` by any preorder respected by `f`, `g` restricted to the elements of `s`. + Add `gmultiset_set_fold_disj_union_strong`, which generalizes `gmultiset_set_fold_disj_union` to any preorder for appropriately-chosen fold functions. - Improve efficiency of `encode`/`decode` for `string` and `ascii`. - Rename `equiv_Forall2` → `list_equiv_Forall2` and `equiv_option_Forall2` → `option_equiv_Forall2`. Add similar lemmas `list_eq_Forall2` and `option_eq_Forall2` for `=` instead of `≡`. - Rename `fmap_inj` → `list_fmap_eq_inj` and `option_fmap_inj` → `option_fmap_eq_inj`. The new lemmas `list_fmap_inj`/`option_fmap_inj` generalize injectivity to `Forall2`/`option_Forall2`. - Generalize `set_map`, `set_bind`, `set_omap`, `map_to_set` and `map_img` lemmas from `Set_` to `SemiSet`. - Rename `sub_add'` to `add_sub'` for consistency with Coq's `add_sub` lemma. - Rename `map_filter_lookup` → `map_lookup_filter` and `map_filter_lookup_Some` → `map_lookup_filter_Some` and `map_filter_lookup_None` → `map_lookup_filter_None`. - Add `map_compose` operation, notation `m ∘ₘ n`, and associated lemmas. (by Dorian Lesbre) - Add `Assoc`, `Comm`, `LeftId`, `RightId`, `LeftAbsorb`, `RightAbsorb` instances for number types. - Add tactics `odestruct`, `oinversion`, `opose proof`, `ospecialize`, `ogeneralize` that work with open terms. All `_` remaining after inference will be turned into evars or subgoals using the same heuristic as `refine`. For instance, with `H: ∀ n, P n → Q n`, `ospecialize (H _ _)` will create an evar for `n` and open a subgoal for `P ?n`. `odestruct` is a more powerful version of `edestruct` that does not require all `_` in the destructed term to be immediately inferred. - Replace `feed`/`efeed` tactics by variants of the `o` tactics that automatically add extra `_` until there are no more leading `∀`/`→`. `efeed tac` becomes `otac*`; the `feed` variants (that only specialize `→` but not `∀`) are no longer provided. - Add lemmas for `reverse` of `take`/`drop` and `take`/`drop` of `reverse`. - Rework lemmas for `take`/`drop` of an `++`: + Add `take_app` and `drop_app`, which are the strongest versions, and use `take_app_X` for derived versions. + Consistently use `'` suffix for version with premise `n = length`, and have versions without `'` with `length` inlined. + Rename `take_app` → `take_app_length`, `take_app_alt` → `take_app_length'`, `take_add_app` → `take_app_add'`, `take_app3_alt` → `take_app3_length'`, `drop_app` → `drop_app_length`, `drop_app_alt` → `drop_app_length'`, `drop_add_app` → `drop_app_add'`, `drop_app3_alt` → `drop_app3_length'`. - Add instance `cons_equiv_inj`. **Changes in `stdpp_unstable`:** - Add bitvector number literal notations. (by Thibaut Pérami) The following `sed` script should perform most of the renaming (on macOS, replace `sed` by `gsed`, installed via e.g. `brew install gnu-sed`). Note that the script is not idempotent, do not run it twice. ``` sed -i -E -f- $(find theories -name "*.v") <` and `destruct select as `. - Add some more lemmas about `Finite` and `pred_finite`. - Add lemmas about `last`: `last_app_cons`, `last_app`, `last_Some`, and `last_Some_elem_of`. - Add versions of Pigeonhole principle for Finite types, natural numbers, and lists. The following `sed` script should perform most of the renaming (on macOS, replace `sed` by `gsed`, installed via e.g. `brew install gnu-sed`). Note that the script is not idempotent, do not run it twice. ``` sed -i -E -f- $(find theories -name "*.v") <` and `-n>`. - Optimize `f_equiv` by doing more syntactic checking before handing off to unification. This can make some uses 50x faster, but also makes the tactic slightly weaker in case the left-hand side and right-hand side of the relation call a function with arguments that are convertible but not syntactically equal. - Add lemma `choose_proper` showing that `choose P` respects predicate equivalence. (by Paolo G. Giarrusso, BedRock Systems) - Extract module `well_founded` from `relations`, and re-export it for compatibility. This contains `wf`, `Acc_impl`, `wf_guard`, `wf_projected`, `Fix_F_proper`, `Fix_unfold_rel`. - Add induction principle `well_founded.Acc_dep_ind`, a dependent version of `Acc_ind`. (by Paolo G. Giarrusso, BedRock Systems) The following `sed` script should perform most of the renaming (on macOS, replace `sed` by `gsed`, installed via e.g. `brew install gnu-sed`). Note that the script is not idempotent, do not run it twice. ``` sed -i -E -f- $(find theories -name "*.v") < into ` tactic to find a hypothesis by pattern and give it a fixed name. - Add `eunify` tactic that lifts Coq's `unify` tactic to `open_constr`. - Generalize `omap_insert`, `omap_singleton`, `map_size_insert`, and `map_size_delete` to cover the `Some` and `None` case. Add `_Some` and `_None` versions of the lemmas for the specific cases. - Rename `dom_map filter` → `dom_filter`, `dom_map_filter_L` → `dom_filter_L`, and `dom_map_filter_subseteq` → `dom_filter_subseteq` for consistency's sake. - Remove unused notations `∪**`, `∪*∪**`, `∖**`, `∖*∖**`, `⊆**`, `⊆1*`, `⊆2*`, `⊆1**`, `⊆2**"`, `##**`, `##1*`, `##2*`, `##1**`, `##2**` for nested `zip_with` and `Forall2` versions of `∪`, `∖`, and `##`. - Remove unused type classes `DisjointE`, `DisjointList`, `LookupE`, and `InsertE`. - Fix a bug where `pretty 0` was defined as `""`, the empty string. It now returns `"0"` for `N`, `Z`, and `nat`. - Remove duplicate `map_fmap_empty` of `fmap_empty`, and rename `map_fmap_empty_inv` into `fmap_empty_inv` for consistency's sake. - Rename `seq_S_end_app` to `seq_S`. (The lemma `seq_S` is also in Coq's stdlib since Coq 8.12.) - Remove `omega` import and hint database in `tactics` file. - Remove unused `find_pat` tactic that was made mostly obsolete by `select`. - Rename `_11` and `_12` into `_1_1` and `_1_2`, respectively. These suffixes are used for `A → B1` and `A → B2` variants of `A ↔ B1 ∧ B2` lemmas. - Rename `Forall_Forall2` → `Forall_Forall2_diag` to be consistent with the names for big operators in Iris. - Rename set equality and equivalence lemmas: `elem_of_equiv_L` → `set_eq`, `set_equiv_spec_L` → `set_eq_subseteq`, `elem_of_equiv` → `set_equiv`, `set_equiv_spec` → `set_equiv_subseteq`. - Remove lemmas `map_filter_iff` and `map_filter_lookup_eq` in favor of the stronger extensionality lemmas `map_filter_ext` and `map_filter_strong_ext`. The following `sed` script should perform most of the renaming (on macOS, replace `sed` by `gsed`, installed via e.g. `brew install gnu-sed`): ``` sed -i -E ' s/\bQp_plus\b/Qp_add/g s/\bQp_mult\b/Qp_mul/g s/\bQp_mult_1_l\b/Qp_mul_1_l/g s/\bQp_mult_1_r\b/Qp_mul_1_r/g s/\bQp_plus_id_free\b/Qp_add_id_free/g s/\bQp_not_plus_ge\b/Qp_not_add_le_l/g s/\bQp_le_plus_l\b/Qp_le_add_l/g s/\bQp_mult_plus_distr_l\b/Qp_mul_add_distr_r/g s/\bQp_mult_plus_distr_r\b/Qp_mul_add_distr_l/g s/\bmap_fmap_empty\b/fmap_empty/g s/\bmap_fmap_empty_inv\b/fmap_empty_inv/g s/\bseq_S_end_app\b/seq_S/g s/\bomap_insert\b/omap_insert_Some/g s/\bomap_singleton\b/omap_singleton_Some/g s/\bomap_size_insert\b/map_size_insert_None/g s/\bomap_size_delete\b/map_size_delete_Some/g s/\bNoDup_cons_11\b/NoDup_cons_1_1/g s/\bNoDup_cons_12\b/NoDup_cons_1_2/g s/\bmap_filter_lookup_Some_11\b/map_filter_lookup_Some_1_1/g s/\bmap_filter_lookup_Some_12\b/map_filter_lookup_Some_1_2/g s/\bmap_Forall_insert_11\b/map_Forall_insert_1_1/g s/\bmap_Forall_insert_12\b/map_Forall_insert_1_2/g s/\bmap_Forall_union_11\b/map_Forall_union_1_1/g s/\bmap_Forall_union_12\b/map_Forall_union_1_2/g s/\bForall_Forall2\b/Forall_Forall2_diag/g s/\belem_of_equiv_L\b/set_eq/g s/\bset_equiv_spec_L\b/set_eq_subseteq/g s/\belem_of_equiv\b/set_equiv/g s/\bset_equiv_spec\b/set_equiv_subseteq/g ' $(find theories -name "*.v") ``` ## std++ 1.4.0 (released 2020-07-15) Coq 8.12 is newly supported by this release, and Coq 8.7 is no longer supported. This release of std++ received contributions by Gregory Malecha, Michael Sammler, Olivier Laurent, Paolo G. Giarrusso, Ralf Jung, Robbert Krebbers, sarahzrf, and Tej Chajed. - Rename `Z2Nat_inj_div` and `Z2Nat_inj_mod` to `Nat2Z_inj_div` and `Nat2Z_inj_mod` to follow the naming convention of `Nat2Z` and `Z2Nat`. Re-purpose the names `Z2Nat_inj_div` and `Z2Nat_inj_mod` for be the lemmas they should actually be. - Add `rotate` and `rotate_take` functions for accessing a list with wrap-around. Also add `rotate_nat_add` and `rotate_nat_sub` for computing indicies into a rotated list. - Add the `select` and `revert select` tactics for selecting and reverting a hypothesis based on a pattern. - Extract `list_numbers.v` from `list.v` and `numbers.v` for functions, which operate on lists of numbers (`seq`, `seqZ`, `sum_list(_with)` and `max_list(_with)`). `list_numbers.v` is exported by the prelude. This is a breaking change if one only imports `list.v`, but not the prelude. - Rename `drop_insert` into `drop_insert_gt` and add `drop_insert_le`. - Add `Countable` instance for `Ascii.ascii`. - Make lemma `list_find_Some` more apply friendly. - Add `filter_app` lemma. - Add tactic `multiset_solver` for solving goals involving multisets. - Rename `fin_maps.singleton_proper` into `singletonM_proper` since it concerns `singletonM` and to avoid overlap with `sets.singleton_proper`. - Add `wn R` for weakly normalizing elements w.r.t. a relation `R`. - Add `encode_Z`/`decode_Z` functions to encode elements of a countable type as integers `Z`, in analogy with `encode_nat`/`decode_nat`. - Fix list `Datatypes.length` and string `strings.length` shadowing (`length` should now always be `Datatypes.length`). - Change the notation for pattern matching monadic bind into `'pat ← x; y`. It was `''pat ← x; y` (with double `'`) due to a shortcoming of Coq ≤8.7. ## std++ 1.3.0 (released 2020-03-18) Coq 8.11 is supported by this release. This release of std++ received contributions by Amin Timany, Armaël Guéneau, Dan Frumin, David Swasey, Jacques-Henri Jourdan, Michael Sammler, Paolo G. Giarrusso, Pierre-Marie Pédrot, Ralf Jung, Robbert Krebbers, Simon Friis Vindum, Tej Chajed, and William Mansky Noteworthy additions and changes: - Rename `dom_map_filter` into `dom_map_filter_subseteq` and repurpose `dom_map_filter` for the version with the equality. This follows the naming convention for similar lemmas. - Generalize `list_find_Some` and `list_find_None` to become bi-implications. - Disambiguate Haskell-style notations for partially applied operators. For example, change `(!! i)` into `(.!! x)` so that `!!` can also be used as a prefix, as done in VST. A sed script to perform the renaming can be found at: https://gitlab.mpi-sws.org/iris/stdpp/merge_requests/93 - Add type class `TopSet` for sets with a `⊤` element. Provide instances for `boolset`, `propset`, and `coPset`. - Add `set_solver` support for `dom`. - Rename `vec_to_list_of_list` into `vec_to_list_to_vec`, and add new lemma `list_to_vec_to_list` for the converse. - Rename `fin_of_nat` into `nat_to_fin`, `fin_to_of_nat` into `fin_to_nat_to_fin`, and `fin_of_to_nat` into `nat_to_fin_to_nat`, to follow the conventions. - Add `Countable` instance for `vec`. - Introduce `destruct_or{?,!}` to repeatedly destruct disjunctions in assumptions. The tactic can also be provided an explicit assumption name; `destruct_and{?,!}` has been generalized accordingly and now can also be provided an explicit assumption name. Slight breaking change: `destruct_and` no longer handle `False`; `destruct_or` now handles `False` while `destruct_and` handles `True`, as the respective units of disjunction and conjunction. - Add tactic `set_unfold in H`. - Set `Hint Mode` for `TCAnd`, `TCOr`, `TCForall`, `TCForall2`, `TCElemOf`, `TCEq`, and `TCDiag`. - Add type class `LookupTotal` with total lookup operation `(!!!) : M → K → A`. Provide instances for `list`, `fin_map`, and `vec`, as well as corresponding lemmas for the operations on these types. The instance for `vec` replaces the ad-hoc `!!!` definition. As a consequence, arguments of `!!!` are no longer parsed in `vec_scope` and `fin_scope`, respectively. Moreover, since `!!!` is overloaded, coercions around `!!!` no longer work. - Make lemmas for `seq` and `seqZ` consistent: + Rename `fmap_seq` → `fmap_S_seq` + Add `fmap_add_seq`, and rename `seqZ_fmap` → `fmap_add_seqZ` + Rename `lookup_seq` → `lookup_seq_lt` + Rename `seqZ_lookup_lt` → `lookup_seqZ_lt`, `seqZ_lookup_ge` → `lookup_seqZ_ge`, and `seqZ_lookup` → `lookup_seqZ` + Rename `lookup_seq_inv` → `lookup_seq` and generalize it to a bi-implication + Add `NoDup_seqZ` and `Forall_seqZ` The following `sed` script should perform most of the renaming (on macOS, replace `sed` by `gsed`, installed via e.g. `brew install gnu-sed`): ``` sed -i ' s/\bdom_map_filter\b/dom_map_filter_subseteq/g s/\bfmap_seq\b/fmap_S_seq/g s/\bseqZ_fmap\b/fmap_add_seqZ/g s/\blookup_seq\b/lookup_seq_lt/g s/\blookup_seq_inv\b/lookup_seq/g s/\bseqZ_lookup_lt\b/lookup_seqZ_lt/g s/\bseqZ_lookup_ge\b/lookup_seqZ_ge/g s/\bseqZ_lookup\b/lookup_seqZ/g s/\bvec_to_list_of_list\b/vec_to_list_to_vec/g s/\bfin_of_nat\b/nat_to_fin/g s/\bfin_to_of_nat\b/fin_to_nat_to_fin/g s/\bfin_of_to_nat\b/nat_to_fin_to_nat/g ' $(find theories -name "*.v") ``` ## std++ 1.2.1 (released 2019-08-29) This release of std++ received contributions by Dan Frumin, Michael Sammler, Paolo G. Giarrusso, Paulo Emílio de Vilhena, Ralf Jung, Robbert Krebbers, Rodolphe Lepigre, and Simon Spies. Noteworthy additions and changes: - Introduce `max` and `min` infix notations for `N` and `Z` like we have for `nat`. - Make `solve_ndisj` tactic more powerful. - Add type class `Involutive`. - Improve `naive_solver` performance in case the goal is trivially solvable. - Add a bunch of new lemmas for list, set, and map operations. - Rename `lookup_imap` into `map_lookup_imap`. ## std++ 1.2.0 (released 2019-04-26) Coq 8.9 is supported by this release, but Coq 8.6 is no longer supported. Use std++ 1.1 if you have to use Coq 8.6. The repository moved to a new location at https://gitlab.mpi-sws.org/iris/stdpp and automatically generated Coq-doc of master is available at https://plv.mpi-sws.org/coqdoc/stdpp/. This release of std++ received contributions by Dan Frumin, Hai Dang, Jan-Oliver Kaiser, Mackie Loeffel, Maxime Dénès, Ralf Jung, Robbert Krebbers, and Tej Chajed. New features: - New notations `=@{A}`, `≡@{A}`, `∈@{A}`, `∉@{A}`, `##@{A}`, `⊆@{A}`, `⊂@{A}`, `⊑@{A}`, `≡ₚ@{A}` for being explicit about the type. - A definition of basic telescopes `tele` and some theory about them. - A simple type class based canceler `NatCancel` for natural numbers. - A type `binder` for anonymous and named binders to be used in program language definitions with string-based binders. - More results about `set_fold` on sets and multisets. - Notions of infinite and finite predicates/sets and basic theory about them. - New operation `map_seq`. - The symmetric and reflexive/transitive/symmetric closure of a relation (`sc` and `rtsc`, respectively). - Different notions of confluence (diamond property, confluence, local confluence) and the relations between these. - A `size` function for finite maps and prove some properties. - More results about `Qp` fractions. - More miscellaneous results about sets, maps, lists, multisets. - Various type class utilities, e.g. `TCEq`, `TCIf`, `TCDiag`, `TCNoBackTrack`, and `tc_to_bool`. - Generalize `gset_to_propset` to `set_to_propset` for any `SemiSet`. Changes: - Consistently use `lia` instead of `omega` everywhere. - Consistently block `simpl` on all `Z` operations. - The `Infinite` class is now defined using a function `fresh : list A → A` that given a list `xs`, gives an element `fresh xs ∉ xs`. - Make `default` an abbreviation for `from_option id` (instead of just swapping the argument order of `from_option`). - More efficient `Countable` instance for `list` that is linear instead of exponential. - Improve performance of `set_solver` significantly by introducing specialized type class `SetUnfoldElemOf` for propositions involving `∈`. - Make `gset` a `Definition` instead of a `Notation` to improve performance. - Use `disj_union` (notation `⊎`) for disjoint union on multisets (that adds the multiplicities). Repurpose `∪` on multisets for the actual union (that takes the max of the multiplicities). - Set `Hint Mode` for `pretty`. Naming: - Consistently use the `set` prefix instead of the `collection` prefix for definitions and lemmas. - Renaming of classes: + `Collection` into `Set_` (`_` since `Set` is a reserved keyword) + `SimpleCollection` into `SemiSet` + `FinCollection` into `FinSet` + `CollectionMonad` into `MonadSet` - Types: + `set A := A → Prop` into `propset` + `bset := A → bool` into `boolset`. - Files: + `collections.v` into `sets.v` + `fin_collections.v` into `fin_sets.v` + `bset` into `boolset` + `set` into `propset` - Consistently use the naming scheme `X_to_Y` for conversion functions, e.g. `list_to_map` instead of the former `map_of_list`. The following `sed` script should perform most of the renaming: ``` sed ' s/SimpleCollection/SemiSet/g; s/FinCollection/FinSet/g; s/CollectionMonad/MonadSet/g; s/Collection/Set\_/g; s/collection\_simple/set\_semi\_set/g; s/fin\_collection/fin\_set/g; s/collection\_monad\_simple/monad\_set\_semi\_set/g; s/collection\_equiv/set\_equiv/g; s/\bbset/boolset/g; s/mkBSet/BoolSet/g; s/mkSet/PropSet/g; s/set\_equivalence/set\_equiv\_equivalence/g; s/collection\_subseteq/set\_subseteq/g; s/collection\_disjoint/set\_disjoint/g; s/collection\_fold/set\_fold/g; s/collection\_map/set\_map/g; s/collection\_size/set\_size/g; s/collection\_filter/set\_filter/g; s/collection\_guard/set\_guard/g; s/collection\_choose/set\_choose/g; s/collection\_ind/set\_ind/g; s/collection\_wf/set\_wf/g; s/map\_to\_collection/map\_to\_set/g; s/map\_of\_collection/set\_to\_map/g; s/map\_of\_list/list\_to\_map/g; s/map\_of\_to_list/list\_to\_map\_to\_list/g; s/map\_to\_of\_list/map\_to\_list\_to\_map/g; s/\bof\_list/list\_to\_set/g; s/\bof\_option/option\_to\_set/g; s/elem\_of\_of\_list/elem\_of\_list\_to\_set/g; s/elem\_of\_of\_option/elem\_of\_option\_to\_set/g; s/collection\_not\_subset\_inv/set\_not\_subset\_inv/g; s/seq\_set/set\_seq/g; s/collections/sets/g; s/collection/set/g; s/to\_gmap/gset\_to\_gmap/g; s/of\_bools/bools\_to\_natset/g; s/to_bools/natset\_to\_bools/g; s/coPset\.of_gset/gset\_to\_coPset/g; s/coPset\.elem\_of\_of\_gset/elem\_of\_gset\_to\_coPset/g; s/of\_gset\_finite/gset\_to\_coPset\_finite/g; s/set\_seq\_S\_disjoint/set\_seq\_S\_end\_disjoint/g; s/set\_seq\_S\_union/set\_seq\_S\_end\_union/g; s/map\_to\_of\_list/map\_to\_list\_to\_map/g; s/of\_bools/bools\_to\_natset/g; s/to\_bools/natset\_to\_bools/g; ' -i $(find -name "*.v") ``` ## std++ 1.1.0 (released 2017-12-19) Coq 8.5 is no longer supported by this release of std++. Use std++ 1.0 if you have to use Coq 8.5. New features: - Many new lemmas about lists, vectors, sets, maps. - Equivalence proofs between std++ functions and their alternative in the the Coq standard library, e.g. `List.nth`, `List.NoDop`. - Typeclass versions of the logical connectives and list predicates: `TCOr`, `TCAnd`, `TCTrue`, `TCForall`, `TCForall2`. - A function `tc_opaque` to make definitions type class opaque. - A type class `Infinite` for infinite types. - A generic implementation to obtain fresh elements of infinite types. - More theory about curry and uncurry functions on `gmap`. - A generic `filter` and `zip_with` operation on finite maps. - A type of generic trees for showing that arbitrary types are countable. Changes: - Get rid of `Automatic Coercions Import`, it is deprecated. Also get rid of `Set Asymmetric Patterns`. - Various changes and improvements to `f_equiv` and `solve_proper`. - `Hint Mode` is now set for all operational type classes to make instance search less likely to diverge. - New type class `RelDecision` for decidable relations, and `EqDecision` is defined in terms of it. This class allows to set `Hint Mode` properly. - Use the flag `assert` of `Arguments` to make it more robust. - The functions `imap` and `imap2` on lists are defined so that they enjoy more definitional equalities. - Theory about `fin` is moved to its own file `fin.v`. - Rename `preserving` → `mono`. Changes to notations: - Operational type classes for lattice notations: `⊑`,`⊓`, `⊔`, `⊤` `⊥`. - Replace `⊥` for disjointness with `##`, so that `⊥` can be used for the bottom lattice element. - All notations are now in `stdpp_scope` with scope key `stdpp` (formerly `C_scope` and `C`). - Higher precedence for `.1` and `.2` that is compatible with ssreflect. - Various changes to monadic notations to improve compatibility with Mtac2: + Pattern matching notation for monadic bind `'pat ← x; y` where `pat` can be any Coq pattern. + Change the level of the do-notation. + `<$>` is left associative. + Notation `x ;; y` for `_ ← x; y`. ## History Coq-std++ has originally been developed by Robbert Krebbers as part of his formalization of the C programming language in his PhD thesis, called [CH2O](http://robbertkrebbers.nl/thesis.html). After that, Coq-std++ has been part of the [Iris project](http://iris-project.org), and has continued to be developed by Robbert Krebbers, Ralf Jung, and Jacques Henri-Jourdan. stdpp-coq-stdpp-1.9.0/LICENSE000066400000000000000000000033211451153341500155710ustar00rootroot00000000000000All files in this development are distributed under the terms of the 3-clause BSD license (https://opensource.org/licenses/BSD-3-Clause), included below. Copyright: std++ developers and contributors ------------------------------------------------------------------------------ Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. stdpp-coq-stdpp-1.9.0/Makefile000066400000000000000000000036211451153341500162270ustar00rootroot00000000000000# Default target all: Makefile.coq +@$(MAKE) -f Makefile.coq all .PHONY: all # Permit local customization -include Makefile.local # Forward most targets to Coq makefile (with some trick to make this phony) %: Makefile.coq phony @#echo "Forwarding $@" +@$(MAKE) -f Makefile.coq $@ phony: ; .PHONY: phony clean: Makefile.coq +@$(MAKE) -f Makefile.coq clean @# Make sure not to enter the `_opam` folder. find [a-z]*/ \( -name "*.d" -o -name "*.vo" -o -name "*.vo[sk]" -o -name "*.aux" -o -name "*.cache" -o -name "*.glob" -o -name "*.vio" \) -print -delete || true rm -f Makefile.coq .lia.cache builddep/* .PHONY: clean # Create Coq Makefile. Makefile.coq: _CoqProject Makefile "$(COQBIN)coq_makefile" -f _CoqProject -o Makefile.coq $(EXTRA_COQFILES) # Install build-dependencies OPAMFILES=$(wildcard *.opam) BUILDDEPFILES=$(addsuffix -builddep.opam, $(addprefix builddep/,$(basename $(OPAMFILES)))) builddep/%-builddep.opam: %.opam Makefile @echo "# Creating builddep package for $<." @mkdir -p builddep @sed <$< -E 's/^(build|install|remove):.*/\1: []/; s/"(.*)"(.*= *version.*)$$/"\1-builddep"\2/;' >$@ builddep-opamfiles: $(BUILDDEPFILES) .PHONY: builddep-opamfiles builddep: builddep-opamfiles @# We want opam to not just install the build-deps now, but to also keep satisfying these @# constraints. Otherwise, `opam upgrade` may well update some packages to versions @# that are incompatible with our build requirements. @# To achieve this, we create a fake opam package that has our build-dependencies as @# dependencies, but does not actually install anything itself. @echo "# Installing builddep packages." @opam install $(OPAMFLAGS) $(BUILDDEPFILES) .PHONY: builddep # Backwards compatibility target build-dep: builddep .PHONY: build-dep # Some files that do *not* need to be forwarded to Makefile.coq. # ("::" lets Makefile.local overwrite this.) Makefile Makefile.local _CoqProject $(OPAMFILES):: ; stdpp-coq-stdpp-1.9.0/Makefile.coq.local000066400000000000000000000042141451153341500201000ustar00rootroot00000000000000# use NO_TEST=1 to skip the tests NO_TEST:= # use MAKE_REF=1 to generate new reference files MAKE_REF:= # Run tests interleaved with main build. They have to be in the same target for this. real-all: style $(if $(NO_TEST),,test) style: $(VFILES) coq-lint.sh # Make sure everything imports the options, and some general linting. $(SHOW)"COQLINT" $(HIDE)for FILE in $(VFILES); do \ if ! grep -F -q 'From stdpp Require Import options.' "$$FILE"; then echo "ERROR: $$FILE does not import 'options'."; echo; exit 1; fi ; \ ./coq-lint.sh "$$FILE" || exit 1; \ done .PHONY: style # the test suite TESTFILES:=$(shell find tests -name "*.v") NORMALIZER:=test-normalizer.sed test: $(TESTFILES:.v=.vo) .PHONY: test COQ_TEST=$(COQTOP) $(COQDEBUG) -batch -test-mode # Need to make this a lazy variable (`=` instead of `:=`) since COQ_VERSION is only set later. COQ_MINOR_VERSION=$(shell echo "$(COQ_VERSION)" | grep -E '^[0-9]+\.[0-9]+\b' -o) tests/.coqdeps.d: $(TESTFILES) $(SHOW)'COQDEP TESTFILES' $(HIDE)$(COQDEP) -dyndep var $(COQMF_COQLIBS_NOML) $^ $(redir_if_ok) -include tests/.coqdeps.d # Main test script (comments out-of-line because macOS otherwise barfs?!?) # - Determine reference file (`REF`). # - Print user-visible status line. # - unset env vars that change Coq's output # - Dump Coq output into a temporary file. # - Run `sed -i` on that file in a way that works on macOS. # - Either compare the result with the reference file, or move it over the reference file. # - Cleanup, and mark as done for make. $(TESTFILES:.v=.vo): %.vo: %.v $(if $(MAKE_REF),,%.ref) $(NORMALIZER) $(HIDE)if test -f $*".$(COQ_MINOR_VERSION).ref"; then \ REF=$*".$(COQ_MINOR_VERSION).ref"; \ else \ REF=$*".ref"; \ fi && \ echo "COQTEST$(if $(MAKE_REF), [make ref],) $< (ref: $$REF)" && \ TMPFILE="$$(mktemp)" && \ unset OCAMLRUNPARAM && \ $(TIMER) $(COQ_TEST) $(COQFLAGS) $(COQLIBS) -load-vernac-source $< > "$$TMPFILE" && \ sed -f $(NORMALIZER) "$$TMPFILE" > "$$TMPFILE".new && \ mv "$$TMPFILE".new "$$TMPFILE" && \ $(if $(MAKE_REF),mv "$$TMPFILE" "$$REF",diff --strip-trailing-cr -u "$$REF" "$$TMPFILE") && \ rm -f "$$TMPFILE" && \ touch $@ stdpp-coq-stdpp-1.9.0/README.md000066400000000000000000000107701451153341500160510ustar00rootroot00000000000000# Coq-std++ [[coqdoc]](https://plv.mpi-sws.org/coqdoc/stdpp/) This project contains an extended "Standard Library" for Coq called coq-std++. The key features of this library are as follows: - It provides a great number of definitions and lemmas for common data structures such as lists, finite maps, finite sets, and finite multisets. - It uses type classes for common notations (like `∅`, `∪`, and Haskell-style monad notations) so that these can be overloaded for different data structures. - It uses type classes to keep track of common properties of types, like it having decidable equality or being countable or finite. - Most data structures are represented in canonical ways so that Leibniz equality can be used as much as possible (for example, for maps we have `m1 = m2` iff `∀ i, m1 !! i = m2 !! i`). On top of that, the library provides setoid instances for most types and operations. - It provides various tactics for common tasks, like an ssreflect inspired `done` tactic for finishing trivial goals, a simple breadth-first solver `naive_solver`, an equality simplifier `simplify_eq`, a solver `solve_proper` for proving compatibility of functions with respect to relations, and a solver `set_solver` for goals involving set operations. - It is entirely dependency- and axiom-free. ## Side-effects Importing std++ has some side effects as the library sets some global options. Notably: * `Generalizable All Variables`: This option enables implicit generalization in arguments of the form `` `{...}`` (i.e., anonymous arguments) and in terms of shape `` `{}``/`` `[]``/`` `()``. See [Coq's manual](https://coq.inria.fr/distrib/current/refman/language/extensions/implicit-arguments.html#implicit-generalization) for further details. * The behavior of `Program` is tweaked: `Unset Transparent Obligations`, `Obligation Tactic := idtac`, `Add Search Blacklist "_obligation_"`. See [`base.v`](theories/base.v) for further details. * It blocks `simpl` on all operations involving integers `Z` (by setting `Arguments op : simpl never`). We do this because `simpl` tends to expose the internals of said operations (e.g. try `simpl` on `Z.of_nat (S n) + y`). * It sets `intuition_solver` to `auto`. The default is `auto with *`, which is very expensive. ## Prerequisites This version is known to compile with: - Coq version 8.16.1 / 8.17.1 / 8.18.0 Generally we always aim to support the last two stable Coq releases. Support for older versions will be dropped when it is convenient. ## Installing via opam To obtain the latest stable release via opam (2.0.0 or newer), you have to add the Coq opam repository: opam repo add coq-released https://coq.inria.fr/opam/released Then you can do `opam install coq-stdpp`. To obtain a development version, add the Iris opam repository: opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git ## Building from source Run `make -jN` in this directory to build the library, where `N` is the number of your CPU cores. Then run `make install` to install the library. ## Unstable libraries The `stdpp_unstable` folder contains a set of libraries that are not deemed stable enough to be included in the main std++ library. These libraries are available via the `coq-stdpp-unstable` opam package. For each library, there is a corresponding "tracking issue" in the std++ issue tracker (also linked from the library itself) which tracks the work that still needs to be done before moving the library to std++. No stability guarantees whatsoever are made for this package. Note that the unstable package is not released, so it only exists in the development version of std++. ## Contributing to std++ If you want to report a bug, please use the [issue tracker](https://gitlab.mpi-sws.org/iris/stdpp/issues). You will have to create an account at the [MPI-SWS GitLab](https://gitlab.mpi-sws.org/users/sign_in) (use the "Register" tab). To contribute code, please send your MPI-SWS GitLab username to [Ralf Jung](https://gitlab.mpi-sws.org/jung) to enable personal projects for your account. Then you can fork the [Coq-std++ git repository](https://gitlab.mpi-sws.org/iris/stdpp), make your changes in your fork, and create a merge request. Please refer to [our style guide](https://gitlab.mpi-sws.org/iris/iris/-/blob/master/docs/style_guide.md) for code formatting and naming policies. ## Common problems On Windows, differences in line endings may cause tests to fail. This can be fixed by setting Git's autocrlf option to true: git config --global core.autocrlf true stdpp-coq-stdpp-1.9.0/_CoqProject000066400000000000000000000022031451153341500167150ustar00rootroot00000000000000# Search paths for all packages. They must all match the regex # `-Q $PACKAGE[/ ]` so that we can filter out the right ones for each package. -Q stdpp stdpp -Q stdpp_unstable stdpp.unstable # Fixing this one requires Coq 8.17 -arg -w -arg -future-coercion-class-field stdpp/options.v stdpp/base.v stdpp/tactics.v stdpp/option.v stdpp/fin_map_dom.v stdpp/boolset.v stdpp/fin_maps.v stdpp/fin.v stdpp/vector.v stdpp/pmap.v stdpp/stringmap.v stdpp/fin_sets.v stdpp/mapset.v stdpp/proof_irrel.v stdpp/hashset.v stdpp/pretty.v stdpp/countable.v stdpp/orders.v stdpp/natmap.v stdpp/strings.v stdpp/well_founded.v stdpp/relations.v stdpp/sets.v stdpp/listset.v stdpp/streams.v stdpp/gmap.v stdpp/gmultiset.v stdpp/prelude.v stdpp/listset_nodup.v stdpp/finite.v stdpp/numbers.v stdpp/nmap.v stdpp/zmap.v stdpp/coPset.v stdpp/coGset.v stdpp/lexico.v stdpp/propset.v stdpp/decidable.v stdpp/list.v stdpp/list_numbers.v stdpp/functions.v stdpp/hlist.v stdpp/sorting.v stdpp/infinite.v stdpp/nat_cancel.v stdpp/namespaces.v stdpp/telescopes.v stdpp/binders.v stdpp/ssreflect.v stdpp_unstable/bitblast.v stdpp_unstable/bitvector.v stdpp_unstable/bitvector_tactics.v stdpp-coq-stdpp-1.9.0/coq-lint.sh000077500000000000000000000010451451153341500166520ustar00rootroot00000000000000#!/bin/bash set -e ## A simple shell script checking for some common Coq issues. FILE="$1" if grep -E -n '^\s*((Existing\s+|Program\s+|Declare\s+)?Instance|Arguments|Remove|Hint\s+(Extern|Constructors|Resolve|Immediate|Mode|Opaque|Transparent|Unfold|Rewrite)|(Open|Close)\s+Scope|Opaque|Transparent|Typeclasses (Opaque|Transparent))\b' "$FILE"; then echo "ERROR: $FILE contains 'Instance'/'Arguments'/'Hint' or another side-effect without locality (see above)." echo "Please add 'Global' or 'Local' as appropriate." echo exit 1 fi stdpp-coq-stdpp-1.9.0/coq-stdpp-unstable.opam000066400000000000000000000012521451153341500211700ustar00rootroot00000000000000opam-version: "2.0" maintainer: "Ralf Jung " authors: "The std++ team" license: "BSD-3-Clause" homepage: "https://gitlab.mpi-sws.org/iris/stdpp" bug-reports: "https://gitlab.mpi-sws.org/iris/stdpp/issues" dev-repo: "git+https://gitlab.mpi-sws.org/iris/stdpp.git" version: "dev" synopsis: "Unfinished std++ libraries" description: """ This package contains libraries that have been proposed for inclusion in std++, but more work is needed before they are ready for this. """ tags: [ "logpath:stdpp.unstable" ] depends: [ "coq-stdpp" {= version} ] build: ["./make-package" "stdpp_unstable" "-j%{jobs}%"] install: ["./make-package" "stdpp_unstable" "install"] stdpp-coq-stdpp-1.9.0/coq-stdpp.opam000066400000000000000000000033101451153341500173520ustar00rootroot00000000000000opam-version: "2.0" maintainer: "Ralf Jung " authors: "The std++ team" license: "BSD-3-Clause" homepage: "https://gitlab.mpi-sws.org/iris/stdpp" bug-reports: "https://gitlab.mpi-sws.org/iris/stdpp/issues" dev-repo: "git+https://gitlab.mpi-sws.org/iris/stdpp.git" version: "dev" synopsis: "An extended \"Standard Library\" for Coq" description: """ The key features of this library are as follows: - It provides a great number of definitions and lemmas for common data structures such as lists, finite maps, finite sets, and finite multisets. - It uses type classes for common notations (like `∅`, `∪`, and Haskell-style monad notations) so that these can be overloaded for different data structures. - It uses type classes to keep track of common properties of types, like it having decidable equality or being countable or finite. - Most data structures are represented in canonical ways so that Leibniz equality can be used as much as possible (for example, for maps we have `m1 = m2` iff `∀ i, m1 !! i = m2 !! i`). On top of that, the library provides setoid instances for most types and operations. - It provides various tactics for common tasks, like an ssreflect inspired `done` tactic for finishing trivial goals, a simple breadth-first solver `naive_solver`, an equality simplifier `simplify_eq`, a solver `solve_proper` for proving compatibility of functions with respect to relations, and a solver `set_solver` for goals involving set operations. - It is entirely dependency- and axiom-free. """ tags: [ "logpath:stdpp" ] depends: [ "coq" { (>= "8.16" & < "8.19~") | (= "dev") } ] build: ["./make-package" "stdpp" "-j%{jobs}%"] install: ["./make-package" "stdpp" "install"] stdpp-coq-stdpp-1.9.0/make-package000077500000000000000000000016521451153341500170250ustar00rootroot00000000000000#!/bin/bash set -e # Helper script to build and/or install just one package out of this repository. # Assumes that all the other packages it depends on have been installed already! PROJECT="$1" shift COQFILE="_CoqProject.$PROJECT" MAKEFILE="Makefile.package.$PROJECT" if ! grep -E -q "^$PROJECT/" _CoqProject; then echo "No files in $PROJECT/ found in _CoqProject; this does not seem to be a valid project name." exit 1 fi # Generate _CoqProject file and Makefile rm -f "$COQFILE" # Get the right "-Q" line. grep -E "^-Q $PROJECT[ /]" _CoqProject >> "$COQFILE" # Get everything until the first empty line except for the "-Q" lines. sed -n '/./!q;p' _CoqProject | grep -E -v "^-Q " >> "$COQFILE" # Get the files. grep -E "^$PROJECT/" _CoqProject >> "$COQFILE" # Now we can run coq_makefile. "${COQBIN}coq_makefile" -f "$COQFILE" -o "$MAKEFILE" # Run build make -f "$MAKEFILE" "$@" # Cleanup rm -f ".$MAKEFILE.d" "$MAKEFILE"* stdpp-coq-stdpp-1.9.0/stdpp/000077500000000000000000000000001451153341500157175ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/stdpp/base.v000066400000000000000000002231511451153341500170240ustar00rootroot00000000000000(** This file collects type class interfaces, notations, and general theorems that are used throughout the whole development. Most importantly it contains abstract interfaces for ordered structures, sets, and various other data structures. *) (* We want to ensure that [le] and [lt] refer to operations on [nat]. These two functions being defined both in [Coq.Bool] and in [Coq.Peano], we must export [Coq.Peano] later than any export of [Coq.Bool]. *) (* We also want to ensure that notations from [Coq.Utf8] take precedence over the ones of [Coq.Peano] (see Coq PR#12950), so we import [Utf8] last. *) From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8. From Coq Require Import Permutation. Export ListNotations. From Coq.Program Require Export Basics Syntax. From stdpp Require Import options. (** This notation is necessary to prevent [length] from being printed as [strings.length] if strings.v is imported and later base.v. See also strings.v and https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/144 and https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/129. *) Notation length := Datatypes.length. (** * Enable implicit generalization. *) (** This option enables implicit generalization in arguments of the form [`{...}] (i.e., anonymous arguments). Unfortunately, it also enables implicit generalization in [Instance]. We think that the fact that both behaviors are coupled together is a [bug in Coq](https://github.com/coq/coq/issues/6030). *) Global Generalizable All Variables. (** * Tweak program *) (** 1. Since we only use Program to solve logical side-conditions, they should always be made Opaque, otherwise we end up with performance problems due to Coq blindly unfolding them. Note that in most cases we use [Next Obligation. (* ... *) Qed.], for which this option does not matter. However, sometimes we write things like [Solve Obligations with naive_solver (* ... *)], and then the obligations should surely be opaque. *) Global Unset Transparent Obligations. (** 2. Do not let Program automatically simplify obligations. The default obligation tactic is [Tactics.program_simpl], which, among other things, introduces all variables and gives them fresh names. As such, it becomes impossible to refer to hypotheses in a robust way. *) Global Obligation Tactic := idtac. (** 3. Hide obligations and unsealing lemmas from the results of the [Search] commands. *) Add Search Blacklist "_obligation_". Add Search Blacklist "_unseal". (** * Sealing off definitions *) #[projections(primitive=yes)] Record seal {A} (f : A) := { unseal : A; seal_eq : unseal = f }. Global Arguments unseal {_ _} _ : assert. Global Arguments seal_eq {_ _} _ : assert. (** * Solving type class instances *) (** The tactic [tc_solve] is used to solve type class goals by invoking type class search. It is similar to [apply _], but it is more robust since it does not affect unrelated goals/evars due to https://github.com/coq/coq/issues/6583. The tactic [tc_solve] is particularly useful when building custom tactics that need tight control over when type class search is invoked. In Iris, many of the proof mode tactics make use of [notypeclasses refine] and use [tc_solve] to manually invoke type class search. Note that [typeclasses eauto] is multi-success. That means, whenever subsequent tactics fail, it will backtrack to [typeclasses eauto] to try the next type class instance. This is almost always undesired and can lead to poor performance and horrible error messages. Hence, we wrap it in a [once]. *) Ltac tc_solve := solve [once (typeclasses eauto)]. (** * Non-backtracking type classes *) (** The type class [TCNoBackTrack P] can be used to establish [P] without ever backtracking on the instance of [P] that has been found. Backtracking may normally happen when [P] contains evars that could be instanciated in different ways depending on which instance is picked, and type class search somewhere else depends on this evar. The proper way of handling this would be by setting Coq's option `Typeclasses Unique Instances`. However, this option seems to be broken, see Coq issue #6714. See https://gitlab.mpi-sws.org/FP/iris-coq/merge_requests/112 for a rationale of this type class. *) Class TCNoBackTrack (P : Prop) := TCNoBackTrack_intro { tc_no_backtrack : P }. Global Hint Extern 0 (TCNoBackTrack _) => notypeclasses refine (TCNoBackTrack_intro _ _); tc_solve : typeclass_instances. (* A conditional at the type class level. Note that [TCIf P Q R] is not the same as [TCOr (TCAnd P Q) R]: the latter will backtrack to [R] if it fails to establish [Q], i.e. does not have the behavior of a conditional. Furthermore, note that [TCOr (TCAnd P Q) (TCAnd (TCNot P) R)] would not work; we generally would not be able to prove the negation of [P]. *) Inductive TCIf (P Q R : Prop) : Prop := | TCIf_true : P → Q → TCIf P Q R | TCIf_false : R → TCIf P Q R. Existing Class TCIf. Global Hint Extern 0 (TCIf _ _ _) => first [notypeclasses refine (TCIf_true _ _ _ _ _); [tc_solve|] |notypeclasses refine (TCIf_false _ _ _ _)] : typeclass_instances. (** * Typeclass opaque definitions *) (** The constant [tc_opaque] is used to make definitions opaque for just type class search. Note that [simpl] is set up to always unfold [tc_opaque]. *) Definition tc_opaque {A} (x : A) : A := x. Global Typeclasses Opaque tc_opaque. Global Arguments tc_opaque {_} _ /. (** Below we define type class versions of the common logical operators. It is important to note that we duplicate the definitions, and do not declare the existing logical operators as type classes. That is, we do not say: Existing Class or. Existing Class and. If we could define the existing logical operators as classes, there is no way of disambiguating whether a premise of a lemma should be solved by type class resolution or not. These classes are useful for two purposes: writing complicated type class premises in a more concise way, and for efficiency. For example, using the [Or] class, instead of defining two instances [P → Q1 → R] and [P → Q2 → R] we could have one instance [P → Or Q1 Q2 → R]. When we declare the instance that way, we avoid the need to derive [P] twice. *) Inductive TCOr (P1 P2 : Prop) : Prop := | TCOr_l : P1 → TCOr P1 P2 | TCOr_r : P2 → TCOr P1 P2. Existing Class TCOr. Global Existing Instance TCOr_l | 9. Global Existing Instance TCOr_r | 10. Global Hint Mode TCOr ! ! : typeclass_instances. Inductive TCAnd (P1 P2 : Prop) : Prop := TCAnd_intro : P1 → P2 → TCAnd P1 P2. Existing Class TCAnd. Global Existing Instance TCAnd_intro. Global Hint Mode TCAnd ! ! : typeclass_instances. Inductive TCTrue : Prop := TCTrue_intro : TCTrue. Existing Class TCTrue. Global Existing Instance TCTrue_intro. (** The class [TCFalse] is not stricly necessary as one could also use [False]. However, users might expect that TCFalse exists and if it does not, it can cause hard to diagnose bugs due to automatic generalization. *) Inductive TCFalse : Prop :=. Existing Class TCFalse. (** The class [TCUnless] can be used to check that search for [P] fails. This is useful as a guard for certain instances together with classes like [TCFastDone] (see [tactics.v]) to prevent infinite loops (e.g. when saturating the context). *) Notation TCUnless P := (TCIf P TCFalse TCTrue). Inductive TCForall {A} (P : A → Prop) : list A → Prop := | TCForall_nil : TCForall P [] | TCForall_cons x xs : P x → TCForall P xs → TCForall P (x :: xs). Existing Class TCForall. Global Existing Instance TCForall_nil. Global Existing Instance TCForall_cons. Global Hint Mode TCForall ! ! ! : typeclass_instances. (** The class [TCForall2 P l k] is commonly used to transform an input list [l] into an output list [k], or the converse. Therefore there are two modes, either [l] input and [k] output, or [k] input and [l] input. *) Inductive TCForall2 {A B} (P : A → B → Prop) : list A → list B → Prop := | TCForall2_nil : TCForall2 P [] [] | TCForall2_cons x y xs ys : P x y → TCForall2 P xs ys → TCForall2 P (x :: xs) (y :: ys). Existing Class TCForall2. Global Existing Instance TCForall2_nil. Global Existing Instance TCForall2_cons. Global Hint Mode TCForall2 ! ! ! ! - : typeclass_instances. Global Hint Mode TCForall2 ! ! ! - ! : typeclass_instances. Inductive TCExists {A} (P : A → Prop) : list A → Prop := | TCExists_cons_hd x l : P x → TCExists P (x :: l) | TCExists_cons_tl x l: TCExists P l → TCExists P (x :: l). Existing Class TCExists. Global Existing Instance TCExists_cons_hd | 10. Global Existing Instance TCExists_cons_tl | 20. Global Hint Mode TCExists ! ! ! : typeclass_instances. Inductive TCElemOf {A} (x : A) : list A → Prop := | TCElemOf_here xs : TCElemOf x (x :: xs) | TCElemOf_further y xs : TCElemOf x xs → TCElemOf x (y :: xs). Existing Class TCElemOf. Global Existing Instance TCElemOf_here. Global Existing Instance TCElemOf_further. Global Hint Mode TCElemOf ! ! ! : typeclass_instances. (** The intended use of [TCEq x y] is to use [x] as input and [y] as output, but this is not enforced. We use output mode [-] (instead of [!]) for [x] to ensure that type class search succeed on goals like [TCEq (if ? then e1 else e2) ?y], see https://gitlab.mpi-sws.org/iris/iris/merge_requests/391 for a use case. Mode [-] is harmless, the only instance of [TCEq] is [TCEq_refl] below, so we cannot create loops. *) Inductive TCEq {A} (x : A) : A → Prop := TCEq_refl : TCEq x x. Existing Class TCEq. Global Existing Instance TCEq_refl. Global Hint Mode TCEq ! - - : typeclass_instances. Lemma TCEq_eq {A} (x1 x2 : A) : TCEq x1 x2 ↔ x1 = x2. Proof. split; destruct 1; reflexivity. Qed. Inductive TCDiag {A} (C : A → Prop) : A → A → Prop := | TCDiag_diag x : C x → TCDiag C x x. Existing Class TCDiag. Global Existing Instance TCDiag_diag. Global Hint Mode TCDiag ! ! ! - : typeclass_instances. Global Hint Mode TCDiag ! ! - ! : typeclass_instances. (** Given a proposition [P] that is a type class, [tc_to_bool P] will return [true] iff there is an instance of [P]. It is often useful in Ltac programming, where one can do [lazymatch tc_to_bool P with true => .. | false => .. end]. *) Definition tc_to_bool (P : Prop) {p : bool} `{TCIf P (TCEq p true) (TCEq p false)} : bool := p. (** Throughout this development we use [stdpp_scope] for all general purpose notations that do not belong to a more specific scope. *) Declare Scope stdpp_scope. Delimit Scope stdpp_scope with stdpp. Global Open Scope stdpp_scope. (** Change [True] and [False] into notations in order to enable overloading. We will use this to give [True] and [False] a different interpretation for embedded logics. *) Notation "'True'" := True (format "True") : type_scope. Notation "'False'" := False (format "False") : type_scope. (** Change [forall] into a notation in order to enable overloading. *) Notation "'forall' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity, only parsing) : type_scope. (** * Equality *) (** Introduce some Haskell style like notations. *) Notation "(=)" := eq (only parsing) : stdpp_scope. Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope. Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope. Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope. Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope. Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope. Infix "=@{ A }" := (@eq A) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope. Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope. Notation "X ≠@{ A } Y":= (¬X =@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. Global Hint Extern 0 (_ = _) => reflexivity : core. Global Hint Extern 100 (_ ≠ _) => discriminate : core. Global Instance: ∀ A, PreOrder (=@{A}). Proof. split; repeat intro; congruence. Qed. (** ** Setoid equality *) (** We define an operational type class for setoid equality, i.e., the "canonical" equivalence for a type. The typeclass is tied to the \equiv symbol. This is based on (Spitters/van der Weegen, 2011). *) Class Equiv A := equiv: relation A. Global Hint Mode Equiv ! : typeclass_instances. (** We instruct setoid rewriting to infer [equiv] as a relation on type [A] when needed. This allows setoid_rewrite to solve constraints of shape [Proper (eq ==> ?R) f] using [Proper (eq ==> (equiv (A:=A))) f] when an equivalence relation is available on type [A]. We put this instance at level 150 so it does not take precedence over Coq's stdlib instances, favoring inference of [eq] (all Coq functions are automatically morphisms for [eq]). We have [eq] (at 100) < [≡] (at 150) < [⊑] (at 200). *) Global Instance equiv_rewrite_relation `{Equiv A} : RewriteRelation (@equiv A _) | 150 := {}. Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope. Infix "≡@{ A }" := (@equiv A _) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(≡)" := equiv (only parsing) : stdpp_scope. Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope. Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope. Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope. Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope. Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope. Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope. Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope. Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope. Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. (** The type class [LeibnizEquiv] collects setoid equalities that coincide with Leibniz equality. We provide the tactic [fold_leibniz] to transform such setoid equalities into Leibniz equalities, and [unfold_leibniz] for the reverse. *) Class LeibnizEquiv A `{Equiv A} := leibniz_equiv (x y : A) : x ≡ y → x = y. Global Hint Mode LeibnizEquiv ! ! : typeclass_instances. Lemma leibniz_equiv_iff `{LeibnizEquiv A, !Reflexive (≡@{A})} (x y : A) : x ≡ y ↔ x = y. Proof. split; [apply leibniz_equiv|]. intros ->; reflexivity. Qed. Ltac fold_leibniz := repeat match goal with | H : context [ _ ≡@{?A} _ ] |- _ => setoid_rewrite (leibniz_equiv_iff (A:=A)) in H | |- context [ _ ≡@{?A} _ ] => setoid_rewrite (leibniz_equiv_iff (A:=A)) end. Ltac unfold_leibniz := repeat match goal with | H : context [ _ =@{?A} _ ] |- _ => setoid_rewrite <-(leibniz_equiv_iff (A:=A)) in H | |- context [ _ =@{?A} _ ] => setoid_rewrite <-(leibniz_equiv_iff (A:=A)) end. Definition equivL {A} : Equiv A := (=). (** A [Params f n] instance forces the setoid rewriting mechanism not to rewrite in the first [n] arguments of the function [f]. We will declare such instances for all operational type classes in this development. *) Global Instance: Params (@equiv) 2 := {}. (** The following instance forces [setoid_replace] to use setoid equality (for types that have an [Equiv] instance) rather than the standard Leibniz equality. *) Global Instance equiv_default_relation `{Equiv A} : DefaultRelation (≡@{A}) | 3 := {}. Global Hint Extern 0 (_ ≡ _) => reflexivity : core. Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core. (** * Type classes *) (** ** Decidable propositions *) (** This type class by (Spitters/van der Weegen, 2011) collects decidable propositions. *) Class Decision (P : Prop) := decide : {P} + {¬P}. Global Hint Mode Decision ! : typeclass_instances. Global Arguments decide _ {_} : simpl never, assert. (** Although [RelDecision R] is just [∀ x y, Decision (R x y)], we make this an explicit class instead of a notation for two reasons: - It allows us to control [Hint Mode] more precisely. In particular, if it were defined as a notation, the above [Hint Mode] for [Decision] would not prevent diverging instance search when looking for [RelDecision (@eq ?A)], which would result in it looking for [Decision (@eq ?A x y)], i.e. an instance where the head position of [Decision] is not en evar. - We use it to avoid inefficient computation due to eager evaluation of propositions by [vm_compute]. This inefficiency arises for example if [(x = y) := (f x = f y)]. Since [decide (x = y)] evaluates to [decide (f x = f y)], this would then lead to evaluation of [f x] and [f y]. Using the [RelDecision], the [f] is hidden under a lambda, which prevents unnecessary evaluation. *) Class RelDecision {A B} (R : A → B → Prop) := decide_rel x y :> Decision (R x y). Global Hint Mode RelDecision ! ! ! : typeclass_instances. Global Arguments decide_rel {_ _} _ {_} _ _ : simpl never, assert. Notation EqDecision A := (RelDecision (=@{A})). (** ** Inhabited types *) (** This type class collects types that are inhabited. *) Class Inhabited (A : Type) : Type := populate { inhabitant : A }. Global Hint Mode Inhabited ! : typeclass_instances. Global Arguments populate {_} _ : assert. (** ** Proof irrelevant types *) (** This type class collects types that are proof irrelevant. That means, all elements of the type are equal. We use this notion only used for propositions, but by universe polymorphism we can generalize it. *) Class ProofIrrel (A : Type) : Prop := proof_irrel (x y : A) : x = y. Global Hint Mode ProofIrrel ! : typeclass_instances. (** ** Common properties *) (** These operational type classes allow us to refer to common mathematical properties in a generic way. For example, for injectivity of [(k ++.)] it allows us to write [inj (k ++.)] instead of [app_inv_head k]. *) Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop := inj x y : S (f x) (f y) → R x y. Class Inj2 {A B C} (R1 : relation A) (R2 : relation B) (S : relation C) (f : A → B → C) : Prop := inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2. Class Cancel {A B} (S : relation B) (f : A → B) (g : B → A) : Prop := cancel : ∀ x, S (f (g x)) x. Class Surj {A B} (R : relation B) (f : A → B) := surj y : ∃ x, R (f x) y. Class IdemP {A} (R : relation A) (f : A → A → A) : Prop := idemp x : R (f x x) x. Class Comm {A B} (R : relation A) (f : B → B → A) : Prop := comm x y : R (f x y) (f y x). Class LeftId {A} (R : relation A) (i : A) (f : A → A → A) : Prop := left_id x : R (f i x) x. Class RightId {A} (R : relation A) (i : A) (f : A → A → A) : Prop := right_id x : R (f x i) x. Class Assoc {A} (R : relation A) (f : A → A → A) : Prop := assoc x y z : R (f x (f y z)) (f (f x y) z). Class LeftAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop := left_absorb x : R (f i x) i. Class RightAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop := right_absorb x : R (f x i) i. Class AntiSymm {A} (R S : relation A) : Prop := anti_symm x y : S x y → S y x → R x y. Class Total {A} (R : relation A) := total x y : R x y ∨ R y x. Class Trichotomy {A} (R : relation A) := trichotomy x y : R x y ∨ x = y ∨ R y x. Class TrichotomyT {A} (R : relation A) := trichotomyT x y : {R x y} + {x = y} + {R y x}. Notation Involutive R f := (Cancel R f f). Lemma involutive {A} {R : relation A} (f : A → A) `{Involutive R f} x : R (f (f x)) x. Proof. auto. Qed. Global Arguments irreflexivity {_} _ {_} _ _ : assert. Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert. Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert. Global Arguments cancel {_ _ _} _ _ {_} _ : assert. Global Arguments surj {_ _ _} _ {_} _ : assert. Global Arguments idemp {_ _} _ {_} _ : assert. Global Arguments comm {_ _ _} _ {_} _ _ : assert. Global Arguments left_id {_ _} _ _ {_} _ : assert. Global Arguments right_id {_ _} _ _ {_} _ : assert. Global Arguments assoc {_ _} _ {_} _ _ _ : assert. Global Arguments left_absorb {_ _} _ _ {_} _ : assert. Global Arguments right_absorb {_ _} _ _ {_} _ : assert. Global Arguments anti_symm {_ _} _ {_} _ _ _ _ : assert. Global Arguments total {_} _ {_} _ _ : assert. Global Arguments trichotomy {_} _ {_} _ _ : assert. Global Arguments trichotomyT {_} _ {_} _ _ : assert. Lemma not_symmetry `{R : relation A, !Symmetric R} x y : ¬R x y → ¬R y x. Proof. intuition. Qed. Lemma symmetry_iff `(R : relation A) `{!Symmetric R} x y : R x y ↔ R y x. Proof. intuition. Qed. Lemma not_inj `{Inj A B R R' f} x y : ¬R x y → ¬R' (f x) (f y). Proof. intuition. Qed. Lemma not_inj2_1 `{Inj2 A B C R R' R'' f} x1 x2 y1 y2 : ¬R x1 x2 → ¬R'' (f x1 y1) (f x2 y2). Proof. intros HR HR''. destruct (inj2 f x1 y1 x2 y2); auto. Qed. Lemma not_inj2_2 `{Inj2 A B C R R' R'' f} x1 x2 y1 y2 : ¬R' y1 y2 → ¬R'' (f x1 y1) (f x2 y2). Proof. intros HR' HR''. destruct (inj2 f x1 y1 x2 y2); auto. Qed. Lemma inj_iff {A B} {R : relation A} {S : relation B} (f : A → B) `{!Inj R S f} `{!Proper (R ==> S) f} x y : S (f x) (f y) ↔ R x y. Proof. firstorder. Qed. Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Lemma cancel_inj `{Cancel A B R1 f g, !Equivalence R1, !Proper (R2 ==> R1) f} : Inj R1 R2 g. Proof. intros x y E. rewrite <-(cancel f g x), <-(cancel f g y), E. reflexivity. Qed. Lemma cancel_surj `{Cancel A B R1 f g} : Surj R1 f. Proof. intros y. exists (g y). auto. Qed. (** The following lemmas are specific versions of the projections of the above type classes for Leibniz equality. These lemmas allow us to enforce Coq not to use the setoid rewriting mechanism. *) Lemma idemp_L {A} f `{!@IdemP A (=) f} x : f x x = x. Proof. auto. Qed. Lemma comm_L {A B} f `{!@Comm A B (=) f} x y : f x y = f y x. Proof. auto. Qed. Lemma left_id_L {A} i f `{!@LeftId A (=) i f} x : f i x = x. Proof. auto. Qed. Lemma right_id_L {A} i f `{!@RightId A (=) i f} x : f x i = x. Proof. auto. Qed. Lemma assoc_L {A} f `{!@Assoc A (=) f} x y z : f x (f y z) = f (f x y) z. Proof. auto. Qed. Lemma left_absorb_L {A} i f `{!@LeftAbsorb A (=) i f} x : f i x = i. Proof. auto. Qed. Lemma right_absorb_L {A} i f `{!@RightAbsorb A (=) i f} x : f x i = i. Proof. auto. Qed. (** ** Generic orders *) (** The classes [PreOrder], [PartialOrder], and [TotalOrder] use an arbitrary relation [R] instead of [⊆] to support multiple orders on the same type. *) Definition strict {A} (R : relation A) : relation A := λ X Y, R X Y ∧ ¬R Y X. Global Instance: Params (@strict) 2 := {}. Class PartialOrder {A} (R : relation A) : Prop := { partial_order_pre :> PreOrder R; partial_order_anti_symm :> AntiSymm (=) R }. Global Hint Mode PartialOrder ! ! : typeclass_instances. Class TotalOrder {A} (R : relation A) : Prop := { total_order_partial :> PartialOrder R; total_order_trichotomy :> Trichotomy (strict R) }. Global Hint Mode TotalOrder ! ! : typeclass_instances. (** * Logic *) Global Instance prop_inhabited : Inhabited Prop := populate True. Notation "(∧)" := and (only parsing) : stdpp_scope. Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope. Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope. Notation "(∨)" := or (only parsing) : stdpp_scope. Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope. Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope. Notation "(↔)" := iff (only parsing) : stdpp_scope. Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope. Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ↔ _) => reflexivity : core. Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core. Lemma or_l P Q : ¬Q → P ∨ Q ↔ P. Proof. tauto. Qed. Lemma or_r P Q : ¬P → P ∨ Q ↔ Q. Proof. tauto. Qed. Lemma and_wlog_l (P Q : Prop) : (Q → P) → Q → (P ∧ Q). Proof. tauto. Qed. Lemma and_wlog_r (P Q : Prop) : P → (P → Q) → (P ∧ Q). Proof. tauto. Qed. Lemma impl_transitive (P Q R : Prop) : (P → Q) → (Q → R) → (P → R). Proof. tauto. Qed. Lemma forall_proper {A} (P Q : A → Prop) : (∀ x, P x ↔ Q x) → (∀ x, P x) ↔ (∀ x, Q x). Proof. firstorder. Qed. Lemma exist_proper {A} (P Q : A → Prop) : (∀ x, P x ↔ Q x) → (∃ x, P x) ↔ (∃ x, Q x). Proof. firstorder. Qed. Global Instance eq_comm {A} : Comm (↔) (=@{A}). Proof. red; intuition. Qed. Global Instance flip_eq_comm {A} : Comm (↔) (λ x y, y =@{A} x). Proof. red; intuition. Qed. Global Instance iff_comm : Comm (↔) (↔). Proof. red; intuition. Qed. Global Instance and_comm : Comm (↔) (∧). Proof. red; intuition. Qed. Global Instance and_assoc : Assoc (↔) (∧). Proof. red; intuition. Qed. Global Instance and_idemp : IdemP (↔) (∧). Proof. red; intuition. Qed. Global Instance or_comm : Comm (↔) (∨). Proof. red; intuition. Qed. Global Instance or_assoc : Assoc (↔) (∨). Proof. red; intuition. Qed. Global Instance or_idemp : IdemP (↔) (∨). Proof. red; intuition. Qed. Global Instance True_and : LeftId (↔) True (∧). Proof. red; intuition. Qed. Global Instance and_True : RightId (↔) True (∧). Proof. red; intuition. Qed. Global Instance False_and : LeftAbsorb (↔) False (∧). Proof. red; intuition. Qed. Global Instance and_False : RightAbsorb (↔) False (∧). Proof. red; intuition. Qed. Global Instance False_or : LeftId (↔) False (∨). Proof. red; intuition. Qed. Global Instance or_False : RightId (↔) False (∨). Proof. red; intuition. Qed. Global Instance True_or : LeftAbsorb (↔) True (∨). Proof. red; intuition. Qed. Global Instance or_True : RightAbsorb (↔) True (∨). Proof. red; intuition. Qed. Global Instance True_impl : LeftId (↔) True impl. Proof. unfold impl. red; intuition. Qed. Global Instance impl_True : RightAbsorb (↔) True impl. Proof. unfold impl. red; intuition. Qed. (** * Common data types *) (** ** Functions *) Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope. Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope. Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope. Notation "t $ r" := (t r) (at level 65, right associativity, only parsing) : stdpp_scope. Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope. Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope. Infix "∘" := compose : stdpp_scope. Notation "(∘)" := compose (only parsing) : stdpp_scope. Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope. Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope. Global Instance impl_inhabited {A} `{Inhabited B} : Inhabited (A → B) := populate (λ _, inhabitant). (** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully applied. *) Global Arguments id _ _ / : assert. Global Arguments compose _ _ _ _ _ _ / : assert. Global Arguments flip _ _ _ _ _ _ / : assert. Global Arguments const _ _ _ _ / : assert. Global Typeclasses Transparent id compose flip const. Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' := g ∘ h ∘ f. Global Instance const_proper `{R1 : relation A, R2 : relation B} (x : B) : Reflexive R2 → Proper (R1 ==> R2) (λ _, x). Proof. intros ? y1 y2; reflexivity. Qed. Global Instance id_inj {A} : Inj (=) (=) (@id A). Proof. intros ??; auto. Qed. Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) : Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f). Proof. red; intuition. Qed. Global Instance id_surj {A} : Surj (=) (@id A). Proof. intros y; exists y; reflexivity. Qed. Global Instance compose_surj {A B C} R (f : A → B) (g : B → C) : Surj (=) f → Surj R g → Surj R (g ∘ f). Proof. intros ?? x. unfold compose. destruct (surj g x) as [y ?]. destruct (surj f y) as [z ?]. exists z. congruence. Qed. Global Instance const2_comm {A B} (x : B) : Comm (=) (λ _ _ : A, x). Proof. intros ?; reflexivity. Qed. Global Instance const2_assoc {A} (x : A) : Assoc (=) (λ _ _ : A, x). Proof. intros ???; reflexivity. Qed. Global Instance id1_assoc {A} : Assoc (=) (λ x _ : A, x). Proof. intros ???; reflexivity. Qed. Global Instance id2_assoc {A} : Assoc (=) (λ _ x : A, x). Proof. intros ???; reflexivity. Qed. Global Instance id1_idemp {A} : IdemP (=) (λ x _ : A, x). Proof. intros ?; reflexivity. Qed. Global Instance id2_idemp {A} : IdemP (=) (λ _ x : A, x). Proof. intros ?; reflexivity. Qed. (** ** Lists *) Global Instance list_inhabited {A} : Inhabited (list A) := populate []. Definition zip_with {A B C} (f : A → B → C) : list A → list B → list C := fix go l1 l2 := match l1, l2 with x1 :: l1, x2 :: l2 => f x1 x2 :: go l1 l2 | _ , _ => [] end. Notation zip := (zip_with pair). (** ** Booleans *) (** The following coercion allows us to use Booleans as propositions. *) Coercion Is_true : bool >-> Sortclass. Global Hint Unfold Is_true : core. Global Hint Immediate Is_true_eq_left : core. Global Hint Resolve orb_prop_intro andb_prop_intro : core. Notation "(&&)" := andb (only parsing). Notation "(||)" := orb (only parsing). Infix "&&*" := (zip_with (&&)) (at level 40). Infix "||*" := (zip_with (||)) (at level 50). Global Instance bool_inhabated : Inhabited bool := populate true. Definition bool_le (β1 β2 : bool) : Prop := negb β1 || β2. Infix "=.>" := bool_le (at level 70). Infix "=.>*" := (Forall2 bool_le) (at level 70). Global Instance: PartialOrder bool_le. Proof. repeat split; repeat intros [|]; compute; tauto. Qed. Lemma andb_True b1 b2 : b1 && b2 ↔ b1 ∧ b2. Proof. destruct b1, b2; simpl; tauto. Qed. Lemma orb_True b1 b2 : b1 || b2 ↔ b1 ∨ b2. Proof. destruct b1, b2; simpl; tauto. Qed. Lemma negb_True b : negb b ↔ ¬b. Proof. destruct b; simpl; tauto. Qed. Lemma Is_true_true (b : bool) : b ↔ b = true. Proof. now destruct b. Qed. Lemma Is_true_true_1 (b : bool) : b → b = true. Proof. apply Is_true_true. Qed. Lemma Is_true_true_2 (b : bool) : b = true → b. Proof. apply Is_true_true. Qed. Lemma Is_true_false (b : bool) : ¬ b ↔ b = false. Proof. now destruct b; simpl. Qed. Lemma Is_true_false_1 (b : bool) : ¬b → b = false. Proof. apply Is_true_false. Qed. Lemma Is_true_false_2 (b : bool) : b = false → ¬b. Proof. apply Is_true_false. Qed. (** ** Unit *) Global Instance unit_equiv : Equiv unit := λ _ _, True. Global Instance unit_equivalence : Equivalence (≡@{unit}). Proof. repeat split. Qed. Global Instance unit_leibniz : LeibnizEquiv unit. Proof. intros [] []; reflexivity. Qed. Global Instance unit_inhabited: Inhabited unit := populate (). (** ** Empty *) Global Instance Empty_set_equiv : Equiv Empty_set := λ _ _, True. Global Instance Empty_set_equivalence : Equivalence (≡@{Empty_set}). Proof. repeat split. Qed. Global Instance Empty_set_leibniz : LeibnizEquiv Empty_set. Proof. intros [] []; reflexivity. Qed. (** ** Products *) Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope. Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope. Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2"). Global Instance: Params (@pair) 2 := {}. Global Instance: Params (@fst) 2 := {}. Global Instance: Params (@snd) 2 := {}. Global Instance: Params (@curry) 3 := {}. Global Instance: Params (@uncurry) 3 := {}. Definition uncurry3 {A B C D} (f : A → B → C → D) (p : A * B * C) : D := let '(a,b,c) := p in f a b c. Global Instance: Params (@uncurry3) 4 := {}. Definition uncurry4 {A B C D E} (f : A → B → C → D → E) (p : A * B * C * D) : E := let '(a,b,c,d) := p in f a b c d. Global Instance: Params (@uncurry4) 5 := {}. Definition curry3 {A B C D} (f : A * B * C → D) (a : A) (b : B) (c : C) : D := f (a, b, c). Global Instance: Params (@curry3) 4 := {}. Definition curry4 {A B C D E} (f : A * B * C * D → E) (a : A) (b : B) (c : C) (d : D) : E := f (a, b, c, d). Global Instance: Params (@curry4) 5 := {}. Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' := (f (p.1), g (p.2)). Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert. Definition prod_zip {A A' A'' B B' B''} (f : A → A' → A'') (g : B → B' → B'') (p : A * B) (q : A' * B') : A'' * B'' := (f (p.1) (q.1), g (p.2) (q.2)). Global Arguments prod_zip {_ _ _ _ _ _} _ _ !_ !_ / : assert. Global Instance prod_inhabited {A B} (iA : Inhabited A) (iB : Inhabited B) : Inhabited (A * B) := match iA, iB with populate x, populate y => populate (x,y) end. (** Note that we need eta for products for the [uncurry_curry] lemmas to hold in non-applied form ([uncurry (curry f) = f]). *) Lemma curry_uncurry {A B C} (f : A → B → C) : curry (uncurry f) = f. Proof. reflexivity. Qed. Lemma uncurry_curry {A B C} (f : A * B → C) p : uncurry (curry f) p = f p. Proof. destruct p; reflexivity. Qed. Lemma curry3_uncurry3 {A B C D} (f : A → B → C → D) : curry3 (uncurry3 f) = f. Proof. reflexivity. Qed. Lemma uncurry3_curry3 {A B C D} (f : A * B * C → D) p : uncurry3 (curry3 f) p = f p. Proof. destruct p as [[??] ?]; reflexivity. Qed. Lemma curry4_uncurry4 {A B C D E} (f : A → B → C → D → E) : curry4 (uncurry4 f) = f. Proof. reflexivity. Qed. Lemma uncurry4_curry4 {A B C D E} (f : A * B * C * D → E) p : uncurry4 (curry4 f) p = f p. Proof. destruct p as [[[??] ?] ?]; reflexivity. Qed. (** [pair_eq] as a name is more consistent with our usual naming. *) Lemma pair_eq {A B} (a1 a2 : A) (b1 b2 : B) : (a1, b1) = (a2, b2) ↔ a1 = a2 ∧ b1 = b2. Proof. apply pair_equal_spec. Qed. Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B). Proof. injection 1; auto. Qed. Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g). Proof. intros ?? [??] [??] ?; simpl in *; f_equal; [apply (inj f)|apply (inj g)]; congruence. Qed. Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) : relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2). Section prod_relation. Context `{RA : relation A, RB : relation B}. Global Instance prod_relation_refl : Reflexive RA → Reflexive RB → Reflexive (prod_relation RA RB). Proof. firstorder eauto. Qed. Global Instance prod_relation_sym : Symmetric RA → Symmetric RB → Symmetric (prod_relation RA RB). Proof. firstorder eauto. Qed. Global Instance prod_relation_trans : Transitive RA → Transitive RB → Transitive (prod_relation RA RB). Proof. firstorder eauto. Qed. Global Instance prod_relation_equiv : Equivalence RA → Equivalence RB → Equivalence (prod_relation RA RB). Proof. split; apply _. Qed. Global Instance pair_proper' : Proper (RA ==> RB ==> prod_relation RA RB) pair. Proof. firstorder eauto. Qed. Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair. Proof. inversion_clear 1; eauto. Qed. Global Instance fst_proper' : Proper (prod_relation RA RB ==> RA) fst. Proof. firstorder eauto. Qed. Global Instance snd_proper' : Proper (prod_relation RA RB ==> RB) snd. Proof. firstorder eauto. Qed. Global Instance curry_proper' `{RC : relation C} : Proper ((prod_relation RA RB ==> RC) ==> RA ==> RB ==> RC) curry. Proof. firstorder eauto. Qed. Global Instance uncurry_proper' `{RC : relation C} : Proper ((RA ==> RB ==> RC) ==> prod_relation RA RB ==> RC) uncurry. Proof. intros f1 f2 Hf [x1 y1] [x2 y2] []; apply Hf; assumption. Qed. Global Instance curry3_proper' `{RC : relation C, RD : relation D} : Proper ((prod_relation (prod_relation RA RB) RC ==> RD) ==> RA ==> RB ==> RC ==> RD) curry3. Proof. firstorder eauto. Qed. Global Instance uncurry3_proper' `{RC : relation C, RD : relation D} : Proper ((RA ==> RB ==> RC ==> RD) ==> prod_relation (prod_relation RA RB) RC ==> RD) uncurry3. Proof. intros f1 f2 Hf [[??] ?] [[??] ?] [[??] ?]; apply Hf; assumption. Qed. Global Instance curry4_proper' `{RC : relation C, RD : relation D, RE : relation E} : Proper ((prod_relation (prod_relation (prod_relation RA RB) RC) RD ==> RE) ==> RA ==> RB ==> RC ==> RD ==> RE) curry4. Proof. firstorder eauto. Qed. Global Instance uncurry4_proper' `{RC : relation C, RD : relation D, RE : relation E} : Proper ((RA ==> RB ==> RC ==> RD ==> RE) ==> prod_relation (prod_relation (prod_relation RA RB) RC) RD ==> RE) uncurry4. Proof. intros f1 f2 Hf [[[??] ?] ?] [[[??] ?] ?] [[[??] ?] ?]; apply Hf; assumption. Qed. End prod_relation. Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) := prod_relation (≡) (≡). (** Below we make [prod_equiv] type class opaque, so we first lift all instances *) Section prod_setoid. Context `{Equiv A, Equiv B}. Global Instance prod_equivalence : Equivalence (≡@{A}) → Equivalence (≡@{B}) → Equivalence (≡@{A * B}) := _. Global Instance pair_proper : Proper ((≡) ==> (≡) ==> (≡@{A*B})) pair := _. Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _. Global Instance fst_proper : Proper ((≡@{A*B}) ==> (≡)) fst := _. Global Instance snd_proper : Proper ((≡@{A*B}) ==> (≡)) snd := _. Global Instance curry_proper `{Equiv C} : Proper (((≡@{A*B}) ==> (≡@{C})) ==> (≡) ==> (≡) ==> (≡)) curry := _. Global Instance uncurry_proper `{Equiv C} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{A*B}) ==> (≡@{C})) uncurry := _. Global Instance curry3_proper `{Equiv C, Equiv D} : Proper (((≡@{A*B*C}) ==> (≡@{D})) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) curry3 := _. Global Instance uncurry3_proper `{Equiv C, Equiv D} : Proper (((≡) ==> (≡) ==> (≡) ==> (≡)) ==> (≡@{A*B*C}) ==> (≡@{D})) uncurry3 := _. Global Instance curry4_proper `{Equiv C, Equiv D, Equiv E} : Proper (((≡@{A*B*C*D}) ==> (≡@{E})) ==> (≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) curry4 := _. Global Instance uncurry4_proper `{Equiv C, Equiv D, Equiv E} : Proper (((≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) ==> (≡@{A*B*C*D}) ==> (≡@{E})) uncurry4 := _. Lemma pair_equiv (a1 a2 : A) (b1 b2 : B) : (a1, b1) ≡ (a2, b2) ↔ a1 ≡ a2 ∧ b1 ≡ b2. Proof. reflexivity. Qed. End prod_setoid. Global Typeclasses Opaque prod_equiv. Global Instance prod_leibniz `{LeibnizEquiv A, LeibnizEquiv B} : LeibnizEquiv (A * B). Proof. intros [??] [??] [??]; f_equal; apply leibniz_equiv; auto. Qed. (** ** Sums *) Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' := match xy with inl x => inl (f x) | inr y => inr (g y) end. Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert. Global Instance sum_inhabited_l {A B} (iA : Inhabited A) : Inhabited (A + B) := match iA with populate x => populate (inl x) end. Global Instance sum_inhabited_r {A B} (iB : Inhabited B) : Inhabited (A + B) := match iB with populate y => populate (inr y) end. Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B). Proof. injection 1; auto. Qed. Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B). Proof. injection 1; auto. Qed. Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g). Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed. Inductive sum_relation {A B} (RA : relation A) (RB : relation B) : relation (A + B) := | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2) | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2). Section sum_relation. Context `{RA : relation A, RB : relation B}. Global Instance sum_relation_refl : Reflexive RA → Reflexive RB → Reflexive (sum_relation RA RB). Proof. intros ?? [?|?]; constructor; reflexivity. Qed. Global Instance sum_relation_sym : Symmetric RA → Symmetric RB → Symmetric (sum_relation RA RB). Proof. destruct 3; constructor; eauto. Qed. Global Instance sum_relation_trans : Transitive RA → Transitive RB → Transitive (sum_relation RA RB). Proof. destruct 3; inversion_clear 1; constructor; eauto. Qed. Global Instance sum_relation_equiv : Equivalence RA → Equivalence RB → Equivalence (sum_relation RA RB). Proof. split; apply _. Qed. Global Instance inl_proper' : Proper (RA ==> sum_relation RA RB) inl. Proof. constructor; auto. Qed. Global Instance inr_proper' : Proper (RB ==> sum_relation RA RB) inr. Proof. constructor; auto. Qed. Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl. Proof. inversion_clear 1; auto. Qed. Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr. Proof. inversion_clear 1; auto. Qed. End sum_relation. Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡). Global Instance inl_proper `{Equiv A, Equiv B} : Proper ((≡) ==> (≡)) (@inl A B) := _. Global Instance inr_proper `{Equiv A, Equiv B} : Proper ((≡) ==> (≡)) (@inr A B) := _. Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _. Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _. Global Typeclasses Opaque sum_equiv. (** ** Option *) Global Instance option_inhabited {A} : Inhabited (option A) := populate None. (** ** Sigma types *) Global Arguments existT {_ _} _ _ : assert. Global Arguments projT1 {_ _} _ : assert. Global Arguments projT2 {_ _} _ : assert. Global Arguments exist {_} _ _ _ : assert. Global Arguments proj1_sig {_ _} _ : assert. Global Arguments proj2_sig {_ _} _ : assert. Notation "x ↾ p" := (exist _ x p) (at level 20) : stdpp_scope. Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope. Lemma proj1_sig_inj {A} (P : A → Prop) x (Px : P x) y (Py : P y) : x↾Px = y↾Py → x = y. Proof. injection 1; trivial. Qed. Section sig_map. Context `{P : A → Prop} `{Q : B → Prop} (f : A → B) (Hf : ∀ x, P x → Q (f x)). Definition sig_map (x : sig P) : sig Q := f (`x) ↾ Hf _ (proj2_sig x). Global Instance sig_map_inj: (∀ x, ProofIrrel (P x)) → Inj (=) (=) f → Inj (=) (=) sig_map. Proof. intros ?? [x Hx] [y Hy]. injection 1. intros Hxy. apply (inj f) in Hxy; subst. rewrite (proof_irrel _ Hy). auto. Qed. End sig_map. Global Arguments sig_map _ _ _ _ _ _ !_ / : assert. Definition proj1_ex {P : Prop} {Q : P → Prop} (p : ∃ x, Q x) : P := let '(ex_intro _ x _) := p in x. Definition proj2_ex {P : Prop} {Q : P → Prop} (p : ∃ x, Q x) : Q (proj1_ex p) := let '(ex_intro _ x H) := p in H. (** * Operations on sets *) (** We define operational type classes for the traditional operations and relations on sets: the empty set [∅], the union [(∪)], intersection [(∩)], and difference [(∖)], the singleton [{[_]}], the subset [(⊆)] and element of [(∈)] relation, and disjointess [(##)]. *) Class Empty A := empty: A. Global Hint Mode Empty ! : typeclass_instances. Notation "∅" := empty (format "∅") : stdpp_scope. Global Instance empty_inhabited `(Empty A) : Inhabited A := populate ∅. Class Union A := union: A → A → A. Global Hint Mode Union ! : typeclass_instances. Global Instance: Params (@union) 2 := {}. Infix "∪" := union (at level 50, left associativity) : stdpp_scope. Notation "(∪)" := union (only parsing) : stdpp_scope. Notation "( x ∪.)" := (union x) (only parsing) : stdpp_scope. Notation "(.∪ x )" := (λ y, union y x) (only parsing) : stdpp_scope. Infix "∪*" := (zip_with (∪)) (at level 50, left associativity) : stdpp_scope. Notation "(∪*)" := (zip_with (∪)) (only parsing) : stdpp_scope. Definition union_list `{Empty A} `{Union A} : list A → A := fold_right (∪) ∅. Global Arguments union_list _ _ _ !_ / : assert. Notation "⋃ l" := (union_list l) (at level 20, format "⋃ l") : stdpp_scope. Class Intersection A := intersection: A → A → A. Global Hint Mode Intersection ! : typeclass_instances. Global Instance: Params (@intersection) 2 := {}. Infix "∩" := intersection (at level 40) : stdpp_scope. Notation "(∩)" := intersection (only parsing) : stdpp_scope. Notation "( x ∩.)" := (intersection x) (only parsing) : stdpp_scope. Notation "(.∩ x )" := (λ y, intersection y x) (only parsing) : stdpp_scope. Class Difference A := difference: A → A → A. Global Hint Mode Difference ! : typeclass_instances. Global Instance: Params (@difference) 2 := {}. Infix "∖" := difference (at level 40, left associativity) : stdpp_scope. Notation "(∖)" := difference (only parsing) : stdpp_scope. Notation "( x ∖.)" := (difference x) (only parsing) : stdpp_scope. Notation "(.∖ x )" := (λ y, difference y x) (only parsing) : stdpp_scope. Infix "∖*" := (zip_with (∖)) (at level 40, left associativity) : stdpp_scope. Notation "(∖*)" := (zip_with (∖)) (only parsing) : stdpp_scope. Class Singleton A B := singleton: A → B. Global Hint Mode Singleton - ! : typeclass_instances. Global Instance: Params (@singleton) 3 := {}. Notation "{[ x ]}" := (singleton x) (at level 1) : stdpp_scope. Notation "{[ x ; y ; .. ; z ]}" := (union .. (union (singleton x) (singleton y)) .. (singleton z)) (at level 1) : stdpp_scope. Class SubsetEq A := subseteq: relation A. Global Hint Mode SubsetEq ! : typeclass_instances. Global Instance: Params (@subseteq) 2 := {}. Infix "⊆" := subseteq (at level 70) : stdpp_scope. Notation "(⊆)" := subseteq (only parsing) : stdpp_scope. Notation "( X ⊆.)" := (subseteq X) (only parsing) : stdpp_scope. Notation "(.⊆ X )" := (λ Y, Y ⊆ X) (only parsing) : stdpp_scope. Notation "X ⊈ Y" := (¬X ⊆ Y) (at level 70) : stdpp_scope. Notation "(⊈)" := (λ X Y, X ⊈ Y) (only parsing) : stdpp_scope. Notation "( X ⊈.)" := (λ Y, X ⊈ Y) (only parsing) : stdpp_scope. Notation "(.⊈ X )" := (λ Y, Y ⊈ X) (only parsing) : stdpp_scope. Infix "⊆@{ A }" := (@subseteq A _) (at level 70, only parsing) : stdpp_scope. Notation "(⊆@{ A } )" := (@subseteq A _) (only parsing) : stdpp_scope. Infix "⊆*" := (Forall2 (⊆)) (at level 70) : stdpp_scope. Notation "(⊆*)" := (Forall2 (⊆)) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ⊆ _) => reflexivity : core. Global Hint Extern 0 (_ ⊆* _) => reflexivity : core. Infix "⊂" := (strict (⊆)) (at level 70) : stdpp_scope. Notation "(⊂)" := (strict (⊆)) (only parsing) : stdpp_scope. Notation "( X ⊂.)" := (strict (⊆) X) (only parsing) : stdpp_scope. Notation "(.⊂ X )" := (λ Y, Y ⊂ X) (only parsing) : stdpp_scope. Notation "X ⊄ Y" := (¬X ⊂ Y) (at level 70) : stdpp_scope. Notation "(⊄)" := (λ X Y, X ⊄ Y) (only parsing) : stdpp_scope. Notation "( X ⊄.)" := (λ Y, X ⊄ Y) (only parsing) : stdpp_scope. Notation "(.⊄ X )" := (λ Y, Y ⊄ X) (only parsing) : stdpp_scope. Infix "⊂@{ A }" := (strict (⊆@{A})) (at level 70, only parsing) : stdpp_scope. Notation "(⊂@{ A } )" := (strict (⊆@{A})) (only parsing) : stdpp_scope. Notation "X ⊆ Y ⊆ Z" := (X ⊆ Y ∧ Y ⊆ Z) (at level 70, Y at next level) : stdpp_scope. Notation "X ⊆ Y ⊂ Z" := (X ⊆ Y ∧ Y ⊂ Z) (at level 70, Y at next level) : stdpp_scope. Notation "X ⊂ Y ⊆ Z" := (X ⊂ Y ∧ Y ⊆ Z) (at level 70, Y at next level) : stdpp_scope. Notation "X ⊂ Y ⊂ Z" := (X ⊂ Y ∧ Y ⊂ Z) (at level 70, Y at next level) : stdpp_scope. (** We define type classes for multisets: disjoint union [⊎] and the multiset singleton [{[+ _ +]}]. Multiset literals [{[+ x1; ..; xn +]}] are defined in terms of iterated disjoint union [{[+ x1 +]} ⊎ .. ⊎ {[+ xn +]}], and are thus different from set literals [{[ x1; ..; xn ]}], which use [∪]. Note that in principle we could reuse the set singleton [{[ _ ]}] for multisets, and define [{[+ x1; ..; xn +]}] as [{[ x1 ]} ⊎ .. ⊎ {[ xn ]}]. However, this would risk accidentally using [{[ x1; ..; xn ]}] for multisets (leading to unexpected results) and lead to ambigious pretty printing for [{[+ x +]}]. *) Class DisjUnion A := disj_union: A → A → A. Global Hint Mode DisjUnion ! : typeclass_instances. Global Instance: Params (@disj_union) 2 := {}. Infix "⊎" := disj_union (at level 50, left associativity) : stdpp_scope. Notation "(⊎)" := disj_union (only parsing) : stdpp_scope. Notation "( x ⊎.)" := (disj_union x) (only parsing) : stdpp_scope. Notation "(.⊎ x )" := (λ y, disj_union y x) (only parsing) : stdpp_scope. Class SingletonMS A B := singletonMS: A → B. Global Hint Mode SingletonMS - ! : typeclass_instances. Global Instance: Params (@singletonMS) 3 := {}. Notation "{[+ x +]}" := (singletonMS x) (at level 1, format "{[+ x +]}") : stdpp_scope. Notation "{[+ x ; y ; .. ; z +]}" := (disj_union .. (disj_union (singletonMS x) (singletonMS y)) .. (singletonMS z)) (at level 1, format "{[+ x ; y ; .. ; z +]}") : stdpp_scope. Definition option_to_set `{Singleton A C, Empty C} (mx : option A) : C := match mx with None => ∅ | Some x => {[ x ]} end. Fixpoint list_to_set `{Singleton A C, Empty C, Union C} (l : list A) : C := match l with [] => ∅ | x :: l => {[ x ]} ∪ list_to_set l end. Fixpoint list_to_set_disj `{SingletonMS A C, Empty C, DisjUnion C} (l : list A) : C := match l with [] => ∅ | x :: l => {[+ x +]} ⊎ list_to_set_disj l end. Class ScalarMul N A := scalar_mul : N → A → A. Global Hint Mode ScalarMul - ! : typeclass_instances. (** The [N] arguments is typically [nat] or [Z], so we do not want to rewrite in that. Hence, the value of [Params] is 3. *) Global Instance: Params (@scalar_mul) 3 := {}. (** The notation [*:] and level is taken from ssreflect, see https://github.com/math-comp/math-comp/blob/master/mathcomp/ssreflect/ssrnotations.v *) Infix "*:" := scalar_mul (at level 40) : stdpp_scope. Notation "(*:)" := scalar_mul (only parsing) : stdpp_scope. Notation "( x *:.)" := (scalar_mul x) (only parsing) : stdpp_scope. Notation "(.*: x )" := (λ y, scalar_mul y x) (only parsing) : stdpp_scope. (** The class [Lexico A] is used for the lexicographic order on [A]. This order is used to create finite maps, finite sets, etc, and is typically different from the order [(⊆)]. *) Class Lexico A := lexico: relation A. Global Hint Mode Lexico ! : typeclass_instances. Class ElemOf A B := elem_of: A → B → Prop. Global Hint Mode ElemOf - ! : typeclass_instances. Global Instance: Params (@elem_of) 3 := {}. Infix "∈" := elem_of (at level 70) : stdpp_scope. Notation "(∈)" := elem_of (only parsing) : stdpp_scope. Notation "( x ∈.)" := (elem_of x) (only parsing) : stdpp_scope. Notation "(.∈ X )" := (λ x, elem_of x X) (only parsing) : stdpp_scope. Notation "x ∉ X" := (¬x ∈ X) (at level 80) : stdpp_scope. Notation "(∉)" := (λ x X, x ∉ X) (only parsing) : stdpp_scope. Notation "( x ∉.)" := (λ X, x ∉ X) (only parsing) : stdpp_scope. Notation "(.∉ X )" := (λ x, x ∉ X) (only parsing) : stdpp_scope. Infix "∈@{ B }" := (@elem_of _ B _) (at level 70, only parsing) : stdpp_scope. Notation "(∈@{ B } )" := (@elem_of _ B _) (only parsing) : stdpp_scope. Notation "x ∉@{ B } X" := (¬x ∈@{B} X) (at level 80, only parsing) : stdpp_scope. Notation "(∉@{ B } )" := (λ x X, x ∉@{B} X) (only parsing) : stdpp_scope. Class Disjoint A := disjoint : A → A → Prop. Global Hint Mode Disjoint ! : typeclass_instances. Global Instance: Params (@disjoint) 2 := {}. Infix "##" := disjoint (at level 70) : stdpp_scope. Notation "(##)" := disjoint (only parsing) : stdpp_scope. Notation "( X ##.)" := (disjoint X) (only parsing) : stdpp_scope. Notation "(.## X )" := (λ Y, Y ## X) (only parsing) : stdpp_scope. Infix "##@{ A }" := (@disjoint A _) (at level 70, only parsing) : stdpp_scope. Notation "(##@{ A } )" := (@disjoint A _) (only parsing) : stdpp_scope. Infix "##*" := (Forall2 (##)) (at level 70) : stdpp_scope. Notation "(##*)" := (Forall2 (##)) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ## _) => symmetry; eassumption : core. Global Hint Extern 0 (_ ##* _) => symmetry; eassumption : core. Class Filter A B := filter: ∀ (P : A → Prop) `{∀ x, Decision (P x)}, B → B. Global Hint Mode Filter - ! : typeclass_instances. Class UpClose A B := up_close : A → B. Global Hint Mode UpClose - ! : typeclass_instances. Notation "↑ x" := (up_close x) (at level 20, format "↑ x"). (** * Monadic operations *) (** We define operational type classes for the monadic operations bind, join and fmap. We use these type classes merely for convenient overloading of notations and do not formalize any theory on monads (we do not even define a class with the monad laws). *) Class MRet (M : Type → Type) := mret: ∀ {A}, A → M A. Global Arguments mret {_ _ _} _ : assert. Global Instance: Params (@mret) 3 := {}. Global Hint Mode MRet ! : typeclass_instances. Class MBind (M : Type → Type) := mbind : ∀ {A B}, (A → M B) → M A → M B. Global Arguments mbind {_ _ _ _} _ !_ / : assert. Global Instance: Params (@mbind) 4 := {}. Global Hint Mode MBind ! : typeclass_instances. Class MJoin (M : Type → Type) := mjoin: ∀ {A}, M (M A) → M A. Global Arguments mjoin {_ _ _} !_ / : assert. Global Instance: Params (@mjoin) 3 := {}. Global Hint Mode MJoin ! : typeclass_instances. Class FMap (M : Type → Type) := fmap : ∀ {A B}, (A → B) → M A → M B. Global Arguments fmap {_ _ _ _} _ !_ / : assert. Global Instance: Params (@fmap) 4 := {}. Global Hint Mode FMap ! : typeclass_instances. Class OMap (M : Type → Type) := omap: ∀ {A B}, (A → option B) → M A → M B. Global Arguments omap {_ _ _ _} _ !_ / : assert. Global Instance: Params (@omap) 4 := {}. Global Hint Mode OMap ! : typeclass_instances. Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : stdpp_scope. Notation "( m ≫=.)" := (λ f, mbind f m) (only parsing) : stdpp_scope. Notation "(.≫= f )" := (mbind f) (only parsing) : stdpp_scope. Notation "(≫=)" := (λ m f, mbind f m) (only parsing) : stdpp_scope. Notation "x ← y ; z" := (y ≫= (λ x : _, z)) (at level 20, y at level 100, z at level 200, only parsing) : stdpp_scope. Notation "' x ← y ; z" := (y ≫= (λ x : _, z)) (at level 20, x pattern, y at level 100, z at level 200, only parsing) : stdpp_scope. Infix "<$>" := fmap (at level 61, left associativity) : stdpp_scope. Notation "x ;; z" := (x ≫= λ _, z) (at level 100, z at level 200, only parsing, right associativity): stdpp_scope. Notation "ps .*1" := (fmap (M:=list) fst ps) (at level 2, left associativity, format "ps .*1"). Notation "ps .*2" := (fmap (M:=list) snd ps) (at level 2, left associativity, format "ps .*2"). Class MGuard (M : Type → Type) := mguard: ∀ P {dec : Decision P} {A}, (P → M A) → M A. Global Arguments mguard _ _ _ !_ _ _ / : assert. Global Hint Mode MGuard ! : typeclass_instances. Notation "'guard' P ; z" := (mguard P (λ _, z)) (at level 20, z at level 200, only parsing, right associativity) : stdpp_scope. Notation "'guard' P 'as' H ; z" := (mguard P (λ H, z)) (at level 20, z at level 200, only parsing, right associativity) : stdpp_scope. (** * Operations on maps *) (** In this section we define operational type classes for the operations on maps. In the file [fin_maps] we will axiomatize finite maps. The function look up [m !! k] should yield the element at key [k] in [m]. *) Class Lookup (K A M : Type) := lookup: K → M → option A. Global Hint Mode Lookup - - ! : typeclass_instances. Global Instance: Params (@lookup) 5 := {}. Notation "m !! i" := (lookup i m) (at level 20) : stdpp_scope. Notation "(!!)" := lookup (only parsing) : stdpp_scope. Notation "( m !!.)" := (λ i, m !! i) (only parsing) : stdpp_scope. Notation "(.!! i )" := (lookup i) (only parsing) : stdpp_scope. Global Arguments lookup _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [lookup_total] should be the total over-approximation of the partial [lookup] function. *) Class LookupTotal (K A M : Type) := lookup_total : K → M → A. Global Hint Mode LookupTotal - - ! : typeclass_instances. Global Instance: Params (@lookup_total) 5 := {}. Notation "m !!! i" := (lookup_total i m) (at level 20) : stdpp_scope. Notation "(!!!)" := lookup_total (only parsing) : stdpp_scope. Notation "( m !!!.)" := (λ i, m !!! i) (only parsing) : stdpp_scope. Notation "(.!!! i )" := (lookup_total i) (only parsing) : stdpp_scope. Global Arguments lookup_total _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The singleton map *) Class SingletonM K A M := singletonM: K → A → M. Global Hint Mode SingletonM - - ! : typeclass_instances. Global Instance: Params (@singletonM) 5 := {}. Notation "{[ k := a ]}" := (singletonM k a) (at level 1) : stdpp_scope. (** The function insert [<[k:=a]>m] should update the element at key [k] with value [a] in [m]. *) Class Insert (K A M : Type) := insert: K → A → M → M. Global Hint Mode Insert - - ! : typeclass_instances. Global Instance: Params (@insert) 5 := {}. Notation "<[ k := a ]>" := (insert k a) (at level 5, right associativity, format "<[ k := a ]>") : stdpp_scope. Global Arguments insert _ _ _ _ !_ _ !_ / : simpl nomatch, assert. (** Notation for more elements (up to 13) *) (* Defining a generic notation does not seem possible with Coq's recursive notation system, so we define individual notations for some cases relevant in practice. *) (* The "format" makes sure that linebreaks are placed after the separating semicola [;] when printing. *) (* TODO : we are using parantheses in the "de-sugaring" of the notation instead of [$] because Coq 8.12 and earlier have trouble with using the notation for printing otherwise. Once support for Coq 8.12 is dropped, this can be replaced with [$]. *) Notation "{[ k1 := a1 ; k2 := a2 ]}" := (<[ k1 := a1 ]>{[ k2 := a2 ]}) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]>{[ k3 := a3 ]})) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]>{[ k4 := a4 ]}))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]>{[ k5 := a5 ]})))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]>{[ k6 := a6 ]}))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]>{[ k7 := a7 ]})))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]>{[ k8 := a8 ]}))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]>{[ k9 := a9 ]})))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]>{[ k10 := a10 ]}))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]> ( <[ k10 := a10 ]>{[ k11 := a11 ]})))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ; k12 := a12 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]> ( <[ k10 := a10 ]> ( <[ k11 := a11 ]>{[ k12 := a12 ]}))))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ; ']' '/' '[' k12 := a12 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ; k12 := a12 ; k13 := a13 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]> ( <[ k10 := a10 ]> ( <[ k11 := a11 ]> ( <[ k12 := a12 ]>{[ k13 := a13 ]})))))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ; ']' '/' '[' k12 := a12 ; ']' '/' '[' k13 := a13 ']' ']' ]}") : stdpp_scope. (** The function delete [delete k m] should delete the value at key [k] in [m]. If the key [k] is not a member of [m], the original map should be returned. *) Class Delete (K M : Type) := delete: K → M → M. Global Hint Mode Delete - ! : typeclass_instances. Global Instance: Params (@delete) 4 := {}. Global Arguments delete _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [alter f k m] should update the value at key [k] using the function [f], which is called with the original value. *) Class Alter (K A M : Type) := alter: (A → A) → K → M → M. Global Hint Mode Alter - - ! : typeclass_instances. Global Instance: Params (@alter) 4 := {}. Global Arguments alter {_ _ _ _} _ !_ !_ / : simpl nomatch, assert. (** The function [partial_alter f k m] should update the value at key [k] using the function [f], which is called with the original value at key [k] or [None] if [k] is not a member of [m]. The value at [k] should be deleted if [f] yields [None]. *) Class PartialAlter (K A M : Type) := partial_alter: (option A → option A) → K → M → M. Global Hint Mode PartialAlter - - ! : typeclass_instances. Global Instance: Params (@partial_alter) 4 := {}. Global Arguments partial_alter _ _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [dom m] should yield the domain of [m]. That is a finite set of type [D] that contains the keys that are a member of [m]. [D] is an output of the typeclass, i.e., there can be only one instance per map type [M]. *) Class Dom (M D : Type) := dom: M → D. Global Hint Mode Dom ! - : typeclass_instances. Global Instance: Params (@dom) 3 := {}. Global Arguments dom : clear implicits. Global Arguments dom {_ _ _} !_ / : simpl nomatch, assert. (** The function [merge f m1 m2] should merge the maps [m1] and [m2] by constructing a new map whose value at key [k] is [f (m1 !! k) (m2 !! k)].*) Class Merge (M : Type → Type) := merge: ∀ {A B C}, (option A → option B → option C) → M A → M B → M C. Global Hint Mode Merge ! : typeclass_instances. Global Instance: Params (@merge) 4 := {}. Global Arguments merge _ _ _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [union_with f m1 m2] is supposed to yield the union of [m1] and [m2] using the function [f] to combine values of members that are in both [m1] and [m2]. *) Class UnionWith (A M : Type) := union_with: (A → A → option A) → M → M → M. Global Hint Mode UnionWith - ! : typeclass_instances. Global Instance: Params (@union_with) 3 := {}. Global Arguments union_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. (** Similarly for intersection and difference. *) Class IntersectionWith (A M : Type) := intersection_with: (A → A → option A) → M → M → M. Global Hint Mode IntersectionWith - ! : typeclass_instances. Global Instance: Params (@intersection_with) 3 := {}. Global Arguments intersection_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. Class DifferenceWith (A M : Type) := difference_with: (A → A → option A) → M → M → M. Global Hint Mode DifferenceWith - ! : typeclass_instances. Global Instance: Params (@difference_with) 3 := {}. Global Arguments difference_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. Definition intersection_with_list `{IntersectionWith A M} (f : A → A → option A) : M → list M → M := fold_right (intersection_with f). Global Arguments intersection_with_list _ _ _ _ _ !_ / : assert. (** * Notations for lattices. *) (** SqSubsetEq registers the "canonical" partial order for a type, and is used for the \sqsubseteq symbol. *) Class SqSubsetEq A := sqsubseteq: relation A. Global Hint Mode SqSubsetEq ! : typeclass_instances. Global Instance: Params (@sqsubseteq) 2 := {}. Infix "⊑" := sqsubseteq (at level 70) : stdpp_scope. Notation "(⊑)" := sqsubseteq (only parsing) : stdpp_scope. Notation "( x ⊑.)" := (sqsubseteq x) (only parsing) : stdpp_scope. Notation "(.⊑ y )" := (λ x, sqsubseteq x y) (only parsing) : stdpp_scope. Infix "⊑@{ A }" := (@sqsubseteq A _) (at level 70, only parsing) : stdpp_scope. Notation "(⊑@{ A } )" := (@sqsubseteq A _) (only parsing) : stdpp_scope. (** [sqsubseteq] does not take precedence over the stdlib's instances (like [eq], [impl], [iff]) or std++'s [equiv]. We have [eq] (at 100) < [≡] (at 150) < [⊑] (at 200). *) Global Instance sqsubseteq_rewrite `{SqSubsetEq A} : RewriteRelation (⊑@{A}) | 200 := {}. Global Hint Extern 0 (_ ⊑ _) => reflexivity : core. Class Meet A := meet: A → A → A. Global Hint Mode Meet ! : typeclass_instances. Global Instance: Params (@meet) 2 := {}. Infix "⊓" := meet (at level 40) : stdpp_scope. Notation "(⊓)" := meet (only parsing) : stdpp_scope. Notation "( x ⊓.)" := (meet x) (only parsing) : stdpp_scope. Notation "(.⊓ y )" := (λ x, meet x y) (only parsing) : stdpp_scope. Class Join A := join: A → A → A. Global Hint Mode Join ! : typeclass_instances. Global Instance: Params (@join) 2 := {}. Infix "⊔" := join (at level 50) : stdpp_scope. Notation "(⊔)" := join (only parsing) : stdpp_scope. Notation "( x ⊔.)" := (join x) (only parsing) : stdpp_scope. Notation "(.⊔ y )" := (λ x, join x y) (only parsing) : stdpp_scope. Class Top A := top : A. Global Hint Mode Top ! : typeclass_instances. Notation "⊤" := top (format "⊤") : stdpp_scope. Class Bottom A := bottom : A. Global Hint Mode Bottom ! : typeclass_instances. Notation "⊥" := bottom (format "⊥") : stdpp_scope. (** * Axiomatization of sets *) (** The classes [SemiSet A C], [Set_ A C], and [TopSet A C] axiomatize sets of type [C] with elements of type [A]. The first class, [SemiSet] does not include intersection and difference. It is useful for the case of lists, where decidable equality is needed to implement intersection and difference, but not union. Note that we cannot use the name [Set] since that is a reserved keyword. Hence we use [Set_]. *) Class SemiSet A C `{ElemOf A C, Empty C, Singleton A C, Union C} : Prop := { not_elem_of_empty (x : A) : x ∉@{C} ∅; (* We prove [elem_of_empty : x ∈@{C} ∅ ↔ False] in [sets.v], which is more convenient for rewriting. *) elem_of_singleton (x y : A) : x ∈@{C} {[ y ]} ↔ x = y; elem_of_union (X Y : C) (x : A) : x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y }. Global Hint Mode SemiSet - ! - - - - : typeclass_instances. Class Set_ A C `{ElemOf A C, Empty C, Singleton A C, Union C, Intersection C, Difference C} : Prop := { set_semi_set :> SemiSet A C; elem_of_intersection (X Y : C) (x : A) : x ∈ X ∩ Y ↔ x ∈ X ∧ x ∈ Y; elem_of_difference (X Y : C) (x : A) : x ∈ X ∖ Y ↔ x ∈ X ∧ x ∉ Y }. Global Hint Mode Set_ - ! - - - - - - : typeclass_instances. Class TopSet A C `{ElemOf A C, Empty C, Top C, Singleton A C, Union C, Intersection C, Difference C} : Prop := { top_set_set :> Set_ A C; elem_of_top' (x : A) : x ∈@{C} ⊤; (* We prove [elem_of_top : x ∈@{C} ⊤ ↔ True] in [sets.v], which is more convenient for rewriting. *) }. Global Hint Mode TopSet - ! - - - - - - - : typeclass_instances. (** We axiomative a finite set as a set whose elements can be enumerated as a list. These elements, given by the [elements] function, may be in any order and should not contain duplicates. *) Class Elements A C := elements: C → list A. Global Hint Mode Elements - ! : typeclass_instances. Global Instance: Params (@elements) 3 := {}. (** We redefine the standard library's [In] and [NoDup] using type classes. *) Inductive elem_of_list {A} : ElemOf A (list A) := | elem_of_list_here (x : A) l : x ∈ x :: l | elem_of_list_further (x y : A) l : x ∈ l → x ∈ y :: l. Global Existing Instance elem_of_list. Lemma elem_of_list_In {A} (l : list A) x : x ∈ l ↔ In x l. Proof. split. - induction 1; simpl; auto. - induction l; destruct 1; subst; constructor; auto. Qed. Inductive NoDup {A} : list A → Prop := | NoDup_nil_2 : NoDup [] | NoDup_cons_2 x l : x ∉ l → NoDup l → NoDup (x :: l). Lemma NoDup_ListNoDup {A} (l : list A) : NoDup l ↔ List.NoDup l. Proof. split. - induction 1; constructor; rewrite <-?elem_of_list_In; auto. - induction 1; constructor; rewrite ?elem_of_list_In; auto. Qed. (** Decidability of equality of the carrier set is admissible, but we add it anyway so as to avoid cycles in type class search. *) Class FinSet A C `{ElemOf A C, Empty C, Singleton A C, Union C, Intersection C, Difference C, Elements A C, EqDecision A} : Prop := { fin_set_set :> Set_ A C; elem_of_elements (X : C) x : x ∈ elements X ↔ x ∈ X; NoDup_elements (X : C) : NoDup (elements X) }. Global Hint Mode FinSet - ! - - - - - - - - : typeclass_instances. Class Size C := size: C → nat. Global Hint Mode Size ! : typeclass_instances. Global Arguments size {_ _} !_ / : simpl nomatch, assert. Global Instance: Params (@size) 2 := {}. (** The class [MonadSet M] axiomatizes a type constructor [M] that can be used to construct a set [M A] with elements of type [A]. The advantage of this class, compared to [Set_], is that it also axiomatizes the the monadic operations. The disadvantage is that not many inhabitants are possible: we will only provide as inhabitants [propset] and [listset], which are represented respectively using Boolean functions and lists with duplicates. More interesting implementations typically need decidable equality, or a total order on the elements, which do not fit in a type constructor of type [Type → Type]. *) Class MonadSet M `{∀ A, ElemOf A (M A), ∀ A, Empty (M A), ∀ A, Singleton A (M A), ∀ A, Union (M A), !MBind M, !MRet M, !FMap M, !MJoin M} : Prop := { monad_set_semi_set A :> SemiSet A (M A); elem_of_bind {A B} (f : A → M B) (X : M A) (x : B) : x ∈ X ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ X; elem_of_ret {A} (x y : A) : x ∈@{M A} mret y ↔ x = y; elem_of_fmap {A B} (f : A → B) (X : M A) (x : B) : x ∈ f <$> X ↔ ∃ y, x = f y ∧ y ∈ X; elem_of_join {A} (X : M (M A)) (x : A) : x ∈ mjoin X ↔ ∃ Y : M A, x ∈ Y ∧ Y ∈ X }. (** The [Infinite A] class axiomatizes types [A] with infinitely many elements. It contains a function [fresh : list A → A] that given a list [xs] gives an element [fresh xs ∉ xs]. We do not directly make [fresh] a field of the [Infinite] class, but use a separate operational type class [Fresh] for it. That way we can overload [fresh] to pick fresh elements from other data structure like sets. See the file [fin_sets], where we define [fresh : C → A] for any finite set implementation [FinSet C A]. Note: we require [fresh] to respect permutations, which is needed to define the aforementioned [fresh] function on finite sets that respects set equality. Instead of instantiating [Infinite] directly, consider using [max_infinite] or [inj_infinite] from the [infinite] module. *) Class Fresh A C := fresh: C → A. Global Hint Mode Fresh - ! : typeclass_instances. Global Instance: Params (@fresh) 3 := {}. Global Arguments fresh : simpl never. Class Infinite A := { infinite_fresh :> Fresh A (list A); infinite_is_fresh (xs : list A) : fresh xs ∉ xs; infinite_fresh_Permutation :> Proper (@Permutation A ==> (=)) fresh; }. Global Hint Mode Infinite ! : typeclass_instances. Global Arguments infinite_fresh : simpl never. (** * Miscellaneous *) Class Half A := half: A → A. Global Hint Mode Half ! : typeclass_instances. Notation "½" := half (format "½") : stdpp_scope. Notation "½*" := (fmap (M:=list) half) : stdpp_scope. stdpp-coq-stdpp-1.9.0/stdpp/binders.v000066400000000000000000000112501451153341500175330ustar00rootroot00000000000000(** This file implements a type [binder] with elements [BAnon] for the anonymous binder, and [BNamed] for named binders. This type is isomorphic to [option string], but we use a special type so that we can define [BNamed] as a coercion. This library is used in various Iris developments, like heap-lang, LambdaRust, Iron, Fairis. *) From stdpp Require Export strings. From stdpp Require Import sets countable finite fin_maps. From stdpp Require Import options. (* Pick up extra assumptions from section parameters. *) Set Default Proof Using "Type*". Declare Scope binder_scope. Delimit Scope binder_scope with binder. Inductive binder := BAnon | BNamed :> string → binder. Bind Scope binder_scope with binder. Notation "<>" := BAnon : binder_scope. (** [binder_list] matches [option_list]. *) Definition binder_list (b : binder) : list string := match b with | BAnon => [] | BNamed s => [s] end. Global Instance binder_dec_eq : EqDecision binder. Proof. solve_decision. Defined. Global Instance binder_inhabited : Inhabited binder := populate BAnon. Global Instance binder_countable : Countable binder. Proof. refine (inj_countable' (λ b, match b with BAnon => None | BNamed s => Some s end) (λ b, match b with None => BAnon | Some s => BNamed s end) _); by intros []. Qed. (** The functions [cons_binder b ss] and [app_binder bs ss] are typically used to collect the free variables of an expression. Here [ss] is the current list of free variables, and [b], respectively [bs], are the binders that are being added. *) Definition cons_binder (b : binder) (ss : list string) : list string := match b with BAnon => ss | BNamed s => s :: ss end. Infix ":b:" := cons_binder (at level 60, right associativity). Fixpoint app_binder (bs : list binder) (ss : list string) : list string := match bs with [] => ss | b :: bs => b :b: app_binder bs ss end. Infix "+b+" := app_binder (at level 60, right associativity). Global Instance set_unfold_cons_binder s b ss P : SetUnfoldElemOf s ss P → SetUnfoldElemOf s (b :b: ss) (BNamed s = b ∨ P). Proof. constructor. rewrite <-(set_unfold (s ∈ ss) P). destruct b; simpl; rewrite ?elem_of_cons; naive_solver. Qed. Global Instance set_unfold_app_binder s bs ss P Q : SetUnfoldElemOf (BNamed s) bs P → SetUnfoldElemOf s ss Q → SetUnfoldElemOf s (bs +b+ ss) (P ∨ Q). Proof. intros HinP HinQ. constructor. rewrite <-(set_unfold (s ∈ ss) Q), <-(set_unfold (BNamed s ∈ bs) P). clear HinP HinQ. induction bs; set_solver. Qed. Lemma app_binder_named ss1 ss2 : (BNamed <$> ss1) +b+ ss2 = ss1 ++ ss2. Proof. induction ss1; by f_equal/=. Qed. Lemma app_binder_snoc bs s ss : bs +b+ (s :: ss) = (bs ++ [BNamed s]) +b+ ss. Proof. induction bs; by f_equal/=. Qed. Global Instance cons_binder_Permutation b : Proper ((≡ₚ) ==> (≡ₚ)) (cons_binder b). Proof. intros ss1 ss2 Hss. destruct b; csimpl; by rewrite Hss. Qed. Global Instance app_binder_Permutation : Proper ((≡ₚ) ==> (≡ₚ) ==> (≡ₚ)) app_binder. Proof. assert (∀ bs, Proper ((≡ₚ) ==> (≡ₚ)) (app_binder bs)). { intros bs. induction bs as [|[]]; intros ss1 ss2; simpl; by intros ->. } induction 1 as [|[]|[] []|]; intros ss1 ss2 Hss; simpl; first [by eauto using perm_trans|by rewrite 1?perm_swap, Hss]. Qed. Definition binder_delete `{Delete string M} (b : binder) (m : M) : M := match b with BAnon => m | BNamed s => delete s m end. Definition binder_insert `{Insert string A M} (b : binder) (x : A) (m : M) : M := match b with BAnon => m | BNamed s => <[s:=x]> m end. Global Instance: Params (@binder_insert) 4 := {}. Section binder_delete_insert. Context `{FinMap string M}. Global Instance binder_insert_proper `{Equiv A} b : Proper ((≡) ==> (≡) ==> (≡@{M A})) (binder_insert b). Proof. destruct b; solve_proper. Qed. Lemma binder_delete_empty {A} b : binder_delete b ∅ =@{M A} ∅. Proof. destruct b; simpl; eauto using delete_empty. Qed. Lemma lookup_binder_delete_None {A} (m : M A) b s : binder_delete b m !! s = None ↔ b = BNamed s ∨ m !! s = None. Proof. destruct b; simpl; by rewrite ?lookup_delete_None; naive_solver. Qed. Lemma binder_insert_fmap {A B} (f : A → B) (x : A) b (m : M A) : f <$> binder_insert b x m = binder_insert b (f x) (f <$> m). Proof. destruct b; simpl; by rewrite ?fmap_insert. Qed. Lemma binder_delete_insert {A} b s x (m : M A) : b ≠ BNamed s → binder_delete b (<[s:=x]> m) = <[s:=x]> (binder_delete b m). Proof. intros. destruct b; simpl; by rewrite ?delete_insert_ne by congruence. Qed. Lemma binder_delete_delete {A} b s (m : M A) : binder_delete b (delete s m) = delete s (binder_delete b m). Proof. destruct b; simpl; by rewrite 1?delete_commute. Qed. End binder_delete_insert. stdpp-coq-stdpp-1.9.0/stdpp/boolset.v000066400000000000000000000034041451153341500175560ustar00rootroot00000000000000(** This file implements boolsets as functions into Prop. *) From stdpp Require Export prelude. From stdpp Require Import options. Record boolset (A : Type) : Type := BoolSet { boolset_car : A → bool }. Global Arguments BoolSet {_} _ : assert. Global Arguments boolset_car {_} _ _ : assert. Global Instance boolset_top {A} : Top (boolset A) := BoolSet (λ _, true). Global Instance boolset_empty {A} : Empty (boolset A) := BoolSet (λ _, false). Global Instance boolset_singleton `{EqDecision A} : Singleton A (boolset A) := λ x, BoolSet (λ y, bool_decide (y = x)). Global Instance boolset_elem_of {A} : ElemOf A (boolset A) := λ x X, boolset_car X x. Global Instance boolset_union {A} : Union (boolset A) := λ X1 X2, BoolSet (λ x, boolset_car X1 x || boolset_car X2 x). Global Instance boolset_intersection {A} : Intersection (boolset A) := λ X1 X2, BoolSet (λ x, boolset_car X1 x && boolset_car X2 x). Global Instance boolset_difference {A} : Difference (boolset A) := λ X1 X2, BoolSet (λ x, boolset_car X1 x && negb (boolset_car X2 x)). Global Instance boolset_top_set `{EqDecision A} : TopSet A (boolset A). Proof. split; [split; [split| |]|]. - by intros x ?. - by intros x y; rewrite <-(bool_decide_spec (x = y)). - split; [apply orb_prop_elim | apply orb_prop_intro]. - split; [apply andb_prop_elim | apply andb_prop_intro]. - intros X Y x; unfold elem_of, boolset_elem_of; simpl. destruct (boolset_car X x), (boolset_car Y x); simpl; tauto. - done. Qed. Global Instance boolset_elem_of_dec {A} : RelDecision (∈@{boolset A}). Proof. refine (λ x X, cast_if (decide (boolset_car X x))); done. Defined. Global Typeclasses Opaque boolset_elem_of. Global Opaque boolset_empty boolset_singleton boolset_union boolset_intersection boolset_difference. stdpp-coq-stdpp-1.9.0/stdpp/coGset.v000066400000000000000000000164001451153341500173330ustar00rootroot00000000000000(** This file implements the type [coGset A] of finite/cofinite sets of elements of any countable type [A]. Note that [coGset positive] cannot represent all elements of [coPset] (e.g., [coPset_suffixes], [coPset_l], and [coPset_r] construct infinite sets that cannot be represented). *) From stdpp Require Export sets countable. From stdpp Require Import decidable finite gmap coPset. From stdpp Require Import options. (* Pick up extra assumptions from section parameters. *) Set Default Proof Using "Type*". Inductive coGset `{Countable A} := | FinGSet (X : gset A) | CoFinGset (X : gset A). Global Arguments coGset _ {_ _} : assert. Global Instance coGset_eq_dec `{Countable A} : EqDecision (coGset A). Proof. solve_decision. Defined. Global Instance coGset_countable `{Countable A} : Countable (coGset A). Proof. apply (inj_countable' (λ X, match X with FinGSet X => inl X | CoFinGset X => inr X end) (λ s, match s with inl X => FinGSet X | inr X => CoFinGset X end)). by intros []. Qed. Section coGset. Context `{Countable A}. Global Instance coGset_elem_of : ElemOf A (coGset A) := λ x X, match X with FinGSet X => x ∈ X | CoFinGset X => x ∉ X end. Global Instance coGset_empty : Empty (coGset A) := FinGSet ∅. Global Instance coGset_top : Top (coGset A) := CoFinGset ∅. Global Instance coGset_singleton : Singleton A (coGset A) := λ x, FinGSet {[x]}. Global Instance coGset_union : Union (coGset A) := λ X Y, match X, Y with | FinGSet X, FinGSet Y => FinGSet (X ∪ Y) | CoFinGset X, CoFinGset Y => CoFinGset (X ∩ Y) | FinGSet X, CoFinGset Y => CoFinGset (Y ∖ X) | CoFinGset X, FinGSet Y => CoFinGset (X ∖ Y) end. Global Instance coGset_intersection : Intersection (coGset A) := λ X Y, match X, Y with | FinGSet X, FinGSet Y => FinGSet (X ∩ Y) | CoFinGset X, CoFinGset Y => CoFinGset (X ∪ Y) | FinGSet X, CoFinGset Y => FinGSet (X ∖ Y) | CoFinGset X, FinGSet Y => FinGSet (Y ∖ X) end. Global Instance coGset_difference : Difference (coGset A) := λ X Y, match X, Y with | FinGSet X, FinGSet Y => FinGSet (X ∖ Y) | CoFinGset X, CoFinGset Y => FinGSet (Y ∖ X) | FinGSet X, CoFinGset Y => FinGSet (X ∩ Y) | CoFinGset X, FinGSet Y => CoFinGset (X ∪ Y) end. Global Instance coGset_set : TopSet A (coGset A). Proof. split; [split; [split| |]|]. - by intros ??. - intros x y. unfold elem_of, coGset_elem_of; simpl. by rewrite elem_of_singleton. - intros [X|X] [Y|Y] x; unfold elem_of, coGset_elem_of, coGset_union; simpl. + set_solver. + by rewrite not_elem_of_difference, (comm (∨)). + by rewrite not_elem_of_difference. + by rewrite not_elem_of_intersection. - intros [] []; unfold elem_of, coGset_elem_of, coGset_intersection; set_solver. - intros [X|X] [Y|Y] x; unfold elem_of, coGset_elem_of, coGset_difference; simpl. + set_solver. + rewrite elem_of_intersection. destruct (decide (x ∈ Y)); tauto. + set_solver. + rewrite elem_of_difference. destruct (decide (x ∈ Y)); tauto. - done. Qed. End coGset. Global Instance coGset_elem_of_dec `{Countable A} : RelDecision (∈@{coGset A}) := λ x X, match X with | FinGSet X => decide_rel elem_of x X | CoFinGset X => not_dec (decide_rel elem_of x X) end. Section infinite. Context `{Countable A, Infinite A}. Global Instance coGset_leibniz : LeibnizEquiv (coGset A). Proof. intros [X|X] [Y|Y]; rewrite set_equiv; unfold elem_of, coGset_elem_of; simpl; intros HXY. - f_equal. by apply leibniz_equiv. - by destruct (exist_fresh (X ∪ Y)) as [? [? ?%HXY]%not_elem_of_union]. - by destruct (exist_fresh (X ∪ Y)) as [? [?%HXY ?]%not_elem_of_union]. - f_equal. apply leibniz_equiv; intros x. by apply not_elem_of_iff. Qed. Global Instance coGset_equiv_dec : RelDecision (≡@{coGset A}). Proof. refine (λ X Y, cast_if (decide (X = Y))); abstract (by fold_leibniz). Defined. Global Instance coGset_disjoint_dec : RelDecision (##@{coGset A}). Proof. refine (λ X Y, cast_if (decide (X ∩ Y = ∅))); abstract (by rewrite disjoint_intersection_L). Defined. Global Instance coGset_subseteq_dec : RelDecision (⊆@{coGset A}). Proof. refine (λ X Y, cast_if (decide (X ∪ Y = Y))); abstract (by rewrite subseteq_union_L). Defined. Definition coGset_finite (X : coGset A) : bool := match X with FinGSet _ => true | CoFinGset _ => false end. Lemma coGset_finite_spec X : set_finite X ↔ coGset_finite X. Proof. destruct X as [X|X]; unfold set_finite, elem_of at 1, coGset_elem_of; simpl. - split; [done|intros _]. exists (elements X). set_solver. - split; [intros [Y HXY]%(pred_finite_set(C:=gset A))|done]. by destruct (exist_fresh (X ∪ Y)) as [? [?%HXY ?]%not_elem_of_union]. Qed. Global Instance coGset_finite_dec (X : coGset A) : Decision (set_finite X). Proof. refine (cast_if (decide (coGset_finite X))); abstract (by rewrite coGset_finite_spec). Defined. End infinite. (** * Pick elements from infinite sets *) Definition coGpick `{Countable A, Infinite A} (X : coGset A) : A := fresh (match X with FinGSet _ => ∅ | CoFinGset X => X end). Lemma coGpick_elem_of `{Countable A, Infinite A} (X : coGset A) : ¬set_finite X → coGpick X ∈ X. Proof. unfold coGpick. destruct X as [X|X]; rewrite coGset_finite_spec; simpl; [done|]. by intros _; apply is_fresh. Qed. (** * Conversion to and from gset *) Definition coGset_to_gset `{Countable A} (X : coGset A) : gset A := match X with FinGSet X => X | CoFinGset _ => ∅ end. Definition gset_to_coGset `{Countable A} : gset A → coGset A := FinGSet. Section to_gset. Context `{Countable A}. Lemma elem_of_gset_to_coGset (X : gset A) x : x ∈ gset_to_coGset X ↔ x ∈ X. Proof. done. Qed. Context `{Infinite A}. Lemma elem_of_coGset_to_gset (X : coGset A) x : set_finite X → x ∈ coGset_to_gset X ↔ x ∈ X. Proof. rewrite coGset_finite_spec. by destruct X. Qed. Lemma gset_to_coGset_finite (X : gset A) : set_finite (gset_to_coGset X). Proof. by rewrite coGset_finite_spec. Qed. End to_gset. (** * Conversion to coPset *) Definition coGset_to_coPset (X : coGset positive) : coPset := match X with | FinGSet X => gset_to_coPset X | CoFinGset X => ⊤ ∖ gset_to_coPset X end. Lemma elem_of_coGset_to_coPset X x : x ∈ coGset_to_coPset X ↔ x ∈ X. Proof. destruct X as [X|X]; simpl. - by rewrite elem_of_gset_to_coPset. - by rewrite elem_of_difference, elem_of_gset_to_coPset, (left_id True (∧)). Qed. (** * Inefficient conversion to arbitrary sets with a top element *) (** This shows that, when [A] is countable, [coGset A] is initial among sets with [∪], [∩], [∖], [∅], [{[_]}], and [⊤]. *) Definition coGset_to_top_set `{Countable A, Empty C, Singleton A C, Union C, Top C, Difference C} (X : coGset A) : C := match X with | FinGSet X => list_to_set (elements X) | CoFinGset X => ⊤ ∖ list_to_set (elements X) end. Lemma elem_of_coGset_to_top_set `{Countable A, TopSet A C} X x : x ∈@{C} coGset_to_top_set X ↔ x ∈ X. Proof. destruct X; set_solver. Qed. Global Typeclasses Opaque coGset_elem_of coGset_empty coGset_top coGset_singleton. Global Typeclasses Opaque coGset_union coGset_intersection coGset_difference. stdpp-coq-stdpp-1.9.0/stdpp/coPset.v000066400000000000000000000476011451153341500173530ustar00rootroot00000000000000(** This files implements the type [coPset] of efficient finite/cofinite sets of positive binary naturals [positive]. These sets are: - Closed under union, intersection and set complement. - Closed under splitting of cofinite sets. Also, they enjoy various nice properties, such as decidable equality and set membership, as well as extensional equality (i.e. [X = Y ↔ ∀ x, x ∈ X ↔ x ∈ Y]). Since [positive]s are bitstrings, we encode [coPset]s as trees that correspond to the decision function that map bitstrings to bools. *) From stdpp Require Export sets. From stdpp Require Import pmap gmap mapset. From stdpp Require Import options. Local Open Scope positive_scope. (** * The tree data structure *) Inductive coPset_raw := | coPLeaf : bool → coPset_raw | coPNode : bool → coPset_raw → coPset_raw → coPset_raw. Global Instance coPset_raw_eq_dec : EqDecision coPset_raw. Proof. solve_decision. Defined. Fixpoint coPset_wf (t : coPset_raw) : bool := match t with | coPLeaf _ => true | coPNode true (coPLeaf true) (coPLeaf true) => false | coPNode false (coPLeaf false) (coPLeaf false) => false | coPNode _ l r => coPset_wf l && coPset_wf r end. Global Arguments coPset_wf !_ / : simpl nomatch, assert. Lemma coPNode_wf b l r : coPset_wf l → coPset_wf r → (l = coPLeaf true → r = coPLeaf true → b = true → False) → (l = coPLeaf false → r = coPLeaf false → b = false → False) → coPset_wf (coPNode b l r). Proof. destruct b, l as [[]|], r as [[]|]; naive_solver. Qed. Lemma coPNode_wf_l b l r : coPset_wf (coPNode b l r) → coPset_wf l. Proof. destruct b, l as [[]|],r as [[]|]; simpl; rewrite ?andb_True; tauto. Qed. Lemma coPNode_wf_r b l r : coPset_wf (coPNode b l r) → coPset_wf r. Proof. destruct b, l as [[]|],r as [[]|]; simpl; rewrite ?andb_True; tauto. Qed. Local Hint Immediate coPNode_wf_l coPNode_wf_r : core. Definition coPNode' (b : bool) (l r : coPset_raw) : coPset_raw := match b, l, r with | true, coPLeaf true, coPLeaf true => coPLeaf true | false, coPLeaf false, coPLeaf false => coPLeaf false | _, _, _ => coPNode b l r end. Global Arguments coPNode' : simpl never. Lemma coPNode'_wf b l r : coPset_wf l → coPset_wf r → coPset_wf (coPNode' b l r). Proof. destruct b, l as [[]|], r as [[]|]; simpl; auto. Qed. Global Hint Resolve coPNode'_wf : core. Fixpoint coPset_elem_of_raw (p : positive) (t : coPset_raw) {struct t} : bool := match t, p with | coPLeaf b, _ => b | coPNode b l r, 1 => b | coPNode _ l _, p~0 => coPset_elem_of_raw p l | coPNode _ _ r, p~1 => coPset_elem_of_raw p r end. Local Notation e_of := coPset_elem_of_raw. Global Arguments coPset_elem_of_raw _ !_ / : simpl nomatch, assert. Lemma coPset_elem_of_node b l r p : e_of p (coPNode' b l r) = e_of p (coPNode b l r). Proof. by destruct p, b, l as [[]|], r as [[]|]. Qed. Lemma coPLeaf_wf t b : (∀ p, e_of p t = b) → coPset_wf t → t = coPLeaf b. Proof. induction t as [b'|b' l IHl r IHr]; intros Ht ?; [f_equal; apply (Ht 1)|]. assert (b' = b) by (apply (Ht 1)); subst. assert (l = coPLeaf b) as -> by (apply IHl; try apply (λ p, Ht (p~0)); eauto). assert (r = coPLeaf b) as -> by (apply IHr; try apply (λ p, Ht (p~1)); eauto). by destruct b. Qed. Lemma coPset_eq t1 t2 : (∀ p, e_of p t1 = e_of p t2) → coPset_wf t1 → coPset_wf t2 → t1 = t2. Proof. revert t2. induction t1 as [b1|b1 l1 IHl r1 IHr]; intros [b2|b2 l2 r2] Ht ??; simpl in *. - f_equal; apply (Ht 1). - by discriminate (coPLeaf_wf (coPNode b2 l2 r2) b1). - by discriminate (coPLeaf_wf (coPNode b1 l1 r1) b2). - f_equal; [apply (Ht 1)| |]. + apply IHl; try apply (λ x, Ht (x~0)); eauto. + apply IHr; try apply (λ x, Ht (x~1)); eauto. Qed. Fixpoint coPset_singleton_raw (p : positive) : coPset_raw := match p with | 1 => coPNode true (coPLeaf false) (coPLeaf false) | p~0 => coPNode' false (coPset_singleton_raw p) (coPLeaf false) | p~1 => coPNode' false (coPLeaf false) (coPset_singleton_raw p) end. Global Instance coPset_union_raw : Union coPset_raw := fix go t1 t2 := let _ : Union _ := @go in match t1, t2 with | coPLeaf false, coPLeaf false => coPLeaf false | _, coPLeaf true => coPLeaf true | coPLeaf true, _ => coPLeaf true | coPNode b l r, coPLeaf false => coPNode b l r | coPLeaf false, coPNode b l r => coPNode b l r | coPNode b1 l1 r1, coPNode b2 l2 r2 => coPNode' (b1||b2) (l1 ∪ l2) (r1 ∪ r2) end. Local Arguments union _ _!_ !_ / : assert. Global Instance coPset_intersection_raw : Intersection coPset_raw := fix go t1 t2 := let _ : Intersection _ := @go in match t1, t2 with | coPLeaf true, coPLeaf true => coPLeaf true | _, coPLeaf false => coPLeaf false | coPLeaf false, _ => coPLeaf false | coPNode b l r, coPLeaf true => coPNode b l r | coPLeaf true, coPNode b l r => coPNode b l r | coPNode b1 l1 r1, coPNode b2 l2 r2 => coPNode' (b1&&b2) (l1 ∩ l2) (r1 ∩ r2) end. Local Arguments intersection _ _!_ !_ / : assert. Fixpoint coPset_opp_raw (t : coPset_raw) : coPset_raw := match t with | coPLeaf b => coPLeaf (negb b) | coPNode b l r => coPNode' (negb b) (coPset_opp_raw l) (coPset_opp_raw r) end. Lemma coPset_singleton_wf p : coPset_wf (coPset_singleton_raw p). Proof. induction p; simpl; eauto. Qed. Lemma coPset_union_wf t1 t2 : coPset_wf t1 → coPset_wf t2 → coPset_wf (t1 ∪ t2). Proof. revert t2; induction t1 as [[]|[]]; intros [[]|[] ??]; simpl; eauto. Qed. Lemma coPset_intersection_wf t1 t2 : coPset_wf t1 → coPset_wf t2 → coPset_wf (t1 ∩ t2). Proof. revert t2; induction t1 as [[]|[]]; intros [[]|[] ??]; simpl; eauto. Qed. Lemma coPset_opp_wf t : coPset_wf (coPset_opp_raw t). Proof. induction t as [[]|[]]; simpl; eauto. Qed. Lemma coPset_elem_of_singleton p q : e_of p (coPset_singleton_raw q) ↔ p = q. Proof. split; [|by intros <-; induction p; simpl; rewrite ?coPset_elem_of_node]. by revert q; induction p; intros [?|?|]; simpl; rewrite ?coPset_elem_of_node; intros; f_equal/=; auto. Qed. Lemma coPset_elem_of_union t1 t2 p : e_of p (t1 ∪ t2) = e_of p t1 || e_of p t2. Proof. by revert t2 p; induction t1 as [[]|[]]; intros [[]|[] ??] [?|?|]; simpl; rewrite ?coPset_elem_of_node; simpl; rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r. Qed. Lemma coPset_elem_of_intersection t1 t2 p : e_of p (t1 ∩ t2) = e_of p t1 && e_of p t2. Proof. by revert t2 p; induction t1 as [[]|[]]; intros [[]|[] ??] [?|?|]; simpl; rewrite ?coPset_elem_of_node; simpl; rewrite ?andb_true_l, ?andb_false_l, ?andb_true_r, ?andb_false_r. Qed. Lemma coPset_elem_of_opp t p : e_of p (coPset_opp_raw t) = negb (e_of p t). Proof. by revert p; induction t as [[]|[]]; intros [?|?|]; simpl; rewrite ?coPset_elem_of_node; simpl. Qed. (** * Packed together + set operations *) Definition coPset := { t | coPset_wf t }. Global Instance coPset_singleton : Singleton positive coPset := λ p, coPset_singleton_raw p ↾ coPset_singleton_wf _. Global Instance coPset_elem_of : ElemOf positive coPset := λ p X, e_of p (`X). Global Instance coPset_empty : Empty coPset := coPLeaf false ↾ I. Global Instance coPset_top : Top coPset := coPLeaf true ↾ I. Global Instance coPset_union : Union coPset := λ X Y, let (t1,Ht1) := X in let (t2,Ht2) := Y in (t1 ∪ t2) ↾ coPset_union_wf _ _ Ht1 Ht2. Global Instance coPset_intersection : Intersection coPset := λ X Y, let (t1,Ht1) := X in let (t2,Ht2) := Y in (t1 ∩ t2) ↾ coPset_intersection_wf _ _ Ht1 Ht2. Global Instance coPset_difference : Difference coPset := λ X Y, let (t1,Ht1) := X in let (t2,Ht2) := Y in (t1 ∩ coPset_opp_raw t2) ↾ coPset_intersection_wf _ _ Ht1 (coPset_opp_wf _). Global Instance coPset_top_set : TopSet positive coPset. Proof. split; [split; [split| |]|]. - by intros ??. - intros p q. apply coPset_elem_of_singleton. - intros [t] [t'] p; unfold elem_of, coPset_elem_of, coPset_union; simpl. by rewrite coPset_elem_of_union, orb_True. - intros [t] [t'] p; unfold elem_of,coPset_elem_of,coPset_intersection; simpl. by rewrite coPset_elem_of_intersection, andb_True. - intros [t] [t'] p; unfold elem_of, coPset_elem_of, coPset_difference; simpl. by rewrite coPset_elem_of_intersection, coPset_elem_of_opp, andb_True, negb_True. - done. Qed. (** Iris and specifically [solve_ndisj] heavily rely on this hint. *) Local Definition coPset_top_subseteq := top_subseteq (C:=coPset). Global Hint Resolve coPset_top_subseteq : core. Global Instance coPset_leibniz : LeibnizEquiv coPset. Proof. intros X Y; rewrite set_equiv; intros HXY. apply (sig_eq_pi _), coPset_eq; try apply @proj2_sig. intros p; apply eq_bool_prop_intro, (HXY p). Qed. Global Instance coPset_elem_of_dec : RelDecision (∈@{coPset}). Proof. solve_decision. Defined. Global Instance coPset_equiv_dec : RelDecision (≡@{coPset}). Proof. refine (λ X Y, cast_if (decide (X = Y))); abstract (by fold_leibniz). Defined. Global Instance mapset_disjoint_dec : RelDecision (##@{coPset}). Proof. refine (λ X Y, cast_if (decide (X ∩ Y = ∅))); abstract (by rewrite disjoint_intersection_L). Defined. Global Instance mapset_subseteq_dec : RelDecision (⊆@{coPset}). Proof. refine (λ X Y, cast_if (decide (X ∪ Y = Y))); abstract (by rewrite subseteq_union_L). Defined. (** * Finite sets *) Fixpoint coPset_finite (t : coPset_raw) : bool := match t with | coPLeaf b => negb b | coPNode b l r => coPset_finite l && coPset_finite r end. Lemma coPset_finite_node b l r : coPset_finite (coPNode' b l r) = coPset_finite l && coPset_finite r. Proof. by destruct b, l as [[]|], r as [[]|]. Qed. Lemma coPset_finite_spec X : set_finite X ↔ coPset_finite (`X). Proof. destruct X as [t Ht]. unfold set_finite, elem_of at 1, coPset_elem_of; simpl; clear Ht; split. - induction t as [b|b l IHl r IHr]; simpl. { destruct b; simpl; [intros [l Hl]|done]. by apply (infinite_is_fresh l), Hl. } intros [ll Hll]; rewrite andb_True; split. + apply IHl; exists (omap (maybe (~0)) ll); intros i. rewrite elem_of_list_omap; intros; exists (i~0); auto. + apply IHr; exists (omap (maybe (~1)) ll); intros i. rewrite elem_of_list_omap; intros; exists (i~1); auto. - induction t as [b|b l IHl r IHr]; simpl; [by exists []; destruct b|]. rewrite andb_True; intros [??]; destruct IHl as [ll ?], IHr as [rl ?]; auto. exists ([1] ++ ((~0) <$> ll) ++ ((~1) <$> rl))%list; intros [i|i|]; simpl; rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap; naive_solver. Qed. Global Instance coPset_finite_dec (X : coPset) : Decision (set_finite X). Proof. refine (cast_if (decide (coPset_finite (`X)))); by rewrite coPset_finite_spec. Defined. (** * Pick element from infinite sets *) (* The function [coPpick X] gives an element that is in the set [X], provided that the set [X] is infinite. Note that [coPpick] function is implemented by depth-first search, so using it repeatedly to obtain elements [x], and inserting these elements [x] into the set [X], will give rise to a very unbalanced tree. *) Fixpoint coPpick_raw (t : coPset_raw) : option positive := match t with | coPLeaf true | coPNode true _ _ => Some 1 | coPLeaf false => None | coPNode false l r => match coPpick_raw l with | Some i => Some (i~0) | None => (~1) <$> coPpick_raw r end end. Definition coPpick (X : coPset) : positive := default 1 (coPpick_raw (`X)). Lemma coPpick_raw_elem_of t i : coPpick_raw t = Some i → e_of i t. Proof. revert i; induction t as [[]|[] l ? r]; intros i ?; simplify_eq/=; auto. destruct (coPpick_raw l); simplify_option_eq; auto. Qed. Lemma coPpick_raw_None t : coPpick_raw t = None → coPset_finite t. Proof. induction t as [[]|[] l ? r]; intros i; simplify_eq/=; auto. destruct (coPpick_raw l); simplify_option_eq; auto. Qed. Lemma coPpick_elem_of X : ¬set_finite X → coPpick X ∈ X. Proof. destruct X as [t ?]; unfold coPpick; destruct (coPpick_raw _) as [j|] eqn:?. - by intros; apply coPpick_raw_elem_of. - by intros []; apply coPset_finite_spec, coPpick_raw_None. Qed. (** * Conversion to psets *) Fixpoint coPset_to_Pset_raw (t : coPset_raw) : Pmap () := match t with | coPLeaf _ => PEmpty | coPNode false l r => pmap.PNode (coPset_to_Pset_raw l) None (coPset_to_Pset_raw r) | coPNode true l r => pmap.PNode (coPset_to_Pset_raw l) (Some ()) (coPset_to_Pset_raw r) end. Definition coPset_to_Pset (X : coPset) : Pset := let (t,Ht) := X in Mapset (coPset_to_Pset_raw t). Lemma elem_of_coPset_to_Pset X i : set_finite X → i ∈ coPset_to_Pset X ↔ i ∈ X. Proof. rewrite coPset_finite_spec; destruct X as [t Ht]. change (coPset_finite t → coPset_to_Pset_raw t !! i = Some () ↔ e_of i t). clear Ht; revert i; induction t as [[]|[] l IHl r IHr]; intros [i|i|]; simpl; rewrite ?andb_True, ?pmap.Pmap_lookup_PNode; naive_solver. Qed. (** * Conversion from psets *) Definition Pset_to_coPset_raw_aux (go : Pmap_ne () → coPset_raw) (mt : Pmap ()) : coPset_raw := match mt with PNodes t => go t | PEmpty => coPLeaf false end. Fixpoint Pset_ne_to_coPset_raw (t : Pmap_ne ()) : coPset_raw := pmap.Pmap_ne_case t $ λ ml mx mr, coPNode match mx with Some _ => true | None => false end (Pset_to_coPset_raw_aux Pset_ne_to_coPset_raw ml) (Pset_to_coPset_raw_aux Pset_ne_to_coPset_raw mr). Definition Pset_to_coPset_raw : Pmap () → coPset_raw := Pset_to_coPset_raw_aux Pset_ne_to_coPset_raw. Lemma Pset_to_coPset_raw_PNode ml mx mr : pmap.PNode_valid ml mx mr → Pset_to_coPset_raw (pmap.PNode ml mx mr) = coPNode match mx with Some _ => true | None => false end (Pset_to_coPset_raw ml) (Pset_to_coPset_raw mr). Proof. by destruct ml, mx, mr. Qed. Lemma Pset_to_coPset_raw_wf t : coPset_wf (Pset_to_coPset_raw t). Proof. induction t as [|ml mx mr] using pmap.Pmap_ind; [done|]. rewrite Pset_to_coPset_raw_PNode by done. apply coPNode_wf; [done|done|..]; destruct mx; destruct ml using pmap.Pmap_ind; destruct mr using pmap.Pmap_ind; rewrite ?Pset_to_coPset_raw_PNode by done; naive_solver. Qed. Lemma elem_of_Pset_to_coPset_raw i t : e_of i (Pset_to_coPset_raw t) ↔ t !! i = Some (). Proof. revert i. induction t as [|ml mx mr] using pmap.Pmap_ind; [done|]. intros []; rewrite Pset_to_coPset_raw_PNode, pmap.Pmap_lookup_PNode by done; destruct mx as [[]|]; naive_solver. Qed. Lemma Pset_to_coPset_raw_finite t : coPset_finite (Pset_to_coPset_raw t). Proof. induction t as [|ml mx mr] using pmap.Pmap_ind; [done|]. rewrite Pset_to_coPset_raw_PNode by done. destruct mx; naive_solver. Qed. Definition Pset_to_coPset (X : Pset) : coPset := let 'Mapset t := X in Pset_to_coPset_raw t ↾ Pset_to_coPset_raw_wf _. Lemma elem_of_Pset_to_coPset X i : i ∈ Pset_to_coPset X ↔ i ∈ X. Proof. destruct X; apply elem_of_Pset_to_coPset_raw. Qed. Lemma Pset_to_coPset_finite X : set_finite (Pset_to_coPset X). Proof. apply coPset_finite_spec; destruct X; apply Pset_to_coPset_raw_finite. Qed. (** * Conversion to and from gsets of positives *) Definition coPset_to_gset (X : coPset) : gset positive := let 'Mapset m := coPset_to_Pset X in Mapset (pmap_to_gmap m). Definition gset_to_coPset (X : gset positive) : coPset := let 'Mapset m := X in Pset_to_coPset_raw (gmap_to_pmap m) ↾ Pset_to_coPset_raw_wf _. Lemma elem_of_coPset_to_gset X i : set_finite X → i ∈ coPset_to_gset X ↔ i ∈ X. Proof. intros ?. rewrite <-elem_of_coPset_to_Pset by done. destruct X as [X ?]. unfold elem_of, gset_elem_of, mapset_elem_of, coPset_to_gset; simpl. by rewrite lookup_pmap_to_gmap. Qed. Lemma elem_of_gset_to_coPset X i : i ∈ gset_to_coPset X ↔ i ∈ X. Proof. destruct X as [m]. unfold elem_of, coPset_elem_of; simpl. by rewrite elem_of_Pset_to_coPset_raw, lookup_gmap_to_pmap. Qed. Lemma gset_to_coPset_finite X : set_finite (gset_to_coPset X). Proof. apply coPset_finite_spec; destruct X as [[?]]; apply Pset_to_coPset_raw_finite. Qed. (** * Infinite sets *) Lemma coPset_infinite_finite (X : coPset) : set_infinite X ↔ ¬set_finite X. Proof. split; [intros ??; by apply (set_not_infinite_finite X)|]. intros Hfin xs. exists (coPpick (X ∖ list_to_set xs)). cut (coPpick (X ∖ list_to_set xs) ∈ X ∖ list_to_set xs); [set_solver|]. apply coPpick_elem_of; intros Hfin'. apply Hfin, (difference_finite_inv _ (list_to_set xs)), Hfin'. apply list_to_set_finite. Qed. Lemma coPset_finite_infinite (X : coPset) : set_finite X ↔ ¬set_infinite X. Proof. rewrite coPset_infinite_finite. split; [tauto|apply dec_stable]. Qed. Global Instance coPset_infinite_dec (X : coPset) : Decision (set_infinite X). Proof. refine (cast_if (decide (¬set_finite X))); by rewrite coPset_infinite_finite. Defined. (** * Suffix sets *) Fixpoint coPset_suffixes_raw (p : positive) : coPset_raw := match p with | 1 => coPLeaf true | p~0 => coPNode' false (coPset_suffixes_raw p) (coPLeaf false) | p~1 => coPNode' false (coPLeaf false) (coPset_suffixes_raw p) end. Lemma coPset_suffixes_wf p : coPset_wf (coPset_suffixes_raw p). Proof. induction p; simpl; eauto. Qed. Definition coPset_suffixes (p : positive) : coPset := coPset_suffixes_raw p ↾ coPset_suffixes_wf _. Lemma elem_coPset_suffixes p q : p ∈ coPset_suffixes q ↔ ∃ q', p = q' ++ q. Proof. unfold elem_of, coPset_elem_of; simpl; split. - revert p; induction q; intros [?|?|]; simpl; rewrite ?coPset_elem_of_node; naive_solver. - by intros [q' ->]; induction q; simpl; rewrite ?coPset_elem_of_node. Qed. Lemma coPset_suffixes_infinite p : ¬set_finite (coPset_suffixes p). Proof. rewrite coPset_finite_spec; simpl. induction p; simpl; rewrite ?coPset_finite_node, ?andb_True; naive_solver. Qed. (** * Splitting of infinite sets *) Fixpoint coPset_l_raw (t : coPset_raw) : coPset_raw := match t with | coPLeaf false => coPLeaf false | coPLeaf true => coPNode true (coPLeaf true) (coPLeaf false) | coPNode b l r => coPNode' b (coPset_l_raw l) (coPset_l_raw r) end. Fixpoint coPset_r_raw (t : coPset_raw) : coPset_raw := match t with | coPLeaf false => coPLeaf false | coPLeaf true => coPNode false (coPLeaf false) (coPLeaf true) | coPNode b l r => coPNode' false (coPset_r_raw l) (coPset_r_raw r) end. Lemma coPset_l_wf t : coPset_wf (coPset_l_raw t). Proof. induction t as [[]|]; simpl; auto. Qed. Lemma coPset_r_wf t : coPset_wf (coPset_r_raw t). Proof. induction t as [[]|]; simpl; auto. Qed. Definition coPset_l (X : coPset) : coPset := let (t,Ht) := X in coPset_l_raw t ↾ coPset_l_wf _. Definition coPset_r (X : coPset) : coPset := let (t,Ht) := X in coPset_r_raw t ↾ coPset_r_wf _. Lemma coPset_lr_disjoint X : coPset_l X ∩ coPset_r X = ∅. Proof. apply elem_of_equiv_empty_L; intros p; apply Is_true_false. destruct X as [t Ht]; simpl; clear Ht; rewrite coPset_elem_of_intersection. revert p; induction t as [[]|[]]; intros [?|?|]; simpl; rewrite ?coPset_elem_of_node; simpl; rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r; auto. Qed. Lemma coPset_lr_union X : coPset_l X ∪ coPset_r X = X. Proof. apply set_eq; intros p; apply eq_bool_prop_elim. destruct X as [t Ht]; simpl; clear Ht; rewrite coPset_elem_of_union. revert p; induction t as [[]|[]]; intros [?|?|]; simpl; rewrite ?coPset_elem_of_node; simpl; rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r; auto. Qed. Lemma coPset_l_finite X : set_finite (coPset_l X) → set_finite X. Proof. rewrite !coPset_finite_spec; destruct X as [t Ht]; simpl; clear Ht. induction t as [[]|]; simpl; rewrite ?coPset_finite_node, ?andb_True; tauto. Qed. Lemma coPset_r_finite X : set_finite (coPset_r X) → set_finite X. Proof. rewrite !coPset_finite_spec; destruct X as [t Ht]; simpl; clear Ht. induction t as [[]|]; simpl; rewrite ?coPset_finite_node, ?andb_True; tauto. Qed. Lemma coPset_split (X : coPset) : ¬set_finite X → ∃ X1 X2, X = X1 ∪ X2 ∧ X1 ∩ X2 = ∅ ∧ ¬set_finite X1 ∧ ¬set_finite X2. Proof. exists (coPset_l X), (coPset_r X); eauto 10 using coPset_lr_union, coPset_lr_disjoint, coPset_l_finite, coPset_r_finite. Qed. Lemma coPset_split_infinite (X : coPset) : set_infinite X → ∃ X1 X2, X = X1 ∪ X2 ∧ X1 ∩ X2 = ∅ ∧ set_infinite X1 ∧ set_infinite X2. Proof. setoid_rewrite coPset_infinite_finite. eapply coPset_split. Qed. stdpp-coq-stdpp-1.9.0/stdpp/countable.v000066400000000000000000000332041451153341500200640ustar00rootroot00000000000000From Coq.QArith Require Import QArith_base Qcanon. From stdpp Require Export list numbers list_numbers fin. From stdpp Require Import well_founded. From stdpp Require Import options. Local Open Scope positive. (** Note that [Countable A] gives rise to [EqDecision A] by checking equality of the results of [encode]. This instance of [EqDecision A] is very inefficient, so the native decider is typically preferred for actual computation. To avoid overlapping instances, we include [EqDecision A] explicitly as a parameter of [Countable A]. *) Class Countable A `{EqDecision A} := { encode : A → positive; decode : positive → option A; decode_encode x : decode (encode x) = Some x }. Global Hint Mode Countable ! - : typeclass_instances. Global Arguments encode : simpl never. Global Arguments decode : simpl never. Global Instance encode_inj `{Countable A} : Inj (=) (=) (encode (A:=A)). Proof. intros x y Hxy; apply (inj Some). by rewrite <-(decode_encode x), Hxy, decode_encode. Qed. Definition encode_nat `{Countable A} (x : A) : nat := pred (Pos.to_nat (encode x)). Definition decode_nat `{Countable A} (i : nat) : option A := decode (Pos.of_nat (S i)). Global Instance encode_nat_inj `{Countable A} : Inj (=) (=) (encode_nat (A:=A)). Proof. unfold encode_nat; intros x y Hxy; apply (inj encode); lia. Qed. Lemma decode_encode_nat `{Countable A} (x : A) : decode_nat (encode_nat x) = Some x. Proof. pose proof (Pos2Nat.is_pos (encode x)). unfold decode_nat, encode_nat. rewrite Nat.succ_pred by lia. by rewrite Pos2Nat.id, decode_encode. Qed. Definition encode_Z `{Countable A} (x : A) : Z := Zpos (encode x). Definition decode_Z `{Countable A} (i : Z) : option A := match i with Zpos i => decode i | _ => None end. Global Instance encode_Z_inj `{Countable A} : Inj (=) (=) (encode_Z (A:=A)). Proof. unfold encode_Z; intros x y Hxy; apply (inj encode); lia. Qed. Lemma decode_encode_Z `{Countable A} (x : A) : decode_Z (encode_Z x) = Some x. Proof. apply decode_encode. Qed. (** * Choice principles *) Section choice. Context `{Countable A} (P : A → Prop). Inductive choose_step: relation positive := | choose_step_None {p} : decode (A:=A) p = None → choose_step (Pos.succ p) p | choose_step_Some {p} {x : A} : decode p = Some x → ¬P x → choose_step (Pos.succ p) p. Lemma choose_step_acc : (∃ x, P x) → Acc choose_step 1%positive. Proof. intros [x Hx]. cut (∀ i p, i ≤ encode x → 1 + encode x = p + i → Acc choose_step p). { intros help. by apply (help (encode x)). } intros i. induction i as [|i IH] using Pos.peano_ind; intros p ??. { constructor. intros j. assert (p = encode x) by lia; subst. inversion 1 as [? Hd|?? Hd]; subst; rewrite decode_encode in Hd; congruence. } constructor. intros j. inversion 1 as [? Hd|? y Hd]; subst; auto with lia. Qed. Context `{∀ x, Decision (P x)}. Fixpoint choose_go {i} (acc : Acc choose_step i) : A := match Some_dec (decode i) with | inleft (x↾Hx) => match decide (P x) with | left _ => x | right H => choose_go (Acc_inv acc (choose_step_Some Hx H)) end | inright H => choose_go (Acc_inv acc (choose_step_None H)) end. Fixpoint choose_go_correct {i} (acc : Acc choose_step i) : P (choose_go acc). Proof. destruct acc; simpl. repeat case_match; auto. Qed. Fixpoint choose_go_pi {i} (acc1 acc2 : Acc choose_step i) : choose_go acc1 = choose_go acc2. Proof. destruct acc1, acc2; simpl; repeat case_match; auto. Qed. Definition choose (H: ∃ x, P x) : A := choose_go (choose_step_acc H). Definition choose_correct (H: ∃ x, P x) : P (choose H) := choose_go_correct _. Definition choose_pi (H1 H2 : ∃ x, P x) : choose H1 = choose H2 := choose_go_pi _ _. Definition choice (HA : ∃ x, P x) : { x | P x } := _↾choose_correct HA. End choice. Section choice_proper. Context `{Countable A}. Context (P1 P2 : A → Prop) `{∀ x, Decision (P1 x)} `{∀ x, Decision (P2 x)}. Context (Heq : ∀ x, P1 x ↔ P2 x). Lemma choose_go_proper {i} (acc1 acc2 : Acc (choose_step _) i) : choose_go P1 acc1 = choose_go P2 acc2. Proof using Heq. induction acc1 as [i a1 IH] using Acc_dep_ind; destruct acc2 as [acc2]; simpl. destruct (Some_dec _) as [[x Hx]|]; [|done]. do 2 case_decide; done || exfalso; naive_solver. Qed. Lemma choose_proper p1 p2 : choose P1 p1 = choose P2 p2. Proof using Heq. apply choose_go_proper. Qed. End choice_proper. Lemma surj_cancel `{Countable A} `{EqDecision B} (f : A → B) `{!Surj (=) f} : { g : B → A & Cancel (=) f g }. Proof. exists (λ y, choose (λ x, f x = y) (surj f y)). intros y. by rewrite (choose_correct (λ x, f x = y) (surj f y)). Qed. (** * Instances *) (** ** Injection *) Section inj_countable. Context `{Countable A, EqDecision B}. Context (f : B → A) (g : A → option B) (fg : ∀ x, g (f x) = Some x). Program Definition inj_countable : Countable B := {| encode y := encode (f y); decode p := x ← decode p; g x |}. Next Obligation. intros y; simpl; rewrite decode_encode; eauto. Qed. End inj_countable. Section inj_countable'. Context `{Countable A, EqDecision B}. Context (f : B → A) (g : A → B) (fg : ∀ x, g (f x) = x). Program Definition inj_countable' : Countable B := inj_countable f (Some ∘ g) _. Next Obligation. intros x. by f_equal/=. Qed. End inj_countable'. (** ** Empty *) Global Program Instance Empty_set_countable : Countable Empty_set := {| encode u := 1; decode p := None |}. Next Obligation. by intros []. Qed. (** ** Unit *) Global Program Instance unit_countable : Countable unit := {| encode u := 1; decode p := Some () |}. Next Obligation. by intros []. Qed. (** ** Bool *) Global Program Instance bool_countable : Countable bool := {| encode b := if b then 1 else 2; decode p := Some match p return bool with 1 => true | _ => false end |}. Next Obligation. by intros []. Qed. (** ** Option *) Global Program Instance option_countable `{Countable A} : Countable (option A) := {| encode o := match o with None => 1 | Some x => Pos.succ (encode x) end; decode p := if decide (p = 1) then Some None else Some <$> decode (Pos.pred p) |}. Next Obligation. intros ??? [x|]; simpl; repeat case_decide; auto with lia. by rewrite Pos.pred_succ, decode_encode. Qed. (** ** Sums *) Global Program Instance sum_countable `{Countable A} `{Countable B} : Countable (A + B)%type := {| encode xy := match xy with inl x => (encode x)~0 | inr y => (encode y)~1 end; decode p := match p with | 1 => None | p~0 => inl <$> decode p | p~1 => inr <$> decode p end |}. Next Obligation. by intros ?????? [x|y]; simpl; rewrite decode_encode. Qed. (** ** Products *) Fixpoint prod_encode_fst (p : positive) : positive := match p with | 1 => 1 | p~0 => (prod_encode_fst p)~0~0 | p~1 => (prod_encode_fst p)~0~1 end. Fixpoint prod_encode_snd (p : positive) : positive := match p with | 1 => 1~0 | p~0 => (prod_encode_snd p)~0~0 | p~1 => (prod_encode_snd p)~1~0 end. Fixpoint prod_encode (p q : positive) : positive := match p, q with | 1, 1 => 1~1 | p~0, 1 => (prod_encode_fst p)~1~0 | p~1, 1 => (prod_encode_fst p)~1~1 | 1, q~0 => (prod_encode_snd q)~0~1 | 1, q~1 => (prod_encode_snd q)~1~1 | p~0, q~0 => (prod_encode p q)~0~0 | p~0, q~1 => (prod_encode p q)~1~0 | p~1, q~0 => (prod_encode p q)~0~1 | p~1, q~1 => (prod_encode p q)~1~1 end. Fixpoint prod_decode_fst (p : positive) : option positive := match p with | p~0~0 => (~0) <$> prod_decode_fst p | p~0~1 => Some match prod_decode_fst p with Some q => q~1 | _ => 1 end | p~1~0 => (~0) <$> prod_decode_fst p | p~1~1 => Some match prod_decode_fst p with Some q => q~1 | _ => 1 end | 1~0 => None | 1~1 => Some 1 | 1 => Some 1 end. Fixpoint prod_decode_snd (p : positive) : option positive := match p with | p~0~0 => (~0) <$> prod_decode_snd p | p~0~1 => (~0) <$> prod_decode_snd p | p~1~0 => Some match prod_decode_snd p with Some q => q~1 | _ => 1 end | p~1~1 => Some match prod_decode_snd p with Some q => q~1 | _ => 1 end | 1~0 => Some 1 | 1~1 => Some 1 | 1 => None end. Lemma prod_decode_encode_fst p q : prod_decode_fst (prod_encode p q) = Some p. Proof. assert (∀ p, prod_decode_fst (prod_encode_fst p) = Some p). { intros p'. by induction p'; simplify_option_eq. } assert (∀ p, prod_decode_fst (prod_encode_snd p) = None). { intros p'. by induction p'; simplify_option_eq. } revert q. by induction p; intros [?|?|]; simplify_option_eq. Qed. Lemma prod_decode_encode_snd p q : prod_decode_snd (prod_encode p q) = Some q. Proof. assert (∀ p, prod_decode_snd (prod_encode_snd p) = Some p). { intros p'. by induction p'; simplify_option_eq. } assert (∀ p, prod_decode_snd (prod_encode_fst p) = None). { intros p'. by induction p'; simplify_option_eq. } revert q. by induction p; intros [?|?|]; simplify_option_eq. Qed. Global Program Instance prod_countable `{Countable A} `{Countable B} : Countable (A * B)%type := {| encode xy := prod_encode (encode (xy.1)) (encode (xy.2)); decode p := x ← prod_decode_fst p ≫= decode; y ← prod_decode_snd p ≫= decode; Some (x, y) |}. Next Obligation. intros ?????? [x y]; simpl. rewrite prod_decode_encode_fst, prod_decode_encode_snd; simpl. by rewrite !decode_encode. Qed. (** ** Lists *) Global Program Instance list_countable `{Countable A} : Countable (list A) := {| encode xs := positives_flatten (encode <$> xs); decode p := positives ← positives_unflatten p; mapM decode positives; |}. Next Obligation. intros A EqA CA xs. simpl. rewrite positives_unflatten_flatten. simpl. apply (mapM_fmap_Some _ _ _ decode_encode). Qed. (** ** Numbers *) Global Instance pos_countable : Countable positive := {| encode := id; decode := Some; decode_encode x := eq_refl |}. Global Program Instance N_countable : Countable N := {| encode x := match x with N0 => 1 | Npos p => Pos.succ p end; decode p := if decide (p = 1) then Some 0%N else Some (Npos (Pos.pred p)) |}. Next Obligation. intros [|p]; simpl; [done|]. by rewrite decide_False, Pos.pred_succ by (by destruct p). Qed. Global Program Instance Z_countable : Countable Z := {| encode x := match x with Z0 => 1 | Zpos p => p~0 | Zneg p => p~1 end; decode p := Some match p with 1 => Z0 | p~0 => Zpos p | p~1 => Zneg p end |}. Next Obligation. by intros [|p|p]. Qed. Global Program Instance nat_countable : Countable nat := {| encode x := encode (N.of_nat x); decode p := N.to_nat <$> decode p |}. Next Obligation. by intros x; lazy beta; rewrite decode_encode; csimpl; rewrite Nat2N.id. Qed. Global Program Instance Qc_countable : Countable Qc := inj_countable (λ p : Qc, let 'Qcmake (x # y) _ := p return _ in (x,y)) (λ q : Z * positive, let '(x,y) := q return _ in Some (Q2Qc (x # y))) _. Next Obligation. intros [[x y] Hcan]. f_equal. apply Qc_is_canon. simpl. by rewrite Hcan. Qed. Global Program Instance Qp_countable : Countable Qp := inj_countable Qp_to_Qc (λ p : Qc, guard (0 < p)%Qc as Hp; Some (mk_Qp p Hp)) _. Next Obligation. intros [p Hp]. unfold mguard, option_guard; simpl. case_match; [|done]. f_equal. by apply Qp.to_Qc_inj_iff. Qed. Global Program Instance fin_countable n : Countable (fin n) := inj_countable fin_to_nat (λ m : nat, guard (m < n)%nat as Hm; Some (nat_to_fin Hm)) _. Next Obligation. intros n i; simplify_option_eq. - by rewrite nat_to_fin_to_nat. - by pose proof (fin_to_nat_lt i). Qed. (** ** Generic trees *) Local Close Scope positive. Inductive gen_tree (T : Type) : Type := | GenLeaf : T → gen_tree T | GenNode : nat → list (gen_tree T) → gen_tree T. Global Arguments GenLeaf {_} _ : assert. Global Arguments GenNode {_} _ _ : assert. Global Instance gen_tree_dec `{EqDecision T} : EqDecision (gen_tree T). Proof. refine ( fix go t1 t2 := let _ : EqDecision _ := @go in match t1, t2 with | GenLeaf x1, GenLeaf x2 => cast_if (decide (x1 = x2)) | GenNode n1 ts1, GenNode n2 ts2 => cast_if_and (decide (n1 = n2)) (decide (ts1 = ts2)) | _, _ => right _ end); abstract congruence. Defined. Fixpoint gen_tree_to_list {T} (t : gen_tree T) : list (nat * nat + T) := match t with | GenLeaf x => [inr x] | GenNode n ts => (ts ≫= gen_tree_to_list) ++ [inl (length ts, n)] end. Fixpoint gen_tree_of_list {T} (k : list (gen_tree T)) (l : list (nat * nat + T)) : option (gen_tree T) := match l with | [] => head k | inr x :: l => gen_tree_of_list (GenLeaf x :: k) l | inl (len,n) :: l => gen_tree_of_list (GenNode n (reverse (take len k)) :: drop len k) l end. Lemma gen_tree_of_to_list {T} k l (t : gen_tree T) : gen_tree_of_list k (gen_tree_to_list t ++ l) = gen_tree_of_list (t :: k) l. Proof. revert t k l; fix FIX 1; intros [|n ts] k l; simpl; auto. trans (gen_tree_of_list (reverse ts ++ k) ([inl (length ts, n)] ++ l)). - rewrite <-(assoc_L _). revert k. generalize ([inl (length ts, n)] ++ l). induction ts as [|t ts'' IH]; intros k ts'''; csimpl; auto. rewrite reverse_cons, <-!(assoc_L _), FIX; simpl; auto. - simpl. by rewrite take_app_length', drop_app_length', reverse_involutive by (by rewrite reverse_length). Qed. Global Program Instance gen_tree_countable `{Countable T} : Countable (gen_tree T) := inj_countable gen_tree_to_list (gen_tree_of_list []) _. Next Obligation. intros T ?? t. by rewrite <-(right_id_L [] _ (gen_tree_to_list _)), gen_tree_of_to_list. Qed. (** ** Sigma *) Global Program Instance countable_sig `{Countable A} (P : A → Prop) `{!∀ x, Decision (P x), !∀ x, ProofIrrel (P x)} : Countable { x : A | P x } := inj_countable proj1_sig (λ x, guard (P x) as Hx; Some (x ↾ Hx)) _. Next Obligation. intros A ?? P ?? [x Hx]. by erewrite (option_guard_True_pi (P x)). Qed. stdpp-coq-stdpp-1.9.0/stdpp/decidable.v000066400000000000000000000273311451153341500200100ustar00rootroot00000000000000(** This file collects theorems, definitions, tactics, related to propositions with a decidable equality. Such propositions are collected by the [Decision] type class. *) From stdpp Require Export proof_irrel. From stdpp Require Import options. (* Pick up extra assumptions from section parameters. *) Set Default Proof Using "Type*". Lemma dec_stable `{Decision P} : ¬¬P → P. Proof. firstorder. Qed. Lemma Is_true_reflect (b : bool) : reflect b b. Proof. destruct b; [left; constructor | right; intros []]. Qed. Global Instance: Inj (=) (↔) Is_true. Proof. intros [] []; simpl; intuition. Qed. Lemma decide_True {A} `{Decision P} (x y : A) : P → (if decide P then x else y) = x. Proof. destruct (decide P); tauto. Qed. Lemma decide_False {A} `{Decision P} (x y : A) : ¬P → (if decide P then x else y) = y. Proof. destruct (decide P); tauto. Qed. Lemma decide_ext {A} P Q `{Decision P, Decision Q} (x y : A) : (P ↔ Q) → (if decide P then x else y) = (if decide Q then x else y). Proof. intros [??]. destruct (decide P), (decide Q); tauto. Qed. Lemma decide_True_pi `{Decision P, !ProofIrrel P} (HP : P) : decide P = left HP. Proof. destruct (decide P); [|contradiction]. f_equal. apply proof_irrel. Qed. Lemma decide_False_pi `{Decision P, !ProofIrrel (¬ P)} (HP : ¬ P) : decide P = right HP. Proof. destruct (decide P); [contradiction|]. f_equal. apply proof_irrel. Qed. (** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the components is double negated, it will try to remove the double negation. *) Tactic Notation "destruct_decide" constr(dec) "as" ident(H) := destruct dec as [H|H]; try match type of H with | ¬¬_ => apply dec_stable in H end. Tactic Notation "destruct_decide" constr(dec) := let H := fresh in destruct_decide dec as H. (** The tactic [case_decide] performs case analysis on an arbitrary occurrence of [decide] or [decide_rel] in the conclusion or hypotheses. *) Tactic Notation "case_decide" "as" ident(Hd) := match goal with | H : context [@decide ?P ?dec] |- _ => destruct_decide (@decide P dec) as Hd | H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ => destruct_decide (@decide_rel _ _ R x y dec) as Hd | |- context [@decide ?P ?dec] => destruct_decide (@decide P dec) as Hd | |- context [@decide_rel _ _ ?R ?x ?y ?dec] => destruct_decide (@decide_rel _ _ R x y dec) as Hd end. Tactic Notation "case_decide" := let H := fresh in case_decide as H. (** The tactic [solve_decision] uses Coq's [decide equality] tactic together with instance resolution to automatically generate decision procedures. *) Ltac solve_trivial_decision := match goal with | |- Decision (?P) => apply _ | |- sumbool ?P (¬?P) => change (Decision P); apply _ end. Ltac solve_decision := unfold EqDecision; intros; first [ solve_trivial_decision | unfold Decision; decide equality; solve_trivial_decision ]. (** The following combinators are useful to create Decision proofs in combination with the [refine] tactic. *) Notation swap_if S := (match S with left H => right H | right H => left H end). Notation cast_if S := (if S then left _ else right _). Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _). Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _). Notation cast_if_and4 S1 S2 S3 S4 := (if S1 then cast_if_and3 S2 S3 S4 else right _). Notation cast_if_and5 S1 S2 S3 S4 S5 := (if S1 then cast_if_and4 S2 S3 S4 S5 else right _). Notation cast_if_and6 S1 S2 S3 S4 S5 S6 := (if S1 then cast_if_and5 S2 S3 S4 S5 S6 else right _). Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2). Notation cast_if_or3 S1 S2 S3 := (if S1 then left _ else cast_if_or S2 S3). Notation cast_if_not_or S1 S2 := (if S1 then cast_if S2 else left _). Notation cast_if_not S := (if S then right _ else left _). (** * Instances of [Decision] *) (** Instances of [Decision] for operators of propositional logic. *) (** The instances for [True] and [False] have a very high cost. If they are applied too eagerly, HO-unification could wrongfully instantiate TC instances with [λ .., True] or [λ .., False]. See https://gitlab.mpi-sws.org/iris/stdpp/-/issues/165 *) Global Instance True_dec: Decision True | 1000 := left I. Global Instance False_dec: Decision False | 1000 := right (False_rect False). Global Instance Is_true_dec b : Decision (Is_true b). Proof. destruct b; simpl; apply _. Defined. Section prop_dec. Context `(P_dec : Decision P) `(Q_dec : Decision Q). Global Instance not_dec: Decision (¬P). Proof. refine (cast_if_not P_dec); intuition. Defined. Global Instance and_dec: Decision (P ∧ Q). Proof. refine (cast_if_and P_dec Q_dec); intuition. Defined. Global Instance or_dec: Decision (P ∨ Q). Proof. refine (cast_if_or P_dec Q_dec); intuition. Defined. Global Instance impl_dec: Decision (P → Q). Proof. refine (if P_dec then cast_if Q_dec else left _); intuition. Defined. End prop_dec. Global Instance iff_dec `(P_dec : Decision P) `(Q_dec : Decision Q) : Decision (P ↔ Q) := and_dec _ _. (** Instances of [Decision] for common data types. *) Global Instance bool_eq_dec : EqDecision bool. Proof. solve_decision. Defined. Global Instance unit_eq_dec : EqDecision unit. Proof. solve_decision. Defined. Global Instance Empty_set_eq_dec : EqDecision Empty_set. Proof. solve_decision. Defined. Global Instance prod_eq_dec `{EqDecision A, EqDecision B} : EqDecision (A * B). Proof. solve_decision. Defined. Global Instance sum_eq_dec `{EqDecision A, EqDecision B} : EqDecision (A + B). Proof. solve_decision. Defined. Global Instance uncurry_dec `(P_dec : ∀ (x : A) (y : B), Decision (P x y)) p : Decision (uncurry P p) := match p as p return Decision (uncurry P p) with | (x,y) => P_dec x y end. Global Instance sig_eq_dec `(P : A → Prop) `{∀ x, ProofIrrel (P x), EqDecision A} : EqDecision (sig P). Proof. refine (λ x y, cast_if (decide (`x = `y))); rewrite sig_eq_pi; trivial. Defined. (** Some laws for decidable propositions *) Lemma not_and_l {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q. Proof. destruct (decide P); tauto. Qed. Lemma not_and_r {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q. Proof. destruct (decide Q); tauto. Qed. Lemma not_and_l_alt {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ (¬Q ∧ P). Proof. destruct (decide P); tauto. Qed. Lemma not_and_r_alt {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ (¬P ∧ Q) ∨ ¬Q. Proof. destruct (decide Q); tauto. Qed. Program Definition inj_eq_dec `{EqDecision A} {B} (f : B → A) `{!Inj (=) (=) f} : EqDecision B := λ x y, cast_if (decide (f x = f y)). Solve Obligations with firstorder congruence. (** * Instances of [RelDecision] *) Definition flip_dec {A} (R : relation A) `{!RelDecision R} : RelDecision (flip R) := λ x y, decide_rel R y x. (** We do not declare this as an actual instance since Coq can unify [flip ?R] with any relation. Coq's standard library is carrying out the same approach for the [Reflexive], [Transitive], etc, instance of [flip]. *) Global Hint Extern 3 (RelDecision (flip _)) => apply flip_dec : typeclass_instances. (** We can convert decidable propositions to booleans. *) Definition bool_decide (P : Prop) {dec : Decision P} : bool := if dec then true else false. Lemma bool_decide_reflect P `{dec : Decision P} : reflect P (bool_decide P). Proof. unfold bool_decide. destruct dec; [left|right]; assumption. Qed. Lemma bool_decide_decide P `{!Decision P} : bool_decide P = if decide P then true else false. Proof. reflexivity. Qed. Lemma decide_bool_decide P {Hdec: Decision P} {X : Type} (x1 x2 : X): (if decide P then x1 else x2) = (if bool_decide P then x1 else x2). Proof. unfold bool_decide, decide. destruct Hdec; reflexivity. Qed. Tactic Notation "case_bool_decide" "as" ident(Hd) := match goal with | H : context [@bool_decide ?P ?dec] |- _ => destruct_decide (@bool_decide_reflect P dec) as Hd | |- context [@bool_decide ?P ?dec] => destruct_decide (@bool_decide_reflect P dec) as Hd end. Tactic Notation "case_bool_decide" := let H := fresh in case_bool_decide as H. Lemma bool_decide_spec (P : Prop) {dec : Decision P} : bool_decide P ↔ P. Proof. unfold bool_decide. destruct dec; simpl; tauto. Qed. Lemma bool_decide_unpack (P : Prop) {dec : Decision P} : bool_decide P → P. Proof. rewrite bool_decide_spec; trivial. Qed. Lemma bool_decide_pack (P : Prop) {dec : Decision P} : P → bool_decide P. Proof. rewrite bool_decide_spec; trivial. Qed. Global Hint Resolve bool_decide_pack : core. Lemma bool_decide_eq_true (P : Prop) `{Decision P} : bool_decide P = true ↔ P. Proof. case_bool_decide; intuition discriminate. Qed. Lemma bool_decide_eq_false (P : Prop) `{Decision P} : bool_decide P = false ↔ ¬P. Proof. case_bool_decide; intuition discriminate. Qed. Lemma bool_decide_ext (P Q : Prop) `{Decision P, Decision Q} : (P ↔ Q) → bool_decide P = bool_decide Q. Proof. apply decide_ext. Qed. Lemma bool_decide_eq_true_1 P `{!Decision P}: bool_decide P = true → P. Proof. apply bool_decide_eq_true. Qed. Lemma bool_decide_eq_true_2 P `{!Decision P}: P → bool_decide P = true. Proof. apply bool_decide_eq_true. Qed. Lemma bool_decide_eq_false_1 P `{!Decision P}: bool_decide P = false → ¬P. Proof. apply bool_decide_eq_false. Qed. Lemma bool_decide_eq_false_2 P `{!Decision P}: ¬P → bool_decide P = false. Proof. apply bool_decide_eq_false. Qed. Lemma bool_decide_True : bool_decide True = true. Proof. reflexivity. Qed. Lemma bool_decide_False : bool_decide False = false. Proof. reflexivity. Qed. Lemma bool_decide_not P `{Decision P} : bool_decide (¬ P) = negb (bool_decide P). Proof. repeat case_bool_decide; intuition. Qed. Lemma bool_decide_or P Q `{Decision P, Decision Q} : bool_decide (P ∨ Q) = bool_decide P || bool_decide Q. Proof. repeat case_bool_decide; intuition. Qed. Lemma bool_decide_and P Q `{Decision P, Decision Q} : bool_decide (P ∧ Q) = bool_decide P && bool_decide Q. Proof. repeat case_bool_decide; intuition. Qed. Lemma bool_decide_impl P Q `{Decision P, Decision Q} : bool_decide (P → Q) = implb (bool_decide P) (bool_decide Q). Proof. repeat case_bool_decide; intuition. Qed. Lemma bool_decide_iff P Q `{Decision P, Decision Q} : bool_decide (P ↔ Q) = eqb (bool_decide P) (bool_decide Q). Proof. repeat case_bool_decide; intuition. Qed. (** The tactic [compute_done] solves the following kinds of goals: - Goals [P] where [Decidable P] can be derived. - Goals that compute to [True] or [x = x]. The goal must be a ground term for this, i.e., not contain variables (that do not compute away). The goal is solved by using [vm_compute] and then using a trivial proof term ([I]/[eq_refl]). *) Tactic Notation "compute_done" := try apply (bool_decide_unpack _); vm_compute; first [ exact I | exact eq_refl ]. Tactic Notation "compute_by" tactic(tac) := tac; compute_done. (** Backwards compatibility notations. *) Notation bool_decide_true := bool_decide_eq_true_2. Notation bool_decide_false := bool_decide_eq_false_2. (** * Decidable Sigma types *) (** Leibniz equality on Sigma types requires the equipped proofs to be equal as Coq does not support proof irrelevance. For decidable we propositions we define the type [dsig P] whose Leibniz equality is proof irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. *) Definition dsig `(P : A → Prop) `{∀ x : A, Decision (P x)} := { x | bool_decide (P x) }. Definition proj2_dsig `{∀ x : A, Decision (P x)} (x : dsig P) : P (`x) := bool_decide_unpack _ (proj2_sig x). Definition dexist `{∀ x : A, Decision (P x)} (x : A) (p : P x) : dsig P := x↾bool_decide_pack _ p. Lemma dsig_eq `(P : A → Prop) `{∀ x, Decision (P x)} (x y : dsig P) : x = y ↔ `x = `y. Proof. apply (sig_eq_pi _). Qed. Lemma dexists_proj1 `(P : A → Prop) `{∀ x, Decision (P x)} (x : dsig P) p : dexist (`x) p = x. Proof. apply dsig_eq; reflexivity. Qed. stdpp-coq-stdpp-1.9.0/stdpp/fin.v000066400000000000000000000103371451153341500166660ustar00rootroot00000000000000(** This file collects general purpose definitions and theorems on the fin type (bounded naturals). It uses the definitions from the standard library, but renames or changes their notations, so that it becomes more consistent with the naming conventions in this development. *) From stdpp Require Export base tactics. From stdpp Require Import options. (** * The fin type *) (** The type [fin n] represents natural numbers [i] with [0 ≤ i < n]. We define a scope [fin], in which we declare notations for small literals of the [fin] type. Whereas the standard library starts counting at [1], we start counting at [0]. This way, the embedding [fin_to_nat] preserves [0], and allows us to define [fin_to_nat] as a coercion without introducing notational ambiguity. *) Notation fin := Fin.t. Notation FS := Fin.FS. Declare Scope fin_scope. Delimit Scope fin_scope with fin. Bind Scope fin_scope with fin. Global Arguments Fin.FS _ _%fin : assert. (** Allow any non-negative number literal to be parsed as a [fin]. For example [42%fin : fin 64], or [42%fin : fin _], or [42%fin : fin (43 + _)]. *) Number Notation fin Nat.of_num_uint Nat.to_num_uint (via nat mapping [[Fin.F1] => O, [Fin.FS] => S]) : fin_scope. Fixpoint fin_to_nat {n} (i : fin n) : nat := match i with 0%fin => 0 | FS i => S (fin_to_nat i) end. Coercion fin_to_nat : fin >-> nat. Notation nat_to_fin := Fin.of_nat_lt. Notation fin_rect2 := Fin.rect2. Global Instance fin_dec {n} : EqDecision (fin n). Proof. refine (fin_rect2 (λ n (i j : fin n), { i = j } + { i ≠ j }) (λ _, left _) (λ _ _, right _) (λ _ _, right _) (λ _ _ _ H, cast_if H)); abstract (f_equal; by auto using Fin.FS_inj). Defined. (** The inversion principle [fin_S_inv] is more convenient than its variant [Fin.caseS] in the standard library, as we keep the parameter [n] fixed. In the tactic [inv_fin i] to perform dependent case analysis on [i], we therefore do not have to generalize over the index [n] and all assumptions depending on it. Notice that contrary to [dependent destruction], which uses the [JMeq_eq] axiom, the tactic [inv_fin] produces axiom free proofs.*) Notation fin_0_inv := Fin.case0. Definition fin_S_inv {n} (P : fin (S n) → Type) (H0 : P 0%fin) (HS : ∀ i, P (FS i)) (i : fin (S n)) : P i. Proof. revert P H0 HS. refine match i with 0%fin => λ _ H0 _, H0 | FS i => λ _ _ HS, HS i end. Defined. Ltac inv_fin i := let T := type of i in match eval hnf in T with | fin ?n => match eval hnf in n with | 0 => generalize dependent i; match goal with |- ∀ i, @?P i => apply (fin_0_inv P) end | S ?n => generalize dependent i; match goal with |- ∀ i, @?P i => apply (fin_S_inv P) end end end. Global Instance FS_inj {n} : Inj (=) (=) (@FS n). Proof. intros i j. apply Fin.FS_inj. Qed. Global Instance fin_to_nat_inj {n} : Inj (=) (=) (@fin_to_nat n). Proof. intros i. induction i; intros j; inv_fin j; intros; f_equal/=; auto with lia. Qed. Lemma fin_to_nat_lt {n} (i : fin n) : fin_to_nat i < n. Proof. induction i; simpl; lia. Qed. Lemma fin_to_nat_to_fin n m (H : n < m) : fin_to_nat (nat_to_fin H) = n. Proof. revert m H. induction n; intros [|?]; simpl; auto; intros; exfalso; lia. Qed. Lemma nat_to_fin_to_nat {n} (i : fin n) H : @nat_to_fin (fin_to_nat i) n H = i. Proof. apply (inj fin_to_nat), fin_to_nat_to_fin. Qed. Fixpoint fin_add_inv {n1 n2} : ∀ (P : fin (n1 + n2) → Type) (H1 : ∀ i1 : fin n1, P (Fin.L n2 i1)) (H2 : ∀ i2, P (Fin.R n1 i2)) (i : fin (n1 + n2)), P i := match n1 with | 0 => λ P H1 H2 i, H2 i | S n => λ P H1 H2, fin_S_inv P (H1 0%fin) (fin_add_inv _ (λ i, H1 (FS i)) H2) end. Lemma fin_add_inv_l {n1 n2} (P : fin (n1 + n2) → Type) (H1: ∀ i1 : fin n1, P (Fin.L _ i1)) (H2: ∀ i2, P (Fin.R _ i2)) (i: fin n1) : fin_add_inv P H1 H2 (Fin.L n2 i) = H1 i. Proof. revert P H1 H2 i. induction n1 as [|n1 IH]; intros P H1 H2 i; inv_fin i; simpl; auto. intros i. apply (IH (λ i, P (FS i))). Qed. Lemma fin_add_inv_r {n1 n2} (P : fin (n1 + n2) → Type) (H1: ∀ i1 : fin n1, P (Fin.L _ i1)) (H2: ∀ i2, P (Fin.R _ i2)) (i: fin n2) : fin_add_inv P H1 H2 (Fin.R n1 i) = H2 i. Proof. revert P H1 H2 i; induction n1 as [|n1 IH]; intros P H1 H2 i; simpl; auto. apply (IH (λ i, P (FS i))). Qed. stdpp-coq-stdpp-1.9.0/stdpp/fin_map_dom.v000066400000000000000000000445641451153341500203730ustar00rootroot00000000000000(** This file provides an axiomatization of the domain function of finite maps. We provide such an axiomatization, instead of implementing the domain function in a generic way, to allow more efficient implementations. *) From stdpp Require Export sets fin_maps. From stdpp Require Import options. (* Pick up extra assumptions from section parameters. *) Set Default Proof Using "Type*". Class FinMapDom K M D `{∀ A, Dom (M A) D, FMap M, ∀ A, Lookup K A (M A), ∀ A, Empty (M A), ∀ A, PartialAlter K A (M A), OMap M, Merge M, ∀ A, MapFold K A (M A), EqDecision K, ElemOf K D, Empty D, Singleton K D, Union D, Intersection D, Difference D} := { finmap_dom_map :> FinMap K M; finmap_dom_set :> Set_ K D; elem_of_dom {A} (m : M A) i : i ∈ dom m ↔ is_Some (m !! i) }. Section fin_map_dom. Context `{FinMapDom K M D}. Lemma lookup_lookup_total_dom `{!Inhabited A} (m : M A) i : i ∈ dom m → m !! i = Some (m !!! i). Proof. rewrite elem_of_dom. apply lookup_lookup_total. Qed. Lemma dom_imap_subseteq {A B} (f: K → A → option B) (m: M A) : dom (map_imap f m) ⊆ dom m. Proof. intros k. rewrite 2!elem_of_dom, map_lookup_imap. destruct 1 as [?[?[Eq _]]%bind_Some]. by eexists. Qed. Lemma dom_imap {A B} (f : K → A → option B) (m : M A) (X : D) : (∀ i, i ∈ X ↔ ∃ x, m !! i = Some x ∧ is_Some (f i x)) → dom (map_imap f m) ≡ X. Proof. intros HX k. rewrite elem_of_dom, HX, map_lookup_imap. unfold is_Some. setoid_rewrite bind_Some. naive_solver. Qed. Lemma elem_of_dom_2 {A} (m : M A) i x : m !! i = Some x → i ∈ dom m. Proof. rewrite elem_of_dom; eauto. Qed. Lemma not_elem_of_dom {A} (m : M A) i : i ∉ dom m ↔ m !! i = None. Proof. by rewrite elem_of_dom, eq_None_not_Some. Qed. Lemma not_elem_of_dom_1 {A} (m : M A) i : i ∉ dom m → m !! i = None. Proof. apply not_elem_of_dom. Qed. Lemma not_elem_of_dom_2 {A} (m : M A) i : m !! i = None → i ∉ dom m. Proof. apply not_elem_of_dom. Qed. Lemma subseteq_dom {A} (m1 m2 : M A) : m1 ⊆ m2 → dom m1 ⊆ dom m2. Proof. rewrite map_subseteq_spec. intros ??. rewrite !elem_of_dom. inversion 1; eauto. Qed. Lemma subset_dom {A} (m1 m2 : M A) : m1 ⊂ m2 → dom m1 ⊂ dom m2. Proof. intros [Hss1 Hss2]; split; [by apply subseteq_dom |]. contradict Hss2. rewrite map_subseteq_spec. intros i x Hi. specialize (Hss2 i). rewrite !elem_of_dom in Hss2. destruct Hss2; eauto. by simplify_map_eq. Qed. Lemma dom_filter {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m : M A) (X : D) : (∀ i, i ∈ X ↔ ∃ x, m !! i = Some x ∧ P (i, x)) → dom (filter P m) ≡ X. Proof. intros HX i. rewrite elem_of_dom, HX. unfold is_Some. by setoid_rewrite map_lookup_filter_Some. Qed. Lemma dom_filter_subseteq {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m : M A): dom (filter P m) ⊆ dom m. Proof. apply subseteq_dom, map_filter_subseteq. Qed. Lemma filter_dom {A} `{!Elements K D, !FinSet K D} (P : K → Prop) `{!∀ x, Decision (P x)} (m : M A) : filter P (dom m) ≡ dom (filter (λ kv, P kv.1) m). Proof. intros i. rewrite elem_of_filter, !elem_of_dom. unfold is_Some. setoid_rewrite map_lookup_filter_Some. naive_solver. Qed. Lemma dom_empty {A} : dom (@empty (M A) _) ≡ ∅. Proof. intros x. rewrite elem_of_dom, lookup_empty, <-not_eq_None_Some. set_solver. Qed. Lemma dom_empty_iff {A} (m : M A) : dom m ≡ ∅ ↔ m = ∅. Proof. split; [|intros ->; by rewrite dom_empty]. intros E. apply map_empty. intros. apply not_elem_of_dom. rewrite E. set_solver. Qed. Lemma dom_empty_inv {A} (m : M A) : dom m ≡ ∅ → m = ∅. Proof. apply dom_empty_iff. Qed. Lemma dom_alter {A} f (m : M A) i : dom (alter f i m) ≡ dom m. Proof. apply set_equiv; intros j; rewrite !elem_of_dom; unfold is_Some. destruct (decide (i = j)); simplify_map_eq/=; eauto. destruct (m !! j); naive_solver. Qed. Lemma dom_insert {A} (m : M A) i x : dom (<[i:=x]>m) ≡ {[ i ]} ∪ dom m. Proof. apply set_equiv. intros j. rewrite elem_of_union, !elem_of_dom. unfold is_Some. setoid_rewrite lookup_insert_Some. destruct (decide (i = j)); set_solver. Qed. Lemma dom_insert_lookup {A} (m : M A) i x : is_Some (m !! i) → dom (<[i:=x]>m) ≡ dom m. Proof. intros Hindom. assert (i ∈ dom m) by by apply elem_of_dom. rewrite dom_insert. set_solver. Qed. Lemma dom_insert_subseteq {A} (m : M A) i x : dom m ⊆ dom (<[i:=x]>m). Proof. rewrite (dom_insert _). set_solver. Qed. Lemma dom_insert_subseteq_compat_l {A} (m : M A) i x X : X ⊆ dom m → X ⊆ dom (<[i:=x]>m). Proof. intros. trans (dom m); eauto using dom_insert_subseteq. Qed. Lemma dom_singleton {A} (i : K) (x : A) : dom ({[i := x]} : M A) ≡ {[ i ]}. Proof. rewrite <-insert_empty, dom_insert, dom_empty; set_solver. Qed. Lemma dom_delete {A} (m : M A) i : dom (delete i m) ≡ dom m ∖ {[ i ]}. Proof. apply set_equiv. intros j. rewrite elem_of_difference, !elem_of_dom. unfold is_Some. setoid_rewrite lookup_delete_Some. set_solver. Qed. Lemma delete_partial_alter_dom {A} (m : M A) i f : i ∉ dom m → delete i (partial_alter f i m) = m. Proof. rewrite not_elem_of_dom. apply delete_partial_alter. Qed. Lemma delete_insert_dom {A} (m : M A) i x : i ∉ dom m → delete i (<[i:=x]>m) = m. Proof. rewrite not_elem_of_dom. apply delete_insert. Qed. Lemma map_disjoint_dom {A} (m1 m2 : M A) : m1 ##ₘ m2 ↔ dom m1 ## dom m2. Proof. rewrite map_disjoint_spec, elem_of_disjoint. setoid_rewrite elem_of_dom. unfold is_Some. naive_solver. Qed. Lemma map_disjoint_dom_1 {A} (m1 m2 : M A) : m1 ##ₘ m2 → dom m1 ## dom m2. Proof. apply map_disjoint_dom. Qed. Lemma map_disjoint_dom_2 {A} (m1 m2 : M A) : dom m1 ## dom m2 → m1 ##ₘ m2. Proof. apply map_disjoint_dom. Qed. Lemma dom_union {A} (m1 m2 : M A) : dom (m1 ∪ m2) ≡ dom m1 ∪ dom m2. Proof. apply set_equiv. intros i. rewrite elem_of_union, !elem_of_dom. unfold is_Some. setoid_rewrite lookup_union_Some_raw. destruct (m1 !! i); naive_solver. Qed. Lemma dom_intersection {A} (m1 m2: M A) : dom (m1 ∩ m2) ≡ dom m1 ∩ dom m2. Proof. apply set_equiv. intros i. rewrite elem_of_intersection, !elem_of_dom. unfold is_Some. setoid_rewrite lookup_intersection_Some. naive_solver. Qed. Lemma dom_difference {A} (m1 m2 : M A) : dom (m1 ∖ m2) ≡ dom m1 ∖ dom m2. Proof. apply set_equiv. intros i. rewrite elem_of_difference, !elem_of_dom. unfold is_Some. setoid_rewrite lookup_difference_Some. destruct (m2 !! i); naive_solver. Qed. Lemma dom_fmap {A B} (f : A → B) (m : M A) : dom (f <$> m) ≡ dom m. Proof. apply set_equiv. intros i. rewrite !elem_of_dom, lookup_fmap, <-!not_eq_None_Some. destruct (m !! i); naive_solver. Qed. Lemma dom_finite {A} (m : M A) : set_finite (dom m). Proof. induction m using map_ind; rewrite ?dom_empty, ?dom_insert. - by apply empty_finite. - apply union_finite; [apply singleton_finite|done]. Qed. Global Instance dom_proper `{!Equiv A} : Proper ((≡@{M A}) ==> (≡)) dom. Proof. intros m1 m2 EQm. apply set_equiv. intros i. rewrite !elem_of_dom, EQm. done. Qed. Lemma dom_list_to_map {A} (l : list (K * A)) : dom (list_to_map l : M A) ≡ list_to_set l.*1. Proof. induction l as [|?? IH]. - by rewrite dom_empty. - simpl. by rewrite dom_insert, IH. Qed. (** Alternative definition of [dom] in terms of [map_to_list]. *) Lemma dom_alt {A} (m : M A) : dom m ≡ list_to_set (map_to_list m).*1. Proof. rewrite <-(list_to_map_to_list m) at 1. rewrite dom_list_to_map. done. Qed. Lemma size_dom `{!Elements K D, !FinSet K D} {A} (m : M A) : size (dom m) = size m. Proof. induction m as [|i x m ? IH] using map_ind. { by rewrite dom_empty, map_size_empty, size_empty. } assert ({[i]} ## dom m). { intros j. rewrite elem_of_dom. unfold is_Some. set_solver. } by rewrite dom_insert, size_union, size_singleton, map_size_insert_None, IH. Qed. Lemma dom_subseteq_size {A} (m1 m2 : M A) : dom m2 ⊆ dom m1 → size m2 ≤ size m1. Proof. revert m1. induction m2 as [|i x m2 ? IH] using map_ind; intros m1 Hdom. { rewrite map_size_empty. lia. } rewrite dom_insert in Hdom. assert (i ∉ dom m2) by (by apply not_elem_of_dom). assert (i ∈ dom m1) as [x' Hx']%elem_of_dom by set_solver. rewrite <-(insert_delete m1 i x') by done. rewrite !map_size_insert_None, <-Nat.succ_le_mono by (by rewrite ?lookup_delete). apply IH. rewrite dom_delete. set_solver. Qed. Lemma dom_subset_size {A} (m1 m2 : M A) : dom m2 ⊂ dom m1 → size m2 < size m1. Proof. revert m1. induction m2 as [|i x m2 ? IH] using map_ind; intros m1 Hdom. { destruct m1 as [|i x m1 ? _] using map_ind. - rewrite !dom_empty in Hdom. set_solver. - rewrite map_size_empty, map_size_insert_None by done. lia. } rewrite dom_insert in Hdom. assert (i ∉ dom m2) by (by apply not_elem_of_dom). assert (i ∈ dom m1) as [x' Hx']%elem_of_dom by set_solver. rewrite <-(insert_delete m1 i x') by done. rewrite !map_size_insert_None, <-Nat.succ_lt_mono by (by rewrite ?lookup_delete). apply IH. rewrite dom_delete. split; [set_solver|]. intros ?. destruct Hdom as [? []]. intros j. destruct (decide (i = j)); set_solver. Qed. Lemma subseteq_dom_eq {A} (m1 m2 : M A) : m1 ⊆ m2 → dom m2 ⊆ dom m1 → m1 = m2. Proof. intros. apply map_subseteq_size_eq; auto using dom_subseteq_size. Qed. Lemma dom_singleton_inv {A} (m : M A) i : dom m ≡ {[i]} → ∃ x, m = {[i := x]}. Proof. intros Hdom. assert (is_Some (m !! i)) as [x ?]. { apply (elem_of_dom (D:=D)); set_solver. } exists x. apply map_eq; intros j. destruct (decide (i = j)); simplify_map_eq; [done|]. apply not_elem_of_dom. set_solver. Qed. Lemma dom_map_zip_with {A B C} (f : A → B → C) (ma : M A) (mb : M B) : dom (map_zip_with f ma mb) ≡ dom ma ∩ dom mb. Proof. rewrite set_equiv. intros x. rewrite elem_of_intersection, !elem_of_dom, map_lookup_zip_with. destruct (ma !! x), (mb !! x); rewrite !is_Some_alt; naive_solver. Qed. Lemma dom_union_inv `{!RelDecision (∈@{D})} {A} (m : M A) (X1 X2 : D) : X1 ## X2 → dom m ≡ X1 ∪ X2 → ∃ m1 m2, m = m1 ∪ m2 ∧ m1 ##ₘ m2 ∧ dom m1 ≡ X1 ∧ dom m2 ≡ X2. Proof. intros. exists (filter (λ '(k,x), k ∈ X1) m), (filter (λ '(k,x), k ∉ X1) m). assert (filter (λ '(k, _), k ∈ X1) m ##ₘ filter (λ '(k, _), k ∉ X1) m). { apply map_disjoint_filter_complement. } split_and!; [|done| |]. - apply map_eq; intros i. apply option_eq; intros x. rewrite lookup_union_Some, !map_lookup_filter_Some by done. destruct (decide (i ∈ X1)); naive_solver. - apply dom_filter; intros i; split; [|naive_solver]. intros. assert (is_Some (m !! i)) as [x ?] by (apply elem_of_dom; set_solver). naive_solver. - apply dom_filter; intros i; split. + intros. assert (is_Some (m !! i)) as [x ?] by (apply elem_of_dom; set_solver). naive_solver. + intros (x&?&?). apply dec_stable; intros ?. assert (m !! i = None) by (apply not_elem_of_dom; set_solver). naive_solver. Qed. Lemma dom_kmap `{!Elements K D, !FinSet K D, FinMapDom K2 M2 D2} {A} (f : K → K2) `{!Inj (=) (=) f} (m : M A) : dom (kmap (M2:=M2) f m) ≡@{D2} set_map f (dom m). Proof. apply set_equiv. intros i. rewrite !elem_of_dom, (lookup_kmap_is_Some _), elem_of_map. by setoid_rewrite elem_of_dom. Qed. Lemma dom_omap_subseteq {A B} (f : A → option B) (m : M A) : dom (omap f m) ⊆ dom m. Proof. intros a. rewrite !elem_of_dom. intros [c Hm]. apply lookup_omap_Some in Hm. naive_solver. Qed. Lemma map_compose_dom_subseteq {C} `{FinMap K' M'} (m: M' C) (n : M K') : dom (m ∘ₘ n : M C) ⊆@{D} dom n. Proof. apply dom_omap_subseteq. Qed. Lemma map_compose_min_r_dom {C} `{FinMap K' M', !RelDecision (∈@{D})} (m : M C) (n : M' K) : m ∘ₘ n = m ∘ₘ filter (λ '(_,b), b ∈ dom m) n. Proof. rewrite map_compose_min_r. f_equal. apply map_filter_ext. intros. by rewrite elem_of_dom. Qed. Lemma map_compose_empty_iff_dom_img {C} `{FinMap K' M', !RelDecision (∈@{D})} (m : M C) (n : M' K) : m ∘ₘ n = ∅ ↔ dom m ## map_img n. Proof. rewrite map_compose_empty_iff, elem_of_disjoint. setoid_rewrite elem_of_dom. setoid_rewrite eq_None_not_Some. setoid_rewrite elem_of_map_img. naive_solver. Qed. (** If [D] has Leibniz equality, we can show an even stronger result. This is a common case e.g. when having a [gmap K A] where the key [K] has Leibniz equality (and thus also [gset K], the usual domain) but the value type [A] does not. *) Global Instance dom_proper_L `{!Equiv A, !LeibnizEquiv D} : Proper ((≡@{M A}) ==> (=)) (dom) | 0. Proof. intros ???. unfold_leibniz. by apply dom_proper. Qed. Section leibniz. Context `{!LeibnizEquiv D}. Lemma dom_filter_L {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m : M A) X : (∀ i, i ∈ X ↔ ∃ x, m !! i = Some x ∧ P (i, x)) → dom (filter P m) = X. Proof. unfold_leibniz. apply dom_filter. Qed. Lemma filter_dom_L {A} `{!Elements K D, !FinSet K D} (P : K → Prop) `{!∀ x, Decision (P x)} (m : M A) : filter P (dom m) = dom (filter (λ kv, P kv.1) m). Proof. unfold_leibniz. apply filter_dom. Qed. Lemma dom_empty_L {A} : dom (@empty (M A) _) = ∅. Proof. unfold_leibniz; apply dom_empty. Qed. Lemma dom_empty_iff_L {A} (m : M A) : dom m = ∅ ↔ m = ∅. Proof. unfold_leibniz. apply dom_empty_iff. Qed. Lemma dom_empty_inv_L {A} (m : M A) : dom m = ∅ → m = ∅. Proof. by intros; apply dom_empty_inv; unfold_leibniz. Qed. Lemma dom_alter_L {A} f (m : M A) i : dom (alter f i m) = dom m. Proof. unfold_leibniz; apply dom_alter. Qed. Lemma dom_insert_L {A} (m : M A) i x : dom (<[i:=x]>m) = {[ i ]} ∪ dom m. Proof. unfold_leibniz; apply dom_insert. Qed. Lemma dom_insert_lookup_L {A} (m : M A) i x : is_Some (m !! i) → dom (<[i:=x]>m) = dom m. Proof. unfold_leibniz; apply dom_insert_lookup. Qed. Lemma dom_singleton_L {A} (i : K) (x : A) : dom ({[i := x]} : M A) = {[ i ]}. Proof. unfold_leibniz; apply dom_singleton. Qed. Lemma dom_delete_L {A} (m : M A) i : dom (delete i m) = dom m ∖ {[ i ]}. Proof. unfold_leibniz; apply dom_delete. Qed. Lemma dom_union_L {A} (m1 m2 : M A) : dom (m1 ∪ m2) = dom m1 ∪ dom m2. Proof. unfold_leibniz; apply dom_union. Qed. Lemma dom_intersection_L {A} (m1 m2 : M A) : dom (m1 ∩ m2) = dom m1 ∩ dom m2. Proof. unfold_leibniz; apply dom_intersection. Qed. Lemma dom_difference_L {A} (m1 m2 : M A) : dom (m1 ∖ m2) = dom m1 ∖ dom m2. Proof. unfold_leibniz; apply dom_difference. Qed. Lemma dom_fmap_L {A B} (f : A → B) (m : M A) : dom (f <$> m) = dom m. Proof. unfold_leibniz; apply dom_fmap. Qed. Lemma dom_imap_L {A B} (f: K → A → option B) (m: M A) X : (∀ i, i ∈ X ↔ ∃ x, m !! i = Some x ∧ is_Some (f i x)) → dom (map_imap f m) = X. Proof. unfold_leibniz; apply dom_imap. Qed. Lemma dom_list_to_map_L {A} (l : list (K * A)) : dom (list_to_map l : M A) = list_to_set l.*1. Proof. unfold_leibniz. apply dom_list_to_map. Qed. Lemma dom_singleton_inv_L {A} (m : M A) i : dom m = {[i]} → ∃ x, m = {[i := x]}. Proof. unfold_leibniz. apply dom_singleton_inv. Qed. Lemma dom_map_zip_with_L {A B C} (f : A → B → C) (ma : M A) (mb : M B) : dom (map_zip_with f ma mb) = dom ma ∩ dom mb. Proof. unfold_leibniz. apply dom_map_zip_with. Qed. Lemma dom_union_inv_L `{!RelDecision (∈@{D})} {A} (m : M A) (X1 X2 : D) : X1 ## X2 → dom m = X1 ∪ X2 → ∃ m1 m2, m = m1 ∪ m2 ∧ m1 ##ₘ m2 ∧ dom m1 = X1 ∧ dom m2 = X2. Proof. unfold_leibniz. apply dom_union_inv. Qed. End leibniz. Lemma dom_kmap_L `{!Elements K D, !FinSet K D, FinMapDom K2 M2 D2} `{!LeibnizEquiv D2} {A} (f : K → K2) `{!Inj (=) (=) f} (m : M A) : dom (kmap (M2:=M2) f m) = set_map f (dom m). Proof. unfold_leibniz. by apply dom_kmap. Qed. (** * Set solver instances *) Global Instance set_unfold_dom_empty {A} i : SetUnfoldElemOf i (dom (∅:M A)) False. Proof. constructor. by rewrite dom_empty, elem_of_empty. Qed. Global Instance set_unfold_dom_alter {A} f i j (m : M A) Q : SetUnfoldElemOf i (dom m) Q → SetUnfoldElemOf i (dom (alter f j m)) Q. Proof. constructor. by rewrite dom_alter, (set_unfold_elem_of _ (dom _) _). Qed. Global Instance set_unfold_dom_insert {A} i j x (m : M A) Q : SetUnfoldElemOf i (dom m) Q → SetUnfoldElemOf i (dom (<[j:=x]> m)) (i = j ∨ Q). Proof. constructor. by rewrite dom_insert, elem_of_union, (set_unfold_elem_of _ (dom _) _), elem_of_singleton. Qed. Global Instance set_unfold_dom_delete {A} i j (m : M A) Q : SetUnfoldElemOf i (dom m) Q → SetUnfoldElemOf i (dom (delete j m)) (Q ∧ i ≠ j). Proof. constructor. by rewrite dom_delete, elem_of_difference, (set_unfold_elem_of _ (dom _) _), elem_of_singleton. Qed. Global Instance set_unfold_dom_singleton {A} i j x : SetUnfoldElemOf i (dom ({[ j := x ]} : M A)) (i = j). Proof. constructor. by rewrite dom_singleton, elem_of_singleton. Qed. Global Instance set_unfold_dom_union {A} i (m1 m2 : M A) Q1 Q2 : SetUnfoldElemOf i (dom m1) Q1 → SetUnfoldElemOf i (dom m2) Q2 → SetUnfoldElemOf i (dom (m1 ∪ m2)) (Q1 ∨ Q2). Proof. constructor. by rewrite dom_union, elem_of_union, !(set_unfold_elem_of _ (dom _) _). Qed. Global Instance set_unfold_dom_intersection {A} i (m1 m2 : M A) Q1 Q2 : SetUnfoldElemOf i (dom m1) Q1 → SetUnfoldElemOf i (dom m2) Q2 → SetUnfoldElemOf i (dom (m1 ∩ m2)) (Q1 ∧ Q2). Proof. constructor. by rewrite dom_intersection, elem_of_intersection, !(set_unfold_elem_of _ (dom _) _). Qed. Global Instance set_unfold_dom_difference {A} i (m1 m2 : M A) Q1 Q2 : SetUnfoldElemOf i (dom m1) Q1 → SetUnfoldElemOf i (dom m2) Q2 → SetUnfoldElemOf i (dom (m1 ∖ m2)) (Q1 ∧ ¬Q2). Proof. constructor. by rewrite dom_difference, elem_of_difference, !(set_unfold_elem_of _ (dom _) _). Qed. Global Instance set_unfold_dom_fmap {A B} (f : A → B) i (m : M A) Q : SetUnfoldElemOf i (dom m) Q → SetUnfoldElemOf i (dom (f <$> m)) Q. Proof. constructor. by rewrite dom_fmap, (set_unfold_elem_of _ (dom _) _). Qed. End fin_map_dom. Lemma dom_seq `{FinMapDom nat M D} {A} start (xs : list A) : dom (map_seq start (M:=M A) xs) ≡ set_seq start (length xs). Proof. revert start. induction xs as [|x xs IH]; intros start; simpl. - by rewrite dom_empty. - by rewrite dom_insert, IH. Qed. Lemma dom_seq_L `{FinMapDom nat M D, !LeibnizEquiv D} {A} start (xs : list A) : dom (map_seq (M:=M A) start xs) = set_seq start (length xs). Proof. unfold_leibniz. apply dom_seq. Qed. Global Instance set_unfold_dom_seq `{FinMapDom nat M D} {A} start (xs : list A) i : SetUnfoldElemOf i (dom (map_seq start (M:=M A) xs)) (start ≤ i < start + length xs). Proof. constructor. by rewrite dom_seq, elem_of_set_seq. Qed. stdpp-coq-stdpp-1.9.0/stdpp/fin_maps.v000066400000000000000000005771461451153341500177260ustar00rootroot00000000000000(** Finite maps associate data to keys. This file defines an interface for finite maps and collects some theory on it. Most importantly, it proves useful induction principles for finite maps and implements the tactic [simplify_map_eq] to simplify goals involving finite maps. *) From Coq Require Import Permutation. From stdpp Require Export relations orders vector fin_sets. From stdpp Require Import options. (* FIXME: This file needs a 'Proof Using' hint, but they need to be set locally (or things moved out of sections) as no default works well enough. *) Unset Default Proof Using. (** * Axiomatization of finite maps *) (** We require Leibniz equality of finite maps to be extensional, i.e., to enjoy [(∀ i, m1 !! i = m2 !! i) → m1 = m2]. This is a very useful property as it avoids the need for setoid rewriting in proof. However, it comes at the cost of restricting what map implementations we support. Since Coq does not have quotient types, it rules out balanced search trees (AVL, red-black, etc.). We do provide a reasonably efficient implementation of binary tries (see [gmap] and [Pmap]). *) (** Finiteness is axiomatized through a fold operation [map_fold f b m], which folds a function [f] over each element of the map [m]. The order in which the elements are passed to [f] is unspecified. *) Class MapFold K A M := map_fold B : (K → A → B → B) → B → M → B. Global Arguments map_fold {_ _ _ _ _} _ _ _. Global Hint Mode MapFold - - ! : typeclass_instances. Global Hint Mode MapFold ! - - : typeclass_instances. (** Make sure that [map_fold] (and definitions based on it) are not unfolded too eagerly by unification. See [only_evens_Some] in [tests/pmap_gmap] for an example. We use level 1 because it is the least level for which the test works. *) Global Strategy 1 [map_fold]. (** Finite map implementations are required to implement the [merge] function which enables us to give a generic implementation of [union_with], [intersection_with], and [difference_with]. The function [diag_None f] is used in the specification and lemmas of [merge f]. It lifts a function [f : option A → option B → option C] by returning [None] if both arguments are [None], to make sure that in [merge f m1 m2], the function [f] can only operate on elements that are in the domain of either [m1] or [m2]. *) Definition diag_None {A B C} (f : option A → option B → option C) (mx : option A) (my : option B) : option C := match mx, my with None, None => None | _, _ => f mx my end. (** We need the [insert] operation as part of the [map_fold_ind] rule in the [FinMap] interface. Hence we define it before the other derived operations. *) Global Instance map_insert `{PartialAlter K A M} : Insert K A M := λ i x, partial_alter (λ _, Some x) i. Class FinMap K M `{FMap M, ∀ A, Lookup K A (M A), ∀ A, Empty (M A), ∀ A, PartialAlter K A (M A), OMap M, Merge M, ∀ A, MapFold K A (M A), EqDecision K} := { map_eq {A} (m1 m2 : M A) : (∀ i, m1 !! i = m2 !! i) → m1 = m2; lookup_empty {A} i : (∅ : M A) !! i = None; lookup_partial_alter {A} f (m : M A) i : partial_alter f i m !! i = f (m !! i); lookup_partial_alter_ne {A} f (m : M A) i j : i ≠ j → partial_alter f i m !! j = m !! j; lookup_fmap {A B} (f : A → B) (m : M A) i : (f <$> m) !! i = f <$> m !! i; lookup_omap {A B} (f : A → option B) (m : M A) i : omap f m !! i = m !! i ≫= f; lookup_merge {A B C} (f : option A → option B → option C) (m1 : M A) (m2 : M B) i : merge f m1 m2 !! i = diag_None f (m1 !! i) (m2 !! i); map_fold_ind {A B} (P : B → M A → Prop) (f : K → A → B → B) (b : B) : P b ∅ → (∀ i x m r, m !! i = None → P r m → P (f i x r) (<[i:=x]> m)) → ∀ m, P (map_fold f b m) m }. (** * Derived operations *) (** All of the following functions are defined in a generic way for arbitrary finite map implementations. These generic implementations do not cause a significant performance loss, which justifies including them in the finite map interface as primitive operations. *) Global Instance map_alter `{PartialAlter K A M} : Alter K A M := λ f, partial_alter (fmap f). Global Instance map_delete `{PartialAlter K A M} : Delete K M := partial_alter (λ _, None). Global Instance map_singleton `{PartialAlter K A M, Empty M} : SingletonM K A M := λ i x, <[i:=x]> ∅. Definition list_to_map `{Insert K A M, Empty M} : list (K * A) → M := fold_right (λ p, <[p.1:=p.2]>) ∅. Global Instance map_size `{MapFold K A M} : Size M := map_fold (λ _ _, S) 0. Definition map_to_list `{MapFold K A M} : M → list (K * A) := map_fold (λ i x, ((i,x) ::.)) []. Definition map_to_set `{MapFold K A M, Singleton B C, Empty C, Union C} (f : K → A → B) (m : M) : C := list_to_set (uncurry f <$> map_to_list m). Definition set_to_map `{Elements B C, Insert K A M, Empty M} (f : B → K * A) (X : C) : M := list_to_map (f <$> elements X). Global Instance map_union_with `{Merge M} {A} : UnionWith A (M A) := λ f, merge (union_with f). Global Instance map_intersection_with `{Merge M} {A} : IntersectionWith A (M A) := λ f, merge (intersection_with f). Global Instance map_difference_with `{Merge M} {A} : DifferenceWith A (M A) := λ f, merge (difference_with f). (** Higher precedence to make sure it's not used for other types with a [Lookup] instance, such as lists. *) Global Instance map_equiv `{∀ A, Lookup K A (M A), Equiv A} : Equiv (M A) | 20 := λ m1 m2, ∀ i, m1 !! i ≡ m2 !! i. Definition map_Forall `{Lookup K A M} (P : K → A → Prop) : M → Prop := λ m, ∀ i x, m !! i = Some x → P i x. Definition map_Exists `{Lookup K A M} (P : K → A → Prop) : M → Prop := λ m, ∃ i x, m !! i = Some x ∧ P i x. Definition map_relation `{∀ A, Lookup K A (M A)} {A B} (R : A → B → Prop) (P : A → Prop) (Q : B → Prop) (m1 : M A) (m2 : M B) : Prop := ∀ i, option_relation R P Q (m1 !! i) (m2 !! i). Definition map_included `{∀ A, Lookup K A (M A)} {A} (R : relation A) : relation (M A) := map_relation R (λ _, False) (λ _, True). Definition map_agree `{∀ A, Lookup K A (M A)} {A} : relation (M A) := map_relation (=) (λ _, True) (λ _, True). Definition map_disjoint `{∀ A, Lookup K A (M A)} {A} : relation (M A) := map_relation (λ _ _, False) (λ _, True) (λ _, True). Infix "##ₘ" := map_disjoint (at level 70) : stdpp_scope. Global Hint Extern 0 (_ ##ₘ _) => symmetry; eassumption : core. Notation "( m ##ₘ.)" := (map_disjoint m) (only parsing) : stdpp_scope. Notation "(.##ₘ m )" := (λ m2, m2 ##ₘ m) (only parsing) : stdpp_scope. Global Instance map_subseteq `{∀ A, Lookup K A (M A)} {A} : SubsetEq (M A) := map_included (=). (** The union of two finite maps only has a meaningful definition for maps that are disjoint. However, as working with partial functions is inconvenient in Coq, we define the union as a total function. In case both finite maps have a value at the same index, we take the value of the first map. *) Global Instance map_union `{Merge M} {A} : Union (M A) := union_with (λ x _, Some x). Global Instance map_intersection `{Merge M} {A} : Intersection (M A) := intersection_with (λ x _, Some x). (** The difference operation removes all values from the first map whose index contains a value in the second map as well. *) Global Instance map_difference `{Merge M} {A} : Difference (M A) := difference_with (λ _ _, None). (** A stronger variant of map that allows the mapped function to use the index of the elements. Implemented by conversion to lists, so not very efficient. *) Definition map_imap `{∀ A, Insert K A (M A), ∀ A, Empty (M A), ∀ A, MapFold K A (M A)} {A B} (f : K → A → option B) (m : M A) : M B := list_to_map (omap (λ ix, (fst ix ,.) <$> uncurry f ix) (map_to_list m)). (** Given a function [f : K1 → K2], the function [kmap f] turns a maps with keys of type [K1] into a map with keys of type [K2]. The function [kmap f] is only well-behaved if [f] is injective, as otherwise it could map multiple entries into the same entry. All lemmas about [kmap f] thus have the premise [Inj (=) (=) f]. *) Definition kmap `{∀ A, Insert K2 A (M2 A), ∀ A, Empty (M2 A), ∀ A, MapFold K1 A (M1 A)} {A} (f : K1 → K2) (m : M1 A) : M2 A := list_to_map (fmap (prod_map f id) (map_to_list m)). (* The zip operation on maps combines two maps key-wise. The keys of resulting map correspond to the keys that are in both maps. *) Definition map_zip_with `{Merge M} {A B C} (f : A → B → C) : M A → M B → M C := merge (λ mx my, match mx, my with Some x, Some y => Some (f x y) | _, _ => None end). Notation map_zip := (map_zip_with pair). Global Instance map_filter `{MapFold K A M, Insert K A M, Empty M} : Filter (K * A) M := λ P _, map_fold (λ k v m, if decide (P (k,v)) then <[k := v]>m else m) ∅. Fixpoint map_seq `{Insert nat A M, Empty M} (start : nat) (xs : list A) : M := match xs with | [] => ∅ | x :: xs => <[start:=x]> (map_seq (S start) xs) end. Fixpoint map_seqZ `{Insert Z A M, Empty M} (start : Z) (xs : list A) : M := match xs with | [] => ∅ | x :: xs => <[start:=x]> (map_seqZ (Z.succ start) xs) end. Global Instance map_lookup_total `{!Lookup K A (M A), !Inhabited A} : LookupTotal K A (M A) | 20 := λ i m, default inhabitant (m !! i). Global Typeclasses Opaque map_lookup_total. (** Given a finite map [m : M] with keys [K] and values [A], the image [map_img m] gives a finite set containing with the values [A] of [m]. The type of [map_img] is generic to support different map and set implementations. A possible instance is [SA:=gset A]. *) Definition map_img `{MapFold K A M, Singleton A SA, Empty SA, Union SA} : M → SA := map_to_set (λ _ x, x). Global Typeclasses Opaque map_img. (** Given a finite map [m] with keys [K] and values [A], the preimage [map_preimg m] gives a finite map with keys [A] and values being sets of [K]. The type of [map_preimg] is very generic to support different map and set implementations. A possible instance is [MKA:=gmap K A], [MASK:=gmap A (gset K)], and [SK:=gset K]. *) Definition map_preimg `{MapFold K A MKA, Empty MASK, PartialAlter A SK MASK, Empty SK, Singleton K SK, Union SK} (m : MKA) : MASK := map_fold (λ i, partial_alter (λ mX, Some $ {[ i ]} ∪ default ∅ mX)) ∅ m. Global Typeclasses Opaque map_preimg. Definition map_compose `{OMap MA, Lookup B C MB} (m : MB) (n : MA B) : MA C := omap (m !!.) n. Infix "∘ₘ" := map_compose (at level 65, right associativity) : stdpp_scope. Notation "(∘ₘ)" := map_compose (only parsing) : stdpp_scope. Notation "( m ∘ₘ.)" := (map_compose m) (only parsing) : stdpp_scope. Notation "(.∘ₘ m )" := (λ n, map_compose n m) (only parsing) : stdpp_scope. (** * Theorems *) Section theorems. Context `{FinMap K M}. (** ** General properties *) Lemma map_eq_iff {A} (m1 m2 : M A) : m1 = m2 ↔ ∀ i, m1 !! i = m2 !! i. Proof. split; [by intros ->|]. apply map_eq. Qed. Lemma map_subseteq_spec {A} (m1 m2 : M A) : m1 ⊆ m2 ↔ ∀ i x, m1 !! i = Some x → m2 !! i = Some x. Proof. unfold subseteq, map_subseteq, map_relation. split; intros Hm i; specialize (Hm i); destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Global Instance map_included_preorder {A} (R : relation A) : PreOrder R → PreOrder (map_included R : relation (M A)). Proof. split; [intros m i; by destruct (m !! i); simpl|]. intros m1 m2 m3 Hm12 Hm23 i; specialize (Hm12 i); specialize (Hm23 i). destruct (m1 !! i), (m2 !! i), (m3 !! i); simplify_eq/=; done || etrans; eauto. Qed. Global Instance map_subseteq_po {A} : PartialOrder (⊆@{M A}). Proof. split; [apply _|]. intros m1 m2; rewrite !map_subseteq_spec. intros; apply map_eq; intros i; apply option_eq; naive_solver. Qed. Lemma lookup_total_alt `{!Inhabited A} (m : M A) i : m !!! i = default inhabitant (m !! i). Proof. reflexivity. Qed. Lemma lookup_total_correct `{!Inhabited A} (m : M A) i x : m !! i = Some x → m !!! i = x. Proof. rewrite lookup_total_alt. by intros ->. Qed. Lemma lookup_lookup_total `{!Inhabited A} (m : M A) i : is_Some (m !! i) → m !! i = Some (m !!! i). Proof. intros [x Hx]. by rewrite (lookup_total_correct m i x). Qed. Lemma lookup_weaken {A} (m1 m2 : M A) i x : m1 !! i = Some x → m1 ⊆ m2 → m2 !! i = Some x. Proof. rewrite !map_subseteq_spec. auto. Qed. Lemma lookup_weaken_is_Some {A} (m1 m2 : M A) i : is_Some (m1 !! i) → m1 ⊆ m2 → is_Some (m2 !! i). Proof. inversion 1. eauto using lookup_weaken. Qed. Lemma lookup_weaken_None {A} (m1 m2 : M A) i : m2 !! i = None → m1 ⊆ m2 → m1 !! i = None. Proof. rewrite map_subseteq_spec, !eq_None_not_Some. intros Hm2 Hm [??]; destruct Hm2; eauto. Qed. Lemma lookup_weaken_inv {A} (m1 m2 : M A) i x y : m1 !! i = Some x → m1 ⊆ m2 → m2 !! i = Some y → x = y. Proof. intros Hm1 ? Hm2. eapply lookup_weaken in Hm1; eauto. congruence. Qed. Lemma lookup_ne {A} (m : M A) i j : m !! i ≠ m !! j → i ≠ j. Proof. congruence. Qed. Lemma map_empty {A} (m : M A) : m = ∅ ↔ ∀ i, m !! i = None. Proof. split. - intros -> i. by rewrite lookup_empty. - intros Hm. apply map_eq. intros i. by rewrite Hm, lookup_empty. Qed. Lemma lookup_empty_is_Some {A} i : ¬is_Some ((∅ : M A) !! i). Proof. rewrite lookup_empty. by inversion 1. Qed. Lemma lookup_empty_Some {A} i (x : A) : ¬(∅ : M A) !! i = Some x. Proof. by rewrite lookup_empty. Qed. Lemma lookup_total_empty `{!Inhabited A} i : (∅ : M A) !!! i = inhabitant. Proof. by rewrite lookup_total_alt, lookup_empty. Qed. Lemma map_subset_empty {A} (m : M A) : m ⊄ ∅. Proof. intros [_ []]. rewrite map_subseteq_spec. intros ??. by rewrite lookup_empty. Qed. Lemma map_empty_subseteq {A} (m : M A) : ∅ ⊆ m. Proof. apply map_subseteq_spec. intros k v []%lookup_empty_Some. Qed. (** [NoDup_map_to_list] and [NoDup_map_to_list] need to be proved mutually, hence a [Local] helper lemma. *) Local Lemma map_to_list_spec {A} (m : M A) : NoDup (map_to_list m) ∧ (∀ i x, (i,x) ∈ map_to_list m ↔ m !! i = Some x). Proof. apply (map_fold_ind (λ l m, NoDup l ∧ ∀ i x, (i,x) ∈ l ↔ m !! i = Some x)); clear m. { split; [constructor|]. intros i x. by rewrite elem_of_nil, lookup_empty. } intros i x m l ? [IH1 IH2]. split; [constructor; naive_solver|]. intros j y. rewrite elem_of_cons, IH2. unfold insert, map_insert. destruct (decide (i = j)) as [->|]. - rewrite lookup_partial_alter. naive_solver. - rewrite lookup_partial_alter_ne by done. naive_solver. Qed. Lemma NoDup_map_to_list {A} (m : M A) : NoDup (map_to_list m). Proof. apply map_to_list_spec. Qed. Lemma elem_of_map_to_list {A} (m : M A) i x : (i,x) ∈ map_to_list m ↔ m !! i = Some x. Proof. apply map_to_list_spec. Qed. Lemma map_subset_alt {A} (m1 m2 : M A) : m1 ⊂ m2 ↔ m1 ⊆ m2 ∧ ∃ i, m1 !! i = None ∧ is_Some (m2 !! i). Proof. rewrite strict_spec_alt. split. - intros [? Heq]; split; [done|]. destruct (decide (Exists (λ ix, m1 !! ix.1 = None) (map_to_list m2))) as [[[i x] [?%elem_of_map_to_list ?]]%Exists_exists |Hm%(not_Exists_Forall _)]; [eauto|]. destruct Heq; apply (anti_symm (⊆)), map_subseteq_spec; [done|intros i x Hi]. assert (is_Some (m1 !! i)) as [x' ?]. { by apply not_eq_None_Some, (proj1 (Forall_forall _ _) Hm (i,x)), elem_of_map_to_list. } by rewrite <-(lookup_weaken_inv m1 m2 i x' x). - intros [? (i&?&x&?)]; split; [done|]. congruence. Qed. (** ** Properties of the [partial_alter] operation *) Lemma partial_alter_ext {A} (f g : option A → option A) (m : M A) i : (∀ x, m !! i = x → f x = g x) → partial_alter f i m = partial_alter g i m. Proof. intros. apply map_eq; intros j. by destruct (decide (i = j)) as [->|?]; rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne; auto. Qed. Lemma partial_alter_compose {A} f g (m : M A) i: partial_alter (f ∘ g) i m = partial_alter f i (partial_alter g i m). Proof. intros. apply map_eq. intros ii. by destruct (decide (i = ii)) as [->|?]; rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne. Qed. Lemma partial_alter_commute {A} f g (m : M A) i j : i ≠ j → partial_alter f i (partial_alter g j m) = partial_alter g j (partial_alter f i m). Proof. intros. apply map_eq; intros jj. destruct (decide (jj = j)) as [->|?]. { by rewrite lookup_partial_alter_ne, !lookup_partial_alter, lookup_partial_alter_ne. } destruct (decide (jj = i)) as [->|?]. - by rewrite lookup_partial_alter, !lookup_partial_alter_ne, lookup_partial_alter by congruence. - by rewrite !lookup_partial_alter_ne by congruence. Qed. Lemma partial_alter_self_alt {A} (m : M A) i x : x = m !! i → partial_alter (λ _, x) i m = m. Proof. intros. apply map_eq. intros ii. by destruct (decide (i = ii)) as [->|]; rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne. Qed. Lemma partial_alter_self {A} (m : M A) i : partial_alter (λ _, m !! i) i m = m. Proof. by apply partial_alter_self_alt. Qed. Lemma partial_alter_subseteq {A} f (m : M A) i : m !! i = None → m ⊆ partial_alter f i m. Proof. rewrite map_subseteq_spec. intros Hi j x Hj. rewrite lookup_partial_alter_ne; congruence. Qed. Lemma partial_alter_subset {A} f (m : M A) i : m !! i = None → is_Some (f (m !! i)) → m ⊂ partial_alter f i m. Proof. intros Hi Hfi. apply map_subset_alt; split; [by apply partial_alter_subseteq|]. exists i. by rewrite lookup_partial_alter. Qed. Lemma lookup_partial_alter_Some {A} (f : option A → option A) (m : M A) i j x : partial_alter f i m !! j = Some x ↔ (i = j ∧ f (m !! i) = Some x) ∨ (i ≠ j ∧ m !! j = Some x). Proof. destruct (decide (i = j)); subst. - rewrite lookup_partial_alter. naive_solver. - rewrite lookup_partial_alter_ne; naive_solver. Qed. Lemma lookup_total_partial_alter {A} `{Inhabited A} (f : option A → option A) (m : M A) i: partial_alter f i m !!! i = default inhabitant (f (m !! i)). Proof. by rewrite lookup_total_alt, lookup_partial_alter. Qed. (** ** Properties of the [alter] operation *) Lemma lookup_alter {A} (f : A → A) (m : M A) i : alter f i m !! i = f <$> m !! i. Proof. unfold alter. apply lookup_partial_alter. Qed. Lemma lookup_alter_ne {A} (f : A → A) (m : M A) i j : i ≠ j → alter f i m !! j = m !! j. Proof. unfold alter. apply lookup_partial_alter_ne. Qed. Lemma alter_ext {A} (f g : A → A) (m : M A) i : (∀ x, m !! i = Some x → f x = g x) → alter f i m = alter g i m. Proof. intro. apply partial_alter_ext. intros [x|] ?; f_equal/=; auto. Qed. Lemma alter_compose {A} (f g : A → A) (m : M A) i: alter (f ∘ g) i m = alter f i (alter g i m). Proof. unfold alter, map_alter. rewrite <-partial_alter_compose. apply partial_alter_ext. by intros [?|]. Qed. Lemma alter_commute {A} (f g : A → A) (m : M A) i j : i ≠ j → alter f i (alter g j m) = alter g j (alter f i m). Proof. apply partial_alter_commute. Qed. Lemma alter_insert {A} (m : M A) i f x : alter f i (<[i := x]> m) = <[i := f x]> m. Proof. unfold alter, insert, map_alter, map_insert. by rewrite <-partial_alter_compose. Qed. Lemma alter_insert_ne {A} (m : M A) i j f x : i ≠ j → alter f i (<[j := x]> m) = <[j := x]> (alter f i m). Proof. intros. symmetry. by apply partial_alter_commute. Qed. Lemma lookup_alter_Some {A} (f : A → A) (m : M A) i j y : alter f i m !! j = Some y ↔ (i = j ∧ ∃ x, m !! j = Some x ∧ y = f x) ∨ (i ≠ j ∧ m !! j = Some y). Proof. destruct (decide (i = j)) as [->|?]. - rewrite lookup_alter. naive_solver (simplify_option_eq; eauto). - rewrite lookup_alter_ne by done. naive_solver. Qed. Lemma lookup_alter_None {A} (f : A → A) (m : M A) i j : alter f i m !! j = None ↔ m !! j = None. Proof. by destruct (decide (i = j)) as [->|?]; rewrite ?lookup_alter, ?fmap_None, ?lookup_alter_ne. Qed. Lemma lookup_alter_is_Some {A} (f : A → A) (m : M A) i j : is_Some (alter f i m !! j) ↔ is_Some (m !! j). Proof. by rewrite <-!not_eq_None_Some, lookup_alter_None. Qed. Lemma alter_id {A} (f : A → A) (m : M A) i : (∀ x, m !! i = Some x → f x = x) → alter f i m = m. Proof. intros Hi; apply map_eq; intros j; destruct (decide (i = j)) as [->|?]. { rewrite lookup_alter; destruct (m !! j); f_equal/=; auto. } by rewrite lookup_alter_ne by done. Qed. Lemma alter_mono {A} f (m1 m2 : M A) i : m1 ⊆ m2 → alter f i m1 ⊆ alter f i m2. Proof. rewrite !map_subseteq_spec. intros ? j x. rewrite !lookup_alter_Some. naive_solver. Qed. Lemma alter_strict_mono {A} f (m1 m2 : M A) i : m1 ⊂ m2 → alter f i m1 ⊂ alter f i m2. Proof. rewrite !map_subset_alt. intros [? (j&?&?)]; split; auto using alter_mono. exists j. by rewrite lookup_alter_None, lookup_alter_is_Some. Qed. (** ** Properties of the [delete] operation *) Lemma lookup_delete {A} (m : M A) i : delete i m !! i = None. Proof. apply lookup_partial_alter. Qed. Lemma lookup_total_delete `{!Inhabited A} (m : M A) i : delete i m !!! i = inhabitant. Proof. by rewrite lookup_total_alt, lookup_delete. Qed. Lemma lookup_delete_ne {A} (m : M A) i j : i ≠ j → delete i m !! j = m !! j. Proof. apply lookup_partial_alter_ne. Qed. Lemma lookup_total_delete_ne `{!Inhabited A} (m : M A) i j : i ≠ j → delete i m !!! j = m !!! j. Proof. intros. by rewrite lookup_total_alt, lookup_delete_ne. Qed. Lemma lookup_delete_Some {A} (m : M A) i j y : delete i m !! j = Some y ↔ i ≠ j ∧ m !! j = Some y. Proof. split. - destruct (decide (i = j)) as [->|?]; rewrite ?lookup_delete, ?lookup_delete_ne; intuition congruence. - intros [??]. by rewrite lookup_delete_ne. Qed. Lemma lookup_delete_is_Some {A} (m : M A) i j : is_Some (delete i m !! j) ↔ i ≠ j ∧ is_Some (m !! j). Proof. unfold is_Some; setoid_rewrite lookup_delete_Some; naive_solver. Qed. Lemma lookup_delete_None {A} (m : M A) i j : delete i m !! j = None ↔ i = j ∨ m !! j = None. Proof. destruct (decide (i = j)) as [->|?]; rewrite ?lookup_delete, ?lookup_delete_ne; tauto. Qed. Lemma delete_empty {A} i : delete i ∅ =@{M A} ∅. Proof. rewrite <-(partial_alter_self ∅) at 2. by rewrite lookup_empty. Qed. Lemma delete_commute {A} (m : M A) i j : delete i (delete j m) = delete j (delete i m). Proof. destruct (decide (i = j)) as [->|]; [done|]. by apply partial_alter_commute. Qed. Lemma delete_notin {A} (m : M A) i : m !! i = None → delete i m = m. Proof. intros. apply map_eq. intros j. by destruct (decide (i = j)) as [->|?]; rewrite ?lookup_delete, ?lookup_delete_ne. Qed. Lemma delete_idemp {A} (m : M A) i : delete i (delete i m) = delete i m. Proof. by setoid_rewrite <-partial_alter_compose. Qed. Lemma delete_partial_alter {A} (m : M A) i f : m !! i = None → delete i (partial_alter f i m) = m. Proof. intros. unfold delete, map_delete. rewrite <-partial_alter_compose. unfold compose. by apply partial_alter_self_alt. Qed. Lemma delete_insert {A} (m : M A) i x : m !! i = None → delete i (<[i:=x]>m) = m. Proof. apply delete_partial_alter. Qed. Lemma delete_insert_delete {A} (m : M A) i x : delete i (<[i:=x]>m) = delete i m. Proof. by setoid_rewrite <-partial_alter_compose. Qed. Lemma delete_insert_ne {A} (m : M A) i j x : i ≠ j → delete i (<[j:=x]>m) = <[j:=x]>(delete i m). Proof. intro. by apply partial_alter_commute. Qed. Lemma delete_alter {A} (m : M A) i f : delete i (alter f i m) = delete i m. Proof. unfold delete, alter, map_delete, map_alter. by rewrite <-partial_alter_compose. Qed. Lemma delete_alter_ne {A} (m : M A) i j f : i ≠ j → delete i (alter f j m) = alter f j (delete i m). Proof. intro. by apply partial_alter_commute. Qed. Lemma delete_subseteq {A} (m : M A) i : delete i m ⊆ m. Proof. rewrite !map_subseteq_spec. intros j x. rewrite lookup_delete_Some. tauto. Qed. Lemma delete_subset {A} (m : M A) i : is_Some (m !! i) → delete i m ⊂ m. Proof. intros [x ?]; apply map_subset_alt; split; [apply delete_subseteq|]. exists i. rewrite lookup_delete; eauto. Qed. Lemma delete_mono {A} (m1 m2 : M A) i : m1 ⊆ m2 → delete i m1 ⊆ delete i m2. Proof. rewrite !map_subseteq_spec. intros ? j x. rewrite !lookup_delete_Some. intuition eauto. Qed. (** ** Properties of the [insert] operation *) Lemma lookup_insert {A} (m : M A) i x : <[i:=x]>m !! i = Some x. Proof. unfold insert. apply lookup_partial_alter. Qed. Lemma lookup_total_insert `{!Inhabited A} (m : M A) i x : <[i:=x]>m !!! i = x. Proof. by rewrite lookup_total_alt, lookup_insert. Qed. Lemma lookup_insert_rev {A} (m : M A) i x y : <[i:=x]>m !! i = Some y → x = y. Proof. rewrite lookup_insert. congruence. Qed. Lemma lookup_insert_ne {A} (m : M A) i j x : i ≠ j → <[i:=x]>m !! j = m !! j. Proof. unfold insert. apply lookup_partial_alter_ne. Qed. Lemma lookup_total_insert_ne `{!Inhabited A} (m : M A) i j x : i ≠ j → <[i:=x]>m !!! j = m !!! j. Proof. intros. by rewrite lookup_total_alt, lookup_insert_ne. Qed. Lemma insert_insert {A} (m : M A) i x y : <[i:=x]>(<[i:=y]>m) = <[i:=x]>m. Proof. unfold insert, map_insert. by rewrite <-partial_alter_compose. Qed. Lemma insert_commute {A} (m : M A) i j x y : i ≠ j → <[i:=x]>(<[j:=y]>m) = <[j:=y]>(<[i:=x]>m). Proof. apply partial_alter_commute. Qed. Lemma lookup_insert_Some {A} (m : M A) i j x y : <[i:=x]>m !! j = Some y ↔ (i = j ∧ x = y) ∨ (i ≠ j ∧ m !! j = Some y). Proof. split. - destruct (decide (i = j)) as [->|?]; rewrite ?lookup_insert, ?lookup_insert_ne; intuition congruence. - intros [[-> ->]|[??]]; [apply lookup_insert|]. by rewrite lookup_insert_ne. Qed. Lemma lookup_insert_is_Some {A} (m : M A) i j x : is_Some (<[i:=x]>m !! j) ↔ i = j ∨ i ≠ j ∧ is_Some (m !! j). Proof. unfold is_Some; setoid_rewrite lookup_insert_Some; naive_solver. Qed. Lemma lookup_insert_is_Some' {A} (m : M A) i j x : is_Some (<[i:=x]>m !! j) ↔ i = j ∨ is_Some (m !! j). Proof. rewrite lookup_insert_is_Some. destruct (decide (i=j)); naive_solver. Qed. Lemma lookup_insert_None {A} (m : M A) i j x : <[i:=x]>m !! j = None ↔ m !! j = None ∧ i ≠ j. Proof. split; [|by intros [??]; rewrite lookup_insert_ne]. destruct (decide (i = j)) as [->|]; rewrite ?lookup_insert, ?lookup_insert_ne; intuition congruence. Qed. Lemma insert_id {A} (m : M A) i x : m !! i = Some x → <[i:=x]>m = m. Proof. intros; apply map_eq; intros j; destruct (decide (i = j)) as [->|]; by rewrite ?lookup_insert, ?lookup_insert_ne by done. Qed. Lemma insert_included {A} R `{!Reflexive R} (m : M A) i x : (∀ y, m !! i = Some y → R y x) → map_included R m (<[i:=x]>m). Proof. intros ? j; destruct (decide (i = j)) as [->|]. - rewrite lookup_insert. destruct (m !! j); simpl; eauto. - rewrite lookup_insert_ne by done. by destruct (m !! j); simpl. Qed. Lemma insert_empty {A} i (x : A) : <[i:=x]> ∅ =@{M A} {[i := x]}. Proof. done. Qed. Lemma insert_non_empty {A} (m : M A) i x : <[i:=x]>m ≠ ∅. Proof. intros Hi%(f_equal (.!! i)). by rewrite lookup_insert, lookup_empty in Hi. Qed. Lemma insert_delete_insert {A} (m : M A) i x : <[i:=x]>(delete i m) = <[i:=x]> m. Proof. symmetry; apply (partial_alter_compose (λ _, Some x)). Qed. Lemma insert_delete {A} (m : M A) i x : m !! i = Some x → <[i:=x]> (delete i m) = m. Proof. intros. rewrite insert_delete_insert, insert_id; done. Qed. Lemma insert_subseteq {A} (m : M A) i x : m !! i = None → m ⊆ <[i:=x]>m. Proof. apply partial_alter_subseteq. Qed. Lemma insert_subset {A} (m : M A) i x : m !! i = None → m ⊂ <[i:=x]>m. Proof. intro. apply partial_alter_subset; eauto. Qed. Lemma insert_mono {A} (m1 m2 : M A) i x : m1 ⊆ m2 → <[i:=x]> m1 ⊆ <[i:=x]>m2. Proof. rewrite !map_subseteq_spec. intros Hm j y. rewrite !lookup_insert_Some. naive_solver. Qed. Lemma insert_subseteq_r {A} (m1 m2 : M A) i x : m1 !! i = None → m1 ⊆ m2 → m1 ⊆ <[i:=x]>m2. Proof. intros. trans (<[i:=x]> m1); eauto using insert_subseteq, insert_mono. Qed. Lemma insert_subseteq_l {A} (m1 m2 : M A) i x : m2 !! i = Some x → m1 ⊆ m2 → <[i:=x]> m1 ⊆ m2. Proof. intros Hi Hincl. etrans; [apply insert_mono, Hincl|]. by rewrite insert_id. Qed. Lemma insert_delete_subseteq {A} (m1 m2 : M A) i x : m1 !! i = None → <[i:=x]> m1 ⊆ m2 → m1 ⊆ delete i m2. Proof. rewrite !map_subseteq_spec. intros Hi Hix j y Hj. destruct (decide (i = j)) as [->|]; [congruence|]. rewrite lookup_delete_ne by done. apply Hix; by rewrite lookup_insert_ne by done. Qed. Lemma delete_insert_subseteq {A} (m1 m2 : M A) i x : m1 !! i = Some x → delete i m1 ⊆ m2 → m1 ⊆ <[i:=x]> m2. Proof. rewrite !map_subseteq_spec. intros Hix Hi j y Hj. destruct (decide (i = j)) as [->|?]. - rewrite lookup_insert. congruence. - rewrite lookup_insert_ne by done. apply Hi. by rewrite lookup_delete_ne. Qed. Lemma insert_delete_subset {A} (m1 m2 : M A) i x : m1 !! i = None → <[i:=x]> m1 ⊂ m2 → m1 ⊂ delete i m2. Proof. intros ? [Hm12 Hm21]; split; [eauto using insert_delete_subseteq|]. contradict Hm21. apply delete_insert_subseteq; auto. eapply lookup_weaken, Hm12. by rewrite lookup_insert. Qed. Lemma insert_subset_inv {A} (m1 m2 : M A) i x : m1 !! i = None → <[i:=x]> m1 ⊂ m2 → ∃ m2', m2 = <[i:=x]>m2' ∧ m1 ⊂ m2' ∧ m2' !! i = None. Proof. intros Hi Hm1m2. exists (delete i m2). split_and?. - rewrite insert_delete; [done|]. eapply lookup_weaken, strict_include; eauto. by rewrite lookup_insert. - eauto using insert_delete_subset. - by rewrite lookup_delete. Qed. (** ** Properties of the singleton maps *) Lemma lookup_singleton_Some {A} i j (x y : A) : ({[i := x]} : M A) !! j = Some y ↔ i = j ∧ x = y. Proof. rewrite <-insert_empty,lookup_insert_Some, lookup_empty; intuition congruence. Qed. Lemma lookup_singleton_None {A} i j (x : A) : ({[i := x]} : M A) !! j = None ↔ i ≠ j. Proof. rewrite <-insert_empty,lookup_insert_None, lookup_empty; tauto. Qed. Lemma lookup_singleton {A} i (x : A) : ({[i := x]} : M A) !! i = Some x. Proof. by rewrite lookup_singleton_Some. Qed. Lemma lookup_total_singleton `{!Inhabited A} i (x : A) : ({[i := x]} : M A) !!! i = x. Proof. by rewrite lookup_total_alt, lookup_singleton. Qed. Lemma lookup_singleton_ne {A} i j (x : A) : i ≠ j → ({[i := x]} : M A) !! j = None. Proof. by rewrite lookup_singleton_None. Qed. Lemma lookup_total_singleton_ne `{!Inhabited A} i j (x : A) : i ≠ j → ({[i := x]} : M A) !!! j = inhabitant. Proof. intros. by rewrite lookup_total_alt, lookup_singleton_ne. Qed. Global Instance map_singleton_inj {A} : Inj2 (=) (=) (=) (singletonM (M:=M A)). Proof. intros i1 x1 i2 x2 Heq%(f_equal (lookup i1)). rewrite lookup_singleton in Heq. destruct (decide (i1 = i2)) as [->|]. - rewrite lookup_singleton in Heq. naive_solver. - rewrite lookup_singleton_ne in Heq by done. naive_solver. Qed. Lemma map_non_empty_singleton {A} i (x : A) : {[i := x]} ≠@{M A} ∅. Proof. intros Hix. apply (f_equal (.!! i)) in Hix. by rewrite lookup_empty, lookup_singleton in Hix. Qed. Lemma insert_singleton {A} i (x y : A) : <[i:=y]> {[i := x]} =@{M A} {[i := y]}. Proof. unfold singletonM, map_singleton, insert, map_insert. by rewrite <-partial_alter_compose. Qed. Lemma alter_singleton {A} (f : A → A) i x : alter f i {[i := x]} =@{M A} {[i := f x]}. Proof. intros. apply map_eq. intros i'. destruct (decide (i = i')) as [->|?]. - by rewrite lookup_alter, !lookup_singleton. - by rewrite lookup_alter_ne, !lookup_singleton_ne. Qed. Lemma alter_singleton_ne {A} (f : A → A) i j x : i ≠ j → alter f i {[j := x]}=@{M A} {[j := x]}. Proof. intros. apply map_eq; intros i'. by destruct (decide (i = i')) as [->|?]; rewrite ?lookup_alter, ?lookup_singleton_ne, ?lookup_alter_ne by done. Qed. Lemma singleton_non_empty {A} i (x : A) : {[i:=x]} ≠@{M A} ∅. Proof. apply insert_non_empty. Qed. Lemma delete_singleton {A} i (x : A) : delete i {[i := x]} =@{M A} ∅. Proof. setoid_rewrite <-partial_alter_compose. apply delete_empty. Qed. Lemma delete_singleton_ne {A} i j (x : A) : i ≠ j → delete i {[j := x]} =@{M A} {[j := x]}. Proof. intro. apply delete_notin. by apply lookup_singleton_ne. Qed. Lemma map_singleton_subseteq_l {A} i (x : A) (m : M A) : {[i := x]} ⊆ m ↔ m !! i = Some x. Proof. rewrite map_subseteq_spec. setoid_rewrite lookup_singleton_Some. naive_solver. Qed. Lemma map_singleton_subseteq {A} i j (x y : A) : {[i := x]} ⊆@{M A} {[j := y]} ↔ i = j ∧ x = y. Proof. rewrite map_subseteq_spec. setoid_rewrite lookup_singleton_Some. naive_solver. Qed. (** ** Properties of the map operations *) Global Instance map_fmap_inj {A B} (f : A → B) : Inj (=) (=) f → Inj (=@{M A}) (=@{M B}) (fmap f). Proof. intros ? m1 m2 Hm. apply map_eq; intros i. apply (inj (fmap (M:=option) f)). by rewrite <-!lookup_fmap, Hm. Qed. Lemma lookup_fmap_Some {A B} (f : A → B) (m : M A) i y : (f <$> m) !! i = Some y ↔ ∃ x, f x = y ∧ m !! i = Some x. Proof. rewrite lookup_fmap, fmap_Some. naive_solver. Qed. Lemma lookup_omap_Some {A B} (f : A → option B) (m : M A) i y : omap f m !! i = Some y ↔ ∃ x, f x = Some y ∧ m !! i = Some x. Proof. rewrite lookup_omap, bind_Some. naive_solver. Qed. Lemma lookup_omap_id_Some {A} (m : M (option A)) i x : omap id m !! i = Some x ↔ m !! i = Some (Some x). Proof. rewrite lookup_omap_Some. naive_solver. Qed. Lemma fmap_empty {A B} (f : A → B) : f <$> ∅ =@{M B} ∅. Proof. apply map_empty; intros i. by rewrite lookup_fmap, lookup_empty. Qed. Lemma omap_empty {A B} (f : A → option B) : omap f ∅ =@{M B} ∅. Proof. apply map_empty; intros i. by rewrite lookup_omap, lookup_empty. Qed. Lemma fmap_empty_iff {A B} (f : A → B) m : f <$> m =@{M B} ∅ ↔ m = ∅. Proof. split; [|intros ->; by rewrite fmap_empty]. intros Hm. apply map_eq; intros i. generalize (f_equal (lookup i) Hm). by rewrite lookup_fmap, !lookup_empty, fmap_None. Qed. Lemma fmap_empty_inv {A B} (f : A → B) m : f <$> m =@{M B} ∅ → m = ∅. Proof. apply fmap_empty_iff. Qed. Lemma fmap_insert {A B} (f: A → B) (m : M A) i x : f <$> <[i:=x]>m = <[i:=f x]>(f <$> m). Proof. apply map_eq; intros i'; destruct (decide (i' = i)) as [->|]. - by rewrite lookup_fmap, !lookup_insert. - by rewrite lookup_fmap, !lookup_insert_ne, lookup_fmap by done. Qed. Lemma omap_insert {A B} (f : A → option B) (m : M A) i x : omap f (<[i:=x]>m) = (match f x with Some y => <[i:=y]> | None => delete i end) (omap f m). Proof. intros; apply map_eq; intros i'; destruct (decide (i' = i)) as [->|]. - rewrite lookup_omap, !lookup_insert. destruct (f x) as [y|] eqn:Hx; simpl. + by rewrite lookup_insert. + by rewrite lookup_delete, Hx. - rewrite lookup_omap, !lookup_insert_ne by done. destruct (f x) as [y|] eqn:Hx; simpl. + by rewrite lookup_insert_ne, lookup_omap by done. + by rewrite lookup_delete_ne, lookup_omap by done. Qed. Lemma omap_insert_Some {A B} (f : A → option B) (m : M A) i x y : f x = Some y → omap f (<[i:=x]>m) = <[i:=y]>(omap f m). Proof. intros Hx. by rewrite omap_insert, Hx. Qed. Lemma omap_insert_None {A B} (f : A → option B) (m : M A) i x : f x = None → omap f (<[i:=x]>m) = delete i (omap f m). Proof. intros Hx. by rewrite omap_insert, Hx. Qed. Lemma fmap_delete {A B} (f: A → B) (m : M A) i : f <$> delete i m = delete i (f <$> m). Proof. apply map_eq; intros i'; destruct (decide (i' = i)) as [->|]. - by rewrite lookup_fmap, !lookup_delete. - by rewrite lookup_fmap, !lookup_delete_ne, lookup_fmap by done. Qed. Lemma omap_delete {A B} (f: A → option B) (m : M A) i : omap f (delete i m) = delete i (omap f m). Proof. apply map_eq; intros i'; destruct (decide (i' = i)) as [->|]. - by rewrite lookup_omap, !lookup_delete. - by rewrite lookup_omap, !lookup_delete_ne, lookup_omap by done. Qed. Lemma map_fmap_singleton {A B} (f : A → B) i x : f <$> {[i := x]} =@{M B} {[i := f x]}. Proof. by unfold singletonM, map_singleton; rewrite fmap_insert, fmap_empty. Qed. Lemma map_fmap_singleton_inv {A B} (f : A → B) (m : M A) i y : f <$> m = {[i := y]} → ∃ x, y = f x ∧ m = {[ i := x ]}. Proof. intros Hm. pose proof (f_equal (.!! i) Hm) as Hmi. rewrite lookup_fmap, lookup_singleton, fmap_Some in Hmi. destruct Hmi as (x&?&->). exists x. split; [done|]. apply map_eq; intros j. destruct (decide (i = j)) as[->|?]. - by rewrite lookup_singleton. - rewrite lookup_singleton_ne by done. apply (fmap_None f). by rewrite <-lookup_fmap, Hm, lookup_singleton_ne. Qed. Lemma omap_singleton {A B} (f : A → option B) i x : omap f {[ i := x ]} =@{M B} match f x with Some y => {[ i:=y ]} | None => ∅ end. Proof. rewrite <-insert_empty, omap_insert, omap_empty. destruct (f x) as [y|]; simpl. - by rewrite insert_empty. - by rewrite delete_empty. Qed. Lemma omap_singleton_Some {A B} (f : A → option B) i x y : f x = Some y → omap f {[ i := x ]} =@{M B} {[ i := y ]}. Proof. intros Hx. by rewrite omap_singleton, Hx. Qed. Lemma omap_singleton_None {A B} (f : A → option B) i x : f x = None → omap f {[ i := x ]} =@{M B} ∅. Proof. intros Hx. by rewrite omap_singleton, Hx. Qed. Lemma map_fmap_id {A} (m : M A) : id <$> m = m. Proof. apply map_eq; intros i; by rewrite lookup_fmap, option_fmap_id. Qed. Lemma map_fmap_compose {A B C} (f : A → B) (g : B → C) (m : M A) : g ∘ f <$> m = g <$> (f <$> m). Proof. apply map_eq; intros i; by rewrite !lookup_fmap,option_fmap_compose. Qed. Lemma map_fmap_ext {A B} (f1 f2 : A → B) (m : M A) : (∀ i x, m !! i = Some x → f1 x = f2 x) → f1 <$> m = f2 <$> m. Proof. intros Hi; apply map_eq; intros i; rewrite !lookup_fmap. by destruct (m !! i) eqn:?; simpl; erewrite ?Hi by eauto. Qed. Lemma omap_ext {A B} (f1 f2 : A → option B) (m : M A) : (∀ i x, m !! i = Some x → f1 x = f2 x) → omap f1 m = omap f2 m. Proof. intros Hi; apply map_eq; intros i; rewrite !lookup_omap. by destruct (m !! i) eqn:?; simpl; erewrite ?Hi by eauto. Qed. Lemma map_fmap_omap {A B C} (f : A → option B) (g : B → C) (m : M A) : g <$> omap f m = omap (λ x, g <$> f x) m. Proof. apply map_eq. intros i. rewrite !lookup_fmap, !lookup_omap. destruct (m !! i); done. Qed. Lemma map_fmap_alt {A B} (f : A → B) (m : M A) : f <$> m = omap (λ x, Some (f x)) m. Proof. apply map_eq. intros i. rewrite lookup_fmap, lookup_omap. destruct (m !! i); done. Qed. Lemma map_fmap_mono {A B} (f : A → B) (m1 m2 : M A) : m1 ⊆ m2 → f <$> m1 ⊆ f <$> m2. Proof. rewrite !map_subseteq_spec; intros Hm i x. rewrite !lookup_fmap, !fmap_Some. naive_solver. Qed. Lemma map_fmap_strict_mono {A B} (f : A → B) (m1 m2 : M A) : m1 ⊂ m2 → f <$> m1 ⊂ f <$> m2. Proof. rewrite !map_subset_alt. intros [? (j&?&?)]; split; auto using map_fmap_mono. exists j. by rewrite !lookup_fmap, fmap_None, fmap_is_Some. Qed. Lemma map_omap_mono {A B} (f : A → option B) (m1 m2 : M A) : m1 ⊆ m2 → omap f m1 ⊆ omap f m2. Proof. rewrite !map_subseteq_spec; intros Hm i x. rewrite !lookup_omap, !bind_Some. naive_solver. Qed. (** ** Properties of conversion to lists *) Lemma elem_of_map_to_list' {A} (m : M A) ix : ix ∈ map_to_list m ↔ m !! ix.1 = Some (ix.2). Proof. destruct ix as [i x]. apply elem_of_map_to_list. Qed. Lemma map_to_list_unique {A} (m : M A) i x y : (i,x) ∈ map_to_list m → (i,y) ∈ map_to_list m → x = y. Proof. rewrite !elem_of_map_to_list. congruence. Qed. Lemma NoDup_fst_map_to_list {A} (m : M A) : NoDup ((map_to_list m).*1). Proof. eauto using NoDup_fmap_fst, map_to_list_unique, NoDup_map_to_list. Qed. Lemma elem_of_list_to_map_1' {A} (l : list (K * A)) i x : (∀ y, (i,y) ∈ l → x = y) → (i,x) ∈ l → (list_to_map l : M A) !! i = Some x. Proof. induction l as [|[j y] l IH]; csimpl; [by rewrite elem_of_nil|]. setoid_rewrite elem_of_cons. intros Hdup [?|?]; simplify_eq; [by rewrite lookup_insert|]. destruct (decide (i = j)) as [->|]. - rewrite lookup_insert; f_equal; eauto using eq_sym. - rewrite lookup_insert_ne by done; eauto. Qed. Lemma elem_of_list_to_map_1 {A} (l : list (K * A)) i x : NoDup (l.*1) → (i,x) ∈ l → (list_to_map l : M A) !! i = Some x. Proof. intros ? Hx; apply elem_of_list_to_map_1'; eauto using NoDup_fmap_fst. intros y; revert Hx. rewrite !elem_of_list_lookup; intros [i' Hi'] [j' Hj']. cut (i' = j'); [naive_solver|]. apply NoDup_lookup with (l.*1) i; by rewrite ?list_lookup_fmap, ?Hi', ?Hj'. Qed. Lemma elem_of_list_to_map_2 {A} (l : list (K * A)) i x : (list_to_map l : M A) !! i = Some x → (i,x) ∈ l. Proof. induction l as [|[j y] l IH]; simpl; [by rewrite lookup_empty|]. rewrite elem_of_cons. destruct (decide (i = j)) as [->|]; rewrite ?lookup_insert, ?lookup_insert_ne; intuition congruence. Qed. Lemma elem_of_list_to_map' {A} (l : list (K * A)) i x : (∀ x', (i,x) ∈ l → (i,x') ∈ l → x = x') → (i,x) ∈ l ↔ (list_to_map l : M A) !! i = Some x. Proof. split; auto using elem_of_list_to_map_1', elem_of_list_to_map_2. Qed. Lemma elem_of_list_to_map {A} (l : list (K * A)) i x : NoDup (l.*1) → (i,x) ∈ l ↔ (list_to_map l : M A) !! i = Some x. Proof. split; auto using elem_of_list_to_map_1, elem_of_list_to_map_2. Qed. Lemma not_elem_of_list_to_map_1 {A} (l : list (K * A)) i : i ∉ l.*1 → (list_to_map l : M A) !! i = None. Proof. rewrite elem_of_list_fmap, eq_None_not_Some. intros Hi [x ?]; destruct Hi. exists (i,x); simpl; auto using elem_of_list_to_map_2. Qed. Lemma not_elem_of_list_to_map_2 {A} (l : list (K * A)) i : (list_to_map l : M A) !! i = None → i ∉ l.*1. Proof. induction l as [|[j y] l IH]; csimpl; [rewrite elem_of_nil; tauto|]. rewrite elem_of_cons. destruct (decide (i = j)); simplify_eq. - by rewrite lookup_insert. - by rewrite lookup_insert_ne; intuition. Qed. Lemma not_elem_of_list_to_map {A} (l : list (K * A)) i : i ∉ l.*1 ↔ (list_to_map l : M A) !! i = None. Proof. red; auto using not_elem_of_list_to_map_1,not_elem_of_list_to_map_2. Qed. Lemma list_to_map_proper {A} (l1 l2 : list (K * A)) : NoDup (l1.*1) → l1 ≡ₚ l2 → (list_to_map l1 : M A) = list_to_map l2. Proof. intros ? Hperm. apply map_eq. intros i. apply option_eq. intros x. by rewrite <-!elem_of_list_to_map; rewrite <-?Hperm. Qed. Lemma list_to_map_inj {A} (l1 l2 : list (K * A)) : NoDup (l1.*1) → NoDup (l2.*1) → (list_to_map l1 : M A) = list_to_map l2 → l1 ≡ₚ l2. Proof. intros ?? Hl1l2. apply NoDup_Permutation; [by eauto using NoDup_fmap_1..|]. intros [i x]. by rewrite !elem_of_list_to_map, Hl1l2. Qed. Lemma list_to_map_to_list {A} (m : M A) : list_to_map (map_to_list m) = m. Proof. apply map_eq. intros i. apply option_eq. intros x. by rewrite <-elem_of_list_to_map, elem_of_map_to_list by auto using NoDup_fst_map_to_list. Qed. Lemma map_to_list_to_map {A} (l : list (K * A)) : NoDup (l.*1) → map_to_list (list_to_map l) ≡ₚ l. Proof. auto using list_to_map_inj, NoDup_fst_map_to_list, list_to_map_to_list. Qed. Lemma map_to_list_inj {A} (m1 m2 : M A) : map_to_list m1 ≡ₚ map_to_list m2 → m1 = m2. Proof. intros. rewrite <-(list_to_map_to_list m1), <-(list_to_map_to_list m2). auto using list_to_map_proper, NoDup_fst_map_to_list. Qed. Lemma list_to_map_flip {A} (m1 : M A) l2 : map_to_list m1 ≡ₚ l2 → m1 = list_to_map l2. Proof. intros. rewrite <-(list_to_map_to_list m1). auto using list_to_map_proper, NoDup_fst_map_to_list. Qed. Lemma list_to_map_nil {A} : list_to_map [] =@{M A} ∅. Proof. done. Qed. Lemma list_to_map_cons {A} (l : list (K * A)) i x : list_to_map ((i, x) :: l) =@{M A} <[i:=x]>(list_to_map l). Proof. done. Qed. Lemma list_to_map_snoc {A} (l : list (K * A)) i x : i ∉ l.*1 → list_to_map (l ++ [(i, x)]) =@{M A} <[i:=x]>(list_to_map l). Proof. induction l as [|[k y] l IH]; [done|]. csimpl. intros [Hneq Hni]%not_elem_of_cons. by rewrite (IH Hni), insert_commute by done. Qed. Lemma list_to_map_fmap {A B} (f : A → B) l : list_to_map (prod_map id f <$> l) = f <$> (list_to_map l : M A). Proof. induction l as [|[i x] l IH]; csimpl; rewrite ?fmap_empty; auto. rewrite <-list_to_map_cons; simpl. by rewrite IH, <-fmap_insert. Qed. Lemma map_to_list_empty {A} : map_to_list ∅ = @nil (K * A). Proof. apply elem_of_nil_inv. intros [i x]. rewrite elem_of_map_to_list. apply lookup_empty_Some. Qed. Lemma map_to_list_insert {A} (m : M A) i x : m !! i = None → map_to_list (<[i:=x]>m) ≡ₚ (i,x) :: map_to_list m. Proof. intros. apply list_to_map_inj; csimpl. - apply NoDup_fst_map_to_list. - constructor; [|by auto using NoDup_fst_map_to_list]. rewrite elem_of_list_fmap. intros [[??] [? Hlookup]]; subst; simpl in *. rewrite elem_of_map_to_list in Hlookup. congruence. - by rewrite !list_to_map_to_list. Qed. Lemma map_to_list_singleton {A} i (x : A) : map_to_list ({[i:=x]} : M A) = [(i,x)]. Proof. apply Permutation_singleton_r. unfold singletonM, map_singleton. by rewrite map_to_list_insert, map_to_list_empty by eauto using lookup_empty. Qed. Lemma map_to_list_delete {A} (m : M A) i x : m !! i = Some x → (i,x) :: map_to_list (delete i m) ≡ₚ map_to_list m. Proof. intros. rewrite <-map_to_list_insert by (by rewrite lookup_delete). by rewrite insert_delete. Qed. Lemma map_to_list_submseteq {A} (m1 m2 : M A) : m1 ⊆ m2 → map_to_list m1 ⊆+ map_to_list m2. Proof. intros; apply NoDup_submseteq; [by eauto using NoDup_map_to_list|]. intros [i x]. rewrite !elem_of_map_to_list; eauto using lookup_weaken. Qed. Lemma map_to_list_fmap {A B} (f : A → B) (m : M A) : map_to_list (f <$> m) ≡ₚ prod_map id f <$> map_to_list m. Proof. assert (NoDup ((prod_map id f <$> map_to_list m).*1)). { erewrite <-list_fmap_compose, (list_fmap_ext _ fst) by done. apply NoDup_fst_map_to_list. } rewrite <-(list_to_map_to_list m) at 1. by rewrite <-list_to_map_fmap, map_to_list_to_map. Qed. Lemma map_to_list_empty_iff {A} (m : M A) : map_to_list m = [] ↔ m = ∅. Proof. split. - rewrite <-Permutation_nil_r, <-map_to_list_empty. apply map_to_list_inj. - intros ->. apply map_to_list_empty. Qed. Lemma map_to_list_insert_inv {A} (m : M A) l i x : map_to_list m ≡ₚ (i,x) :: l → m = <[i:=x]>(list_to_map l). Proof. intros Hperm. apply map_to_list_inj. assert (i ∉ l.*1 ∧ NoDup (l.*1)) as []. { rewrite <-NoDup_cons. change (NoDup (((i,x)::l).*1)). rewrite <-Hperm. auto using NoDup_fst_map_to_list. } rewrite Hperm, map_to_list_insert, map_to_list_to_map; auto using not_elem_of_list_to_map_1. Qed. Lemma map_to_list_length {A} (m : M A) : length (map_to_list m) = size m. Proof. apply (map_fold_ind (λ n m, length (map_to_list m) = n)); clear m. { by rewrite map_to_list_empty. } intros i x m n ? IH. by rewrite map_to_list_insert, <-IH by done. Qed. Lemma map_choose {A} (m : M A) : m ≠ ∅ → ∃ i x, m !! i = Some x. Proof. rewrite <-map_to_list_empty_iff. intros Hemp. destruct (map_to_list m) as [|[i x] l] eqn:Hm; [done|]. exists i, x. rewrite <-elem_of_map_to_list, Hm. by left. Qed. Global Instance map_eq_dec_empty {A} (m : M A) : Decision (m = ∅) | 20. Proof. refine (cast_if (decide (map_to_list m = []))); by rewrite <-?map_to_list_empty_iff. Defined. Lemma map_choose_or_empty {A} (m : M A) : (∃ i x, m !! i = Some x) ∨ m = ∅. Proof. destruct (decide (m = ∅)); [right|left]; auto using map_choose. Qed. (** Properties of the imap function *) Lemma map_lookup_imap {A B} (f : K → A → option B) (m : M A) i : map_imap f m !! i = m !! i ≫= f i. Proof. unfold map_imap; destruct (m !! i ≫= f i) as [y|] eqn:Hi; simpl. - destruct (m !! i) as [x|] eqn:?; simplify_eq/=. apply elem_of_list_to_map_1'. { intros y'; rewrite elem_of_list_omap; intros ([i' x']&Hi'&?). by rewrite elem_of_map_to_list in Hi'; simplify_option_eq. } apply elem_of_list_omap; exists (i,x); split; [by apply elem_of_map_to_list|by simplify_option_eq]. - apply not_elem_of_list_to_map; rewrite elem_of_list_fmap. intros ([i' x]&->&Hi'); simplify_eq/=. rewrite elem_of_list_omap in Hi'; destruct Hi' as ([j y]&Hj&?). rewrite elem_of_map_to_list in Hj; simplify_option_eq. Qed. Lemma map_imap_Some {A} (m : M A) : map_imap (λ _, Some) m = m. Proof. apply map_eq. intros i. rewrite map_lookup_imap. by destruct (m !! i). Qed. Lemma map_imap_insert {A B} (f : K → A → option B) i x (m : M A) : map_imap f (<[i:=x]> m) = (match f i x with Some y => <[i:=y]> | None => delete i end) (map_imap f m). Proof. destruct (f i x) as [y|] eqn:Hw; simpl. - apply map_eq. intros k. rewrite map_lookup_imap. destruct (decide (k = i)) as [->|Hk_not_i]. + by rewrite lookup_insert, lookup_insert. + rewrite !lookup_insert_ne by done. by rewrite map_lookup_imap. - apply map_eq. intros k. rewrite map_lookup_imap. destruct (decide (k = i)) as [->|Hk_not_i]. + by rewrite lookup_insert, lookup_delete. + rewrite lookup_insert_ne, lookup_delete_ne by done. by rewrite map_lookup_imap. Qed. Lemma map_imap_insert_Some {A B} (f : K → A → option B) i x (m : M A) y : f i x = Some y → map_imap f (<[i:=x]> m) = <[i:=y]> (map_imap f m). Proof. intros Hi. by rewrite map_imap_insert, Hi. Qed. Lemma map_imap_insert_None {A B} (f : K → A → option B) i x (m : M A) : f i x = None → map_imap f (<[i:=x]> m) = delete i (map_imap f m). Proof. intros Hi. by rewrite map_imap_insert, Hi. Qed. Lemma map_imap_delete {A B} (f : K → A → option B) (m : M A) (i : K) : map_imap f (delete i m) = delete i (map_imap f m). Proof. apply map_eq. intros k. rewrite map_lookup_imap. destruct (decide (k = i)) as [->|Hk_not_i]. - by rewrite !lookup_delete. - rewrite !lookup_delete_ne by done. by rewrite map_lookup_imap. Qed. Lemma map_imap_ext {A1 A2 B} (f1 : K → A1 → option B) (f2 : K → A2 → option B) (m1 : M A1) (m2 : M A2) : (∀ k, f1 k <$> (m1 !! k) = f2 k <$> (m2 !! k)) → map_imap f1 m1 = map_imap f2 m2. Proof. intros HExt. apply map_eq. intros i. rewrite !map_lookup_imap. specialize (HExt i). destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_imap_compose {A1 A2 B} (f1 : K → A1 → option B) (f2 : K → A2 → option A1) (m : M A2) : map_imap f1 (map_imap f2 m) = map_imap (λ k x, f2 k x ≫= f1 k) m. Proof. apply map_eq. intros i. rewrite !map_lookup_imap. by destruct (m !! i). Qed. Lemma map_imap_empty {A B} (f : K → A → option B) : map_imap f ∅ =@{M B} ∅. Proof. unfold map_imap. by rewrite map_to_list_empty. Qed. (** ** Properties of the size operation *) Lemma map_size_empty {A} : size (∅ : M A) = 0. Proof. by rewrite <-map_to_list_length, map_to_list_empty. Qed. Lemma map_size_empty_iff {A} (m : M A) : size m = 0 ↔ m = ∅. Proof. by rewrite <-map_to_list_length, length_zero_iff_nil, map_to_list_empty_iff. Qed. Lemma map_size_empty_inv {A} (m : M A) : size m = 0 → m = ∅. Proof. apply map_size_empty_iff. Qed. Lemma map_size_non_empty_iff {A} (m : M A) : size m ≠ 0 ↔ m ≠ ∅. Proof. by rewrite map_size_empty_iff. Qed. Lemma map_size_singleton {A} i (x : A) : size ({[ i := x ]} : M A) = 1. Proof. by rewrite <-map_to_list_length, map_to_list_singleton. Qed. Lemma map_size_ne_0_lookup {A} (m : M A) : size m ≠ 0 ↔ ∃ i, is_Some (m !! i). Proof. rewrite map_size_non_empty_iff. split. - intros Hsz. apply map_choose. intros Hemp. done. - intros [i [k Hi]] ->. rewrite lookup_empty in Hi. done. Qed. Lemma map_size_ne_0_lookup_1 {A} (m : M A) : size m ≠ 0 → ∃ i, is_Some (m !! i). Proof. intros. by eapply map_size_ne_0_lookup. Qed. Lemma map_size_ne_0_lookup_2 {A} (m : M A) i : is_Some (m !! i) → size m ≠ 0. Proof. intros. eapply map_size_ne_0_lookup. eauto. Qed. Lemma map_size_insert {A} i x (m : M A) : size (<[i:=x]> m) = (match m !! i with Some _ => id | None => S end) (size m). Proof. destruct (m !! i) as [y|] eqn:?; simpl. - rewrite <-(insert_id m i y) at 2 by done. rewrite <-!(insert_delete_insert m). rewrite <-!map_to_list_length. by rewrite !map_to_list_insert by (by rewrite lookup_delete). - by rewrite <-!map_to_list_length, map_to_list_insert. Qed. Lemma map_size_insert_Some {A} i x (m : M A) : is_Some (m !! i) → size (<[i:=x]> m) = size m. Proof. intros [y Hi]. by rewrite map_size_insert, Hi. Qed. Lemma map_size_insert_None {A} i x (m : M A) : m !! i = None → size (<[i:=x]> m) = S (size m). Proof. intros Hi. by rewrite map_size_insert, Hi. Qed. Lemma map_size_delete {A} i (m : M A) : size (delete i m) = (match m !! i with Some _ => pred | None => id end) (size m). Proof. destruct (m !! i) as [y|] eqn:?; simpl. - by rewrite <-!map_to_list_length, <-(map_to_list_delete m). - by rewrite delete_notin. Qed. Lemma map_size_delete_Some {A} i (m : M A) : is_Some (m !! i) → size (delete i m) = pred (size m). Proof. intros [y Hi]. by rewrite map_size_delete, Hi. Qed. Lemma map_size_delete_None {A} i (m : M A) : m !! i = None → size (delete i m) = size m. Proof. intros Hi. by rewrite map_size_delete, Hi. Qed. Lemma map_size_fmap {A B} (f : A -> B) (m : M A) : size (f <$> m) = size m. Proof. intros. by rewrite <-!map_to_list_length, map_to_list_fmap, fmap_length. Qed. Lemma map_size_list_to_map {A} (l : list (K * A)) : NoDup l.*1 → size (list_to_map l : M A) = length l. Proof. induction l; csimpl; inversion 1; simplify_eq/=; [by rewrite map_size_empty|]. rewrite map_size_insert_None by eauto using not_elem_of_list_to_map_1. eauto with f_equal. Qed. Lemma map_subseteq_size_eq {A} (m1 m2 : M A) : m1 ⊆ m2 → size m2 ≤ size m1 → m1 = m2. Proof. intros. apply map_to_list_inj, submseteq_length_Permutation. - by apply map_to_list_submseteq. - by rewrite !map_to_list_length. Qed. Lemma map_subseteq_size {A} (m1 m2 : M A) : m1 ⊆ m2 → size m1 ≤ size m2. Proof. intros. rewrite <-!map_to_list_length. by apply submseteq_length, map_to_list_submseteq. Qed. Lemma map_subset_size {A} (m1 m2 : M A) : m1 ⊂ m2 → size m1 < size m2. Proof. intros [Hm12 Hm21]. apply Nat.le_neq. split. - by apply map_subseteq_size. - intros Hsize. destruct Hm21. apply reflexive_eq, symmetry, map_subseteq_size_eq; auto with lia. Qed. (** ** Induction principles *) Lemma map_wf {A} : wf (⊂@{M A}). Proof. apply (wf_projected (<) size); auto using map_subset_size, lt_wf. Qed. Lemma map_ind {A} (P : M A → Prop) : P ∅ → (∀ i x m, m !! i = None → P m → P (<[i:=x]>m)) → ∀ m, P m. Proof. intros ? Hins m. induction (map_wf m) as [m _ IH]. destruct (map_choose_or_empty m) as [(i&x&?)| ->]; [|done]. rewrite <-(insert_delete m i x) by done. apply Hins; [by rewrite lookup_delete|]. by apply IH, delete_subset. Qed. (** ** Properties of conversion from sets *) Section set_to_map. Context {A : Type} `{FinSet B C}. Lemma lookup_set_to_map (f : B → K * A) (Y : C) i x : (∀ y y', y ∈ Y → y' ∈ Y → (f y).1 = (f y').1 → y = y') → (set_to_map f Y : M A) !! i = Some x ↔ ∃ y, y ∈ Y ∧ f y = (i,x). Proof. intros Hinj. assert (∀ x', (i, x) ∈ f <$> elements Y → (i, x') ∈ f <$> elements Y → x = x'). { intros x'. intros (y&Hx&Hy)%elem_of_list_fmap (y'&Hx'&Hy')%elem_of_list_fmap. rewrite elem_of_elements in Hy, Hy'. cut (y = y'); [congruence|]. apply Hinj; auto. by rewrite <-Hx, <-Hx'. } unfold set_to_map; rewrite <-elem_of_list_to_map' by done. rewrite elem_of_list_fmap. setoid_rewrite elem_of_elements; naive_solver. Qed. End set_to_map. Lemma lookup_set_to_map_id `{FinSet (K * A) C} (X : C) i x : (∀ i y y', (i,y) ∈ X → (i,y') ∈ X → y = y') → (set_to_map id X : M A) !! i = Some x ↔ (i,x) ∈ X. Proof. intros. etrans; [apply lookup_set_to_map|naive_solver]. intros [] [] ???; simplify_eq/=; eauto with f_equal. Qed. Section map_to_set. Context {A : Type} `{SemiSet B C}. Lemma elem_of_map_to_set (f : K → A → B) (m : M A) (y : B) : y ∈ map_to_set (C:=C) f m ↔ ∃ i x, m !! i = Some x ∧ f i x = y. Proof. unfold map_to_set; simpl. rewrite elem_of_list_to_set, elem_of_list_fmap. split. - intros ([i x] & ? & ?%elem_of_map_to_list); eauto. - intros (i&x&?&?). exists (i,x). by rewrite elem_of_map_to_list. Qed. Lemma map_to_set_empty (f : K → A → B) : map_to_set f (∅ : M A) = (∅ : C). Proof. unfold map_to_set; simpl. by rewrite map_to_list_empty. Qed. Lemma map_to_set_insert (f : K → A → B)(m : M A) i x : m !! i = None → map_to_set f (<[i:=x]>m) ≡@{C} {[f i x]} ∪ map_to_set f m. Proof. intros. unfold map_to_set; simpl. by rewrite map_to_list_insert. Qed. Lemma map_to_set_insert_L `{!LeibnizEquiv C} (f : K → A → B) (m : M A) i x : m !! i = None → map_to_set f (<[i:=x]>m) =@{C} {[f i x]} ∪ map_to_set f m. Proof. unfold_leibniz. apply map_to_set_insert. Qed. End map_to_set. Lemma elem_of_map_to_set_pair `{SemiSet (K * A) C} (m : M A) i x : (i,x) ∈@{C} map_to_set pair m ↔ m !! i = Some x. Proof. rewrite elem_of_map_to_set. naive_solver. Qed. (** ** The fold operation *) Lemma map_fold_foldr {A B} (R : relation B) `{!PreOrder R} (l : list (K * A)) (f : K → A → B → B) (b : B) m : (∀ j z, Proper (R ==> R) (f j z)) → (∀ j1 j2 z1 z2 y, j1 ≠ j2 → m !! j1 = Some z1 → m !! j2 = Some z2 → R (f j1 z1 (f j2 z2 y)) (f j2 z2 (f j1 z1 y))) → map_to_list m ≡ₚ l → R (map_fold f b m) (foldr (uncurry f) b l). Proof. intros Hf_proper. revert l. apply (map_fold_ind (λ r m, ∀ l, (∀ j1 j2 z1 z2 y, j1 ≠ j2 → m !! j1 = Some z1 → m !! j2 = Some z2 → R (f j1 z1 (f j2 z2 y)) (f j2 z2 (f j1 z1 y))) → map_to_list m ≡ₚ l → R r (foldr (uncurry f) b l))); clear m. { intros [|x l] _; simpl; [done|]. by rewrite map_to_list_empty, Permutation_nil_l. } intros i x m r ? IH l Hf Hl. rewrite map_to_list_insert in Hl by done. etrans; [|apply (foldr_permutation R), Hl]; simpl. - f_equiv. apply IH; [|done]. intros j1 j2 z1 z2 y ???. apply Hf; [done|rewrite lookup_insert_Some; naive_solver..]. - intros []; apply _. - intros j1 [k1 y1] j2 [k2 y2] c Hj Hj1 Hj2. apply Hf. + intros ->. eapply Hj, (NoDup_lookup ((i,x) :: map_to_list m).*1). * csimpl. apply NoDup_cons_2, NoDup_fst_map_to_list. intros ([??]&?&?%elem_of_map_to_list)%elem_of_list_fmap; naive_solver. * by rewrite list_lookup_fmap, Hj1. * by rewrite list_lookup_fmap, Hj2. + apply elem_of_map_to_list. rewrite map_to_list_insert by done. by eapply elem_of_list_lookup_2. + apply elem_of_map_to_list. rewrite map_to_list_insert by done. by eapply elem_of_list_lookup_2. Qed. Lemma map_fold_empty {A B} (f : K → A → B → B) (b : B) : map_fold f b ∅ = b. Proof. apply (map_fold_foldr _ []); [solve_proper|..]. - intros j1 j2 z1 z2 y. by rewrite !lookup_empty. - by rewrite map_to_list_empty. Qed. Lemma map_fold_singleton {A B} (f : K → A → B → B) (b : B) i x : map_fold f b {[i:=x]} = f i x b. Proof. apply (map_fold_foldr _ [(i,x)]); [solve_proper|..]. - intros j1 j2 z1 z2 y ?. rewrite !lookup_singleton_Some. naive_solver. - by rewrite map_to_list_singleton. Qed. Lemma map_fold_insert {A B} (R : relation B) `{!PreOrder R} (f : K → A → B → B) (b : B) (i : K) (x : A) (m : M A) : (∀ j z, Proper (R ==> R) (f j z)) → (∀ j1 j2 z1 z2 y, j1 ≠ j2 → <[i:=x]> m !! j1 = Some z1 → <[i:=x]> m !! j2 = Some z2 → R (f j1 z1 (f j2 z2 y)) (f j2 z2 (f j1 z1 y))) → m !! i = None → R (map_fold f b (<[i:=x]> m)) (f i x (map_fold f b m)). Proof. intros Hf_proper Hf Hi. trans (f i x (foldr (uncurry f) b (map_to_list m))). - apply (map_fold_foldr _ ((i,x) :: map_to_list m)); [solve_proper|done|]. by rewrite map_to_list_insert by done. - f_equiv. apply (map_fold_foldr (flip R)); [solve_proper| |done]. intros j1 j2 z1 z2 y ???. apply Hf; rewrite ?lookup_insert_Some; naive_solver. Qed. Lemma map_fold_insert_L {A B} (f : K → A → B → B) (b : B) (i : K) (x : A) (m : M A) : (∀ j1 j2 z1 z2 y, j1 ≠ j2 → <[i:=x]> m !! j1 = Some z1 → <[i:=x]> m !! j2 = Some z2 → f j1 z1 (f j2 z2 y) = f j2 z2 (f j1 z1 y)) → m !! i = None → map_fold f b (<[i:=x]> m) = f i x (map_fold f b m). Proof. apply map_fold_insert; apply _. Qed. Lemma map_fold_delete {A B} (R : relation B) `{!PreOrder R} (f : K → A → B → B) (b : B) (i : K) (x : A) (m : M A) : (∀ j z, Proper (R ==> R) (f j z)) → (∀ j1 j2 z1 z2 y, j1 ≠ j2 → m !! j1 = Some z1 → m !! j2 = Some z2 → R (f j1 z1 (f j2 z2 y)) (f j2 z2 (f j1 z1 y))) → m !! i = Some x → R (map_fold f b m) (f i x (map_fold f b (delete i m))). Proof. intros Hf_proper Hf Hi. rewrite <-map_fold_insert; [|done|done| |]. - rewrite insert_delete; done. - intros j1 j2 z1 z2 y. rewrite insert_delete_insert, insert_id by done. auto. - rewrite lookup_delete; done. Qed. Lemma map_fold_delete_L {A B} (f : K → A → B → B) (b : B) (i : K) (x : A) (m : M A) : (∀ j1 j2 z1 z2 y, j1 ≠ j2 → m !! j1 = Some z1 → m !! j2 = Some z2 → f j1 z1 (f j2 z2 y) = f j2 z2 (f j1 z1 y)) → m !! i = Some x → map_fold f b m = f i x (map_fold f b (delete i m)). Proof. apply map_fold_delete; apply _. Qed. (** This lemma for commuting [g] in/out of a [map_fold] requires [g] to be [Proper] (second premise) and [f] to be associative/commutative (third premise). Those requirements do not show up for the equivalent lemmas on sets/multisets because their fold operation is defined in terms of [foldr] on lists, so we know that both folds ([set_fold f (g x) m] and [set_fold f x m]) happen in the same order. The [map_fold_ind] principle does not guarantee this happens for [map_fold] too. *) Lemma map_fold_comm_acc_strong {A B} (R : relation B) `{!PreOrder R} (f : K → A → B → B) (g : B → B) (x : B) (m : M A) : (∀ j z, Proper (R ==> R) (f j z)) → Proper (R ==> R) g → (∀ j1 j2 z1 z2 y, j1 ≠ j2 → m !! j1 = Some z1 → m !! j2 = Some z2 → R (f j1 z1 (f j2 z2 y)) (f j2 z2 (f j1 z1 y))) → (∀ j z y, m !! j = Some z → R (f j z (g y)) (g (f j z y))) → R (map_fold f (g x) m) (g (map_fold f x m)). Proof. intros ? ? Hf Hg. apply (map_fold_ind (λ z m, (∀ j1 j2 z1 z2 y, j1 ≠ j2 → m !! j1 = Some z1 → m !! j2 = Some z2 → R (f j1 z1 (f j2 z2 y)) (f j2 z2 (f j1 z1 y))) → (∀ j z y, m !! j = Some z → R (f j z (g y)) (g (f j z y))) → R (map_fold f (g x) m) (g z))); [by rewrite map_fold_empty| |apply Hf|apply Hg]. intros i x' m' r Hx' IH Hfm' Hgm'. rewrite map_fold_insert by (apply _ || done). rewrite <-Hgm' by (by rewrite lookup_insert). f_equiv. apply IH. - intros j1 j2 z1 z2 y Hjs Hl1 Hl2. apply Hfm'; [done|rewrite lookup_insert_Some; naive_solver..]. - intros j z y Hj. apply Hgm'. rewrite lookup_insert_ne by naive_solver. done. Qed. Lemma map_fold_comm_acc {A} (f : K → A → A → A) (g : A → A) (x : A) (m : M A) : (∀ j1 j2 z1 z2 y, f j1 z1 (f j2 z2 y) = f j2 z2 (f j1 z1 y)) → (∀ j z y, f j z (g y) = g (f j z y)) → map_fold f (g x) m = g (map_fold f x m). Proof. intros. apply (map_fold_comm_acc_strong _); [solve_proper|solve_proper|done..]. Qed. (** ** Properties of the [map_Forall] predicate *) Section map_Forall. Context {A} (P : K → A → Prop). Implicit Types m : M A. Lemma map_Forall_to_list m : map_Forall P m ↔ Forall (uncurry P) (map_to_list m). Proof. rewrite Forall_forall. split. - intros Hforall [i x]. rewrite elem_of_map_to_list. by apply (Hforall i x). - intros Hforall i x. rewrite <-elem_of_map_to_list. by apply (Hforall (i,x)). Qed. Lemma map_Forall_empty : map_Forall P (∅ : M A). Proof. intros i x. by rewrite lookup_empty. Qed. Lemma map_Forall_impl (Q : K → A → Prop) m : map_Forall P m → (∀ i x, P i x → Q i x) → map_Forall Q m. Proof. unfold map_Forall; naive_solver. Qed. Lemma map_Forall_insert_1_1 m i x : map_Forall P (<[i:=x]>m) → P i x. Proof. intros Hm. by apply Hm; rewrite lookup_insert. Qed. Lemma map_Forall_insert_1_2 m i x : m !! i = None → map_Forall P (<[i:=x]>m) → map_Forall P m. Proof. intros ? Hm j y ?; apply Hm. by rewrite lookup_insert_ne by congruence. Qed. Lemma map_Forall_insert_2 m i x : P i x → map_Forall P m → map_Forall P (<[i:=x]>m). Proof. intros ?? j y; rewrite lookup_insert_Some; naive_solver. Qed. Lemma map_Forall_insert m i x : m !! i = None → map_Forall P (<[i:=x]>m) ↔ P i x ∧ map_Forall P m. Proof. naive_solver eauto using map_Forall_insert_1_1, map_Forall_insert_1_2, map_Forall_insert_2. Qed. Lemma map_Forall_singleton (i : K) (x : A) : map_Forall P ({[i := x]} : M A) ↔ P i x. Proof. unfold map_Forall. setoid_rewrite lookup_singleton_Some. naive_solver. Qed. Lemma map_Forall_delete m i : map_Forall P m → map_Forall P (delete i m). Proof. intros Hm j x; rewrite lookup_delete_Some. naive_solver. Qed. Lemma map_Forall_lookup m : map_Forall P m ↔ ∀ i x, m !! i = Some x → P i x. Proof. done. Qed. Lemma map_Forall_lookup_1 m i x : map_Forall P m → m !! i = Some x → P i x. Proof. intros ?. by apply map_Forall_lookup. Qed. Lemma map_Forall_lookup_2 m : (∀ i x, m !! i = Some x → P i x) → map_Forall P m. Proof. intros ?. by apply map_Forall_lookup. Qed. Lemma map_Forall_fmap {B} (f : B → A) (m : M B) : map_Forall P (f <$> m) ↔ map_Forall (λ k, (P k ∘ f)) m. Proof. unfold map_Forall. setoid_rewrite lookup_fmap. setoid_rewrite fmap_Some. naive_solver. Qed. Lemma map_Forall_foldr_delete m is : map_Forall P m → map_Forall P (foldr delete m is). Proof. induction is; eauto using map_Forall_delete. Qed. Lemma map_Forall_ind (Q : M A → Prop) : Q ∅ → (∀ m i x, m !! i = None → P i x → map_Forall P m → Q m → Q (<[i:=x]>m)) → ∀ m, map_Forall P m → Q m. Proof. intros Hnil Hinsert m. induction m using map_ind; auto. rewrite map_Forall_insert by done; intros [??]; eauto. Qed. Context `{∀ i x, Decision (P i x)}. Global Instance map_Forall_dec m : Decision (map_Forall P m). Proof. refine (cast_if (decide (Forall (uncurry P) (map_to_list m)))); by rewrite map_Forall_to_list. Defined. Lemma map_not_Forall (m : M A) : ¬map_Forall P m ↔ ∃ i x, m !! i = Some x ∧ ¬P i x. Proof. split; [|intros (i&x&?&?) Hm; specialize (Hm i x); tauto]. rewrite map_Forall_to_list. intros Hm. apply (not_Forall_Exists _), Exists_exists in Hm. destruct Hm as ([i x]&?&?). exists i, x. by rewrite <-elem_of_map_to_list. Qed. End map_Forall. (** ** Properties of the [map_Exists] predicate *) Section map_Exists. Context {A} (P : K → A → Prop). Implicit Types m : M A. Lemma map_Exists_to_list m : map_Exists P m ↔ Exists (uncurry P) (map_to_list m). Proof. rewrite Exists_exists. split. - intros [? [? [? ?]]]. eexists (_, _). by rewrite elem_of_map_to_list. - intros [[??] [??]]. eexists _, _. by rewrite <-elem_of_map_to_list. Qed. Lemma map_Exists_empty : ¬ map_Exists P (∅ : M A). Proof. intros [?[?[Hm ?]]]. by rewrite lookup_empty in Hm. Qed. Lemma map_Exists_impl (Q : K → A → Prop) m : map_Exists P m → (∀ i x, P i x → Q i x) → map_Exists Q m. Proof. unfold map_Exists; naive_solver. Qed. Lemma map_Exists_insert_1 m i x : map_Exists P (<[i:=x]>m) → P i x ∨ map_Exists P m. Proof. intros [j[y[?%lookup_insert_Some ?]]]. unfold map_Exists. naive_solver. Qed. Lemma map_Exists_insert_2_1 m i x : P i x → map_Exists P (<[i:=x]>m). Proof. intros Hm. exists i, x. by rewrite lookup_insert. Qed. Lemma map_Exists_insert_2_2 m i x : m !! i = None → map_Exists P m → map_Exists P (<[i:=x]>m). Proof. intros Hm [j[y[??]]]. exists j, y. by rewrite lookup_insert_ne by congruence. Qed. Lemma map_Exists_insert m i x : m !! i = None → map_Exists P (<[i:=x]>m) ↔ P i x ∨ map_Exists P m. Proof. naive_solver eauto using map_Exists_insert_1, map_Exists_insert_2_1, map_Exists_insert_2_2. Qed. Lemma map_Exists_singleton (i : K) (x : A) : map_Exists P ({[i := x]} : M A) ↔ P i x. Proof. unfold map_Exists. setoid_rewrite lookup_singleton_Some. naive_solver. Qed. Lemma map_Exists_delete m i : map_Exists P (delete i m) → map_Exists P m. Proof. intros [j [y [Hm ?]]]. rewrite lookup_delete_Some in Hm. unfold map_Exists. naive_solver. Qed. Lemma map_Exists_lookup m : map_Exists P m ↔ ∃ i x, m !! i = Some x ∧ P i x. Proof. done. Qed. Lemma map_Exists_lookup_1 m : map_Exists P m → ∃ i x, m !! i = Some x ∧ P i x. Proof. by rewrite map_Exists_lookup. Qed. Lemma map_Exists_lookup_2 m i x : m !! i = Some x → P i x → map_Exists P m. Proof. rewrite map_Exists_lookup. by eauto. Qed. Lemma map_Exists_foldr_delete m is : map_Exists P (foldr delete m is) → map_Exists P m. Proof. induction is; eauto using map_Exists_delete. Qed. Lemma map_Exists_ind (Q : M A → Prop) : (∀ i x, P i x → Q {[ i := x ]}) → (∀ m i x, m !! i = None → map_Exists P m → Q m → Q (<[i:=x]>m)) → ∀ m, map_Exists P m → Q m. Proof. intros Hsingleton Hinsert m Hm. induction m as [|i x m Hi IH] using map_ind. { by destruct map_Exists_empty. } apply map_Exists_insert in Hm as [?|?]; [|by eauto..]. clear IH. induction m as [|j y m Hj IH] using map_ind; [by eauto|]. apply lookup_insert_None in Hi as [??]. rewrite insert_commute by done. apply Hinsert. - by apply lookup_insert_None. - apply map_Exists_insert; by eauto. - eauto. Qed. Lemma map_not_Exists (m : M A) : ¬map_Exists P m ↔ map_Forall (λ i x, ¬ P i x) m. Proof. unfold map_Exists, map_Forall; naive_solver. Qed. Context `{∀ i x, Decision (P i x)}. Global Instance map_Exists_dec m : Decision (map_Exists P m). Proof. refine (cast_if (decide (Exists (uncurry P) (map_to_list m)))); by rewrite map_Exists_to_list. Defined. End map_Exists. (** ** The filter operation *) Section map_lookup_filter. Context {A} (P : K * A → Prop) `{!∀ x, Decision (P x)}. Implicit Types m : M A. Lemma map_lookup_filter m i : filter P m !! i = x ← m !! i; guard (P (i,x)); Some x. Proof. revert m i. apply (map_fold_ind (λ m1 m2, ∀ i, m1 !! i = x ← m2 !! i; guard (P (i,x)); Some x)); intros i. { by rewrite lookup_empty. } intros y m m' Hm IH j. case (decide (j = i))as [->|?]. - case_decide. + rewrite !lookup_insert. simpl. by rewrite option_guard_True. + rewrite lookup_insert. simpl. by rewrite option_guard_False, IH, Hm. - case_decide. + by rewrite !lookup_insert_ne by done. + by rewrite !lookup_insert_ne. Qed. Lemma map_lookup_filter_Some m i x : filter P m !! i = Some x ↔ m !! i = Some x ∧ P (i, x). Proof. rewrite map_lookup_filter. destruct (m !! i); simpl; repeat case_option_guard; naive_solver. Qed. Lemma map_lookup_filter_Some_1_1 m i x : filter P m !! i = Some x → m !! i = Some x. Proof. apply map_lookup_filter_Some. Qed. Lemma map_lookup_filter_Some_1_2 m i x : filter P m !! i = Some x → P (i, x). Proof. apply map_lookup_filter_Some. Qed. Lemma map_lookup_filter_Some_2 m i x : m !! i = Some x → P (i, x) → filter P m !! i = Some x. Proof. intros. by apply map_lookup_filter_Some. Qed. Lemma map_lookup_filter_None m i : filter P m !! i = None ↔ m !! i = None ∨ ∀ x, m !! i = Some x → ¬ P (i, x). Proof. rewrite eq_None_not_Some. unfold is_Some. setoid_rewrite map_lookup_filter_Some. naive_solver. Qed. Lemma map_lookup_filter_None_1 m i : filter P m !! i = None → m !! i = None ∨ ∀ x, m !! i = Some x → ¬ P (i, x). Proof. apply map_lookup_filter_None. Qed. Lemma map_lookup_filter_None_2 m i : m !! i = None ∨ (∀ x : A, m !! i = Some x → ¬ P (i, x)) → filter P m !! i = None. Proof. apply map_lookup_filter_None. Qed. Lemma map_filter_empty_not_lookup m i x : filter P m = ∅ → P (i,x) → m !! i ≠ Some x. Proof. rewrite map_empty. setoid_rewrite map_lookup_filter_None. intros Hm ?. destruct (Hm i); naive_solver. Qed. End map_lookup_filter. Section map_filter_ext. Context {A} (P Q : K * A → Prop) `{!∀ x, Decision (P x), !∀ x, Decision (Q x)}. Lemma map_filter_strong_ext (m1 m2 : M A) : filter P m1 = filter Q m2 ↔ (∀ i x, (P (i, x) ∧ m1 !! i = Some x) ↔ (Q (i, x) ∧ m2 !! i = Some x)). Proof. intros. rewrite map_eq_iff. setoid_rewrite option_eq. setoid_rewrite map_lookup_filter_Some. naive_solver. Qed. Lemma map_filter_strong_ext_1 (m1 m2 : M A) : (∀ i x, (P (i, x) ∧ m1 !! i = Some x) ↔ (Q (i, x) ∧ m2 !! i = Some x)) → filter P m1 = filter Q m2. Proof. by rewrite map_filter_strong_ext. Qed. Lemma map_filter_strong_ext_2 (m1 m2 : M A) i x : filter P m1 = filter Q m2 → (P (i, x) ∧ m1 !! i = Some x) ↔ (Q (i, x) ∧ m2 !! i = Some x). Proof. by rewrite map_filter_strong_ext. Qed. Lemma map_filter_ext (m : M A) : (∀ i x, m !! i = Some x → P (i, x) ↔ Q (i, x)) ↔ filter P m = filter Q m. Proof. rewrite map_filter_strong_ext. naive_solver. Qed. Lemma map_filter_strong_subseteq_ext (m1 m2 : M A) : filter P m1 ⊆ filter Q m2 ↔ (∀ i x, (P (i, x) ∧ m1 !! i = Some x) → (Q (i, x) ∧ m2 !! i = Some x)). Proof. rewrite map_subseteq_spec. setoid_rewrite map_lookup_filter_Some. naive_solver. Qed. Lemma map_filter_subseteq_ext (m : M A) : filter P m ⊆ filter Q m ↔ (∀ i x, m !! i = Some x → P (i, x) → Q (i, x)). Proof. rewrite map_filter_strong_subseteq_ext. naive_solver. Qed. End map_filter_ext. Section map_filter. Context {A} (P : K * A → Prop) `{!∀ x, Decision (P x)}. Implicit Types m : M A. Lemma map_filter_empty : filter P ∅ =@{M A} ∅. Proof. apply map_fold_empty. Qed. Lemma map_filter_empty_iff m : filter P m = ∅ ↔ map_Forall (λ i x, ¬P (i,x)) m. Proof. rewrite map_empty. setoid_rewrite map_lookup_filter_None. split. - intros Hm i x Hi. destruct (Hm i); naive_solver. - intros Hm i. destruct (m !! i) as [x|] eqn:?; [|by auto]. right; intros ? [= <-]. by apply Hm. Qed. Lemma map_filter_delete m i : filter P (delete i m) = delete i (filter P m). Proof. apply map_eq. intros j. apply option_eq; intros y. destruct (decide (j = i)) as [->|?]. - rewrite map_lookup_filter_Some, !lookup_delete. naive_solver. - rewrite lookup_delete_ne, !map_lookup_filter_Some, lookup_delete_ne by done. naive_solver. Qed. Lemma map_filter_delete_not m i: (∀ y, m !! i = Some y → ¬ P (i, y)) → filter P (delete i m) = filter P m. Proof. intros. apply map_filter_strong_ext. intros j y. rewrite lookup_delete_Some. naive_solver. Qed. Lemma map_filter_insert m i x : filter P (<[i:=x]> m) = if decide (P (i, x)) then <[i:=x]> (filter P m) else filter P (delete i m). Proof. apply map_eq. intros j. apply option_eq; intros y. rewrite map_lookup_filter_Some, lookup_insert_Some. case_decide. - rewrite lookup_insert_Some, map_lookup_filter_Some. naive_solver. - rewrite map_lookup_filter_Some, lookup_delete_Some. naive_solver. Qed. Lemma map_filter_insert_True m i x : P (i, x) → filter P (<[i:=x]> m) = <[i:=x]> (filter P m). Proof. intros. by rewrite map_filter_insert, decide_True. Qed. Lemma map_filter_insert_False m i x : ¬ P (i, x) → filter P (<[i:=x]> m) = filter P (delete i m). Proof. intros. by rewrite map_filter_insert, decide_False. Qed. Lemma map_filter_insert_not' m i x : ¬ P (i, x) → (∀ y, m !! i = Some y → ¬ P (i, y)) → filter P (<[i:=x]> m) = filter P m. Proof. intros. rewrite map_filter_insert, decide_False by done. by rewrite map_filter_delete_not. Qed. Lemma map_filter_insert_not m i x : (∀ y, ¬ P (i, y)) → filter P (<[i:=x]> m) = filter P m. Proof. intros. by apply map_filter_insert_not'. Qed. Lemma map_filter_singleton i x : filter P {[i := x]} =@{M A} if decide (P (i, x)) then {[i := x]} else ∅. Proof. by rewrite <-!insert_empty, map_filter_insert, delete_empty, map_filter_empty. Qed. Lemma map_filter_singleton_True i x : P (i, x) → filter P {[i := x]} =@{M A} {[i := x]}. Proof. intros. by rewrite map_filter_singleton, decide_True. Qed. Lemma map_filter_singleton_False i x : ¬ P (i, x) → filter P {[i := x]} =@{M A} ∅. Proof. intros. by rewrite map_filter_singleton, decide_False. Qed. Lemma map_filter_alt m : filter P m = list_to_map (filter P (map_to_list m)). Proof. apply list_to_map_flip. induction m as [|k x m ? IH] using map_ind. { by rewrite map_to_list_empty, map_filter_empty, map_to_list_empty. } rewrite map_to_list_insert, filter_cons by done. destruct (decide (P _)). - rewrite map_filter_insert_True by done. by rewrite map_to_list_insert, IH by (rewrite map_lookup_filter_None; auto). - by rewrite map_filter_insert_not' by naive_solver. Qed. Lemma map_filter_fmap {B} (f : B → A) (m : M B) : filter P (f <$> m) = f <$> filter (λ '(i, x), P (i, (f x))) m. Proof. apply map_eq. intros i. apply option_eq; intros x. repeat (rewrite lookup_fmap, fmap_Some || setoid_rewrite map_lookup_filter_Some). naive_solver. Qed. Lemma map_filter_filter Q `{!∀ x, Decision (Q x)} m : filter P (filter Q m) = filter (λ '(i, x), P (i, x) ∧ Q (i, x)) m. Proof. apply map_filter_strong_ext. intros ??. rewrite map_lookup_filter_Some. naive_solver. Qed. Lemma map_filter_filter_l Q `{!∀ x, Decision (Q x)} m : (∀ i x, m !! i = Some x → P (i, x) → Q (i, x)) → filter P (filter Q m) = filter P m. Proof. intros ?. rewrite map_filter_filter. apply map_filter_ext. naive_solver. Qed. Lemma map_filter_filter_r Q `{!∀ x, Decision (Q x)} m : (∀ i x, m !! i = Some x → Q (i, x) → P (i, x)) → filter P (filter Q m) = filter Q m. Proof. intros ?. rewrite map_filter_filter. apply map_filter_ext. naive_solver. Qed. Lemma map_filter_id m : (∀ i x, m !! i = Some x → P (i, x)) → filter P m = m. Proof. intros Hi. apply map_eq. intros i. rewrite map_lookup_filter. destruct (m !! i) eqn:Hlook; [|done]. apply option_guard_True, Hi, Hlook. Qed. Lemma map_filter_subseteq m : filter P m ⊆ m. Proof. apply map_subseteq_spec, map_lookup_filter_Some_1_1. Qed. Lemma map_filter_subseteq_mono m1 m2 : m1 ⊆ m2 → filter P m1 ⊆ filter P m2. Proof. rewrite map_subseteq_spec. intros Hm1m2. apply map_filter_strong_subseteq_ext. naive_solver. Qed. Lemma map_size_filter m : size (filter P m) ≤ size m. Proof. apply map_subseteq_size. apply map_filter_subseteq. Qed. End map_filter. Lemma map_filter_comm {A} (P Q : K * A → Prop) `{!∀ x, Decision (P x), !∀ x, Decision (Q x)} (m : M A) : filter P (filter Q m) = filter Q (filter P m). Proof. rewrite !map_filter_filter. apply map_filter_ext. naive_solver. Qed. (** ** Properties of the [merge] operation *) Section merge. Context {A} (f : option A → option A → option A). Implicit Types m : M A. (** These instances can in many cases not be applied automatically due to Coq unification bug #6294. Hence there are many explicit derived instances for specific operations such as union or difference in the rest of this file. *) Global Instance: LeftId (=) None f → LeftId (=@{M A}) ∅ (merge f). Proof. intros ? m. apply map_eq; intros i. rewrite !lookup_merge, lookup_empty. destruct (m !! i); by simpl. Qed. Global Instance: RightId (=) None f → RightId (=@{M A}) ∅ (merge f). Proof. intros ? m. apply map_eq; intros i. rewrite !lookup_merge, lookup_empty. destruct (m !! i); by simpl. Qed. Global Instance: LeftAbsorb (=) None f → LeftAbsorb (=@{M A}) ∅ (merge f). Proof. intros ? m. apply map_eq; intros i. rewrite !lookup_merge, lookup_empty. destruct (m !! i); by simpl. Qed. Global Instance: RightAbsorb (=) None f → RightAbsorb (=@{M A}) ∅ (merge f). Proof. intros ? m. apply map_eq; intros i. rewrite !lookup_merge, lookup_empty. destruct (m !! i); by simpl. Qed. Lemma merge_comm m1 m2 : (∀ i, f (m1 !! i) (m2 !! i) = f (m2 !! i) (m1 !! i)) → merge f m1 m2 = merge f m2 m1. Proof. intros Hm. apply map_eq; intros i. specialize (Hm i). rewrite !lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. Global Instance merge_comm' : Comm (=) f → Comm (=@{M A}) (merge f). Proof. intros ???. apply merge_comm. intros. by apply (comm f). Qed. Lemma merge_assoc m1 m2 m3 : (∀ i, diag_None f (m1 !! i) (diag_None f (m2 !! i) (m3 !! i)) = diag_None f (diag_None f (m1 !! i) (m2 !! i)) (m3 !! i)) → merge f m1 (merge f m2 m3) = merge f (merge f m1 m2) m3. Proof. intros Hm. apply map_eq; intros i. specialize (Hm i). by rewrite !lookup_merge. Qed. Lemma merge_idemp m1 : (∀ i, f (m1 !! i) (m1 !! i) = m1 !! i) → merge f m1 m1 = m1. Proof. intros Hm. apply map_eq; intros i. specialize (Hm i). rewrite !lookup_merge. by destruct (m1 !! i). Qed. Global Instance merge_idemp' : IdemP (=) f → IdemP (=@{M A}) (merge f). Proof. intros ??. apply merge_idemp. intros. by apply (idemp f). Qed. End merge. Section more_merge. Context {A B C} (f : option A → option B → option C). Lemma merge_Some (m1 : M A) (m2 : M B) (m : M C) : f None None = None → (∀ i, m !! i = f (m1 !! i) (m2 !! i)) ↔ merge f m1 m2 = m. Proof. intros. rewrite map_eq_iff. apply forall_proper; intros i. rewrite lookup_merge. destruct (m1 !! i), (m2 !! i); naive_solver congruence. Qed. Lemma merge_empty : merge f ∅ ∅ =@{M C} ∅. Proof. apply map_eq. intros. by rewrite !lookup_merge, !lookup_empty. Qed. Lemma partial_alter_merge g g1 g2 (m1 : M A) (m2 : M B) i : g (diag_None f (m1 !! i) (m2 !! i)) = diag_None f (g1 (m1 !! i)) (g2 (m2 !! i)) → partial_alter g i (merge f m1 m2) = merge f (partial_alter g1 i m1) (partial_alter g2 i m2). Proof. intro. apply map_eq. intros j. destruct (decide (i = j)); subst. - by rewrite lookup_merge, !lookup_partial_alter, !lookup_merge. - by rewrite lookup_merge, !lookup_partial_alter_ne, lookup_merge. Qed. Lemma partial_alter_merge_l g g1 (m1 : M A) (m2 : M B) i : g (diag_None f (m1 !! i) (m2 !! i)) = diag_None f (g1 (m1 !! i)) (m2 !! i) → partial_alter g i (merge f m1 m2) = merge f (partial_alter g1 i m1) m2. Proof. intro. apply map_eq. intros j. destruct (decide (i = j)); subst. - by rewrite lookup_merge, !lookup_partial_alter, !lookup_merge. - by rewrite lookup_merge, !lookup_partial_alter_ne, lookup_merge. Qed. Lemma partial_alter_merge_r g g2 (m1 : M A) (m2 : M B) i : g (diag_None f (m1 !! i) (m2 !! i)) = diag_None f (m1 !! i) (g2 (m2 !! i)) → partial_alter g i (merge f m1 m2) = merge f m1 (partial_alter g2 i m2). Proof. intro. apply map_eq. intros j. destruct (decide (i = j)); subst. - by rewrite lookup_merge, !lookup_partial_alter, !lookup_merge. - by rewrite lookup_merge, !lookup_partial_alter_ne, lookup_merge. Qed. Lemma insert_merge (m1 : M A) (m2 : M B) i x y z : f (Some y) (Some z) = Some x → <[i:=x]>(merge f m1 m2) = merge f (<[i:=y]>m1) (<[i:=z]>m2). Proof. intros; by apply partial_alter_merge. Qed. Lemma delete_merge (m1 : M A) (m2 : M B) i : delete i (merge f m1 m2) = merge f (delete i m1) (delete i m2). Proof. intros; by apply partial_alter_merge. Qed. Lemma merge_singleton i x y z : f (Some y) (Some z) = Some x → merge f {[i := y]} {[i := z]} =@{M C} {[i := x]}. Proof. intros. by erewrite <-!insert_empty, <-insert_merge, merge_empty by eauto. Qed. Lemma insert_merge_l (m1 : M A) (m2 : M B) i x y : f (Some y) (m2 !! i) = Some x → <[i:=x]>(merge f m1 m2) = merge f (<[i:=y]>m1) m2. Proof. by intros; apply partial_alter_merge_l. Qed. Lemma insert_merge_r (m1 : M A) (m2 : M B) i x z : f (m1 !! i) (Some z) = Some x → <[i:=x]>(merge f m1 m2) = merge f m1 (<[i:=z]>m2). Proof. intros; apply partial_alter_merge_r. by destruct (m1 !! i). Qed. Lemma fmap_merge {D} (g : C → D) (m1 : M A) (m2 : M B) : g <$> merge f m1 m2 = merge (λ mx1 mx2, g <$> f mx1 mx2) m1 m2. Proof. apply map_eq; intros i. rewrite lookup_fmap, !lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. Lemma omap_merge {D} (g : C → option D) (m1 : M A) (m2 : M B) : omap g (merge f m1 m2) = merge (λ mx1 mx2, f mx1 mx2 ≫= g) m1 m2. Proof. apply map_eq; intros i. rewrite lookup_omap, !lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. End more_merge. Lemma merge_empty_l {A B C} (f : option A → option B → option C) (m2 : M B) : merge f ∅ m2 = omap (f None ∘ Some) m2. Proof. apply map_eq; intros i. rewrite lookup_merge, lookup_omap, lookup_empty. by destruct (m2 !! i). Qed. Lemma merge_empty_r {A B C} (f : option A → option B → option C) (m1 : M A) : merge f m1 ∅ = omap (flip f None ∘ Some) m1. Proof. apply map_eq; intros i. rewrite lookup_merge, lookup_omap, lookup_empty. by destruct (m1 !! i). Qed. Lemma merge_diag {A C} (f : option A → option A → option C) (m : M A) : merge f m m = omap (λ x, f (Some x) (Some x)) m. Proof. apply map_eq. intros i. rewrite lookup_merge, lookup_omap. by destruct (m !! i). Qed. (** Properties of the [map_zip_with] and [map_zip] functions *) Lemma map_lookup_zip_with {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) i : map_zip_with f m1 m2 !! i = (x ← m1 !! i; y ← m2 !! i; Some (f x y)). Proof. unfold map_zip_with. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. Lemma map_lookup_zip_with_Some {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) i z : map_zip_with f m1 m2 !! i = Some z ↔ ∃ x y, z = f x y ∧ m1 !! i = Some x ∧ m2 !! i = Some y. Proof. rewrite map_lookup_zip_with. destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_lookup_zip_with_None {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) i : map_zip_with f m1 m2 !! i = None ↔ m1 !! i = None ∨ m2 !! i = None. Proof. rewrite map_lookup_zip_with. destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_lookup_zip_Some {A B} (m1 : M A) (m2 : M B) i p : map_zip m1 m2 !! i = Some p ↔ m1 !! i = Some p.1 ∧ m2 !! i = Some p.2. Proof. rewrite map_lookup_zip_with_Some. destruct p. naive_solver. Qed. Lemma map_zip_with_empty {A B C} (f : A → B → C) : map_zip_with f ∅ ∅ =@{M C} ∅. Proof. unfold map_zip_with. by rewrite merge_empty by done. Qed. Lemma map_zip_with_empty_l {A B C} (f : A → B → C) m2 : map_zip_with f ∅ m2 =@{M C} ∅. Proof. unfold map_zip_with. apply map_eq; intros i. rewrite lookup_merge, !lookup_empty. destruct (m2 !! i); done. Qed. Lemma map_zip_with_empty_r {A B C} (f : A → B → C) m1 : map_zip_with f m1 ∅ =@{M C} ∅. Proof. unfold map_zip_with. apply map_eq; intros i. rewrite lookup_merge, !lookup_empty. destruct (m1 !! i); done. Qed. Lemma map_insert_zip_with {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) i y z : <[i:=f y z]>(map_zip_with f m1 m2) = map_zip_with f (<[i:=y]>m1) (<[i:=z]>m2). Proof. unfold map_zip_with. by erewrite insert_merge by done. Qed. Lemma map_delete_zip_with {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) i : delete i (map_zip_with f m1 m2) = map_zip_with f (delete i m1) (delete i m2). Proof. unfold map_zip_with. by rewrite delete_merge. Qed. Lemma map_zip_with_singleton {A B C} (f : A → B → C) i x y : map_zip_with f {[ i := x ]} {[ i := y ]} =@{M C} {[ i := f x y ]}. Proof. unfold map_zip_with. by erewrite merge_singleton. Qed. Lemma map_zip_with_fmap {A' A B' B C} (f : A → B → C) (g1 : A' → A) (g2 : B' → B) (m1 : M A') (m2 : M B') : map_zip_with f (g1 <$> m1) (g2 <$> m2) = map_zip_with (λ x y, f (g1 x) (g2 y)) m1 m2. Proof. apply map_eq; intro i. rewrite !map_lookup_zip_with, !lookup_fmap. by destruct (m1 !! i), (m2 !! i). Qed. Lemma map_zip_with_fmap_1 {A' A B C} (f : A → B → C) (g : A' → A) (m1 : M A') (m2 : M B) : map_zip_with f (g <$> m1) m2 = map_zip_with (λ x y, f (g x) y) m1 m2. Proof. rewrite <- (map_fmap_id m2) at 1. by rewrite map_zip_with_fmap. Qed. Lemma map_zip_with_fmap_2 {A B' B C} (f : A → B → C) (g : B' → B) (m1 : M A) (m2 : M B') : map_zip_with f m1 (g <$> m2) = map_zip_with (λ x y, f x (g y)) m1 m2. Proof. rewrite <-(map_fmap_id m1) at 1. by rewrite map_zip_with_fmap. Qed. Lemma map_fmap_zip_with {A B C D} (f : A → B → C) (g : C → D) (m1 : M A) (m2 : M B) : g <$> map_zip_with f m1 m2 = map_zip_with (λ x y, g (f x y)) m1 m2. Proof. apply map_eq; intro i. rewrite lookup_fmap, !map_lookup_zip_with. by destruct (m1 !! i), (m2 !! i). Qed. Lemma map_zip_with_flip {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) : map_zip_with (flip f) m2 m1 = map_zip_with f m1 m2. Proof. apply map_eq; intro i. rewrite !map_lookup_zip_with. by destruct (m1 !! i), (m2 !! i). Qed. Lemma map_zip_with_map_zip {A B C} (f : A → B → C) (m1 : M A) (m2 : M B) : map_zip_with f m1 m2 = uncurry f <$> map_zip m1 m2. Proof. apply map_eq; intro i. rewrite lookup_fmap, !map_lookup_zip_with. by destruct (m1 !! i), (m2 !! i). Qed. Lemma map_fmap_zip {A' A B' B} (g1 : A' → A) (g2 : B' → B) (m1 : M A') (m2 : M B') : map_zip (fmap g1 m1) (fmap g2 m2) = prod_map g1 g2 <$> map_zip m1 m2. Proof. rewrite map_zip_with_fmap, map_zip_with_map_zip. generalize (map_zip m1 m2); intro m. apply map_eq; intro i. by rewrite !lookup_fmap; destruct (m !! i) as [[x1 x2]|]. Qed. Lemma map_fmap_zip_with_l {A B C} (f : A → B → C) (g : C → A) (m1 : M A) (m2 : M B) : (∀ x y, g (f x y) = x) → (∀ k, is_Some (m1 !! k) → is_Some (m2 !! k)) → g <$> map_zip_with f m1 m2 = m1. Proof. intros ? Hm. apply map_eq; intros k. rewrite lookup_fmap, map_lookup_zip_with. destruct (m1 !! _) as [x|] eqn:?; simpl; [|done]. destruct (Hm k) as [y ->]; [by eauto|]. by f_equal/=. Qed. Lemma map_fmap_zip_with_r {A B C} (f : A → B → C) (g : C → B) (m1 : M A) (m2 : M B) : (∀ x y, g (f x y) = y) → (∀ k, is_Some (m2 !! k) → is_Some (m1 !! k)) → g <$> map_zip_with f m1 m2 = m2. Proof. intros ? Hm. apply map_eq; intros k. rewrite lookup_fmap, map_lookup_zip_with. destruct (m2 !! _) as [x|] eqn:?; simpl; [|by destruct (m1 !! _)]. destruct (Hm k) as [y ->]; [by eauto|]. by f_equal/=. Qed. Lemma map_zip_with_diag {A C} (f : A → A → C) (m : M A) : map_zip_with f m m = (λ x, f x x) <$> m. Proof. unfold map_zip_with. by rewrite merge_diag, map_fmap_alt. Qed. Lemma map_zip_diag {A} (m : M A) : map_zip m m = (λ x, (x, x)) <$> m. Proof. apply map_zip_with_diag. Qed. Lemma fst_map_zip {A B} (m1 : M A) (m2 : M B) : (∀ k : K, is_Some (m1 !! k) → is_Some (m2 !! k)) → fst <$> map_zip m1 m2 = m1. Proof. intros ?. by apply map_fmap_zip_with_l. Qed. Lemma snd_map_zip {A B} (m1 : M A) (m2 : M B) : (∀ k : K, is_Some (m2 !! k) → is_Some (m1 !! k)) → snd <$> map_zip m1 m2 = m2. Proof. intros ?. by apply map_fmap_zip_with_r. Qed. Lemma map_zip_fst_snd {A B} (m : M (A * B)) : map_zip (fst <$> m) (snd <$> m) = m. Proof. apply map_eq; intros k. rewrite map_lookup_zip_with, !lookup_fmap. by destruct (m !! k) as [[]|]. Qed. (** ** Properties on the [map_relation] relation *) Section Forall2. Context {A B} (R : A → B → Prop) (P : A → Prop) (Q : B → Prop). Context `{∀ x y, Decision (R x y), ∀ x, Decision (P x), ∀ y, Decision (Q y)}. Let f (mx : option A) (my : option B) : option bool := match mx, my with | Some x, Some y => Some (bool_decide (R x y)) | Some x, None => Some (bool_decide (P x)) | None, Some y => Some (bool_decide (Q y)) | None, None => None end. Lemma map_relation_alt (m1 : M A) (m2 : M B) : map_relation R P Q m1 m2 ↔ map_Forall (λ _, Is_true) (merge f m1 m2). Proof. split. - intros Hm i P'; rewrite lookup_merge; intros. specialize (Hm i). destruct (m1 !! i), (m2 !! i); simplify_eq/=; auto using bool_decide_pack. - intros Hm i. specialize (Hm i). rewrite lookup_merge in Hm. destruct (m1 !! i), (m2 !! i); simplify_eq/=; auto; by eapply bool_decide_unpack, Hm. Qed. Global Instance map_relation_dec : RelDecision (map_relation (M:=M) R P Q). Proof. refine (λ m1 m2, cast_if (decide (map_Forall (λ _, Is_true) (merge f m1 m2)))); abstract by rewrite map_relation_alt. Defined. (** Due to the finiteness of finite maps, we can extract a witness if the relation does not hold. *) Lemma map_not_Forall2 (m1 : M A) (m2 : M B) : ¬map_relation R P Q m1 m2 ↔ ∃ i, (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ ¬R x y) ∨ (∃ x, m1 !! i = Some x ∧ m2 !! i = None ∧ ¬P x) ∨ (∃ y, m1 !! i = None ∧ m2 !! i = Some y ∧ ¬Q y). Proof. split. - rewrite map_relation_alt, (map_not_Forall _). intros (i&?&Hm&?); exists i. rewrite lookup_merge in Hm. destruct (m1 !! i), (m2 !! i); naive_solver auto 2 using bool_decide_pack. - unfold map_relation, option_relation. by intros [i[(x&y&?&?&?)|[(x&?&?&?)|(y&?&?&?)]]] Hm; specialize (Hm i); simplify_option_eq. Qed. End Forall2. (** ** Properties of the [map_agree] operation *) Lemma map_agree_spec {A} (m1 m2 : M A) : map_agree m1 m2 ↔ ∀ i x y, m1 !! i = Some x → m2 !! i = Some y → x = y. Proof. apply forall_proper; intros i; destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_agree_alt {A} (m1 m2 : M A) : map_agree m1 m2 ↔ ∀ i, m1 !! i = None ∨ m2 !! i = None ∨ m1 !! i = m2 !! i. Proof. apply forall_proper; intros i; destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_not_agree {A} (m1 m2 : M A) `{!EqDecision A}: ¬map_agree m1 m2 ↔ ∃ i x1 x2, m1 !! i = Some x1 ∧ m2 !! i = Some x2 ∧ x1 ≠ x2. Proof. unfold map_agree. rewrite map_not_Forall2 by solve_decision. naive_solver. Qed. Global Instance map_agree_refl {A} : Reflexive (map_agree : relation (M A)). Proof. intros ?. rewrite !map_agree_spec. naive_solver. Qed. Global Instance map_agree_sym {A} : Symmetric (map_agree : relation (M A)). Proof. intros m1 m2. rewrite !map_agree_spec. intros Hm i x y Hm1 Hm2. symmetry. naive_solver. Qed. Lemma map_agree_empty_l {A} (m : M A) : map_agree ∅ m. Proof. rewrite !map_agree_spec. intros i x y. by rewrite lookup_empty. Qed. Lemma map_agree_empty_r {A} (m : M A) : map_agree m ∅. Proof. rewrite !map_agree_spec. intros i x y. by rewrite lookup_empty. Qed. Lemma map_agree_weaken {A} (m1 m1' m2 m2' : M A) : map_agree m1' m2' → m1 ⊆ m1' → m2 ⊆ m2' → map_agree m1 m2. Proof. rewrite !map_subseteq_spec, !map_agree_spec. eauto. Qed. Lemma map_agree_weaken_l {A} (m1 m1' m2 : M A) : map_agree m1' m2 → m1 ⊆ m1' → map_agree m1 m2. Proof. eauto using map_agree_weaken. Qed. Lemma map_agree_weaken_r {A} (m1 m2 m2' : M A) : map_agree m1 m2' → m2 ⊆ m2' → map_agree m1 m2. Proof. eauto using map_agree_weaken. Qed. Lemma map_agree_Some_l {A} (m1 m2 : M A) i x: map_agree m1 m2 → m1 !! i = Some x → m2 !! i = Some x ∨ m2 !! i = None. Proof. rewrite map_agree_spec. destruct (m2 !! i) eqn: ?; naive_solver. Qed. Lemma map_agree_Some_r {A} (m1 m2 : M A) i x: map_agree m1 m2 → m2 !! i = Some x → m1 !! i = Some x ∨ m1 !! i = None. Proof. rewrite (symmetry_iff map_agree). apply map_agree_Some_l. Qed. Lemma map_agree_singleton_l {A} (m: M A) i x : map_agree {[i:=x]} m ↔ m !! i = Some x ∨ m !! i = None. Proof. rewrite map_agree_spec. setoid_rewrite lookup_singleton_Some. destruct (m !! i) eqn:?; naive_solver. Qed. Lemma map_agree_singleton_r {A} (m : M A) i x : map_agree m {[i := x]} ↔ m !! i = Some x ∨ m !! i = None. Proof. by rewrite (symmetry_iff map_agree), map_agree_singleton_l. Qed. Lemma map_agree_delete_l {A} (m1 m2 : M A) i : map_agree m1 m2 → map_agree (delete i m1) m2. Proof. rewrite !map_agree_alt. intros Hagree j. rewrite lookup_delete_None. destruct (Hagree j) as [|[|<-]]; auto. destruct (decide (i = j)); [naive_solver|]. rewrite lookup_delete_ne; naive_solver. Qed. Lemma map_agree_delete_r {A} (m1 m2 : M A) i : map_agree m1 m2 → map_agree m1 (delete i m2). Proof. symmetry. by apply map_agree_delete_l. Qed. Lemma map_agree_filter {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m1 m2 : M A) : map_agree m1 m2 → map_agree (filter P m1) (filter P m2). Proof. rewrite !map_agree_spec. intros ? i x y. rewrite !map_lookup_filter_Some. naive_solver. Qed. Lemma map_agree_fmap_1 {A B} (f : A → B) (m1 m2 : M A) `{!Inj (=) (=) f}: map_agree (f <$> m1) (f <$> m2) → map_agree m1 m2. Proof. rewrite !map_agree_spec. setoid_rewrite lookup_fmap_Some. naive_solver. Qed. Lemma map_agree_fmap_2 {A B} (f : A → B) (m1 m2 : M A): map_agree m1 m2 → map_agree (f <$> m1) (f <$> m2). Proof. rewrite !map_agree_spec. setoid_rewrite lookup_fmap_Some. naive_solver. Qed. Lemma map_agree_fmap {A B} (f : A → B) (m1 m2 : M A) `{!Inj (=) (=) f}: map_agree (f <$> m1) (f <$> m2) ↔ map_agree m1 m2. Proof. naive_solver eauto using map_agree_fmap_1, map_agree_fmap_2. Qed. Lemma map_agree_omap {A B} (f : A → option B) (m1 m2 : M A) : map_agree m1 m2 → map_agree (omap f m1) (omap f m2). Proof. rewrite !map_agree_spec. setoid_rewrite lookup_omap_Some. naive_solver. Qed. (** ** Properties on the disjoint maps *) Lemma map_disjoint_spec {A} (m1 m2 : M A) : m1 ##ₘ m2 ↔ ∀ i x y, m1 !! i = Some x → m2 !! i = Some y → False. Proof. apply forall_proper; intros i; destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_disjoint_alt {A} (m1 m2 : M A) : m1 ##ₘ m2 ↔ ∀ i, m1 !! i = None ∨ m2 !! i = None. Proof. apply forall_proper; intros i; destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_not_disjoint {A} (m1 m2 : M A) : ¬m1 ##ₘ m2 ↔ ∃ i x1 x2, m1 !! i = Some x1 ∧ m2 !! i = Some x2. Proof. unfold disjoint, map_disjoint. rewrite map_not_Forall2 by solve_decision. naive_solver. Qed. Global Instance map_disjoint_sym {A} : Symmetric (map_disjoint : relation (M A)). Proof. intros m1 m2. rewrite !map_disjoint_spec. naive_solver. Qed. Lemma map_disjoint_empty_l {A} (m : M A) : ∅ ##ₘ m. Proof. rewrite !map_disjoint_spec. intros i x y. by rewrite lookup_empty. Qed. Lemma map_disjoint_empty_r {A} (m : M A) : m ##ₘ ∅. Proof. rewrite !map_disjoint_spec. intros i x y. by rewrite lookup_empty. Qed. Lemma map_disjoint_weaken {A} (m1 m1' m2 m2' : M A) : m1' ##ₘ m2' → m1 ⊆ m1' → m2 ⊆ m2' → m1 ##ₘ m2. Proof. rewrite !map_subseteq_spec, !map_disjoint_spec. eauto. Qed. Lemma map_disjoint_weaken_l {A} (m1 m1' m2 : M A) : m1' ##ₘ m2 → m1 ⊆ m1' → m1 ##ₘ m2. Proof. eauto using map_disjoint_weaken. Qed. Lemma map_disjoint_weaken_r {A} (m1 m2 m2' : M A) : m1 ##ₘ m2' → m2 ⊆ m2' → m1 ##ₘ m2. Proof. eauto using map_disjoint_weaken. Qed. Lemma map_disjoint_Some_l {A} (m1 m2 : M A) i x: m1 ##ₘ m2 → m1 !! i = Some x → m2 !! i = None. Proof. rewrite map_disjoint_spec, eq_None_not_Some. intros ?? [??]; eauto. Qed. Lemma map_disjoint_Some_r {A} (m1 m2 : M A) i x: m1 ##ₘ m2 → m2 !! i = Some x → m1 !! i = None. Proof. rewrite (symmetry_iff map_disjoint). apply map_disjoint_Some_l. Qed. Lemma map_disjoint_singleton_l {A} (m: M A) i x : {[i:=x]} ##ₘ m ↔ m !! i = None. Proof. rewrite !map_disjoint_spec. setoid_rewrite lookup_singleton_Some. destruct (m !! i) eqn:?; naive_solver. Qed. Lemma map_disjoint_singleton_r {A} (m : M A) i x : m ##ₘ {[i := x]} ↔ m !! i = None. Proof. by rewrite (symmetry_iff map_disjoint), map_disjoint_singleton_l. Qed. Lemma map_disjoint_singleton_l_2 {A} (m : M A) i x : m !! i = None → {[i := x]} ##ₘ m. Proof. by rewrite map_disjoint_singleton_l. Qed. Lemma map_disjoint_singleton_r_2 {A} (m : M A) i x : m !! i = None → m ##ₘ {[i := x]}. Proof. by rewrite map_disjoint_singleton_r. Qed. Lemma map_disjoint_delete_l {A} (m1 m2 : M A) i : m1 ##ₘ m2 → delete i m1 ##ₘ m2. Proof. rewrite !map_disjoint_alt. intros Hdisjoint j. destruct (Hdisjoint j); auto. rewrite lookup_delete_None. tauto. Qed. Lemma map_disjoint_delete_r {A} (m1 m2 : M A) i : m1 ##ₘ m2 → m1 ##ₘ delete i m2. Proof. symmetry. by apply map_disjoint_delete_l. Qed. Lemma map_disjoint_filter {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m1 m2 : M A) : m1 ##ₘ m2 → filter P m1 ##ₘ filter P m2. Proof. rewrite !map_disjoint_spec. intros ? i x y. rewrite !map_lookup_filter_Some. naive_solver. Qed. Lemma map_disjoint_filter_complement {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m : M A) : filter P m ##ₘ filter (λ v, ¬ P v) m. Proof. apply map_disjoint_spec. intros i x y. rewrite !map_lookup_filter_Some. naive_solver. Qed. Lemma map_disjoint_fmap {A B} (f1 f2 : A → B) (m1 m2 : M A) : f1 <$> m1 ##ₘ f2 <$> m2 ↔ m1 ##ₘ m2. Proof. rewrite !map_disjoint_spec. setoid_rewrite lookup_fmap_Some. naive_solver. Qed. Lemma map_disjoint_omap {A B} (f1 f2 : A → option B) (m1 m2 : M A) : m1 ##ₘ m2 → omap f1 m1 ##ₘ omap f2 m2. Proof. rewrite !map_disjoint_spec. setoid_rewrite lookup_omap_Some. naive_solver. Qed. Lemma map_disjoint_agree {A} (m1 m2 : M A) : m1 ##ₘ m2 → map_agree m1 m2. Proof. rewrite !map_disjoint_spec, !map_agree_spec. naive_solver. Qed. (** ** Properties of the [union_with] operation *) Section union_with. Context {A} (f : A → A → option A). Implicit Types m : M A. Lemma lookup_union_with m1 m2 i : union_with f m1 m2 !! i = union_with f (m1 !! i) (m2 !! i). Proof. unfold union_with, map_union_with. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. Lemma lookup_union_with_Some m1 m2 i z : union_with f m1 m2 !! i = Some z ↔ (m1 !! i = Some z ∧ m2 !! i = None) ∨ (m1 !! i = None ∧ m2 !! i = Some z) ∨ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ f x y = Some z). Proof. rewrite lookup_union_with. destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. Global Instance: LeftId (=@{M A}) ∅ (union_with f). Proof. unfold union_with, map_union_with. apply _. Qed. Global Instance: RightId (=@{M A}) ∅ (union_with f). Proof. unfold union_with, map_union_with. apply _. Qed. Lemma union_with_comm m1 m2 : (∀ i x y, m1 !! i = Some x → m2 !! i = Some y → f x y = f y x) → union_with f m1 m2 = union_with f m2 m1. Proof. intros. apply merge_comm. intros i. destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; simpl; eauto. Qed. Global Instance: Comm (=) f → Comm (=@{M A}) (union_with f). Proof. intros ???. apply union_with_comm. eauto. Qed. Lemma union_with_idemp m : (∀ i x, m !! i = Some x → f x x = Some x) → union_with f m m = m. Proof. intros. apply merge_idemp. intros i. destruct (m !! i) eqn:?; simpl; eauto. Qed. Lemma alter_union_with (g : A → A) m1 m2 i : (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f (g x) (g y)) → alter g i (union_with f m1 m2) = union_with f (alter g i m1) (alter g i m2). Proof. intros. apply partial_alter_merge. destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; simpl; eauto. Qed. Lemma alter_union_with_l (g : A → A) m1 m2 i : (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f (g x) y) → (∀ y, m1 !! i = None → m2 !! i = Some y → g y = y) → alter g i (union_with f m1 m2) = union_with f (alter g i m1) m2. Proof. intros. apply partial_alter_merge_l. destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; f_equal/=; auto. Qed. Lemma alter_union_with_r (g : A → A) m1 m2 i : (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f x (g y)) → (∀ x, m1 !! i = Some x → m2 !! i = None → g x = x) → alter g i (union_with f m1 m2) = union_with f m1 (alter g i m2). Proof. intros. apply partial_alter_merge_r. destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; f_equal/=; auto. Qed. Lemma delete_union_with m1 m2 i : delete i (union_with f m1 m2) = union_with f (delete i m1) (delete i m2). Proof. by apply partial_alter_merge. Qed. Lemma foldr_delete_union_with (m1 m2 : M A) is : foldr delete (union_with f m1 m2) is = union_with f (foldr delete m1 is) (foldr delete m2 is). Proof. induction is as [|?? IHis]; simpl; [done|]. by rewrite IHis, delete_union_with. Qed. Lemma insert_union_with m1 m2 i x y z : f x y = Some z → <[i:=z]>(union_with f m1 m2) = union_with f (<[i:=x]>m1) (<[i:=y]>m2). Proof. by intros; apply (partial_alter_merge _). Qed. Lemma insert_union_with_l m1 m2 i x : m2 !! i = None → <[i:=x]>(union_with f m1 m2) = union_with f (<[i:=x]>m1) m2. Proof. intros Hm2. unfold union_with, map_union_with. by erewrite insert_merge_l by (by rewrite Hm2). Qed. Lemma insert_union_with_r m1 m2 i x : m1 !! i = None → <[i:=x]>(union_with f m1 m2) = union_with f m1 (<[i:=x]>m2). Proof. intros Hm1. unfold union_with, map_union_with. by erewrite insert_merge_r by (by rewrite Hm1). Qed. End union_with. (** ** Properties of the [union] operation *) Global Instance map_empty_union {A} : LeftId (=@{M A}) ∅ (∪) := _. Global Instance map_union_empty {A} : RightId (=@{M A}) ∅ (∪) := _. Global Instance map_union_assoc {A} : Assoc (=@{M A}) (∪). Proof. intros m1 m2 m3. unfold union, map_union, union_with, map_union_with. apply merge_assoc. intros i. by destruct (m1 !! i), (m2 !! i), (m3 !! i). Qed. Global Instance map_union_idemp {A} : IdemP (=@{M A}) (∪). Proof. intros ?. by apply union_with_idemp. Qed. Lemma lookup_union {A} (m1 m2 : M A) i : (m1 ∪ m2) !! i = (m1 !! i) ∪ (m2 !! i). Proof. apply lookup_union_with. Qed. Lemma lookup_union_r {A} (m1 m2 : M A) i : m1 !! i = None → (m1 ∪ m2) !! i = m2 !! i. Proof. intros Hi. by rewrite lookup_union, Hi, (left_id_L _ _). Qed. Lemma lookup_union_l {A} (m1 m2 : M A) i : m2 !! i = None → (m1 ∪ m2) !! i = m1 !! i. Proof. intros Hi. rewrite lookup_union, Hi. by destruct (m1 !! i). Qed. Lemma lookup_union_l' {A} (m1 m2 : M A) i : is_Some (m1 !! i) → (m1 ∪ m2) !! i = m1 !! i. Proof. intros [x Hi]. rewrite lookup_union, Hi. by destruct (m2 !! i). Qed. Lemma lookup_union_Some_raw {A} (m1 m2 : M A) i x : (m1 ∪ m2) !! i = Some x ↔ m1 !! i = Some x ∨ (m1 !! i = None ∧ m2 !! i = Some x). Proof. rewrite lookup_union. destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma lookup_union_None {A} (m1 m2 : M A) i : (m1 ∪ m2) !! i = None ↔ m1 !! i = None ∧ m2 !! i = None. Proof. rewrite lookup_union. destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma lookup_union_None_1 {A} (m1 m2 : M A) i : (m1 ∪ m2) !! i = None → m1 !! i = None ∧ m2 !! i = None. Proof. apply lookup_union_None. Qed. Lemma lookup_union_None_2 {A} (m1 m2 : M A) i : m1 !! i = None → m2 !! i = None → (m1 ∪ m2) !! i = None. Proof. intros. by apply lookup_union_None. Qed. Lemma lookup_union_Some {A} (m1 m2 : M A) i x : m1 ##ₘ m2 → (m1 ∪ m2) !! i = Some x ↔ m1 !! i = Some x ∨ m2 !! i = Some x. Proof. intros Hdisjoint. rewrite lookup_union_Some_raw. intuition eauto using map_disjoint_Some_r. Qed. Lemma lookup_union_Some_l {A} (m1 m2 : M A) i x : m1 !! i = Some x → (m1 ∪ m2) !! i = Some x. Proof. intro. rewrite lookup_union_Some_raw; intuition. Qed. Lemma lookup_union_Some_r {A} (m1 m2 : M A) i x : m1 ##ₘ m2 → m2 !! i = Some x → (m1 ∪ m2) !! i = Some x. Proof. intro. rewrite lookup_union_Some; intuition. Qed. Lemma lookup_union_Some_inv_l {A} (m1 m2 : M A) i x : (m1 ∪ m2) !! i = Some x → m2 !! i = None → m1 !! i = Some x. Proof. rewrite lookup_union_Some_raw. naive_solver. Qed. Lemma lookup_union_Some_inv_r {A} (m1 m2 : M A) i x : (m1 ∪ m2) !! i = Some x → m1 !! i = None → m2 !! i = Some x. Proof. rewrite lookup_union_Some_raw. naive_solver. Qed. Lemma lookup_union_is_Some {A} (m1 m2 : M A) i : is_Some ((m1 ∪ m2) !! i) ↔ is_Some (m1 !! i) ∨ is_Some (m2 !! i). Proof. rewrite <-!not_eq_None_Some, !lookup_union_None. destruct (m1 !! i); naive_solver. Qed. Lemma map_union_comm {A} (m1 m2 : M A) : m1 ##ₘ m2 → m1 ∪ m2 = m2 ∪ m1. Proof. intros Hdisjoint. apply (merge_comm (union_with (λ x _, Some x))). intros i. specialize (Hdisjoint i). destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. Lemma map_positive_l {A} (m1 m2 : M A) : m1 ∪ m2 = ∅ → m1 = ∅. Proof. intros Hm. apply map_empty. intros i. apply (f_equal (.!! i)) in Hm. rewrite lookup_empty, lookup_union_None in Hm; tauto. Qed. Lemma map_positive_l_alt {A} (m1 m2 : M A) : m1 ≠ ∅ → m1 ∪ m2 ≠ ∅. Proof. eauto using map_positive_l. Qed. Lemma map_subseteq_union {A} (m1 m2 : M A) : m1 ⊆ m2 → m1 ∪ m2 = m2. Proof. rewrite map_subseteq_spec. intros Hm1m2. apply map_eq. intros i. apply option_eq. intros x. rewrite lookup_union_Some_raw. split; [by intuition |]. intros Hm2. specialize (Hm1m2 i). destruct (m1 !! i) as [y|]; [| by auto]. rewrite (Hm1m2 y eq_refl) in Hm2. intuition congruence. Qed. Lemma map_union_subseteq_l {A} (m1 m2 : M A) : m1 ⊆ m1 ∪ m2. Proof. rewrite map_subseteq_spec. intros ? i x. rewrite lookup_union_Some_raw. tauto. Qed. Lemma map_union_subseteq_r {A} (m1 m2 : M A) : m1 ##ₘ m2 → m2 ⊆ m1 ∪ m2. Proof. intros. rewrite map_union_comm by done. by apply map_union_subseteq_l. Qed. Lemma map_union_subseteq_l' {A} (m1 m2 m3 : M A) : m1 ⊆ m2 → m1 ⊆ m2 ∪ m3. Proof. intros. trans m2; auto using map_union_subseteq_l. Qed. Lemma map_union_subseteq_r' {A} (m1 m2 m3 : M A) : m2 ##ₘ m3 → m1 ⊆ m3 → m1 ⊆ m2 ∪ m3. Proof. intros. trans m3; auto using map_union_subseteq_r. Qed. Lemma map_union_least {A} (m1 m2 m3 : M A) : m1 ⊆ m3 → m2 ⊆ m3 → m1 ∪ m2 ⊆ m3. Proof. intros ??. apply map_subseteq_spec. intros ?? [?|[_ ?]]%lookup_union_Some_raw; by eapply lookup_weaken. Qed. Lemma map_union_mono_l {A} (m1 m2 m3 : M A) : m1 ⊆ m2 → m3 ∪ m1 ⊆ m3 ∪ m2. Proof. rewrite !map_subseteq_spec. intros ???. rewrite !lookup_union_Some_raw. naive_solver. Qed. Lemma map_union_mono_r {A} (m1 m2 m3 : M A) : m2 ##ₘ m3 → m1 ⊆ m2 → m1 ∪ m3 ⊆ m2 ∪ m3. Proof. intros. rewrite !(map_union_comm _ m3) by eauto using map_disjoint_weaken_l. by apply map_union_mono_l. Qed. Lemma map_union_reflecting_l {A} (m1 m2 m3 : M A) : m3 ##ₘ m1 → m3 ##ₘ m2 → m3 ∪ m1 ⊆ m3 ∪ m2 → m1 ⊆ m2. Proof. rewrite !map_subseteq_spec. intros Hm31 Hm32 Hm i x ?. specialize (Hm i x). rewrite !lookup_union_Some in Hm by done. destruct Hm; auto. by rewrite map_disjoint_spec in Hm31; destruct (Hm31 i x x). Qed. Lemma map_union_reflecting_r {A} (m1 m2 m3 : M A) : m1 ##ₘ m3 → m2 ##ₘ m3 → m1 ∪ m3 ⊆ m2 ∪ m3 → m1 ⊆ m2. Proof. intros ??. rewrite !(map_union_comm _ m3) by done. by apply map_union_reflecting_l. Qed. Lemma map_union_cancel_l {A} (m1 m2 m3 : M A) : m1 ##ₘ m3 → m2 ##ₘ m3 → m3 ∪ m1 = m3 ∪ m2 → m1 = m2. Proof. intros. apply (anti_symm (⊆)); apply map_union_reflecting_l with m3; by try apply reflexive_eq. Qed. Lemma map_union_cancel_r {A} (m1 m2 m3 : M A) : m1 ##ₘ m3 → m2 ##ₘ m3 → m1 ∪ m3 = m2 ∪ m3 → m1 = m2. Proof. intros. apply (anti_symm (⊆)); apply map_union_reflecting_r with m3; by try apply reflexive_eq. Qed. Lemma map_disjoint_union_l {A} (m1 m2 m3 : M A) : m1 ∪ m2 ##ₘ m3 ↔ m1 ##ₘ m3 ∧ m2 ##ₘ m3. Proof. rewrite !map_disjoint_alt. setoid_rewrite lookup_union_None. naive_solver. Qed. Lemma map_disjoint_union_r {A} (m1 m2 m3 : M A) : m1 ##ₘ m2 ∪ m3 ↔ m1 ##ₘ m2 ∧ m1 ##ₘ m3. Proof. rewrite !map_disjoint_alt. setoid_rewrite lookup_union_None. naive_solver. Qed. Lemma map_disjoint_union_l_2 {A} (m1 m2 m3 : M A) : m1 ##ₘ m3 → m2 ##ₘ m3 → m1 ∪ m2 ##ₘ m3. Proof. by rewrite map_disjoint_union_l. Qed. Lemma map_disjoint_union_r_2 {A} (m1 m2 m3 : M A) : m1 ##ₘ m2 → m1 ##ₘ m3 → m1 ##ₘ m2 ∪ m3. Proof. by rewrite map_disjoint_union_r. Qed. Lemma insert_union_singleton_l {A} (m : M A) i x : <[i:=x]>m = {[i := x]} ∪ m. Proof. apply map_eq. intros j. apply option_eq. intros y. rewrite lookup_union_Some_raw. destruct (decide (i = j)); subst. - rewrite !lookup_singleton, lookup_insert. intuition congruence. - rewrite !lookup_singleton_ne, lookup_insert_ne; intuition congruence. Qed. Lemma insert_union_singleton_r {A} (m : M A) i x : m !! i = None → <[i:=x]>m = m ∪ {[i := x]}. Proof. intro. rewrite insert_union_singleton_l, map_union_comm; [done |]. by apply map_disjoint_singleton_l. Qed. Lemma union_singleton_r {A} (m : M A) i x y : m !! i = Some x → m ∪ {[i := y]} = m. Proof. intro Hlkup. apply map_eq. intros j. rewrite lookup_union. destruct (decide (i = j)); subst. - by rewrite !lookup_singleton, Hlkup. - rewrite lookup_singleton_ne by done. by destruct (m !! j). Qed. Lemma map_disjoint_insert_l {A} (m1 m2 : M A) i x : <[i:=x]>m1 ##ₘ m2 ↔ m2 !! i = None ∧ m1 ##ₘ m2. Proof. rewrite insert_union_singleton_l. by rewrite map_disjoint_union_l, map_disjoint_singleton_l. Qed. Lemma map_disjoint_insert_r {A} (m1 m2 : M A) i x : m1 ##ₘ <[i:=x]>m2 ↔ m1 !! i = None ∧ m1 ##ₘ m2. Proof. rewrite insert_union_singleton_l. by rewrite map_disjoint_union_r, map_disjoint_singleton_r. Qed. Lemma map_disjoint_insert_l_2 {A} (m1 m2 : M A) i x : m2 !! i = None → m1 ##ₘ m2 → <[i:=x]>m1 ##ₘ m2. Proof. by rewrite map_disjoint_insert_l. Qed. Lemma map_disjoint_insert_r_2 {A} (m1 m2 : M A) i x : m1 !! i = None → m1 ##ₘ m2 → m1 ##ₘ <[i:=x]>m2. Proof. by rewrite map_disjoint_insert_r. Qed. Lemma insert_union_l {A} (m1 m2 : M A) i x : <[i:=x]>(m1 ∪ m2) = <[i:=x]>m1 ∪ m2. Proof. by rewrite !insert_union_singleton_l, (assoc_L (∪)). Qed. Lemma insert_union_r {A} (m1 m2 : M A) i x : m1 !! i = None → <[i:=x]>(m1 ∪ m2) = m1 ∪ <[i:=x]>m2. Proof. intro. rewrite !insert_union_singleton_l, !(assoc_L (∪)). rewrite (map_union_comm m1); [done |]. by apply map_disjoint_singleton_r. Qed. Lemma foldr_insert_union {A} (m : M A) l : foldr (λ p, <[p.1:=p.2]>) m l = list_to_map l ∪ m. Proof. induction l as [|i l IH]; simpl; [by rewrite (left_id_L _ _)|]. by rewrite IH, insert_union_l. Qed. Lemma delete_union {A} (m1 m2 : M A) i : delete i (m1 ∪ m2) = delete i m1 ∪ delete i m2. Proof. apply delete_union_with. Qed. Lemma union_delete_insert {A} (m1 m2 : M A) i x : m1 !! i = Some x → delete i m1 ∪ <[i:=x]> m2 = m1 ∪ m2. Proof. intros. rewrite <-insert_union_r by apply lookup_delete. by rewrite insert_union_l, insert_delete by done. Qed. Lemma union_insert_delete {A} (m1 m2 : M A) i x : m1 !! i = None → m2 !! i = Some x → <[i:=x]> m1 ∪ delete i m2 = m1 ∪ m2. Proof. intros. rewrite <-insert_union_l by apply lookup_delete. by rewrite insert_union_r, insert_delete by done. Qed. Lemma map_Forall_union_1_1 {A} (m1 m2 : M A) P : map_Forall P (m1 ∪ m2) → map_Forall P m1. Proof. intros HP i x ?. apply HP, lookup_union_Some_raw; auto. Qed. Lemma map_Forall_union_1_2 {A} (m1 m2 : M A) P : m1 ##ₘ m2 → map_Forall P (m1 ∪ m2) → map_Forall P m2. Proof. intros ? HP i x ?. apply HP, lookup_union_Some; auto. Qed. Lemma map_Forall_union_2 {A} (m1 m2 : M A) P : map_Forall P m1 → map_Forall P m2 → map_Forall P (m1 ∪ m2). Proof. intros ???? [|[]]%lookup_union_Some_raw; eauto. Qed. Lemma map_Forall_union {A} (m1 m2 : M A) P : m1 ##ₘ m2 → map_Forall P (m1 ∪ m2) ↔ map_Forall P m1 ∧ map_Forall P m2. Proof. naive_solver eauto using map_Forall_union_1_1, map_Forall_union_1_2, map_Forall_union_2. Qed. Lemma map_filter_union {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m1 m2 : M A) : m1 ##ₘ m2 → filter P (m1 ∪ m2) = filter P m1 ∪ filter P m2. Proof. intros. apply map_eq; intros i. apply option_eq; intros x. rewrite lookup_union_Some, !map_lookup_filter_Some, lookup_union_Some by auto using map_disjoint_filter. naive_solver. Qed. Lemma map_filter_union_complement {A} (P : K * A → Prop) `{!∀ x, Decision (P x)} (m : M A) : filter P m ∪ filter (λ v, ¬ P v) m = m. Proof. apply map_eq; intros i. apply option_eq; intros x. rewrite lookup_union_Some, !map_lookup_filter_Some by auto using map_disjoint_filter_complement. destruct (decide (P (i,x))); naive_solver. Qed. Lemma map_filter_or {A} (P Q : K * A → Prop) `{!∀ x, Decision (P x), !∀ x, Decision (Q x)} (m : M A) : filter (λ x, P x ∨ Q x) m = filter P m ∪ filter Q m. Proof. apply map_eq. intros k. rewrite lookup_union. rewrite !map_lookup_filter. destruct (m !! k); simpl; repeat case_option_guard; naive_solver. Qed. Lemma map_fmap_union {A B} (f : A → B) (m1 m2 : M A) : f <$> (m1 ∪ m2) = (f <$> m1) ∪ (f <$> m2). Proof. apply map_eq; intros i. apply option_eq; intros x. rewrite lookup_fmap, !lookup_union, !lookup_fmap. destruct (m1 !! i), (m2 !! i); auto. Qed. Lemma map_omap_union {A B} (f : A → option B) (m1 m2 : M A) : m1 ##ₘ m2 → omap f (m1 ∪ m2) = omap f m1 ∪ omap f m2. Proof. intros Hdisj. apply map_eq; intros i. specialize (Hdisj i). apply option_eq; intros x. rewrite lookup_omap, !lookup_union, !lookup_omap. destruct (m1 !! i), (m2 !! i); simpl; repeat (destruct (f _)); naive_solver. Qed. Lemma map_size_disj_union {A} (m1 m2 : M A) : m1 ##ₘ m2 → size (m1 ∪ m2) = size m1 + size m2. Proof. intros Hdisj. induction m1 as [|k x m1 Hm1 IH] using map_ind. { rewrite (left_id _ _), map_size_empty. done. } rewrite <-insert_union_l. rewrite map_size_insert. rewrite lookup_union_r by done. apply map_disjoint_insert_l in Hdisj as [-> Hdisj]. rewrite map_size_insert, Hm1. rewrite IH by done. done. Qed. Lemma map_cross_split {A} (ma mb mc md : M A) : ma ##ₘ mb → mc ##ₘ md → ma ∪ mb = mc ∪ md → ∃ mac mad mbc mbd, mac ##ₘ mad ∧ mbc ##ₘ mbd ∧ mac ##ₘ mbc ∧ mad ##ₘ mbd ∧ mac ∪ mad = ma ∧ mbc ∪ mbd = mb ∧ mac ∪ mbc = mc ∧ mad ∪ mbd = md. Proof. intros Hab_disj Hcd_disj Hab. exists (filter (λ kx, is_Some (mc !! kx.1)) ma), (filter (λ kx, ¬is_Some (mc !! kx.1)) ma), (filter (λ kx, is_Some (mc !! kx.1)) mb), (filter (λ kx, ¬is_Some (mc !! kx.1)) mb). split_and!; [auto using map_disjoint_filter_complement, map_disjoint_filter, map_filter_union_complement..| |]. - rewrite <-map_filter_union, Hab by done. apply map_eq; intros k. apply option_eq; intros x. rewrite map_lookup_filter_Some, lookup_union_Some, <-not_eq_None_Some by done. rewrite map_disjoint_alt in Hcd_disj; naive_solver. - rewrite <-map_filter_union, Hab by done. apply map_eq; intros k. apply option_eq; intros x. rewrite map_lookup_filter_Some, lookup_union_Some, <-not_eq_None_Some by done. rewrite map_disjoint_alt in Hcd_disj; naive_solver. Qed. (** ** Properties of the [union_list] operation *) Lemma map_disjoint_union_list_l {A} (ms : list (M A)) (m : M A) : ⋃ ms ##ₘ m ↔ Forall (.##ₘ m) ms. Proof. split. - induction ms; simpl; rewrite ?map_disjoint_union_l; intuition. - induction 1; simpl; [apply map_disjoint_empty_l |]. by rewrite map_disjoint_union_l. Qed. Lemma map_disjoint_union_list_r {A} (ms : list (M A)) (m : M A) : m ##ₘ ⋃ ms ↔ Forall (.##ₘ m) ms. Proof. by rewrite (symmetry_iff map_disjoint), map_disjoint_union_list_l. Qed. Lemma map_disjoint_union_list_l_2 {A} (ms : list (M A)) (m : M A) : Forall (.##ₘ m) ms → ⋃ ms ##ₘ m. Proof. by rewrite map_disjoint_union_list_l. Qed. Lemma map_disjoint_union_list_r_2 {A} (ms : list (M A)) (m : M A) : Forall (.##ₘ m) ms → m ##ₘ ⋃ ms. Proof. by rewrite map_disjoint_union_list_r. Qed. (** ** Properties of the folding the [delete] function *) Lemma lookup_foldr_delete {A} (m : M A) is j : j ∈ is → foldr delete m is !! j = None. Proof. induction 1 as [|i j is]; simpl; [by rewrite lookup_delete|]. by destruct (decide (i = j)) as [->|?]; rewrite ?lookup_delete, ?lookup_delete_ne by done. Qed. Lemma lookup_foldr_delete_not_elem_of {A} (m : M A) is j : j ∉ is → foldr delete m is !! j = m !! j. Proof. induction is; simpl; [done |]. rewrite elem_of_cons; intros. rewrite lookup_delete_ne; intuition. Qed. Lemma lookup_foldr_delete_Some {A} (m : M A) is j y : foldr delete m is !! j = Some y ↔ j ∉ is ∧ m !! j = Some y. Proof. induction is; simpl; rewrite ?lookup_delete_Some; set_solver. Qed. Lemma foldr_delete_notin {A} (m : M A) is : Forall (λ i, m !! i = None) is → foldr delete m is = m. Proof. induction 1; simpl; [done |]. rewrite delete_notin; congruence. Qed. Lemma foldr_delete_commute {A} (m : M A) is j : delete j (foldr delete m is) = foldr delete (delete j m) is. Proof. induction is as [|?? IH]; [done| ]. simpl. by rewrite delete_commute, IH. Qed. Lemma foldr_delete_insert {A} (m : M A) is j x : j ∈ is → foldr delete (<[j:=x]>m) is = foldr delete m is. Proof. induction 1 as [i is|j i is ? IH]; simpl; [|by rewrite IH]. by rewrite !foldr_delete_commute, delete_insert_delete. Qed. Lemma foldr_delete_insert_ne {A} (m : M A) is j x : j ∉ is → foldr delete (<[j:=x]>m) is = <[j:=x]>(foldr delete m is). Proof. induction is as [|?? IHis]; simpl; [done |]. rewrite elem_of_cons. intros. rewrite IHis, delete_insert_ne; intuition. Qed. Lemma map_disjoint_foldr_delete_l {A} (m1 m2 : M A) is : m1 ##ₘ m2 → foldr delete m1 is ##ₘ m2. Proof. induction is; simpl; auto using map_disjoint_delete_l. Qed. Lemma map_disjoint_foldr_delete_r {A} (m1 m2 : M A) is : m1 ##ₘ m2 → m1 ##ₘ foldr delete m2 is. Proof. induction is; simpl; auto using map_disjoint_delete_r. Qed. Lemma map_agree_foldr_delete_l {A} (m1 m2 : M A) is : map_agree m1 m2 → map_agree (foldr delete m1 is) m2. Proof. induction is; simpl; auto using map_agree_delete_l. Qed. Lemma map_agree_foldr_delete_r {A} (m1 m2 : M A) is : map_agree m1 m2 → map_agree m1 (foldr delete m2 is). Proof. induction is; simpl; auto using map_agree_delete_r. Qed. Lemma foldr_delete_union {A} (m1 m2 : M A) is : foldr delete (m1 ∪ m2) is = foldr delete m1 is ∪ foldr delete m2 is. Proof. apply foldr_delete_union_with. Qed. (** ** Properties on conversion to lists that depend on [∪] and [##ₘ] *) Lemma list_to_map_app {A} (l1 l2 : list (K * A)): list_to_map (l1 ++ l2) =@{M A} list_to_map l1 ∪ list_to_map l2. Proof. induction l1 as [|[??] ? IH]; simpl. { by rewrite (left_id _ _). } by rewrite IH, insert_union_l. Qed. Lemma map_disjoint_list_to_map_l {A} (m : M A) ixs : list_to_map ixs ##ₘ m ↔ Forall (λ ix, m !! ix.1 = None) ixs. Proof. split. - induction ixs; simpl; rewrite ?map_disjoint_insert_l in *; intuition. - induction 1; simpl; [apply map_disjoint_empty_l|]. rewrite map_disjoint_insert_l. auto. Qed. Lemma map_disjoint_list_to_map_r {A} (m : M A) ixs : m ##ₘ list_to_map ixs ↔ Forall (λ ix, m !! ix.1 = None) ixs. Proof. by rewrite (symmetry_iff map_disjoint), map_disjoint_list_to_map_l. Qed. Lemma map_disjoint_list_to_map_zip_l {A} (m : M A) is xs : length is = length xs → list_to_map (zip is xs) ##ₘ m ↔ Forall (λ i, m !! i = None) is. Proof. intro. rewrite map_disjoint_list_to_map_l. rewrite <-(fst_zip is xs) at 2 by lia. by rewrite Forall_fmap. Qed. Lemma map_disjoint_list_to_map_zip_r {A} (m : M A) is xs : length is = length xs → m ##ₘ list_to_map (zip is xs) ↔ Forall (λ i, m !! i = None) is. Proof. intro. by rewrite (symmetry_iff map_disjoint), map_disjoint_list_to_map_zip_l. Qed. Lemma map_disjoint_list_to_map_zip_l_2 {A} (m : M A) is xs : length is = length xs → Forall (λ i, m !! i = None) is → list_to_map (zip is xs) ##ₘ m. Proof. intro. by rewrite map_disjoint_list_to_map_zip_l. Qed. Lemma map_disjoint_list_to_map_zip_r_2 {A} (m : M A) is xs : length is = length xs → Forall (λ i, m !! i = None) is → m ##ₘ list_to_map (zip is xs). Proof. intro. by rewrite map_disjoint_list_to_map_zip_r. Qed. (** ** Properties of the [intersection_with] operation *) Section intersection_with. Context {A} (f : A → A → option A). Implicit Type (m: M A). Global Instance : LeftAbsorb (=@{M A}) ∅ (intersection_with f). Proof. unfold intersection_with, map_intersection_with. apply _. Qed. Global Instance: RightAbsorb (=@{M A}) ∅ (intersection_with f). Proof. unfold intersection_with, map_intersection_with. apply _. Qed. Lemma lookup_intersection_with m1 m2 i : intersection_with f m1 m2 !! i = intersection_with f (m1 !! i) (m2 !! i). Proof. unfold intersection_with, map_intersection_with. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. Lemma lookup_intersection_with_Some m1 m2 i z : intersection_with f m1 m2 !! i = Some z ↔ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ f x y = Some z). Proof. rewrite lookup_intersection_with. destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. Lemma intersection_with_comm m1 m2 : (∀ i x y, m1 !! i = Some x → m2 !! i = Some y → f x y = f y x) → intersection_with f m1 m2 = intersection_with f m2 m1. Proof. intros. apply (merge_comm _). intros i. destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; simpl; eauto. Qed. Global Instance: Comm (=) f → Comm (=@{M A}) (intersection_with f). Proof. intros ???. apply intersection_with_comm. eauto. Qed. Lemma intersection_with_idemp m : (∀ i x, m !! i = Some x → f x x = Some x) → intersection_with f m m = m. Proof. intros. apply (merge_idemp _). intros i. destruct (m !! i) eqn:?; simpl; eauto. Qed. Lemma alter_intersection_with (g : A → A) m1 m2 i : (∀ x y, m1 !! i = Some x → m2 !! i = Some y → g <$> f x y = f (g x) (g y)) → alter g i (intersection_with f m1 m2) = intersection_with f (alter g i m1) (alter g i m2). Proof. intros. apply (partial_alter_merge _). destruct (m1 !! i) eqn:?, (m2 !! i) eqn:?; simpl; eauto. Qed. Lemma delete_intersection_with m1 m2 i : delete i (intersection_with f m1 m2) = intersection_with f (delete i m1) (delete i m2). Proof. by apply (partial_alter_merge _). Qed. Lemma foldr_delete_intersection_with (m1 m2 : M A) is : foldr delete (intersection_with f m1 m2) is = intersection_with f (foldr delete m1 is) (foldr delete m2 is). Proof. induction is as [|?? IHis]; simpl; [done|]. by rewrite IHis, delete_intersection_with. Qed. Lemma insert_intersection_with m1 m2 i x y z : f x y = Some z → <[i:=z]>(intersection_with f m1 m2) = intersection_with f (<[i:=x]>m1) (<[i:=y]>m2). Proof. by intros; apply (partial_alter_merge _). Qed. End intersection_with. (** ** Properties of the [intersection] operation *) Global Instance map_empty_interaction {A} : LeftAbsorb (=@{M A}) ∅ (∩) := _. Global Instance map_interaction_empty {A} : RightAbsorb (=@{M A}) ∅ (∩) := _. Global Instance map_interaction_assoc {A} : Assoc (=@{M A}) (∩). Proof. intros m1 m2 m3. unfold intersection, map_intersection, intersection_with, map_intersection_with. apply (merge_assoc _). intros i. by destruct (m1 !! i), (m2 !! i), (m3 !! i). Qed. Global Instance map_intersection_idemp {A} : IdemP (=@{M A}) (∩). Proof. intros ?. by apply intersection_with_idemp. Qed. Lemma lookup_intersection {A} (m1 m2 : M A) i : (m1 ∩ m2) !! i = m1 !! i ∩ m2 !! i. Proof. apply lookup_intersection_with. Qed. Lemma lookup_intersection_Some {A} (m1 m2 : M A) i x : (m1 ∩ m2) !! i = Some x ↔ m1 !! i = Some x ∧ is_Some (m2 !! i). Proof. unfold intersection, map_intersection. rewrite lookup_intersection_with. destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. Lemma lookup_intersection_None {A} (m1 m2 : M A) i : (m1 ∩ m2) !! i = None ↔ m1 !! i = None ∨ m2 !! i = None. Proof. unfold intersection, map_intersection. rewrite lookup_intersection_with. destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. Lemma map_intersection_filter {A} (m1 m2 : M A) : m1 ∩ m2 = filter (λ kx, is_Some (m1 !! kx.1) ∧ is_Some (m2 !! kx.1)) (m1 ∪ m2). Proof. apply map_eq; intros i. apply option_eq; intros x. rewrite lookup_intersection_Some, map_lookup_filter_Some, lookup_union; simpl. unfold is_Some. destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma map_filter_and {A} (P Q : K * A → Prop) `{!∀ x, Decision (P x), !∀ x, Decision (Q x)} (m : M A) : filter (λ x, P x ∧ Q x) m = filter P m ∩ filter Q m. Proof. apply map_eq. intros k. rewrite lookup_intersection. rewrite !map_lookup_filter. destruct (m !! k); simpl; repeat case_option_guard; naive_solver. Qed. Lemma map_fmap_intersection {A B} (f : A → B) (m1 m2 : M A) : f <$> (m1 ∩ m2) = (f <$> m1) ∩ (f <$> m2). Proof. apply map_eq. intros i. rewrite !lookup_intersection, !lookup_fmap, !lookup_intersection. destruct (m1 !! i), (m2 !! i); done. Qed. (** ** Properties of the [difference_with] operation *) Lemma lookup_difference_with {A} (f : A → A → option A) (m1 m2 : M A) i : difference_with f m1 m2 !! i = difference_with f (m1 !! i) (m2 !! i). Proof. unfold difference_with, map_difference_with. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed. Lemma lookup_difference_with_Some {A} (f : A → A → option A) (m1 m2 : M A) i z : difference_with f m1 m2 !! i = Some z ↔ (m1 !! i = Some z ∧ m2 !! i = None) ∨ (∃ x y, m1 !! i = Some x ∧ m2 !! i = Some y ∧ f x y = Some z). Proof. rewrite lookup_difference_with. destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. (** ** Properties of the [difference] operation *) Lemma lookup_difference {A} (m1 m2 : M A) i : (m1 ∖ m2) !! i = match m2 !! i with None => m1 !! i | _ => None end. Proof. unfold difference, map_difference; rewrite lookup_difference_with. destruct (m1 !! i), (m2 !! i); done. Qed. Lemma lookup_difference_Some {A} (m1 m2 : M A) i x : (m1 ∖ m2) !! i = Some x ↔ m1 !! i = Some x ∧ m2 !! i = None. Proof. rewrite lookup_difference. destruct (m1 !! i), (m2 !! i); naive_solver. Qed. Lemma lookup_difference_is_Some {A} (m1 m2 : M A) i : is_Some ((m1 ∖ m2) !! i) ↔ is_Some (m1 !! i) ∧ m2 !! i = None. Proof. unfold is_Some. setoid_rewrite lookup_difference_Some. naive_solver. Qed. Lemma lookup_difference_None {A} (m1 m2 : M A) i : (m1 ∖ m2) !! i = None ↔ m1 !! i = None ∨ is_Some (m2 !! i). Proof. rewrite lookup_difference. destruct (m1 !! i), (m2 !! i); compute; naive_solver. Qed. Lemma map_disjoint_difference_l {A} (m1 m2 : M A) : m1 ⊆ m2 → m2 ∖ m1 ##ₘ m1. Proof. intros Hm i; specialize (Hm i). unfold difference, map_difference; rewrite lookup_difference_with. by destruct (m1 !! i), (m2 !! i). Qed. Lemma map_disjoint_difference_r {A} (m1 m2 : M A) : m1 ⊆ m2 → m1 ##ₘ m2 ∖ m1. Proof. intros. symmetry. by apply map_disjoint_difference_l. Qed. Lemma map_subseteq_difference_l {A} (m1 m2 m : M A) : m1 ⊆ m → m1 ∖ m2 ⊆ m. Proof. rewrite !map_subseteq_spec. setoid_rewrite lookup_difference_Some. naive_solver. Qed. Lemma map_difference_union {A} (m1 m2 : M A) : m1 ⊆ m2 → m1 ∪ m2 ∖ m1 = m2. Proof. rewrite map_subseteq_spec. intro Hm1m2. apply map_eq. intros i. apply option_eq. intros v. specialize (Hm1m2 i). unfold difference, map_difference, difference_with, map_difference_with. rewrite lookup_union_Some_raw, lookup_merge. destruct (m1 !! i) as [x'|], (m2 !! i); try specialize (Hm1m2 x'); compute; intuition congruence. Qed. Lemma map_difference_diag {A} (m : M A) : m ∖ m = ∅. Proof. apply map_empty; intros i. rewrite lookup_difference_None. destruct (m !! i); eauto. Qed. Global Instance map_difference_right_id {A} : RightId (=@{M A}) ∅ (∖) := _. Lemma map_difference_empty {A} (m : M A) : m ∖ ∅ = m. Proof. by rewrite (right_id _ _). Qed. Lemma map_fmap_difference {A B} (f : A → B) (m1 m2 : M A) : f <$> (m1 ∖ m2) = (f <$> m1) ∖ (f <$> m2). Proof. apply map_eq. intros i. rewrite !lookup_difference, !lookup_fmap, !lookup_difference. destruct (m1 !! i), (m2 !! i); done. Qed. Lemma insert_difference {A} (m1 m2 : M A) i x : <[i:=x]> (m1 ∖ m2) = <[i:=x]> m1 ∖ delete i m2. Proof. intros. apply map_eq. intros j. apply option_eq. intros y. rewrite lookup_insert_Some, !lookup_difference_Some, lookup_insert_Some, lookup_delete_None. naive_solver. Qed. Lemma insert_difference' {A} (m1 m2 : M A) i x : m2 !! i = None → <[i:=x]> (m1 ∖ m2) = <[i:=x]> m1 ∖ m2. Proof. intros. by rewrite insert_difference, delete_notin. Qed. Lemma difference_insert {A} (m1 m2 : M A) i x1 x2 x3 : <[i:=x1]> m1 ∖ <[i:=x2]> m2 = m1 ∖ <[i:=x3]> m2. Proof. apply map_eq. intros i'. apply option_eq. intros x'. rewrite !lookup_difference_Some, !lookup_insert_Some, !lookup_insert_None. naive_solver. Qed. Lemma difference_insert_subseteq {A} (m1 m2 : M A) i x1 x2 : <[i:=x1]> m1 ∖ <[i:=x2]> m2 ⊆ m1 ∖ m2. Proof. apply map_subseteq_spec. intros i' x'. rewrite !lookup_difference_Some, lookup_insert_Some, lookup_insert_None. naive_solver. Qed. Lemma delete_difference {A} (m1 m2 : M A) i x : delete i (m1 ∖ m2) = m1 ∖ <[i:=x]> m2. Proof. apply map_eq. intros j. apply option_eq. intros y. rewrite lookup_delete_Some, !lookup_difference_Some, lookup_insert_None. naive_solver. Qed. Lemma difference_delete {A} (m1 m2 : M A) i x : m1 !! i = Some x → m1 ∖ delete i m2 = <[i:=x]> (m1 ∖ m2). Proof. intros. apply map_eq. intros j. apply option_eq. intros y. rewrite lookup_insert_Some, !lookup_difference_Some, lookup_delete_None. destruct (decide (i = j)); naive_solver. Qed. Lemma map_difference_filter {A} (m1 m2 : M A) : m1 ∖ m2 = filter (λ kx, m2 !! kx.1 = None) m1. Proof. apply map_eq; intros i. apply option_eq; intros x. by rewrite lookup_difference_Some, map_lookup_filter_Some. Qed. (** ** Misc properties about the order *) Lemma map_subseteq_inv {A} (m1 m2 : M A) : m1 ⊆ m2 → m1 ⊂ m2 ∨ m1 = m2. Proof. intros. destruct (decide (m2 ∖ m1 = ∅)) as [Hm21|(i&x&Hi)%map_choose]. - right. by rewrite <-(map_difference_union m1 m2), Hm21, (right_id_L _ _). - left. apply lookup_difference_Some in Hi as [??]. apply map_subset_alt; eauto. Qed. (** ** Setoids *) Section setoid. Context `{Equiv A}. Lemma map_equiv_iff (m1 m2 : M A) : m1 ≡ m2 ↔ ∀ i, m1 !! i ≡ m2 !! i. Proof. done. Qed. Lemma map_equiv_lookup_l (m1 m2 : M A) i x : m1 ≡ m2 → m1 !! i = Some x → ∃ y, m2 !! i = Some y ∧ x ≡ y. Proof. intros Hm Hi. destruct (Hm i); naive_solver. Qed. Lemma map_equiv_lookup_r (m1 m2 : M A) i y : m1 ≡ m2 → m2 !! i = Some y → ∃ x, m1 !! i = Some x ∧ x ≡ y. Proof. intros Hm Hi. destruct (Hm i); naive_solver. Qed. Global Instance map_equivalence : Equivalence (≡@{A}) → Equivalence (≡@{M A}). Proof. split. - by intros m i. - by intros m1 m2 ? i. - by intros m1 m2 m3 ?? i; trans (m2 !! i). Qed. Global Instance map_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (M A). Proof. intros m1 m2 Hm; apply map_eq; intros i. apply leibniz_equiv, Hm. Qed. Global Instance lookup_proper (i : K) : Proper ((≡@{M A}) ==> (≡)) (lookup i). Proof. by intros m1 m2 Hm. Qed. Global Instance lookup_total_proper (i : K) `{!Inhabited A} : Proper (≡@{A}) inhabitant → Proper ((≡@{M A}) ==> (≡)) (.!!! i). Proof. intros ? m1 m2 Hm. unfold lookup_total, map_lookup_total. apply from_option_proper; auto. by intros ??. Qed. Global Instance partial_alter_proper : Proper (((≡) ==> (≡)) ==> (=) ==> (≡) ==> (≡@{M A})) partial_alter. Proof. by intros f1 f2 Hf i ? <- m1 m2 Hm j; destruct (decide (i = j)) as [->|]; rewrite ?lookup_partial_alter, ?lookup_partial_alter_ne by done; try apply Hf; apply lookup_proper. Qed. Global Instance insert_proper (i : K) : Proper ((≡) ==> (≡) ==> (≡@{M A})) (insert i). Proof. by intros ???; apply partial_alter_proper; [constructor|]. Qed. Global Instance singletonM_proper k : Proper ((≡) ==> (≡@{M A})) (singletonM k). Proof. intros ???; apply insert_proper; [done|]. intros ?. rewrite lookup_empty; constructor. Qed. Global Instance delete_proper (i : K) : Proper ((≡) ==> (≡@{M A})) (delete i). Proof. by apply partial_alter_proper; [constructor|]. Qed. Global Instance alter_proper : Proper (((≡) ==> (≡)) ==> (=) ==> (≡) ==> (≡@{M A})) alter. Proof. intros ?? Hf; apply partial_alter_proper. by destruct 1; constructor; apply Hf. Qed. Global Instance merge_proper `{Equiv B, Equiv C} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{M A}) ==> (≡@{M B}) ==> (≡@{M C})) merge. Proof. intros ?? Hf ?? Hm1 ?? Hm2 i. rewrite !lookup_merge. destruct (Hm1 i), (Hm2 i); try apply Hf; by constructor. Qed. Global Instance union_with_proper : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡) ==> (≡) ==>(≡@{M A})) union_with. Proof. intros ?? Hf. apply merge_proper. by do 2 destruct 1; first [apply Hf | constructor]. Qed. Global Instance intersection_with_proper : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡) ==> (≡) ==>(≡@{M A})) intersection_with. Proof. intros ?? Hf. apply merge_proper. by do 2 destruct 1; first [apply Hf | constructor]. Qed. Global Instance difference_with_proper : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡) ==> (≡) ==>(≡@{M A})) difference_with. Proof. intros ?? Hf. apply merge_proper. by do 2 destruct 1; first [apply Hf | constructor]. Qed. Global Instance union_proper : Proper ((≡) ==> (≡) ==>(≡@{M A})) union. Proof. apply union_with_proper; solve_proper. Qed. Global Instance intersection_proper : Proper ((≡) ==> (≡) ==>(≡@{M A})) intersection. Proof. apply intersection_with_proper; solve_proper. Qed. Global Instance difference_proper : Proper ((≡) ==> (≡) ==>(≡@{M A})) difference. Proof. apply difference_with_proper. constructor. Qed. Global Instance map_zip_with_proper `{Equiv B, Equiv C} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{M A}) ==> (≡@{M B}) ==> (≡@{M C})) map_zip_with. Proof. intros f1 f2 Hf. apply merge_proper. destruct 1; destruct 1; repeat f_equiv; constructor || by apply Hf. Qed. Global Instance map_disjoint_proper : Proper ((≡@{M A}) ==> (≡@{M A}) ==> iff) map_disjoint. Proof. intros m1 m1' Hm1 m2 m2' Hm2; split; intros Hm i; specialize (Hm i); by destruct (Hm1 i), (Hm2 i). Qed. Global Instance map_fmap_proper `{Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{M A}) ==> (≡@{M B})) fmap. Proof. intros f f' Hf m m' ? k; rewrite !lookup_fmap. by apply option_fmap_proper. Qed. Global Instance map_omap_proper `{Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{M A}) ==> (≡@{M B})) omap. Proof. intros f f' ? m m' ? k; rewrite !lookup_omap. by apply option_bind_proper. Qed. Global Instance map_filter_proper (P : K * A → Prop) `{!∀ kx, Decision (P kx)} : (∀ k, Proper ((≡) ==> iff) (curry P k)) → Proper ((≡@{M A}) ==> (≡)) (filter P). Proof. intros ? m1 m2 Hm i. rewrite !map_lookup_filter. destruct (Hm i); simpl; repeat case_option_guard; try constructor; naive_solver. Qed. Global Instance map_singleton_equiv_inj : Inj2 (=) (≡) (≡) (singletonM (M:=M A)). Proof. intros i1 x1 i2 x2 Heq. specialize (Heq i1). rewrite lookup_singleton in Heq. destruct (decide (i1 = i2)) as [->|]. - rewrite lookup_singleton in Heq. apply (inj _) in Heq. naive_solver. - rewrite lookup_singleton_ne in Heq by done. inversion Heq. Qed. Global Instance map_fmap_equiv_inj `{Equiv B} (f : A → B) : Inj (≡) (≡) f → Inj (≡@{M A}) (≡@{M B}) (fmap f). Proof. intros ? m1 m2 Hm i. apply (inj (fmap (M:=option) f)). rewrite <-!lookup_fmap. by apply Hm. Qed. Lemma map_fmap_equiv_ext `{Equiv B} (f1 f2 : A → B) (m : M A) : (∀ i x, m !! i = Some x → f1 x ≡ f2 x) → f1 <$> m ≡ f2 <$> m. Proof. intros Hi i; rewrite !lookup_fmap. destruct (m !! i) eqn:?; constructor; eauto. Qed. End setoid. (** The lemmas below make it possible to turn an [≡] into an [=]. *) Section setoid_inversion. Context `{Equiv A, !Equivalence (≡@{A})}. Implicit Types m : M A. Lemma map_empty_equiv_eq m : m ≡ ∅ ↔ m = ∅. Proof. split; [intros Hm; apply map_eq; intros i|intros ->]. - generalize (Hm i). by rewrite lookup_empty, None_equiv_eq. - intros ?. rewrite lookup_empty; constructor. Qed. Lemma partial_alter_equiv_eq (f : option A → option A) (m1 m2 : M A) i : Proper ((≡) ==> (≡)) f → (∀ x1 mx2, Some x1 ≡ f mx2 → ∃ mx2', Some x1 = f mx2' ∧ mx2' ≡ mx2) → m1 ≡ partial_alter f i m2 ↔ ∃ m2', m1 = partial_alter f i m2' ∧ m2' ≡ m2. Proof. intros ? Hf. split; [|by intros (?&->&<-)]. intros Hm. assert (∃ mx2', m1 !! i = f mx2' ∧ mx2' ≡ m2 !! i) as (mx2'&?&?). { destruct (m1 !! i) as [x1|] eqn:Hix1. - apply (Hf x1 (m2 !! i)). by rewrite <-Hix1, Hm, lookup_partial_alter. - exists (m2 !! i). split; [|done]. apply symmetry, None_equiv_eq. by rewrite <-Hix1, Hm, lookup_partial_alter. } exists (partial_alter (λ _, mx2') i m1). split. - apply map_eq; intros j. destruct (decide (i = j)) as [->|?]. + by rewrite !lookup_partial_alter. + by rewrite !lookup_partial_alter_ne. - intros j. destruct (decide (i = j)) as [->|?]. + by rewrite lookup_partial_alter. + by rewrite Hm, !lookup_partial_alter_ne. Qed. Lemma alter_equiv_eq (f : A → A) (m1 m2 : M A) i : Proper ((≡) ==> (≡)) f → (∀ x1 x2, x1 ≡ f x2 → ∃ x2', x1 = f x2' ∧ x2' ≡ x2) → m1 ≡ alter f i m2 ↔ ∃ m2', m1 = alter f i m2' ∧ m2' ≡ m2. Proof. intros ? Hf. apply (partial_alter_equiv_eq _ _ _ _ _). intros mx1 [x2|]; simpl. - intros (x2'&->&?)%(inj _)%Hf. exists (Some x2'). by repeat constructor. - intros ->%None_equiv_eq. by exists None. Qed. Lemma delete_equiv_eq m1 m2 i : m1 ≡ delete i m2 ↔ ∃ m2', m1 = delete i m2' ∧ m2' ≡ m2. Proof. apply (partial_alter_equiv_eq _ _ _ _ _). intros ?? [=]%None_equiv_eq. Qed. Lemma insert_equiv_eq m1 m2 i x : m1 ≡ <[i:=x]> m2 ↔ ∃ x' m2', m1 = <[i:=x']> m2' ∧ x' ≡ x ∧ m2' ≡ m2. Proof. split; [|by intros (?&?&->&<-&<-)]. intros Hm. assert (is_Some (m1 !! i)) as [x' Hix']. { rewrite Hm, lookup_insert. eauto. } destruct (m2 !! i) as [y|] eqn:?. - exists x', (<[i:=y]> m1). split_and!. + by rewrite insert_insert, insert_id by done. + apply (inj Some). by rewrite <-Hix', Hm, lookup_insert. + by rewrite Hm, insert_insert, insert_id by done. - exists x', (delete i m1). split_and!. + by rewrite insert_delete by done. + apply (inj Some). by rewrite <-Hix', Hm, lookup_insert. + by rewrite Hm, delete_insert by done. Qed. Lemma map_singleton_equiv_eq m i x : m ≡ {[i:=x]} ↔ ∃ x', m = {[i:=x']} ∧ x' ≡ x. Proof. rewrite <-!insert_empty, insert_equiv_eq. setoid_rewrite map_empty_equiv_eq. naive_solver. Qed. Lemma map_filter_equiv_eq (P : K * A → Prop) `{!∀ kx, Decision (P kx)} (m1 m2 : M A): (∀ k, Proper ((≡) ==> iff) (curry P k)) → m1 ≡ filter P m2 ↔ ∃ m2', m1 = filter P m2' ∧ m2' ≡ m2. Proof. intros HP. split; [|by intros (?&->&->)]. revert m1. induction m2 as [|i x m2 ? IH] using map_ind; intros m1 Hm. { rewrite map_filter_empty in Hm. exists ∅. by rewrite map_filter_empty, <-map_empty_equiv_eq. } rewrite map_filter_insert in Hm. case_decide. - apply insert_equiv_eq in Hm as (x'&m2'&->&?&(m2''&->&?)%IH). exists (<[i:=x']> m2''). split; [|by f_equiv]. by rewrite map_filter_insert_True by (by eapply HP). - rewrite delete_notin in Hm by done. apply IH in Hm as (m2'&->&Hm2). exists (<[i:=x]> m2'). split; [|by f_equiv]. assert (m2' !! i = None). { by rewrite <-None_equiv_eq, Hm2, None_equiv_eq. } by rewrite map_filter_insert_not' by naive_solver. Qed. End setoid_inversion. Lemma map_omap_equiv_eq `{Equiv A, !Equivalence (≡@{A}), Equiv B, !Equivalence (≡@{B})} (f : A → option B) (m1 : M B) (m2 : M A) : Proper ((≡) ==> (≡)) f → (∀ y x, Some y ≡ f x → ∃ x', Some y = f x' ∧ x' ≡ x) → m1 ≡ omap f m2 ↔ ∃ m2', m1 = omap f m2' ∧ m2' ≡ m2. Proof. intros ? Hf. split; [|by intros (?&->&->)]. revert m1. induction m2 as [|i x m2 ? IH] using map_ind; intros m1 Hm. { rewrite omap_empty, map_empty_equiv_eq in Hm. subst m1. exists ∅. by rewrite omap_empty. } rewrite omap_insert in Hm. destruct (f x) as [y|] eqn:Hfx. - apply insert_equiv_eq in Hm as (y'&m1'&->&Hy&(m2'&->&?)%IH). destruct (Hf y' x) as (x'&Hfx'&?). { by rewrite Hfx, Hy. } exists (<[i:=x']> m2'). split; [|by f_equiv]. by rewrite omap_insert, <-Hfx'. - apply delete_equiv_eq in Hm as (m1'&->&(m2'&->&?)%IH). exists (<[i:=x]> m2'). split; [|by f_equiv]. by rewrite omap_insert, Hfx. Qed. Lemma map_fmap_equiv_eq `{Equiv A, !Equivalence (≡@{A}), Equiv B, !Equivalence (≡@{B})} (f : A → B) (m1 : M B) (m2 : M A) : Proper ((≡) ==> (≡)) f → (∀ y x, y ≡ f x → ∃ x', y = f x' ∧ x' ≡ x) → m1 ≡ f <$> m2 ↔ ∃ m2', m1 = f <$> m2' ∧ m2' ≡ m2. Proof. intros ? Hf. rewrite map_fmap_alt; setoid_rewrite map_fmap_alt. apply map_omap_equiv_eq; [solve_proper|]. intros ?? (?&->&?)%(inj _)%Hf; eauto. Qed. Lemma merge_equiv_eq `{Equiv A, !Equivalence (≡@{A}), Equiv B, !Equivalence (≡@{B}), Equiv C, !Equivalence (≡@{C})} (f : option A → option B → option C) (m1 : M C) (m2a : M A) (m2b : M B) : Proper ((≡) ==> (≡) ==> (≡)) f → (∀ y mx1 mx2, Some y ≡ f mx1 mx2 → ∃ mx1' mx2', Some y = f mx1' mx2' ∧ mx1' ≡ mx1 ∧ mx2' ≡ mx2) → m1 ≡ merge f m2a m2b ↔ ∃ m2a' m2b', m1 = merge f m2a' m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. intros ? Hf. split; [|by intros (?&?&->&->&->)]. revert m1. induction m2a as [|i x m2a ? IH] using map_ind; intros m1. { assert (∀ y x, Some y ≡ f None (Some x) → ∃ x', Some y = f None (Some x') ∧ x' ≡ x). { intros ?? (?&?&?&->%None_equiv_eq&(?&->&?)%Some_equiv_eq)%Hf; eauto. } rewrite merge_empty_l, map_omap_equiv_eq by (done || solve_proper). intros (m2'&->&?). exists ∅, m2'. by rewrite merge_empty_l. } unfold insert at 1, map_insert at 1. rewrite <-(partial_alter_merge_l _ (λ _, f (Some x) (m2b !! i))) by done. destruct (f (Some x) (m2b !! i)) as [y|] eqn:Hfi. - intros (y'&m'&->&Hy&(m2a'&m2b'&->&Hm2a&Hm2b)%IH)%insert_equiv_eq. destruct (Hf y' (Some x) (m2b !! i)) as (mx1&mx2&?&(x'&->&?)%Some_equiv_eq&?). { by rewrite Hy, Hfi. } exists (<[i:=x']> m2a'), (partial_alter (λ _, mx2) i m2b'). split_and!; [by apply partial_alter_merge|by f_equiv|]. intros j. destruct (decide (i = j)) as [->|?]. + by rewrite lookup_partial_alter. + by rewrite Hm2b, lookup_partial_alter_ne. - intros (m'&->&(m2a'&m2b'&->&Hm2a&Hm2b)%IH)%delete_equiv_eq. exists (<[i:=x]> m2a'), m2b'. split_and!; [|by f_equiv|done]. apply partial_alter_merge_l, symmetry, None_equiv_eq; simpl. by rewrite Hm2b, Hfi. Qed. Lemma map_union_with_equiv_eq `{Equiv A, !Equivalence (≡@{A})} (f : A → A → option A) (m1 m2a m2b : M A) : Proper ((≡) ==> (≡) ==> (≡)) f → (∀ y x1 x2, Some y ≡ f x1 x2 → ∃ x1' x2', Some y = f x1' x2' ∧ x1' ≡ x1 ∧ x2' ≡ x2) → m1 ≡ union_with f m2a m2b ↔ ∃ m2a' m2b', m1 = union_with f m2a' m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. intros ? Hf. apply (merge_equiv_eq _ _ _ _ _). intros ? [x1|] [x2|]; simpl; first [intros (?&?&?&?&?)%Hf|intros (?&?&?)%Some_equiv_eq|intros ?%None_equiv_eq]; by repeat econstructor. Qed. Lemma map_intersection_with_equiv_eq `{Equiv A, !Equivalence (≡@{A})} (f : A → A → option A) (m1 m2a m2b : M A) : Proper ((≡) ==> (≡) ==> (≡)) f → (∀ y x1 x2, Some y ≡ f x1 x2 → ∃ x1' x2', Some y = f x1' x2' ∧ x1' ≡ x1 ∧ x2' ≡ x2) → m1 ≡ intersection_with f m2a m2b ↔ ∃ m2a' m2b', m1 = intersection_with f m2a' m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. intros ? Hf. apply (merge_equiv_eq _ _ _ _ _). intros ? [x1|] [x2|]; simpl; first [intros (?&?&?&?&?)%Hf|intros (?&?&?)%Some_equiv_eq|intros ?%None_equiv_eq]; by repeat econstructor. Qed. Lemma map_difference_with_equiv_eq `{Equiv A, !Equivalence (≡@{A})} (f : A → A → option A) (m1 m2a m2b : M A) : Proper ((≡) ==> (≡) ==> (≡)) f → (∀ y x1 x2, Some y ≡ f x1 x2 → ∃ x1' x2', Some y = f x1' x2' ∧ x1' ≡ x1 ∧ x2' ≡ x2) → m1 ≡ difference_with f m2a m2b ↔ ∃ m2a' m2b', m1 = difference_with f m2a' m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. intros ? Hf. apply (merge_equiv_eq _ _ _ _ _). intros ? [x1|] [x2|]; simpl; first [intros (?&?&?&?&?)%Hf|intros (?&?&?)%Some_equiv_eq|intros ?%None_equiv_eq]; by repeat econstructor. Qed. Lemma map_union_equiv_eq `{Equiv A, !Equivalence (≡@{A})} (m1 m2a m2b : M A) : m1 ≡ m2a ∪ m2b ↔ ∃ m2a' m2b', m1 = m2a' ∪ m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. apply map_union_with_equiv_eq; [solve_proper|]. intros ??? ?%(inj _); eauto. Qed. Lemma map_intersection_equiv_eq `{Equiv A, !Equivalence (≡@{A})} (m1 m2a m2b : M A) : m1 ≡ m2a ∩ m2b ↔ ∃ m2a' m2b', m1 = m2a' ∩ m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. apply map_intersection_with_equiv_eq; [solve_proper|]. intros ??? ?%(inj _); eauto. Qed. Lemma map_difference_equiv_eq `{Equiv A, !Equivalence (≡@{A})} (m1 m2a m2b : M A) : m1 ≡ m2a ∖ m2b ↔ ∃ m2a' m2b', m1 = m2a' ∖ m2b' ∧ m2a' ≡ m2a ∧ m2b' ≡ m2b. Proof. apply map_difference_with_equiv_eq; [constructor|]. intros ??? [=]%None_equiv_eq. Qed. End theorems. (** ** The [map_seq] operation *) Section map_seq. Context `{FinMap nat M} {A : Type}. Implicit Types x : A. Implicit Types xs : list A. Global Instance map_seq_proper `{Equiv A} start : Proper ((≡@{list A}) ==> (≡@{M A})) (map_seq start). Proof. intros l1 l2 Hl. revert start. induction Hl as [|x1 x2 l1 l2 ?? IH]; intros start; simpl. - intros ?. rewrite lookup_empty; constructor. - repeat (done || f_equiv). Qed. Lemma lookup_map_seq start xs i : map_seq (M:=M A) start xs !! i = guard (start ≤ i); xs !! (i - start). Proof. revert start. induction xs as [|x' xs IH]; intros start; simpl. { rewrite lookup_empty; simplify_option_eq; by rewrite ?lookup_nil. } destruct (decide (start = i)) as [->|?]. - by rewrite lookup_insert, option_guard_True, Nat.sub_diag by lia. - rewrite lookup_insert_ne, IH by done. simplify_option_eq; try done || lia. by replace (i - start) with (S (i - S start)) by lia. Qed. Lemma lookup_map_seq_0 xs i : map_seq (M:=M A) 0 xs !! i = xs !! i. Proof. by rewrite lookup_map_seq, option_guard_True, Nat.sub_0_r by lia. Qed. Lemma lookup_map_seq_Some_inv start xs i x : xs !! i = Some x ↔ map_seq (M:=M A) start xs !! (start + i) = Some x. Proof. rewrite lookup_map_seq, option_guard_True by lia. by rewrite Nat.add_sub_swap, Nat.sub_diag. Qed. Lemma lookup_map_seq_Some start xs i x : map_seq (M:=M A) start xs !! i = Some x ↔ start ≤ i ∧ xs !! (i - start) = Some x. Proof. rewrite lookup_map_seq. case_option_guard; naive_solver. Qed. Lemma lookup_map_seq_None start xs i : map_seq (M:=M A) start xs !! i = None ↔ i < start ∨ start + length xs ≤ i. Proof. rewrite lookup_map_seq. case_option_guard; rewrite ?lookup_ge_None; naive_solver lia. Qed. Lemma lookup_map_seq_is_Some start xs i x : is_Some (map_seq (M:=M A) start xs !! i) ↔ start ≤ i < start + length xs. Proof. rewrite <-not_eq_None_Some, lookup_map_seq_None. lia. Qed. Lemma map_seq_singleton start x : map_seq (M:=M A) start [x] = {[ start := x ]}. Proof. done. Qed. (** [map_seq_disjoint] uses [length xs = 0] instead of [xs = []] as [lia] can handle the former but not the latter. *) Lemma map_seq_disjoint start1 start2 xs1 xs2 : map_seq (M:=M A) start1 xs1 ##ₘ map_seq start2 xs2 ↔ start1 + length xs1 ≤ start2 ∨ start2 + length xs2 ≤ start1 ∨ length xs1 = 0 ∨ length xs2 = 0. Proof. rewrite map_disjoint_alt. setoid_rewrite lookup_map_seq_None. split; intros Hi; [|lia]. pose proof (Hi start1). pose proof (Hi start2). lia. Qed. Lemma map_seq_app_disjoint start xs1 xs2 : map_seq (M:=M A) start xs1 ##ₘ map_seq (start + length xs1) xs2. Proof. apply map_seq_disjoint. lia. Qed. Lemma map_seq_app start xs1 xs2 : map_seq start (xs1 ++ xs2) =@{M A} map_seq start xs1 ∪ map_seq (start + length xs1) xs2. Proof. revert start. induction xs1 as [|x1 xs1 IH]; intros start; simpl. - by rewrite (left_id_L _ _), Nat.add_0_r. - by rewrite IH, Nat.add_succ_r, !insert_union_singleton_l, (assoc_L _). Qed. Lemma map_seq_cons_disjoint start xs : map_seq (M:=M A) (S start) xs !! start = None. Proof. rewrite lookup_map_seq_None. lia. Qed. Lemma map_seq_cons start xs x : map_seq start (x :: xs) =@{M A} <[start:=x]> (map_seq (S start) xs). Proof. done. Qed. Lemma map_seq_snoc_disjoint start xs : map_seq (M:=M A) start xs !! (start+length xs) = None. Proof. rewrite lookup_map_seq_None. lia. Qed. Lemma map_seq_snoc start xs x : map_seq start (xs ++ [x]) =@{M A} <[start+length xs:=x]> (map_seq start xs). Proof. rewrite map_seq_app, map_seq_singleton. by rewrite insert_union_singleton_r by (by rewrite map_seq_snoc_disjoint). Qed. Lemma fmap_map_seq {B} (f : A → B) start xs : f <$> map_seq start xs =@{M B} map_seq start (f <$> xs). Proof. revert start. induction xs as [|x xs IH]; intros start; csimpl. { by rewrite fmap_empty. } by rewrite fmap_insert, IH. Qed. Lemma insert_map_seq start xs i x: start ≤ i < start + length xs → <[i:=x]> (map_seq start xs) =@{M A} map_seq start (<[i - start:=x]> xs). Proof. intros. apply map_eq. intros j. destruct (decide (i = j)) as [->|?]. - rewrite lookup_insert, lookup_map_seq, option_guard_True by lia. by rewrite list_lookup_insert by lia. - rewrite lookup_insert_ne, !lookup_map_seq by done. case_option_guard; [|done]. by rewrite list_lookup_insert_ne by lia. Qed. Lemma map_seq_insert start xs i x: i < length xs → map_seq start (<[i:=x]> xs) =@{M A} <[start + i:=x]> (map_seq start xs). Proof. intros. rewrite insert_map_seq by lia. auto with f_equal lia. Qed. Lemma insert_map_seq_0 xs i x: i < length xs → <[i:=x]> (map_seq 0 xs) =@{M A} map_seq 0 (<[i:=x]> xs). Proof. intros. rewrite insert_map_seq by lia. auto with f_equal lia. Qed. End map_seq. (** ** The [map_seqZ] operation *) Section map_seqZ. Context `{FinMap Z M} {A : Type}. Implicit Types x : A. Implicit Types xs : list A. Local Open Scope Z_scope. Global Instance map_seqZ_proper `{Equiv A} start : Proper ((≡@{list A}) ==> (≡@{M A})) (map_seqZ start). Proof. intros l1 l2 Hl. revert start. induction Hl as [|x1 x2 l1 l2 ?? IH]; intros start; simpl. - intros ?. rewrite lookup_empty; constructor. - repeat (done || f_equiv). Qed. Lemma lookup_map_seqZ start xs i : map_seqZ (M:=M A) start xs !! i = guard (start ≤ i); xs !! Z.to_nat (i - start). Proof. revert start. induction xs as [|x' xs IH]; intros start; simpl. { rewrite lookup_empty; simplify_option_eq; by rewrite ?lookup_nil. } destruct (decide (start = i)) as [->|?]. - by rewrite lookup_insert, option_guard_True, Z.sub_diag by lia. - rewrite lookup_insert_ne, IH by done. simplify_option_eq; try done || lia. replace (i - start) with (Z.succ (i - Z.succ start)) by lia. by rewrite Z2Nat.inj_succ; [|lia]. Qed. Lemma lookup_map_seqZ_0 xs i : 0 ≤ i → map_seqZ (M:=M A) 0 xs !! i = xs !! Z.to_nat i. Proof. intros ?. by rewrite lookup_map_seqZ, option_guard_True, Z.sub_0_r. Qed. Lemma lookup_map_seqZ_Some_inv start xs i x : xs !! i = Some x ↔ map_seqZ (M:=M A) start xs !! (start + Z.of_nat i) = Some x. Proof. rewrite ->lookup_map_seqZ, option_guard_True by lia. assert (Z.to_nat (start + Z.of_nat i - start) = i) as -> by lia. done. Qed. Lemma lookup_map_seqZ_Some start xs i x : map_seqZ (M:=M A) start xs !! i = Some x ↔ start ≤ i ∧ xs !! Z.to_nat (i - start) = Some x. Proof. rewrite lookup_map_seqZ. case_option_guard; naive_solver. Qed. Lemma lookup_map_seqZ_None start xs i : map_seqZ (M:=M A) start xs !! i = None ↔ i < start ∨ start + Z.of_nat (length xs) ≤ i. Proof. rewrite lookup_map_seqZ. case_option_guard; rewrite ?lookup_ge_None; naive_solver lia. Qed. Lemma lookup_map_seqZ_is_Some start xs i : is_Some (map_seqZ (M:=M A) start xs !! i) ↔ start ≤ i < start + Z.of_nat (length xs). Proof. rewrite <-not_eq_None_Some, lookup_map_seqZ_None. lia. Qed. Lemma map_seqZ_singleton start x : map_seqZ (M:=M A) start [x] = {[ start := x ]}. Proof. done. Qed. (** [map_seqZ_disjoint] uses [length xs = 0] instead of [xs = []] as [lia] can handle the former but not the latter. *) Lemma map_seqZ_disjoint start1 start2 xs1 xs2 : map_seqZ (M:=M A) start1 xs1 ##ₘ map_seqZ (M:=M A) start2 xs2 ↔ start1 + Z.of_nat (length xs1) ≤ start2 ∨ start2 + Z.of_nat (length xs2) ≤ start1 ∨ length xs1 = 0%nat ∨ length xs2 = 0%nat. Proof. rewrite map_disjoint_alt. setoid_rewrite lookup_map_seqZ_None. split; intros Hi; [|lia]. pose proof (Hi start1). pose proof (Hi start2). lia. Qed. Lemma map_seqZ_app_disjoint start xs1 xs2 : map_seqZ (M:=M A) start xs1 ##ₘ map_seqZ (start + Z.of_nat (length xs1)) xs2. Proof. apply map_seqZ_disjoint. lia. Qed. Lemma map_seqZ_app start xs1 xs2 : map_seqZ start (xs1 ++ xs2) =@{M A} map_seqZ start xs1 ∪ map_seqZ (start + Z.of_nat (length xs1)) xs2. Proof. revert start. induction xs1 as [|x1 xs1 IH]; intros start; simpl. - by rewrite ->(left_id_L _ _), Z.add_0_r. - by rewrite IH, Nat2Z.inj_succ, Z.add_succ_r, Z.add_succ_l, !insert_union_singleton_l, (assoc_L _). Qed. Lemma map_seqZ_cons_disjoint start xs : map_seqZ (M:=M A) (Z.succ start) xs !! start = None. Proof. rewrite lookup_map_seqZ_None. lia. Qed. Lemma map_seqZ_cons start xs x : map_seqZ start (x :: xs) =@{M A} <[start:=x]> (map_seqZ (Z.succ start) xs). Proof. done. Qed. Lemma map_seqZ_snoc_disjoint start xs : map_seqZ (M:=M A) start xs !! (start + Z.of_nat (length xs)) = None. Proof. rewrite lookup_map_seqZ_None. lia. Qed. Lemma map_seqZ_snoc start xs x : map_seqZ start (xs ++ [x]) =@{M A} <[(start + Z.of_nat (length xs)):=x]> (map_seqZ start xs). Proof. rewrite map_seqZ_app, map_seqZ_singleton. by rewrite insert_union_singleton_r by (by rewrite map_seqZ_snoc_disjoint). Qed. Lemma fmap_map_seqZ {B} (f : A → B) start xs : f <$> map_seqZ start xs =@{M B} map_seqZ start (f <$> xs). Proof. revert start. induction xs as [|x xs IH]; intros start; csimpl. { by rewrite fmap_empty. } by rewrite fmap_insert, IH. Qed. Lemma insert_map_seqZ start xs i x: start ≤ i < start + Z.of_nat (length xs) → <[i:=x]> (map_seqZ start xs) =@{M A} map_seqZ start (<[Z.to_nat (i - start):=x]> xs). Proof. intros. apply map_eq. intros j. destruct (decide (i = j)) as [->|?]. - rewrite lookup_insert, lookup_map_seqZ, option_guard_True by lia. by rewrite list_lookup_insert by lia. - rewrite lookup_insert_ne, !lookup_map_seqZ by done. case_option_guard; [|done]. by rewrite list_lookup_insert_ne by lia. Qed. Lemma map_seqZ_insert start xs i x: (i < length xs)%nat → map_seqZ start (<[i:=x]> xs) =@{M A} <[start + Z.of_nat i:=x]> (map_seqZ start xs). Proof. intros. rewrite insert_map_seqZ by lia. auto with lia f_equal. Qed. Lemma insert_map_seqZ_0 xs i x: 0 ≤ i < Z.of_nat (length xs) → <[i:=x]> (map_seqZ 0 xs) =@{M A} map_seqZ 0 (<[Z.to_nat i:=x]> xs). Proof. intros. rewrite insert_map_seqZ by lia. auto with lia f_equal. Qed. Lemma map_seqZ_insert_0 xs i x: (i < length xs)%nat → map_seqZ 0 (<[i:=x]> xs) =@{M A} <[Z.of_nat i:=x]> (map_seqZ 0 xs). Proof. intros. by rewrite map_seqZ_insert. Qed. End map_seqZ. Section kmap. Context `{FinMap K1 M1} `{FinMap K2 M2}. Context (f : K1 → K2) `{!Inj (=) (=) f}. Local Notation kmap := (kmap (M1:=M1) (M2:=M2)). Lemma lookup_kmap_Some {A} (m : M1 A) (j : K2) x : kmap f m !! j = Some x ↔ ∃ i, j = f i ∧ m !! i = Some x. Proof. assert (∀ x', (j, x) ∈ prod_map f id <$> map_to_list m → (j, x') ∈ prod_map f id <$> map_to_list m → x = x'). { intros x'. rewrite !elem_of_list_fmap. intros [[j' y1] [??]] [[? y2] [??]]; simplify_eq/=. by apply (map_to_list_unique m j'). } unfold kmap. rewrite <-elem_of_list_to_map', elem_of_list_fmap by done. setoid_rewrite elem_of_map_to_list'. split. - intros [[??] [??]]; naive_solver. - intros [? [??]]. eexists (_, _); naive_solver. Qed. Lemma lookup_kmap_is_Some {A} (m : M1 A) (j : K2) : is_Some (kmap f m !! j) ↔ ∃ i, j = f i ∧ is_Some (m !! i). Proof. unfold is_Some. setoid_rewrite lookup_kmap_Some. naive_solver. Qed. Lemma lookup_kmap_None {A} (m : M1 A) (j : K2) : kmap f m !! j = None ↔ ∀ i, j = f i → m !! i = None. Proof. setoid_rewrite eq_None_not_Some. rewrite lookup_kmap_is_Some. naive_solver. Qed. (** Note that to state a lemma [map_kmap f m !! j = ...] we need to have a partial inverse [f_inv] of [f] (which one cannot define constructively). Then we could write [map_kmap f m !! j = (i ← f_inv j; m !! i)] *) Lemma lookup_kmap {A} (m : M1 A) (i : K1) : kmap f m !! (f i) = m !! i. Proof. apply option_eq. setoid_rewrite lookup_kmap_Some. naive_solver. Qed. Lemma lookup_total_kmap `{Inhabited A} (m : M1 A) (i : K1) : kmap f m !!! (f i) = m !!! i. Proof. by rewrite !lookup_total_alt, lookup_kmap. Qed. Global Instance kmap_inj {A} : Inj (=@{M1 A}) (=) (kmap f). Proof. intros m1 m2 Hm. apply map_eq. intros i. by rewrite <-!lookup_kmap, Hm. Qed. Lemma kmap_empty {A} : kmap f ∅ =@{M2 A} ∅. Proof. unfold kmap. by rewrite map_to_list_empty. Qed. Lemma kmap_empty_iff {A} (m : M1 A) : kmap f m = ∅ ↔ m = ∅. Proof. rewrite !map_empty. setoid_rewrite lookup_kmap_None. naive_solver. Qed. Lemma kmap_singleton {A} i (x : A) : kmap f {[ i := x ]} = {[ f i := x ]}. Proof. unfold kmap. by rewrite map_to_list_singleton. Qed. Lemma kmap_partial_alter {A} (g : option A → option A) (m : M1 A) i : kmap f (partial_alter g i m) = partial_alter g (f i) (kmap f m). Proof. apply map_eq; intros j. apply option_eq; intros y. destruct (decide (j = f i)) as [->|?]. { by rewrite lookup_partial_alter, !lookup_kmap, lookup_partial_alter. } rewrite lookup_partial_alter_ne, !lookup_kmap_Some by done. split. - intros [i' [? Hm]]; simplify_eq/=. rewrite lookup_partial_alter_ne in Hm by naive_solver. naive_solver. - intros [i' [? Hm]]; simplify_eq/=. exists i'. rewrite lookup_partial_alter_ne by naive_solver. naive_solver. Qed. Lemma kmap_insert {A} (m : M1 A) i x : kmap f (<[i:=x]> m) = <[f i:=x]> (kmap f m). Proof. apply kmap_partial_alter. Qed. Lemma kmap_delete {A} (m : M1 A) i : kmap f (delete i m) = delete (f i) (kmap f m). Proof. apply kmap_partial_alter. Qed. Lemma kmap_alter {A} (g : A → A) (m : M1 A) i : kmap f (alter g i m) = alter g (f i) (kmap f m). Proof. apply kmap_partial_alter. Qed. Lemma kmap_merge {A B C} (g : option A → option B → option C) (m1 : M1 A) (m2 : M1 B) : kmap f (merge g m1 m2) = merge g (kmap f m1) (kmap f m2). Proof. apply map_eq; intros j. apply option_eq; intros y. rewrite lookup_merge, lookup_kmap_Some. setoid_rewrite lookup_merge. split. { intros [i [-> ?]]. by rewrite !lookup_kmap. } intros Hg. destruct (kmap f m1 !! j) as [x1|] eqn:Hm1. { apply lookup_kmap_Some in Hm1 as (i&->&Hm1i). exists i. split; [done|]. by rewrite Hm1i, <-lookup_kmap. } destruct (kmap f m2 !! j) as [x2|] eqn:Hm2; [|naive_solver]. apply lookup_kmap_Some in Hm2 as (i&->&Hm2i). exists i. split; [done|]. by rewrite Hm2i, <-lookup_kmap, Hm1. Qed. Lemma kmap_union_with {A} (g : A → A → option A) (m1 m2 : M1 A) : kmap f (union_with g m1 m2) = union_with g (kmap f m1) (kmap f m2). Proof. apply kmap_merge. Qed. Lemma kmap_intersection_with {A} (g : A → A → option A) (m1 m2 : M1 A) : kmap f (intersection_with g m1 m2) = intersection_with g (kmap f m1) (kmap f m2). Proof. apply kmap_merge. Qed. Lemma kmap_difference_with {A} (g : A → A → option A) (m1 m2 : M1 A) : kmap f (difference_with g m1 m2) = difference_with g (kmap f m1) (kmap f m2). Proof. apply kmap_merge. Qed. Lemma kmap_union {A} (m1 m2 : M1 A) : kmap f (m1 ∪ m2) = kmap f m1 ∪ kmap f m2. Proof. apply kmap_union_with. Qed. Lemma kmap_intersection {A} (m1 m2 : M1 A) : kmap f (m1 ∩ m2) = kmap f m1 ∩ kmap f m2. Proof. apply kmap_intersection_with. Qed. Lemma kmap_difference {A} (m1 m2 : M1 A) : kmap f (m1 ∖ m2) = kmap f m1 ∖ kmap f m2. Proof. apply kmap_difference_with. Qed. Lemma kmap_zip_with {A B C} (g : A → B → C) (m1 : M1 A) (m2 : M1 B) : kmap f (map_zip_with g m1 m2) = map_zip_with g (kmap f m1) (kmap f m2). Proof. by apply kmap_merge. Qed. Lemma kmap_imap {A B} (g : K2 → A → option B) (m : M1 A) : kmap f (map_imap (g ∘ f) m) = map_imap g (kmap f m). Proof. apply map_eq; intros j. apply option_eq; intros y. rewrite map_lookup_imap, bind_Some. setoid_rewrite lookup_kmap_Some. setoid_rewrite map_lookup_imap. setoid_rewrite bind_Some. naive_solver. Qed. Lemma kmap_omap {A B} (g : A → option B) (m : M1 A) : kmap f (omap g m) = omap g (kmap f m). Proof. apply map_eq; intros j. apply option_eq; intros y. rewrite lookup_omap, bind_Some. setoid_rewrite lookup_kmap_Some. setoid_rewrite lookup_omap. setoid_rewrite bind_Some. naive_solver. Qed. Lemma kmap_fmap {A B} (g : A → B) (m : M1 A) : kmap f (g <$> m) = g <$> (kmap f m). Proof. by rewrite !map_fmap_alt, kmap_omap. Qed. Lemma map_disjoint_kmap {A} (m1 m2 : M1 A) : kmap f m1 ##ₘ kmap f m2 ↔ m1 ##ₘ m2. Proof. rewrite !map_disjoint_spec. setoid_rewrite lookup_kmap_Some. naive_solver. Qed. Lemma map_agree_kmap {A} (m1 m2 : M1 A) : map_agree (kmap f m1) (kmap f m2) ↔ map_agree m1 m2. Proof. rewrite !map_agree_spec. setoid_rewrite lookup_kmap_Some. naive_solver. Qed. Lemma kmap_subseteq {A} (m1 m2 : M1 A) : kmap f m1 ⊆ kmap f m2 ↔ m1 ⊆ m2. Proof. rewrite !map_subseteq_spec. setoid_rewrite lookup_kmap_Some. naive_solver. Qed. Lemma kmap_subset {A} (m1 m2 : M1 A) : kmap f m1 ⊂ kmap f m2 ↔ m1 ⊂ m2. Proof. unfold strict. by rewrite !kmap_subseteq. Qed. End kmap. Section preimg. (** We restrict the theory to finite sets with Leibniz equality, which is sufficient for [gset], but not for [boolset] or [propset]. The result of the pre-image is a map of sets. To support general sets, we would need setoid equality on sets, and thus setoid equality on maps. *) Context `{FinMap K MK, FinMap A MA, FinSet K SK, !LeibnizEquiv SK}. Local Notation map_preimg := (map_preimg (K:=K) (A:=A) (MKA:=MK A) (MASK:=MA SK) (SK:=SK)). Implicit Types m : MK A. Lemma map_preimg_empty : map_preimg ∅ = ∅. Proof. apply map_fold_empty. Qed. Lemma map_preimg_insert m i x : m !! i = None → map_preimg (<[i:=x]> m) = partial_alter (λ mX, Some ({[ i ]} ∪ default ∅ mX)) x (map_preimg m). Proof. intros Hi. refine (map_fold_insert_L _ _ i x m _ Hi). intros j1 j2 x1 x2 m' ? _ _. destruct (decide (x1 = x2)) as [->|?]. - rewrite <-!partial_alter_compose. apply partial_alter_ext; intros ? _; f_equal/=. set_solver. - by apply partial_alter_commute. Qed. (** The [map_preimg] function never returns an empty set (we represent that case via [None]). *) Lemma lookup_preimg_Some_non_empty m x : map_preimg m !! x ≠ Some ∅. Proof. induction m as [|i x' m ? IH] using map_ind. { by rewrite map_preimg_empty, lookup_empty. } rewrite map_preimg_insert by done. destruct (decide (x = x')) as [->|]. - rewrite lookup_partial_alter. intros [=]. set_solver. - rewrite lookup_partial_alter_ne by done. set_solver. Qed. Lemma lookup_preimg_None_1 m x i : map_preimg m !! x = None → m !! i ≠ Some x. Proof. induction m as [|i' x' m ? IH] using map_ind; [by rewrite lookup_empty|]. rewrite map_preimg_insert by done. destruct (decide (x = x')) as [->|]. - by rewrite lookup_partial_alter. - rewrite lookup_partial_alter_ne, lookup_insert_Some by done. naive_solver. Qed. Lemma lookup_preimg_Some_1 m X x i : map_preimg m !! x = Some X → i ∈ X ↔ m !! i = Some x. Proof. revert X. induction m as [|i' x' m ? IH] using map_ind; intros X. { by rewrite map_preimg_empty, lookup_empty. } rewrite map_preimg_insert by done. destruct (decide (x = x')) as [->|]. - rewrite lookup_partial_alter. intros [= <-]. rewrite elem_of_union, elem_of_singleton, lookup_insert_Some. destruct (map_preimg m !! x') as [X'|] eqn:Hx'; simpl. + rewrite IH by done. naive_solver. + apply (lookup_preimg_None_1 _ _ i) in Hx'. set_solver. - rewrite lookup_partial_alter_ne, lookup_insert_Some by done. naive_solver. Qed. Lemma lookup_preimg_None m x : map_preimg m !! x = None ↔ ∀ i, m !! i ≠ Some x. Proof. split; [by eauto using lookup_preimg_None_1|]. intros Hm. apply eq_None_not_Some; intros [X ?]. destruct (set_choose_L X) as [i ?]. { intros ->. by eapply lookup_preimg_Some_non_empty. } by eapply (Hm i), lookup_preimg_Some_1. Qed. Lemma lookup_preimg_Some m x X : map_preimg m !! x = Some X ↔ X ≠ ∅ ∧ ∀ i, i ∈ X ↔ m !! i = Some x. Proof. split. - intros HxX. split; [intros ->; by eapply lookup_preimg_Some_non_empty|]. intros j. by apply lookup_preimg_Some_1. - intros [HXne HX]. destruct (map_preimg m !! x) as [X'|] eqn:HX'. + f_equal; apply set_eq; intros i. rewrite HX. by apply lookup_preimg_Some_1. + apply set_choose_L in HXne as [j ?]. apply (lookup_preimg_None_1 _ _ j) in HX'. naive_solver. Qed. Lemma lookup_total_preimg m x i : i ∈ map_preimg m !!! x ↔ m !! i = Some x. Proof. rewrite lookup_total_alt. destruct (map_preimg m !! x) as [X|] eqn:HX. - by apply lookup_preimg_Some. - rewrite lookup_preimg_None in HX. set_solver. Qed. End preimg. (** ** The [map_img] (image/codomain) operation *) Section img. Context `{FinMap K M, SemiSet A SA}. Implicit Types m : M A. Implicit Types x y : A. Implicit Types X : SA. (* avoid writing ≡@{D} everywhere... *) Notation map_img := (map_img (M:=M A) (SA:=SA)). Lemma elem_of_map_img m x : x ∈ map_img m ↔ ∃ i, m !! i = Some x. Proof. unfold map_img. rewrite elem_of_map_to_set. naive_solver. Qed. Lemma elem_of_map_img_1 m x : x ∈ map_img m → ∃ i, m !! i = Some x. Proof. apply elem_of_map_img. Qed. Lemma elem_of_map_img_2 m i x : m !! i = Some x → x ∈ map_img m. Proof. rewrite elem_of_map_img. eauto. Qed. Lemma not_elem_of_map_img m x : x ∉ map_img m ↔ ∀ i, m !! i ≠ Some x. Proof. rewrite elem_of_map_img. naive_solver. Qed. Lemma not_elem_of_map_img_1 m i x : x ∉ map_img m → m !! i ≠ Some x. Proof. rewrite not_elem_of_map_img. eauto. Qed. Lemma not_elem_of_map_img_2 m x : (∀ i, m !! i ≠ Some x) → x ∉ map_img m. Proof. apply not_elem_of_map_img. Qed. Lemma map_subseteq_img m1 m2 : m1 ⊆ m2 → map_img m1 ⊆ map_img m2. Proof. rewrite map_subseteq_spec. intros ? x. rewrite !elem_of_map_img. naive_solver. Qed. Lemma map_img_filter (P : K * A → Prop) `{!∀ ix, Decision (P ix)} m X : (∀ x, x ∈ X ↔ ∃ i, m !! i = Some x ∧ P (i, x)) → map_img (filter P m) ≡ X. Proof. intros HX x. rewrite elem_of_map_img, HX. unfold is_Some. by setoid_rewrite map_lookup_filter_Some. Qed. Lemma map_img_filter_subseteq (P : K * A → Prop) `{!∀ ix, Decision (P ix)} m : map_img (filter P m) ⊆ map_img m. Proof. apply map_subseteq_img, map_filter_subseteq. Qed. Lemma map_img_empty : map_img ∅ ≡ ∅. Proof. rewrite set_equiv. intros x. rewrite elem_of_map_img, elem_of_empty. setoid_rewrite lookup_empty. naive_solver. Qed. Lemma map_img_empty_iff m : map_img m ≡ ∅ ↔ m = ∅. Proof. split; [|intros ->; by rewrite map_img_empty]. intros Hm. apply map_empty; intros i. apply eq_None_ne_Some; intros x ?%elem_of_map_img_2. set_solver. Qed. Lemma map_img_empty_inv m : map_img m ≡ ∅ → m = ∅. Proof. apply map_img_empty_iff. Qed. Lemma map_img_delete_subseteq i m : map_img (delete i m) ⊆ map_img m. Proof. apply map_subseteq_img, delete_subseteq. Qed. Lemma map_img_insert m i x : map_img (<[i:=x]> m) ≡ {[ x ]} ∪ map_img (delete i m). Proof. intros y. rewrite elem_of_union, !elem_of_map_img, elem_of_singleton. setoid_rewrite lookup_delete_Some. setoid_rewrite lookup_insert_Some. naive_solver. Qed. Lemma map_img_insert_notin m i x : m !! i = None → map_img (<[i:=x]> m) ≡ {[ x ]} ∪ map_img m. Proof. intros. by rewrite map_img_insert, delete_notin. Qed. Lemma map_img_insert_subseteq m i x : map_img (<[i:=x]> m) ⊆ {[ x ]} ∪ map_img m. Proof. rewrite map_img_insert. apply union_mono_l, map_img_delete_subseteq. Qed. Lemma elem_of_map_img_insert m i x : x ∈ map_img (<[i:=x]> m). Proof. apply elem_of_map_img. exists i. apply lookup_insert. Qed. Lemma elem_of_map_img_insert_ne m i x y : x ≠ y → x ∈ map_img (<[i:=y]> m) → x ∈ map_img m. Proof. intros ? ?%map_img_insert_subseteq. set_solver. Qed. Lemma map_img_singleton i x : map_img {[ i := x ]} ≡ {[ x ]}. Proof. apply set_equiv. intros y. rewrite elem_of_map_img. setoid_rewrite lookup_singleton_Some. set_solver. Qed. Lemma elem_of_map_img_union m1 m2 x : x ∈ map_img (m1 ∪ m2) → x ∈ map_img m1 ∨ x ∈ map_img m2. Proof. rewrite !elem_of_map_img. setoid_rewrite lookup_union_Some_raw. naive_solver. Qed. Lemma elem_of_map_img_union_l m1 m2 x : x ∈ map_img m1 → x ∈ map_img (m1 ∪ m2). Proof. rewrite !elem_of_map_img. setoid_rewrite lookup_union_Some_raw. naive_solver. Qed. Lemma elem_of_map_img_union_r m1 m2 x : m1 ##ₘ m2 → x ∈ map_img m2 → x ∈ map_img (m1 ∪ m2). Proof. intros. rewrite map_union_comm by done. by apply elem_of_map_img_union_l. Qed. Lemma elem_of_map_img_union_disjoint m1 m2 x : m1 ##ₘ m2 → x ∈ map_img (m1 ∪ m2) ↔ x ∈ map_img m1 ∨ x ∈ map_img m2. Proof. naive_solver eauto using elem_of_map_img_union, elem_of_map_img_union_l, elem_of_map_img_union_r. Qed. Lemma map_img_union_subseteq m1 m2 : map_img (m1 ∪ m2) ⊆ map_img m1 ∪ map_img m2. Proof. intros v Hv. apply elem_of_union, elem_of_map_img_union. exact Hv. Qed. Lemma map_img_union_subseteq_l m1 m2 : map_img m1 ⊆ map_img (m1 ∪ m2). Proof. intros v Hv. by apply elem_of_map_img_union_l. Qed. Lemma map_img_union_subseteq_r m1 m2 : m1 ##ₘ m2 → map_img m2 ⊆ map_img (m1 ∪ m2). Proof. intros Hdisj v Hv. by apply elem_of_map_img_union_r. Qed. Lemma map_img_union_disjoint m1 m2 : m1 ##ₘ m2 → map_img (m1 ∪ m2) ≡ map_img m1 ∪ map_img m2. Proof. intros Hdisj. apply set_equiv. intros x. rewrite elem_of_union. by apply elem_of_map_img_union_disjoint. Qed. Lemma map_img_finite m : set_finite (map_img m). Proof. induction m as [|i x m ? IH] using map_ind. - rewrite map_img_empty. apply empty_finite. - eapply set_finite_subseteq; [by apply map_img_insert_subseteq|]. apply union_finite; [apply singleton_finite | apply IH]. Qed. (** Alternative definition of [img] in terms of [map_to_list]. *) Lemma map_img_alt m : map_img m ≡ list_to_set (map_to_list m).*2. Proof. induction m as [|i x m ? IH] using map_ind. { by rewrite map_img_empty, map_to_list_empty. } by rewrite map_img_insert_notin, map_to_list_insert by done. Qed. Lemma map_img_singleton_inv m i x : map_img m ≡ {[ x ]} → m !! i = None ∨ m !! i = Some x. Proof. intros Hm. destruct (m !! i) eqn:Hmk; [|by auto]. apply elem_of_map_img_2 in Hmk. set_solver. Qed. Lemma map_img_union_inv `{!RelDecision (∈@{SA})} X Y m : X ## Y → map_img m ≡ X ∪ Y → ∃ m1 m2, m = m1 ∪ m2 ∧ m1 ##ₘ m2 ∧ map_img m1 ≡ X ∧ map_img m2 ≡ Y. Proof. intros Hsep Himg. exists (filter (λ '(_,x), x ∈ X) m), (filter (λ '(_,x), x ∉ X) m). assert (filter (λ '(_,x), x ∈ X) m ##ₘ filter (λ '(_,x), x ∉ X) m). { apply map_disjoint_filter_complement. } split_and!. - symmetry. apply map_filter_union_complement. - done. - apply map_img_filter; intros x. split; [|naive_solver]. intros. destruct (elem_of_map_img_1 m x); set_solver. - apply map_img_filter; intros x; split. + intros. destruct (elem_of_map_img_1 m x); set_solver. + intros (i & ?%elem_of_map_img_2 & ?). set_solver. Qed. Section leibniz. Context `{!LeibnizEquiv SA}. Lemma map_img_empty_L : map_img ∅ = ∅. Proof. unfold_leibniz. exact map_img_empty. Qed. Lemma map_img_empty_iff_L m : map_img m = ∅ ↔ m = ∅. Proof. unfold_leibniz. apply map_img_empty_iff. Qed. Lemma map_img_empty_inv_L m : map_img m = ∅ → m = ∅. Proof. apply map_img_empty_iff_L. Qed. Lemma map_img_singleton_L i x : map_img {[ i := x ]} = {[ x ]}. Proof. unfold_leibniz. apply map_img_singleton. Qed. Lemma map_img_insert_notin_L m i x : m !! i = None → map_img (<[i:=x]> m) = {[ x ]} ∪ map_img m. Proof. unfold_leibniz. apply map_img_insert_notin. Qed. Lemma map_img_union_disjoint_L m1 m2 : m1 ##ₘ m2 → map_img (m1 ∪ m2) = map_img m1 ∪ map_img m2. Proof. unfold_leibniz. apply map_img_union_disjoint. Qed. Lemma map_img_alt_L m : map_img m = list_to_set (map_to_list m).*2. Proof. unfold_leibniz. apply map_img_alt. Qed. Lemma map_img_singleton_inv_L m i x : map_img m = {[ x ]} → m !! i = None ∨ m !! i = Some x. Proof. unfold_leibniz. apply map_img_singleton_inv. Qed. Lemma map_img_union_inv_L `{!RelDecision (∈@{SA})} X Y m : X ## Y → map_img m = X ∪ Y → ∃ m1 m2, m = m1 ∪ m2 ∧ m1 ##ₘ m2 ∧ map_img m1 = X ∧ map_img m2 = Y. Proof. unfold_leibniz. apply map_img_union_inv. Qed. End leibniz. (** Set solver instances *) Global Instance set_unfold_map_img_empty x : SetUnfoldElemOf x (map_img (∅:M A)) False. Proof. constructor. by rewrite map_img_empty, elem_of_empty. Qed. Global Instance set_unfold_map_img_singleton x i y : SetUnfoldElemOf x (map_img ({[i:=y]}:M A)) (x = y). Proof. constructor. by rewrite map_img_singleton, elem_of_singleton. Qed. End img. Lemma map_img_fmap `{FinMap K M, FinSet A SA, SemiSet B SB} (f : A → B) (m : M A) : map_img (f <$> m) ≡@{SB} set_map (C:=SA) f (map_img m). Proof. apply set_equiv. intros y. rewrite elem_of_map_img, elem_of_map. setoid_rewrite lookup_fmap. setoid_rewrite fmap_Some. setoid_rewrite elem_of_map_img. naive_solver. Qed. Lemma map_img_fmap_L `{FinMap K M, FinSet A SA, SemiSet B SB, !LeibnizEquiv SB} (f : A → B) (m : M A) : map_img (f <$> m) =@{SB} set_map (C:=SA) f (map_img m). Proof. unfold_leibniz. apply map_img_fmap. Qed. Lemma map_img_kmap `{FinMap K M, FinMap K2 M2, SemiSet A SA} (f : K → K2) `{!Inj (=) (=) f} m : map_img (kmap (M2:=M2) f m) ≡@{SA} map_img m. Proof. apply set_equiv. intros x. rewrite !elem_of_map_img. setoid_rewrite (lookup_kmap_Some f). naive_solver. Qed. Lemma map_img_kmap_L `{FinMap K M, FinMap K2 M2, SemiSet A SA, !LeibnizEquiv SA} (f : K → K2) `{!Inj (=) (=) f} m : map_img (kmap (M2:=M2) f m) =@{SA} map_img m. Proof. unfold_leibniz. by apply map_img_kmap. Qed. (** ** The [map_compose] operation *) Section map_compose. Context `{FinMap A MA, FinMap B MB} {C : Type}. Implicit Types (m : MB C) (n : MA B) (a : A) (b : B) (c : C). Lemma map_lookup_compose m n a : (m ∘ₘ n) !! a = n !! a ≫= (m !!.). Proof. apply lookup_omap. Qed. Lemma map_lookup_compose_Some m n a c : (m ∘ₘ n) !! a = Some c ↔ ∃ b, n !! a = Some b ∧ m !! b = Some c. Proof. rewrite map_lookup_compose. destruct (n !! a) eqn:?; naive_solver. Qed. Lemma map_lookup_compose_Some_1 m n a c : (m ∘ₘ n) !! a = Some c → ∃ b, n !! a = Some b ∧ m !! b = Some c. Proof. by rewrite map_lookup_compose_Some. Qed. Lemma map_lookup_compose_Some_2 m n a b c : n !! a = Some b → m !! b = Some c → (m ∘ₘ n) !! a = Some c. Proof. intros. apply map_lookup_compose_Some. by exists b. Qed. Lemma map_lookup_compose_None m n a : (m ∘ₘ n) !! a = None ↔ n !! a = None ∨ ∃ b, n !! a = Some b ∧ m !! b = None. Proof. rewrite map_lookup_compose. destruct (n !! a) eqn:?; naive_solver. Qed. Lemma map_lookup_compose_None_1 m n a : (m ∘ₘ n) !! a = None → n !! a = None ∨ ∃ b, n !! a = Some b ∧ m !! b = None. Proof. apply map_lookup_compose_None. Qed. Lemma map_lookup_compose_None_2_1 m n a : n !! a = None → (m ∘ₘ n) !! a = None. Proof. intros. apply map_lookup_compose_None. by left. Qed. Lemma map_lookup_compose_None_2_2 m n a b : n !! a = Some b → m !! b = None → (m ∘ₘ n) !! a = None. Proof. intros. apply map_lookup_compose_None. naive_solver. Qed. Lemma map_compose_img_subseteq `{SemiSet C D} m n : map_img (m ∘ₘ n) ⊆@{D} map_img m. Proof. intros c. rewrite !elem_of_map_img. setoid_rewrite map_lookup_compose_Some. naive_solver. Qed. Lemma map_compose_empty_r m : m ∘ₘ ∅ =@{MA C} ∅. Proof. apply omap_empty. Qed. Lemma map_compose_empty_l n : (∅ : MB C) ∘ₘ n =@{MA C} ∅. Proof. apply map_eq. intros k. rewrite map_lookup_compose, lookup_empty. destruct (n !! k); simpl; [|done]. apply lookup_empty. Qed. Lemma map_compose_empty_iff m n : m ∘ₘ n = ∅ ↔ ∀ a b, n !! a = Some b → m !! b = None. Proof. rewrite map_empty. setoid_rewrite map_lookup_compose_None. apply forall_proper; intros a. destruct (n !! a); naive_solver. Qed. Lemma map_disjoint_compose_l m1 m2 n : m1 ##ₘ m2 → m1 ∘ₘ n ##ₘ m2 ∘ₘ n. Proof. rewrite !map_disjoint_spec; intros Hdisj a c1 c2. rewrite !map_lookup_compose. destruct (n !! a); naive_solver. Qed. Lemma map_disjoint_compose_r m n1 n2 : n1 ##ₘ n2 → m ∘ₘ n1 ##ₘ m ∘ₘ n2. Proof. apply map_disjoint_omap. Qed. Lemma map_compose_union_l m1 m2 n : (m1 ∪ m2) ∘ₘ n = (m1 ∘ₘ n) ∪ (m2 ∘ₘ n). Proof. apply map_eq; intros a. rewrite lookup_union, !map_lookup_compose. destruct (n !! a) as [b|] eqn:?; simpl; [|done]. by rewrite lookup_union. Qed. Lemma map_compose_union_r m n1 n2 : n1 ##ₘ n2 → m ∘ₘ (n1 ∪ n2) = (m ∘ₘ n1) ∪ (m ∘ₘ n2). Proof. intros Hs. by apply map_omap_union. Qed. Lemma map_compose_mono_l m n1 n2 : n1 ⊆ n2 → m ∘ₘ n1 ⊆ m ∘ₘ n2. Proof. by apply map_omap_mono. Qed. Lemma map_compose_mono_r m1 m2 n : m1 ⊆ m2 → m1 ∘ₘ n ⊆ m2 ∘ₘ n. Proof. rewrite !map_subseteq_spec; intros ? a c. rewrite !map_lookup_compose_Some. naive_solver. Qed. Lemma map_compose_mono m1 m2 n1 n2 : m1 ⊆ m2 → n1 ⊆ n2 → m1 ∘ₘ n1 ⊆ m2 ∘ₘ n2. Proof. intros. transitivity (m1 ∘ₘ n2); [by apply map_compose_mono_l|by apply map_compose_mono_r]. Qed. Lemma map_compose_as_omap m n : m ∘ₘ n = omap (m !!.) n. Proof. done. Qed. (** Alternative definition of [m ∘ₘ n] by recursion on [n] *) Lemma map_compose_as_fold m n : m ∘ₘ n = map_fold (λ a b, match m !! b with | Some c => <[a:=c]> | None => id end) ∅ n. Proof. apply (map_fold_ind (λ mn n, omap (m !!.) n = mn)). { apply map_compose_empty_r. } intros k b n' mn Hn' IH. rewrite omap_insert, <-IH. destruct (m !! b); [done|]. by apply delete_notin, map_lookup_compose_None_2_1. Qed. Lemma map_compose_min_l `{SemiSet B D, !RelDecision (∈@{D})} m n : m ∘ₘ n = filter (λ '(b,_), b ∈ map_img (SA:=D) n) m ∘ₘ n. Proof. apply map_eq; intros a. rewrite !map_lookup_compose. destruct (n !! a) as [b|] eqn:?; simpl; [|done]. rewrite map_lookup_filter. destruct (m !! b) eqn:?; simpl; [|done]. by rewrite option_guard_True by (by eapply elem_of_map_img_2). Qed. Lemma map_compose_min_r m n : m ∘ₘ n = m ∘ₘ filter (λ '(_,b), is_Some (m !! b)) n. Proof. apply map_eq; intros a. rewrite !map_lookup_compose, map_lookup_filter. destruct (n !! a) as [b|] eqn:?; simpl; [|done]. by destruct (m !! b) eqn:?. Qed. Lemma map_compose_insert_Some m n a b c : m !! b = Some c → m ∘ₘ <[a:=b]> n =@{MA C} <[a:=c]> (m ∘ₘ n). Proof. intros. by apply omap_insert_Some. Qed. Lemma map_compose_insert_None m n a b : m !! b = None → m ∘ₘ <[a:=b]> n =@{MA C} delete a (m ∘ₘ n). Proof. intros. by apply omap_insert_None. Qed. Lemma map_compose_delete m n a : m ∘ₘ delete a n =@{MA C} delete a (m ∘ₘ n). Proof. intros. by apply omap_delete. Qed. Lemma map_compose_singleton_Some m a b c : m !! b = Some c → m ∘ₘ {[a := b]} =@{MA C} {[a := c]}. Proof. intros. by apply omap_singleton_Some. Qed. Lemma map_compose_singleton_None m a b : m !! b = None → m ∘ₘ {[a := b]} =@{MA C} ∅. Proof. intros. by apply omap_singleton_None. Qed. Lemma map_compose_singletons a b c : ({[b := c]} : MB C) ∘ₘ {[a := b]} =@{MA C} {[a := c]}. Proof. by apply map_compose_singleton_Some, lookup_insert. Qed. End map_compose. Lemma map_compose_assoc `{FinMap A MA, FinMap B MB, FinMap C MC} {D} (m : MC D) (n : MB C) (o : MA B) : m ∘ₘ (n ∘ₘ o) = (m ∘ₘ n) ∘ₘ o. Proof. apply map_eq; intros a. rewrite !map_lookup_compose. destruct (o !! a); simpl; [|done]. by rewrite map_lookup_compose. Qed. Lemma map_fmap_map_compose `{FinMap A MA, FinMap B MB} {C1 C2} (f : C1 → C2) (m : MB C1) (n : MA B) : f <$> (m ∘ₘ n) = (f <$> m) ∘ₘ n. Proof. apply map_eq; intros a. rewrite lookup_fmap, !map_lookup_compose. destruct (n !! a); simpl; [|done]. by rewrite lookup_fmap. Qed. Lemma map_omap_map_compose `{FinMap A MA, FinMap B MB} {C1 C2} (f : C1 → option C2) (m : MB C1) (n : MA B) : omap f (m ∘ₘ n) = omap f m ∘ₘ n. Proof. apply map_eq; intros a. rewrite lookup_omap, !map_lookup_compose. destruct (n !! a); simpl; [|done]. by rewrite lookup_omap. Qed. (** * Tactics *) (** The tactic [decompose_map_disjoint] simplifies occurrences of [disjoint] in the hypotheses that involve the empty map [∅], the union [(∪)] or insert [<[_:=_]>] operation, the singleton [{[_:= _]}] map, and disjointness of lists of maps. This tactic does not yield any information loss as all simplifications performed are reversible. *) Ltac decompose_map_disjoint := repeat match goal with | H : _ ∪ _ ##ₘ _ |- _ => apply map_disjoint_union_l in H; destruct H | H : _ ##ₘ _ ∪ _ |- _ => apply map_disjoint_union_r in H; destruct H | H : {[ _ := _ ]} ##ₘ _ |- _ => apply map_disjoint_singleton_l in H | H : _ ##ₘ {[ _ := _ ]} |- _ => apply map_disjoint_singleton_r in H | H : <[_:=_]>_ ##ₘ _ |- _ => apply map_disjoint_insert_l in H; destruct H | H : _ ##ₘ <[_:=_]>_ |- _ => apply map_disjoint_insert_r in H; destruct H | H : ⋃ _ ##ₘ _ |- _ => apply map_disjoint_union_list_l in H | H : _ ##ₘ ⋃ _ |- _ => apply map_disjoint_union_list_r in H | H : ∅ ##ₘ _ |- _ => clear H | H : _ ##ₘ ∅ |- _ => clear H | H : Forall (.##ₘ _) _ |- _ => rewrite Forall_vlookup in H | H : Forall (.##ₘ _) [] |- _ => clear H | H : Forall (.##ₘ _) (_ :: _) |- _ => rewrite Forall_cons in H; destruct H | H : Forall (.##ₘ _) (_ :: _) |- _ => rewrite Forall_app in H; destruct H end. (** To prove a disjointness property, we first decompose all hypotheses, and then use an auto database to prove the required property. *) Create HintDb map_disjoint discriminated. Ltac solve_map_disjoint := solve [decompose_map_disjoint; auto with map_disjoint]. (** We declare these hints using [Hint Extern] instead of [Hint Resolve] as [eauto] works badly with hints parametrized by type class constraints. *) Global Hint Extern 1 (_ ##ₘ _) => done : map_disjoint. Global Hint Extern 2 (∅ ##ₘ _) => apply map_disjoint_empty_l : map_disjoint. Global Hint Extern 2 (_ ##ₘ ∅) => apply map_disjoint_empty_r : map_disjoint. Global Hint Extern 2 ({[ _ := _ ]} ##ₘ _) => apply map_disjoint_singleton_l_2 : map_disjoint. Global Hint Extern 2 (_ ##ₘ {[ _ := _ ]}) => apply map_disjoint_singleton_r_2 : map_disjoint. Global Hint Extern 2 (_ ∪ _ ##ₘ _) => apply map_disjoint_union_l_2 : map_disjoint. Global Hint Extern 2 (_ ##ₘ _ ∪ _) => apply map_disjoint_union_r_2 : map_disjoint. Global Hint Extern 2 ({[_:= _]} ##ₘ _) => apply map_disjoint_singleton_l : map_disjoint. Global Hint Extern 2 (_ ##ₘ {[_:= _]}) => apply map_disjoint_singleton_r : map_disjoint. Global Hint Extern 2 (<[_:=_]>_ ##ₘ _) => apply map_disjoint_insert_l_2 : map_disjoint. Global Hint Extern 2 (_ ##ₘ <[_:=_]>_) => apply map_disjoint_insert_r_2 : map_disjoint. Global Hint Extern 2 (delete _ _ ##ₘ _) => apply map_disjoint_delete_l : map_disjoint. Global Hint Extern 2 (_ ##ₘ delete _ _) => apply map_disjoint_delete_r : map_disjoint. Global Hint Extern 2 (list_to_map _ ##ₘ _) => apply map_disjoint_list_to_map_zip_l_2 : mem_disjoint. Global Hint Extern 2 (_ ##ₘ list_to_map _) => apply map_disjoint_list_to_map_zip_r_2 : mem_disjoint. Global Hint Extern 2 (⋃ _ ##ₘ _) => apply map_disjoint_union_list_l_2 : mem_disjoint. Global Hint Extern 2 (_ ##ₘ ⋃ _) => apply map_disjoint_union_list_r_2 : mem_disjoint. Global Hint Extern 2 (foldr delete _ _ ##ₘ _) => apply map_disjoint_foldr_delete_l : map_disjoint. Global Hint Extern 2 (_ ##ₘ foldr delete _ _) => apply map_disjoint_foldr_delete_r : map_disjoint. Global Hint Extern 3 (_ ∘ₘ _ ##ₘ _ ∘ₘ _) => apply map_disjoint_compose_l : map_disjoint. Global Hint Extern 3 (_ ∘ₘ _ ##ₘ _ ∘ₘ _) => apply map_disjoint_compose_r : map_disjoint. (** The tactic [simpl_map by tac] simplifies occurrences of finite map look ups. It uses [tac] to discharge generated inequalities. Look ups in unions do not have nice equational properties, hence it invokes [tac] to prove that such look ups yield [Some]. *) Tactic Notation "simpl_map" "by" tactic3(tac) := repeat match goal with | H : context[ ∅ !! _ ] |- _ => rewrite lookup_empty in H | H : context[ (<[_:=_]>_) !! _ ] |- _ => rewrite lookup_insert in H || rewrite lookup_insert_ne in H by tac | H : context[ (alter _ _ _) !! _] |- _ => rewrite lookup_alter in H || rewrite lookup_alter_ne in H by tac | H : context[ (delete _ _) !! _] |- _ => rewrite lookup_delete in H || rewrite lookup_delete_ne in H by tac | H : context[ {[ _ := _ ]} !! _ ] |- _ => rewrite lookup_singleton in H || rewrite lookup_singleton_ne in H by tac | H : context[ (_ <$> _) !! _ ] |- _ => rewrite lookup_fmap in H | H : context[ (omap _ _) !! _ ] |- _ => rewrite lookup_omap in H | H : context[ lookup (A:=?A) ?i (?m1 ∪ ?m2) ] |- _ => let x := mk_evar A in let E := fresh in assert ((m1 ∪ m2) !! i = Some x) as E by (clear H; by tac); rewrite E in H; clear E | |- context[ ∅ !! _ ] => rewrite lookup_empty | |- context[ (<[_:=_]>_) !! _ ] => rewrite lookup_insert || rewrite lookup_insert_ne by tac | |- context[ (alter _ _ _) !! _ ] => rewrite lookup_alter || rewrite lookup_alter_ne by tac | |- context[ (delete _ _) !! _ ] => rewrite lookup_delete || rewrite lookup_delete_ne by tac | |- context[ {[ _ := _ ]} !! _ ] => rewrite lookup_singleton || rewrite lookup_singleton_ne by tac | |- context[ (_ <$> _) !! _ ] => rewrite lookup_fmap | |- context[ (omap _ _) !! _ ] => rewrite lookup_omap | |- context [ lookup (A:=?A) ?i ?m ] => let x := mk_evar A in let E := fresh in assert (m !! i = Some x) as E by tac; rewrite E; clear E end. Create HintDb simpl_map discriminated. Tactic Notation "simpl_map" := simpl_map by eauto with simpl_map map_disjoint. Global Hint Extern 80 ((_ ∪ _) !! _ = Some _) => apply lookup_union_Some_l : simpl_map. Global Hint Extern 81 ((_ ∪ _) !! _ = Some _) => apply lookup_union_Some_r : simpl_map. Global Hint Extern 80 ({[ _:=_ ]} !! _ = Some _) => apply lookup_singleton : simpl_map. Global Hint Extern 80 (<[_:=_]> _ !! _ = Some _) => apply lookup_insert : simpl_map. (** Now we take everything together and also discharge conflicting look ups, simplify overlapping look ups, and perform cancellations of equalities involving unions. *) Tactic Notation "simplify_map_eq" "by" tactic3(tac) := decompose_map_disjoint; repeat match goal with | _ => progress simpl_map by tac | _ => progress simplify_eq/= | _ => progress simpl_option by tac | H : {[ _ := _ ]} !! _ = None |- _ => rewrite lookup_singleton_None in H | H : {[ _ := _ ]} !! _ = Some _ |- _ => rewrite lookup_singleton_Some in H; destruct H | H1 : ?m1 !! ?i = Some ?x, H2 : ?m2 !! ?i = Some ?y |- _ => let H3 := fresh in opose proof* (lookup_weaken_inv m1 m2 i x y) as H3; [done|by tac|done|]; clear H2; symmetry in H3 | H1 : ?m1 !! ?i = Some ?x, H2 : ?m2 !! ?i = None |- _ => let H3 := fresh in apply (lookup_weaken _ m2) in H1; [congruence|by tac] | H : ?m ∪ _ = ?m ∪ _ |- _ => apply map_union_cancel_l in H; [|by tac|by tac] | H : _ ∪ ?m = _ ∪ ?m |- _ => apply map_union_cancel_r in H; [|by tac|by tac] | H : {[?i := ?x]} = ∅ |- _ => by destruct (map_non_empty_singleton i x) | H : ∅ = {[?i := ?x]} |- _ => by destruct (map_non_empty_singleton i x) | H : ?m !! ?i = Some _, H2 : ?m !! ?j = None |- _ => unless (i ≠ j) by done; assert (i ≠ j) by (by intros ?; simplify_eq) end. Tactic Notation "simplify_map_eq" "/=" "by" tactic3(tac) := repeat (progress csimpl in * || simplify_map_eq by tac). Tactic Notation "simplify_map_eq" := simplify_map_eq by eauto with simpl_map map_disjoint. Tactic Notation "simplify_map_eq" "/=" := simplify_map_eq/= by eauto with simpl_map map_disjoint. stdpp-coq-stdpp-1.9.0/stdpp/fin_sets.v000066400000000000000000000706361451153341500177340ustar00rootroot00000000000000(** This file collects definitions and theorems on finite sets. Most importantly, it implements a fold and size function and some useful induction principles on finite sets . *) From stdpp Require Import relations. From stdpp Require Export numbers sets. From stdpp Require Import options. (* Pick up extra assumptions from section parameters. *) Set Default Proof Using "Type*". (** Operations *) Global Instance set_size `{Elements A C} : Size C := length ∘ elements. Global Typeclasses Opaque set_size. Definition set_fold `{Elements A C} {B} (f : A → B → B) (b : B) : C → B := foldr f b ∘ elements. Global Typeclasses Opaque set_fold. Global Instance set_filter `{Elements A C, Empty C, Singleton A C, Union C} : Filter A C := λ P _ X, list_to_set (filter P (elements X)). Global Typeclasses Opaque set_filter. Definition set_map `{Elements A C, Singleton B D, Empty D, Union D} (f : A → B) (X : C) : D := list_to_set (f <$> elements X). Global Typeclasses Opaque set_map. Global Instance: Params (@set_map) 8 := {}. Definition set_bind `{Elements A SA, Empty SB, Union SB} (f : A → SB) (X : SA) : SB := ⋃ (f <$> elements X). Global Typeclasses Opaque set_bind. Global Instance: Params (@set_bind) 6 := {}. Definition set_omap `{Elements A C, Singleton B D, Empty D, Union D} (f : A → option B) (X : C) : D := list_to_set (omap f (elements X)). Global Typeclasses Opaque set_omap. Global Instance: Params (@set_omap) 8 := {}. Global Instance set_fresh `{Elements A C, Fresh A (list A)} : Fresh A C := fresh ∘ elements. Global Typeclasses Opaque set_fresh. (** We generalize the [fresh] operation on sets to generate lists of fresh elements w.r.t. a set [X]. *) Fixpoint fresh_list `{Fresh A C, Union C, Singleton A C} (n : nat) (X : C) : list A := match n with | 0 => [] | S n => let x := fresh X in x :: fresh_list n ({[ x ]} ∪ X) end. Global Instance: Params (@fresh_list) 6 := {}. (** The following inductive predicate classifies that a list of elements is in fact fresh w.r.t. a set [X]. *) Inductive Forall_fresh `{ElemOf A C} (X : C) : list A → Prop := | Forall_fresh_nil : Forall_fresh X [] | Forall_fresh_cons x xs : x ∉ xs → x ∉ X → Forall_fresh X xs → Forall_fresh X (x :: xs). (** Properties **) Section fin_set. Context `{FinSet A C}. Implicit Types X Y : C. Lemma fin_set_finite X : set_finite X. Proof. by exists (elements X); intros; rewrite elem_of_elements. Qed. Local Instance elem_of_dec_slow : RelDecision (∈@{C}) | 100. Proof. refine (λ x X, cast_if (decide_rel (∈) x (elements X))); by rewrite <-(elem_of_elements _). Defined. (** * The [elements] operation *) Global Instance set_unfold_elements X x P : SetUnfoldElemOf x X P → SetUnfoldElemOf x (elements X) P. Proof. constructor. by rewrite elem_of_elements, (set_unfold_elem_of x X P). Qed. Global Instance elements_proper: Proper ((≡) ==> (≡ₚ)) (elements (C:=C)). Proof. intros ?? E. apply NoDup_Permutation. - apply NoDup_elements. - apply NoDup_elements. - intros. by rewrite !elem_of_elements, E. Qed. Lemma elements_empty : elements (∅ : C) = []. Proof. apply elem_of_nil_inv; intros x. rewrite elem_of_elements, elem_of_empty; tauto. Qed. Lemma elements_empty_iff X : elements X = [] ↔ X ≡ ∅. Proof. rewrite <-Permutation_nil_r. split; [|intros ->; by rewrite elements_empty]. intros HX. apply elem_of_equiv_empty; intros x. rewrite <-elem_of_elements, HX. apply not_elem_of_nil. Qed. Lemma elements_empty_inv X : elements X = [] → X ≡ ∅. Proof. apply elements_empty_iff. Qed. Lemma elements_union_singleton (X : C) x : x ∉ X → elements ({[ x ]} ∪ X) ≡ₚ x :: elements X. Proof. intros ?; apply NoDup_Permutation. { apply NoDup_elements. } { by constructor; rewrite ?elem_of_elements; try apply NoDup_elements. } intros y; rewrite elem_of_elements, elem_of_union, elem_of_singleton. by rewrite elem_of_cons, elem_of_elements. Qed. Lemma elements_singleton x : elements ({[ x ]} : C) = [x]. Proof. apply Permutation_singleton_r. by rewrite <-(right_id ∅ (∪) {[x]}), elements_union_singleton, elements_empty by set_solver. Qed. Lemma elements_disj_union (X Y : C) : X ## Y → elements (X ∪ Y) ≡ₚ elements X ++ elements Y. Proof. intros HXY. apply NoDup_Permutation. - apply NoDup_elements. - apply NoDup_app. set_solver by eauto using NoDup_elements. - set_solver. Qed. Lemma elements_submseteq X Y : X ⊆ Y → elements X ⊆+ elements Y. Proof. intros; apply NoDup_submseteq; eauto using NoDup_elements. intros x. rewrite !elem_of_elements; auto. Qed. Lemma list_to_set_elements X : list_to_set (elements X) ≡ X. Proof. intros ?. rewrite elem_of_list_to_set. apply elem_of_elements. Qed. Lemma list_to_set_elements_L `{!LeibnizEquiv C} X : list_to_set (elements X) = X. Proof. unfold_leibniz. apply list_to_set_elements. Qed. Lemma elements_list_to_set l : NoDup l → elements (list_to_set (C:=C) l) ≡ₚ l. Proof. intros Hl. induction Hl. { rewrite list_to_set_nil. rewrite elements_empty. done. } rewrite list_to_set_cons, elements_disj_union by set_solver. rewrite elements_singleton. apply Permutation_skip. done. Qed. (** * The [size] operation *) Global Instance set_size_proper: Proper ((≡) ==> (=)) (@size C _). Proof. intros ?? E. apply Permutation_length. by rewrite E. Qed. Lemma size_empty : size (∅ : C) = 0. Proof. unfold size, set_size. simpl. by rewrite elements_empty. Qed. Lemma size_empty_iff (X : C) : size X = 0 ↔ X ≡ ∅. Proof. split; [|intros ->; by rewrite size_empty]. intros; apply equiv_empty; intros x; rewrite <-elem_of_elements. by rewrite (nil_length_inv (elements X)), ?elem_of_nil. Qed. Lemma size_empty_inv (X : C) : size X = 0 → X ≡ ∅. Proof. apply size_empty_iff. Qed. Lemma size_non_empty_iff (X : C) : size X ≠ 0 ↔ X ≢ ∅. Proof. by rewrite size_empty_iff. Qed. Lemma set_choose_or_empty X : (∃ x, x ∈ X) ∨ X ≡ ∅. Proof. destruct (elements X) as [|x l] eqn:HX; [right|left]. - apply equiv_empty; intros x. by rewrite <-elem_of_elements, HX, elem_of_nil. - exists x. rewrite <-elem_of_elements, HX. by left. Qed. Lemma set_choose X : X ≢ ∅ → ∃ x, x ∈ X. Proof. intros. by destruct (set_choose_or_empty X). Qed. Lemma set_choose_L `{!LeibnizEquiv C} X : X ≠ ∅ → ∃ x, x ∈ X. Proof. unfold_leibniz. apply set_choose. Qed. Lemma size_pos_elem_of X : 0 < size X → ∃ x, x ∈ X. Proof. intros Hsz. destruct (set_choose_or_empty X) as [|HX]; [done|]. contradict Hsz. rewrite HX, size_empty; lia. Qed. Lemma size_singleton (x : A) : size ({[ x ]} : C) = 1. Proof. unfold size, set_size. simpl. by rewrite elements_singleton. Qed. Lemma size_singleton_inv X x y : size X = 1 → x ∈ X → y ∈ X → x = y. Proof. unfold size, set_size. simpl. rewrite <-!elem_of_elements. generalize (elements X). intros [|? l]; intro; simplify_eq/=. rewrite (nil_length_inv l), !elem_of_list_singleton by done; congruence. Qed. Lemma size_1_elem_of X : size X = 1 → ∃ x, X ≡ {[ x ]}. Proof. intros E. destruct (size_pos_elem_of X) as [x ?]; auto with lia. exists x. apply set_equiv. split. - rewrite elem_of_singleton. eauto using size_singleton_inv. - set_solver. Qed. Lemma size_union X Y : X ## Y → size (X ∪ Y) = size X + size Y. Proof. intros. unfold size, set_size. simpl. rewrite <-app_length. apply Permutation_length, NoDup_Permutation. - apply NoDup_elements. - apply NoDup_app; repeat split; try apply NoDup_elements. intros x; rewrite !elem_of_elements; set_solver. - intros. by rewrite elem_of_app, !elem_of_elements, elem_of_union. Qed. Lemma size_union_alt X Y : size (X ∪ Y) = size X + size (Y ∖ X). Proof. rewrite <-size_union by set_solver. setoid_replace (Y ∖ X) with ((Y ∪ X) ∖ X) by set_solver. rewrite <-union_difference, (comm (∪)); set_solver. Qed. Lemma size_difference X Y : Y ⊆ X → size (X ∖ Y) = size X - size Y. Proof. intros. rewrite (union_difference Y X) at 2 by done. rewrite size_union by set_solver. lia. Qed. Lemma size_difference_alt X Y : size (X ∖ Y) = size X - size (X ∩ Y). Proof. intros. rewrite <-size_difference by set_solver. apply set_size_proper. set_solver. Qed. Lemma set_subseteq_size_equiv X1 X2 : X1 ⊆ X2 → size X2 ≤ size X1 → X1 ≡ X2. Proof. intros. apply (anti_symm _); [done|]. apply empty_difference_subseteq, size_empty_iff. rewrite size_difference by done. lia. Qed. Lemma set_subseteq_size_eq `{!LeibnizEquiv C} X1 X2 : X1 ⊆ X2 → size X2 ≤ size X1 → X1 = X2. Proof. unfold_leibniz. apply set_subseteq_size_equiv. Qed. Lemma subseteq_size X Y : X ⊆ Y → size X ≤ size Y. Proof. intros. rewrite (union_difference X Y), size_union_alt by done. lia. Qed. Lemma subset_size X Y : X ⊂ Y → size X < size Y. Proof. intros. rewrite (union_difference X Y) by set_solver. rewrite size_union_alt, difference_twice. cut (size (Y ∖ X) ≠ 0); [lia |]. by apply size_non_empty_iff, non_empty_difference. Qed. Lemma size_list_to_set l : NoDup l → size (list_to_set (C:=C) l) = length l. Proof. intros Hl. unfold size, set_size. simpl. rewrite elements_list_to_set; done. Qed. (** * Induction principles *) Lemma set_wf : wf (⊂@{C}). Proof. apply (wf_projected (<) size); auto using subset_size, lt_wf. Qed. Lemma set_ind (P : C → Prop) : Proper ((≡) ==> impl) P → P ∅ → (∀ x X, x ∉ X → P X → P ({[ x ]} ∪ X)) → ∀ X, P X. Proof. intros ? Hemp Hadd. apply well_founded_induction with (⊂). { apply set_wf. } intros X IH. destruct (set_choose_or_empty X) as [[x ?]|HX]. - rewrite (union_difference {[ x ]} X) by set_solver. apply Hadd; [set_solver|]. apply IH; set_solver. - by rewrite HX. Qed. Lemma set_ind_L `{!LeibnizEquiv C} (P : C → Prop) : P ∅ → (∀ x X, x ∉ X → P X → P ({[ x ]} ∪ X)) → ∀ X, P X. Proof. apply set_ind. by intros ?? ->%leibniz_equiv_iff. Qed. (** * The [set_fold] operation *) Lemma set_fold_ind {B} (P : B → C → Prop) (f : A → B → B) (b : B) : (∀ x, Proper ((≡) ==> impl) (P x)) → P b ∅ → (∀ x X r, x ∉ X → P r X → P (f x r) ({[ x ]} ∪ X)) → ∀ X, P (set_fold f b X) X. Proof. intros ? Hemp Hadd. cut (∀ l, NoDup l → ∀ X, (∀ x, x ∈ X ↔ x ∈ l) → P (foldr f b l) X). { intros help ?. apply help; [apply NoDup_elements|]. symmetry. apply elem_of_elements. } induction 1 as [|x l ?? IH]; simpl. - intros X HX. setoid_rewrite elem_of_nil in HX. rewrite equiv_empty; [done|]. set_solver. - intros X HX. setoid_rewrite elem_of_cons in HX. rewrite (union_difference {[ x ]} X) by set_solver. apply Hadd; [set_solver|]. apply IH; set_solver. Qed. Lemma set_fold_ind_L `{!LeibnizEquiv C} {B} (P : B → C → Prop) (f : A → B → B) (b : B) : P b ∅ → (∀ x X r, x ∉ X → P r X → P (f x r) ({[ x ]} ∪ X)) → ∀ X, P (set_fold f b X) X. Proof. apply set_fold_ind. solve_proper. Qed. Lemma set_fold_proper {B} (R : relation B) `{!PreOrder R} (f : A → B → B) (b : B) `{!∀ a, Proper (R ==> R) (f a)} (Hf : ∀ a1 a2 b, R (f a1 (f a2 b)) (f a2 (f a1 b))) : Proper ((≡) ==> R) (set_fold f b : C → B). Proof. intros ?? E. apply (foldr_permutation R f b); auto. by rewrite E. Qed. Lemma set_fold_empty {B} (f : A → B → B) (b : B) : set_fold f b (∅ : C) = b. Proof. by unfold set_fold; simpl; rewrite elements_empty. Qed. Lemma set_fold_singleton {B} (f : A → B → B) (b : B) (a : A) : set_fold f b ({[a]} : C) = f a b. Proof. by unfold set_fold; simpl; rewrite elements_singleton. Qed. (** Generalization of [set_fold_disj_union] (below) with a.) a relation [R] instead of equality b.) a function [f : A → B → B] instead of [f : A → A → A], and c.) premises that ensure the elements are in [X ∪ Y]. *) Lemma set_fold_disj_union_strong {B} (R : relation B) `{!PreOrder R} (f : A → B → B) (b : B) X Y : (∀ x, Proper (R ==> R) (f x)) → (∀ x1 x2 b', (** This is morally commutativity + associativity for elements of [X ∪ Y] *) x1 ∈ X ∪ Y → x2 ∈ X ∪ Y → x1 ≠ x2 → R (f x1 (f x2 b')) (f x2 (f x1 b'))) → X ## Y → R (set_fold f b (X ∪ Y)) (set_fold f (set_fold f b X) Y). Proof. intros ? Hf Hdisj. unfold set_fold; simpl. rewrite <-foldr_app. apply (foldr_permutation R f b). - intros j1 x1 j2 x2 b' Hj Hj1 Hj2. apply Hf. + apply elem_of_list_lookup_2 in Hj1. set_solver. + apply elem_of_list_lookup_2 in Hj2. set_solver. + intros ->. pose proof (NoDup_elements (X ∪ Y)). by eapply Hj, NoDup_lookup. - by rewrite elements_disj_union, (comm (++)). Qed. Lemma set_fold_disj_union (f : A → A → A) (b : A) X Y : Comm (=) f → Assoc (=) f → X ## Y → set_fold f b (X ∪ Y) = set_fold f (set_fold f b X) Y. Proof. intros. apply (set_fold_disj_union_strong _ _ _ _ _ _); [|done]. intros x1 x2 b' _ _ _. by rewrite !(assoc_L f), (comm_L f x1). Qed. Lemma set_fold_comm_acc_strong {B} (R : relation B) `{!PreOrder R} (f : A → B → B) (g : B → B) (b : B) X : (∀ x, Proper (R ==> R) (f x)) → (∀ x y, x ∈ X → R (f x (g y)) (g (f x y))) → R (set_fold f (g b) X) (g (set_fold f b X)). Proof. intros. unfold set_fold; simpl. apply foldr_comm_acc_strong; [done|solve_proper|set_solver]. Qed. Lemma set_fold_comm_acc (f : A → A → A) (g : A → A) (a : A) X : (∀ x y, f x (g y) = g (f x y)) → set_fold f (g a) X = g (set_fold f a X). Proof. intros. apply (set_fold_comm_acc_strong _); [solve_proper|auto]. Qed. (** * Minimal elements *) Lemma minimal_exists R `{!Transitive R, ∀ x y, Decision (R x y)} (X : C) : X ≢ ∅ → ∃ x, x ∈ X ∧ minimal R x X. Proof. pattern X; apply set_ind; clear X. { by intros X X' HX; setoid_rewrite HX. } { done. } intros x X ? IH Hemp. destruct (set_choose_or_empty X) as [[z ?]|HX]. { destruct IH as (x' & Hx' & Hmin); [set_solver|]. destruct (decide (R x x')). - exists x; split; [set_solver|]. eapply union_minimal; [eapply singleton_minimal|by eapply minimal_weaken]. - exists x'; split; [set_solver|]. by eapply union_minimal; [apply singleton_minimal_not_above|]. } exists x; split; [set_solver|]. rewrite HX, (right_id _ (∪)). apply singleton_minimal. Qed. Lemma minimal_exists_L R `{!LeibnizEquiv C, !Transitive R, ∀ x y, Decision (R x y)} (X : C) : X ≠ ∅ → ∃ x, x ∈ X ∧ minimal R x X. Proof. unfold_leibniz. apply (minimal_exists R). Qed. (** * Filter *) Lemma elem_of_filter (P : A → Prop) `{!∀ x, Decision (P x)} X x : x ∈ filter P X ↔ P x ∧ x ∈ X. Proof. unfold filter, set_filter. by rewrite elem_of_list_to_set, elem_of_list_filter, elem_of_elements. Qed. Global Instance set_unfold_filter (P : A → Prop) `{!∀ x, Decision (P x)} X Q x : SetUnfoldElemOf x X Q → SetUnfoldElemOf x (filter P X) (P x ∧ Q). Proof. intros ?; constructor. by rewrite elem_of_filter, (set_unfold_elem_of x X Q). Qed. Section filter. Context (P : A → Prop) `{!∀ x, Decision (P x)}. Lemma filter_empty : filter P (∅:C) ≡ ∅. Proof. set_solver. Qed. Lemma filter_singleton x : P x → filter P ({[ x ]} : C) ≡ {[ x ]}. Proof. set_solver. Qed. Lemma filter_singleton_not x : ¬P x → filter P ({[ x ]} : C) ≡ ∅. Proof. set_solver. Qed. Lemma filter_empty_not_elem_of X x : filter P X ≡ ∅ → P x → x ∉ X. Proof. set_solver. Qed. Lemma disjoint_filter X Y : X ## Y → filter P X ## filter P Y. Proof. set_solver. Qed. Lemma filter_union X Y : filter P (X ∪ Y) ≡ filter P X ∪ filter P Y. Proof. set_solver. Qed. Lemma disjoint_filter_complement X : filter P X ## filter (λ x, ¬P x) X. Proof. set_solver. Qed. Lemma filter_union_complement X : filter P X ∪ filter (λ x, ¬P x) X ≡ X. Proof. intros x. destruct (decide (P x)); set_solver. Qed. Section leibniz_equiv. Context `{!LeibnizEquiv C}. Lemma filter_empty_L : filter P (∅:C) = ∅. Proof. unfold_leibniz. apply filter_empty. Qed. Lemma filter_singleton_L x : P x → filter P ({[ x ]} : C) = {[ x ]}. Proof. unfold_leibniz. apply filter_singleton. Qed. Lemma filter_singleton_not_L x : ¬P x → filter P ({[ x ]} : C) = ∅. Proof. unfold_leibniz. apply filter_singleton_not. Qed. Lemma filter_empty_not_elem_of_L X x : filter P X = ∅ → P x → x ∉ X. Proof. unfold_leibniz. apply filter_empty_not_elem_of. Qed. Lemma filter_union_L X Y : filter P (X ∪ Y) = filter P X ∪ filter P Y. Proof. unfold_leibniz. apply filter_union. Qed. Lemma filter_union_complement_L X Y : filter P X ∪ filter (λ x, ¬P x) X = X. Proof. unfold_leibniz. apply filter_union_complement. Qed. End leibniz_equiv. End filter. (** * Map *) Section map. Context `{SemiSet B D}. Lemma elem_of_map (f : A → B) (X : C) y : y ∈ set_map (D:=D) f X ↔ ∃ x, y = f x ∧ x ∈ X. Proof. unfold set_map. rewrite elem_of_list_to_set, elem_of_list_fmap. by setoid_rewrite elem_of_elements. Qed. Global Instance set_unfold_map (f : A → B) (X : C) (P : A → Prop) y : (∀ x, SetUnfoldElemOf x X (P x)) → SetUnfoldElemOf y (set_map (D:=D) f X) (∃ x, y = f x ∧ P x). Proof. constructor. rewrite elem_of_map; naive_solver. Qed. Global Instance set_map_proper : Proper (pointwise_relation _ (=) ==> (≡) ==> (≡)) (set_map (C:=C) (D:=D)). Proof. intros f g ? X Y. set_unfold; naive_solver. Qed. Global Instance set_map_mono : Proper (pointwise_relation _ (=) ==> (⊆) ==> (⊆)) (set_map (C:=C) (D:=D)). Proof. intros f g ? X Y. set_unfold; naive_solver. Qed. Lemma elem_of_map_1 (f : A → B) (X : C) (y : B) : y ∈ set_map (D:=D) f X → ∃ x, y = f x ∧ x ∈ X. Proof. set_solver. Qed. Lemma elem_of_map_2 (f : A → B) (X : C) (x : A) : x ∈ X → f x ∈ set_map (D:=D) f X. Proof. set_solver. Qed. Lemma elem_of_map_2_alt (f : A → B) (X : C) (x : A) (y : B) : x ∈ X → y = f x → y ∈ set_map (D:=D) f X. Proof. set_solver. Qed. Lemma set_map_empty (f : A → B) : set_map (C:=C) (D:=D) f ∅ = ∅. Proof. unfold set_map. rewrite elements_empty. done. Qed. Lemma set_map_union (f : A → B) (X Y : C) : set_map (D:=D) f (X ∪ Y) ≡ set_map (D:=D) f X ∪ set_map (D:=D) f Y. Proof. set_solver. Qed. (** This cannot be using [=] because [list_to_set_singleton] does not hold for [=]. *) Lemma set_map_singleton (f : A → B) (x : A) : set_map (C:=C) (D:=D) f {[x]} ≡ {[f x]}. Proof. set_solver. Qed. Lemma set_map_union_L `{!LeibnizEquiv D} (f : A → B) (X Y : C) : set_map (D:=D) f (X ∪ Y) = set_map (D:=D) f X ∪ set_map (D:=D) f Y. Proof. unfold_leibniz. apply set_map_union. Qed. Lemma set_map_singleton_L `{!LeibnizEquiv D} (f : A → B) (x : A) : set_map (C:=C) (D:=D) f {[x]} = {[f x]}. Proof. unfold_leibniz. apply set_map_singleton. Qed. End map. (** * Bind *) Section set_bind. Context `{SemiSet B SB}. Local Notation set_bind := (set_bind (A:=A) (SA:=C) (SB:=SB)). Lemma elem_of_set_bind (f : A → SB) (X : C) y : y ∈ set_bind f X ↔ ∃ x, x ∈ X ∧ y ∈ f x. Proof. unfold set_bind. rewrite !elem_of_union_list. set_solver. Qed. Global Instance set_unfold_set_bind (f : A → SB) (X : C) (y : B) (P : A → B → Prop) (Q : A → Prop) : (∀ x y, SetUnfoldElemOf y (f x) (P x y)) → (∀ x, SetUnfoldElemOf x X (Q x)) → SetUnfoldElemOf y (set_bind f X) (∃ x, Q x ∧ P x y). Proof. intros HSU1 HSU2. constructor. rewrite elem_of_set_bind. set_solver. Qed. Global Instance set_bind_proper : Proper (pointwise_relation _ (≡) ==> (≡) ==> (≡)) set_bind. Proof. unfold pointwise_relation; intros f1 f2 Hf X1 X2 HX. set_solver. Qed. Global Instance set_bind_mono : Proper (pointwise_relation _ (⊆) ==> (⊆) ==> (⊆)) set_bind. Proof. unfold pointwise_relation; intros f1 f2 Hf X1 X2 HX. set_solver. Qed. Lemma set_bind_ext (f g : A → SB) (X Y : C) : (∀ x, x ∈ X → x ∈ Y → f x ≡ g x) → X ≡ Y → set_bind f X ≡ set_bind g Y. Proof. set_solver. Qed. Lemma set_bind_singleton f x : set_bind f {[x]} ≡ f x. Proof. set_solver. Qed. Lemma set_bind_singleton_L `{!LeibnizEquiv SB} f x : set_bind f {[x]} = f x. Proof. unfold_leibniz. apply set_bind_singleton. Qed. Lemma set_bind_disj_union f (X Y : C) : X ## Y → set_bind f (X ∪ Y) ≡ set_bind f X ∪ set_bind f Y. Proof. set_solver. Qed. Lemma set_bind_disj_union_L `{!LeibnizEquiv SB} f (X Y : C) : X ## Y → set_bind f (X ∪ Y) = set_bind f X ∪ set_bind f Y. Proof. unfold_leibniz. apply set_bind_disj_union. Qed. End set_bind. (** * OMap *) Section set_omap. Context `{SemiSet B D}. Implicit Types (f : A → option B). Implicit Types (x : A) (y : B). Notation set_omap := (set_omap (C:=C) (D:=D)). Lemma elem_of_set_omap f X y : y ∈ set_omap f X ↔ ∃ x, x ∈ X ∧ f x = Some y. Proof. unfold set_omap. rewrite elem_of_list_to_set, elem_of_list_omap. by setoid_rewrite elem_of_elements. Qed. Global Instance set_unfold_omap f X (P : A → Prop) y : (∀ x, SetUnfoldElemOf x X (P x)) → SetUnfoldElemOf y (set_omap f X) (∃ x, Some y = f x ∧ P x). Proof. constructor. rewrite elem_of_set_omap; naive_solver. Qed. Global Instance set_omap_proper : Proper (pointwise_relation _ (=) ==> (≡) ==> (≡)) set_omap. Proof. intros f g Hfg X Y. set_unfold. setoid_rewrite Hfg. naive_solver. Qed. Global Instance set_omap_mono : Proper (pointwise_relation _ (=) ==> (⊆) ==> (⊆)) set_omap. Proof. intros f g Hfg X Y. set_unfold. setoid_rewrite Hfg. naive_solver. Qed. Lemma elem_of_set_omap_1 f X y : y ∈ set_omap f X → ∃ x, Some y = f x ∧ x ∈ X. Proof. set_solver. Qed. Lemma elem_of_set_omap_2 f X x y : x ∈ X → f x = Some y → y ∈ set_omap f X. Proof. set_solver. Qed. Lemma set_omap_empty f : set_omap f ∅ = ∅. Proof. unfold set_omap. by rewrite elements_empty. Qed. Lemma set_omap_empty_iff f X : set_omap f X ≡ ∅ ↔ set_Forall (λ x, f x = None) X. Proof. split; set_unfold; unfold set_Forall. - intros Hi x Hx. destruct (f x) as [y|] eqn:Hy; naive_solver. - intros Hi y (x & Hf & Hx). specialize (Hi x Hx). by rewrite Hi in Hf. Qed. Lemma set_omap_union f X Y : set_omap f (X ∪ Y) ≡ set_omap f X ∪ set_omap f Y. Proof. set_solver. Qed. Lemma set_omap_singleton f x : set_omap f {[ x ]} ≡ match f x with Some y => {[ y ]} | None => ∅ end. Proof. set_solver. Qed. Lemma set_omap_singleton_Some f x y : f x = Some y → set_omap f {[ x ]} ≡ {[ y ]}. Proof. intros Hx. by rewrite set_omap_singleton, Hx. Qed. Lemma set_omap_singleton_None f x : f x = None → set_omap f {[ x ]} ≡ ∅. Proof. intros Hx. by rewrite set_omap_singleton, Hx. Qed. Lemma set_omap_alt f X : set_omap f X ≡ set_bind (λ x, option_to_set (f x)) X. Proof. set_solver. Qed. Lemma set_map_alt (f : A → B) X : set_map f X = set_omap (λ x, Some (f x)) X. Proof. set_solver. Qed. Lemma set_omap_filter P `{∀ x, Decision (P x)} f X : (∀ x, x ∈ X → is_Some (f x) → P x) → set_omap f (filter P X) ≡ set_omap f X. Proof. set_solver. Qed. Section leibniz. Context `{!LeibnizEquiv D}. Lemma set_omap_union_L f X Y : set_omap f (X ∪ Y) = set_omap f X ∪ set_omap f Y. Proof. unfold_leibniz. apply set_omap_union. Qed. Lemma set_omap_singleton_L f x : set_omap f {[ x ]} = match f x with Some y => {[ y ]} | None => ∅ end. Proof. unfold_leibniz. apply set_omap_singleton. Qed. Lemma set_omap_singleton_Some_L f x y : f x = Some y → set_omap f {[ x ]} = {[ y ]}. Proof. unfold_leibniz. apply set_omap_singleton_Some. Qed. Lemma set_omap_singleton_None_L f x : f x = None → set_omap f {[ x ]} = ∅. Proof. unfold_leibniz. apply set_omap_singleton_None. Qed. Lemma set_omap_alt_L f X : set_omap f X = set_bind (λ x, option_to_set (f x)) X. Proof. unfold_leibniz. apply set_omap_alt. Qed. Lemma set_omap_filter_L P `{∀ x, Decision (P x)} f X : (∀ x, x ∈ X → is_Some (f x) → P x) → set_omap f (filter P X) = set_omap f X. Proof. unfold_leibniz. apply set_omap_filter. Qed. End leibniz. End set_omap. (** * Decision procedures *) Lemma set_Forall_elements P X : set_Forall P X ↔ Forall P (elements X). Proof. rewrite Forall_forall. by setoid_rewrite elem_of_elements. Qed. Lemma set_Exists_elements P X : set_Exists P X ↔ Exists P (elements X). Proof. rewrite Exists_exists. by setoid_rewrite elem_of_elements. Qed. Lemma set_Forall_Exists_dec (P Q : A → Prop) (dec : ∀ x, {P x} + {Q x}) X : {set_Forall P X} + {set_Exists Q X}. Proof. refine (cast_if (Forall_Exists_dec P Q dec (elements X))); [by apply set_Forall_elements|by apply set_Exists_elements]. Defined. Lemma not_set_Forall_Exists P `{dec : ∀ x, Decision (P x)} X : ¬set_Forall P X → set_Exists (not ∘ P) X. Proof. intro. by destruct (set_Forall_Exists_dec P (not ∘ P) dec X). Qed. Lemma not_set_Exists_Forall P `{dec : ∀ x, Decision (P x)} X : ¬set_Exists P X → set_Forall (not ∘ P) X. Proof. by destruct (set_Forall_Exists_dec (not ∘ P) P (λ x, swap_if (decide (P x))) X). Qed. Global Instance set_Forall_dec (P : A → Prop) `{∀ x, Decision (P x)} X : Decision (set_Forall P X) | 100. Proof. refine (cast_if (decide (Forall P (elements X)))); by rewrite set_Forall_elements. Defined. Global Instance set_Exists_dec `(P : A → Prop) `{∀ x, Decision (P x)} X : Decision (set_Exists P X) | 100. Proof. refine (cast_if (decide (Exists P (elements X)))); by rewrite set_Exists_elements. Defined. (** Alternative versions of finite and infinite predicates *) Lemma pred_finite_set (P : A → Prop) : pred_finite P ↔ (∃ X : C, ∀ x, P x → x ∈ X). Proof. split. - intros [xs Hfin]. exists (list_to_set xs). set_solver. - intros [X Hfin]. exists (elements X). set_solver. Qed. Lemma dec_pred_finite_set_alt (P : A → Prop) `{!∀ x : A, Decision (P x)} : pred_finite P ↔ (∃ X : C, ∀ x, P x ↔ x ∈ X). Proof. rewrite dec_pred_finite_alt; [|done]. split. - intros [xs Hfin]. exists (list_to_set xs). set_solver. - intros [X Hfin]. exists (elements X). set_solver. Qed. Lemma pred_infinite_set (P : A → Prop) : pred_infinite P ↔ (∀ X : C, ∃ x, P x ∧ x ∉ X). Proof. split. - intros Hinf X. destruct (Hinf (elements X)). set_solver. - intros Hinf xs. destruct (Hinf (list_to_set xs)). set_solver. Qed. Section infinite. Context `{Infinite A}. (** Properties about the [fresh] operation on finite sets *) Global Instance fresh_proper: Proper ((≡@{C}) ==> (=)) fresh. Proof. unfold fresh, set_fresh. by intros X1 X2 ->. Qed. Lemma is_fresh X : fresh X ∉ X. Proof. unfold fresh, set_fresh. rewrite <-elem_of_elements. apply infinite_is_fresh. Qed. Lemma exist_fresh X : ∃ x, x ∉ X. Proof. exists (fresh X). apply is_fresh. Qed. (** Properties about the [fresh_list] operation on finite sets *) Global Instance fresh_list_proper n : Proper ((≡@{C}) ==> (=)) (fresh_list n). Proof. induction n as [|n IH]; intros ?? E; by setoid_subst. Qed. Lemma Forall_fresh_NoDup X xs : Forall_fresh X xs → NoDup xs. Proof. induction 1; by constructor. Qed. Lemma Forall_fresh_elem_of X xs x : Forall_fresh X xs → x ∈ xs → x ∉ X. Proof. intros HX; revert x; rewrite <-Forall_forall. by induction HX; constructor. Qed. Lemma Forall_fresh_alt X xs : Forall_fresh X xs ↔ NoDup xs ∧ ∀ x, x ∈ xs → x ∉ X. Proof. split; eauto using Forall_fresh_NoDup, Forall_fresh_elem_of. rewrite <-Forall_forall. intros [Hxs Hxs']. induction Hxs; decompose_Forall_hyps; constructor; auto. Qed. Lemma Forall_fresh_subseteq X Y xs : Forall_fresh X xs → Y ⊆ X → Forall_fresh Y xs. Proof. rewrite !Forall_fresh_alt; set_solver. Qed. Lemma fresh_list_length n X : length (fresh_list n X) = n. Proof. revert X. induction n; simpl; auto. Qed. Lemma fresh_list_is_fresh n X x : x ∈ fresh_list n X → x ∉ X. Proof. revert X. induction n as [|n IH]; intros X; simpl;[by rewrite elem_of_nil|]. rewrite elem_of_cons; intros [->| Hin]; [apply is_fresh|]. apply IH in Hin; set_solver. Qed. Lemma NoDup_fresh_list n X : NoDup (fresh_list n X). Proof. revert X. induction n; simpl; constructor; auto. intros Hin; apply fresh_list_is_fresh in Hin; set_solver. Qed. Lemma Forall_fresh_list X n : Forall_fresh X (fresh_list n X). Proof. rewrite Forall_fresh_alt; eauto using NoDup_fresh_list, fresh_list_is_fresh. Qed. End infinite. End fin_set. Lemma size_set_seq `{FinSet nat C} start len : size (set_seq (C:=C) start len) = len. Proof. rewrite <-list_to_set_seq, size_list_to_set. 2:{ apply NoDup_seq. } rewrite seq_length. done. Qed. stdpp-coq-stdpp-1.9.0/stdpp/finite.v000066400000000000000000000436411451153341500173740ustar00rootroot00000000000000From stdpp Require Export countable vector. From stdpp Require Import options. Class Finite A `{EqDecision A} := { enum : list A; (* [NoDup] makes it easy to define the cardinality of the type. *) NoDup_enum : NoDup enum; elem_of_enum x : x ∈ enum }. Global Hint Mode Finite ! - : typeclass_instances. Global Arguments enum : clear implicits. Global Arguments enum _ {_ _} : assert. Global Arguments NoDup_enum : clear implicits. Global Arguments NoDup_enum _ {_ _} : assert. Definition card A `{Finite A} := length (enum A). Program Definition finite_countable `{Finite A} : Countable A := {| encode := λ x, Pos.of_nat $ S $ default 0 $ fst <$> list_find (x =.) (enum A); decode := λ p, enum A !! pred (Pos.to_nat p) |}. Next Obligation. intros ?? [xs Hxs HA] x; unfold encode, decode; simpl. destruct (list_find_elem_of (x =.) xs x) as [[i y] Hi]; auto. rewrite Nat2Pos.id by done; simpl; rewrite Hi; simpl. destruct (list_find_Some (x =.) xs i y); naive_solver. Qed. Global Hint Immediate finite_countable : typeclass_instances. Definition find `{Finite A} (P : A → Prop) `{∀ x, Decision (P x)} : option A := list_find P (enum A) ≫= decode_nat ∘ fst. Lemma encode_lt_card `{finA: Finite A} (x : A) : encode_nat x < card A. Proof. destruct finA as [xs Hxs HA]; unfold encode_nat, encode, card; simpl. rewrite Nat2Pos.id by done; simpl. destruct (list_find _ xs) as [[i y]|] eqn:HE; simpl. - apply list_find_Some in HE as (?&?&?); eauto using lookup_lt_Some. - destruct xs; simpl; [|lia]. exfalso; eapply not_elem_of_nil, (HA x). Qed. Lemma encode_decode A `{finA: Finite A} i : i < card A → ∃ x : A, decode_nat i = Some x ∧ encode_nat x = i. Proof. destruct finA as [xs Hxs HA]. unfold encode_nat, decode_nat, encode, decode, card; simpl. intros Hi. apply lookup_lt_is_Some in Hi. destruct Hi as [x Hx]. exists x. rewrite !Nat2Pos.id by done; simpl. destruct (list_find_elem_of (x =.) xs x) as [[j y] Hj]; auto. split; [done|]; rewrite Hj; simpl. apply list_find_Some in Hj as (?&->&?). eauto using NoDup_lookup. Qed. Lemma find_Some `{finA: Finite A} (P : A → Prop) `{∀ x, Decision (P x)} (x : A) : find P = Some x → P x. Proof. destruct finA as [xs Hxs HA]; unfold find, decode_nat, decode; simpl. intros Hx. destruct (list_find _ _) as [[i y]|] eqn:Hi; simplify_eq/=. rewrite !Nat2Pos.id in Hx by done. destruct (list_find_Some P xs i y); naive_solver. Qed. Lemma find_is_Some `{finA: Finite A} (P : A → Prop) `{∀ x, Decision (P x)} (x : A) : P x → ∃ y, find P = Some y ∧ P y. Proof. destruct finA as [xs Hxs HA]; unfold find, decode; simpl. intros Hx. destruct (list_find_elem_of P xs x) as [[i y] Hi]; auto. rewrite Hi; unfold decode_nat, decode; simpl. rewrite !Nat2Pos.id by done. simpl. apply list_find_Some in Hi; naive_solver. Qed. Definition encode_fin `{Finite A} (x : A) : fin (card A) := Fin.of_nat_lt (encode_lt_card x). Program Definition decode_fin `{Finite A} (i : fin (card A)) : A := match Some_dec (decode_nat i) return _ with | inleft (x ↾ _) => x | inright _ => _ end. Next Obligation. intros A ?? i ?; exfalso. destruct (encode_decode A i); naive_solver auto using fin_to_nat_lt. Qed. Lemma decode_encode_fin `{Finite A} (x : A) : decode_fin (encode_fin x) = x. Proof. unfold decode_fin, encode_fin. destruct (Some_dec _) as [[x' Hx]|Hx]. { by rewrite fin_to_nat_to_fin, decode_encode_nat in Hx; simplify_eq. } exfalso; by rewrite ->fin_to_nat_to_fin, decode_encode_nat in Hx. Qed. Lemma fin_choice {n} {B : fin n → Type} (P : ∀ i, B i → Prop) : (∀ i, ∃ y, P i y) → ∃ f, ∀ i, P i (f i). Proof. induction n as [|n IH]; intros Hex. { exists (fin_0_inv _); intros i; inv_fin i. } destruct (IH _ _ (λ i, Hex (FS i))) as [f Hf], (Hex 0%fin) as [y Hy]. exists (fin_S_inv _ y f); intros i; by inv_fin i. Qed. Lemma finite_choice `{Finite A} {B : A → Type} (P : ∀ x, B x → Prop) : (∀ x, ∃ y, P x y) → ∃ f, ∀ x, P x (f x). Proof. intros Hex. destruct (fin_choice _ (λ i, Hex (decode_fin i))) as [f ?]. exists (λ x, eq_rect _ _ (f(encode_fin x)) _ (decode_encode_fin x)); intros x. destruct (decode_encode_fin x); simpl; auto. Qed. Lemma card_0_inv P `{finA: Finite A} : card A = 0 → A → P. Proof. intros ? x. destruct finA as [[|??] ??]; simplify_eq. by destruct (not_elem_of_nil x). Qed. Lemma finite_inhabited A `{finA: Finite A} : 0 < card A → Inhabited A. Proof. unfold card; intros. destruct finA as [[|x ?] ??]; simpl in *; [exfalso;lia|]. constructor; exact x. Qed. Lemma finite_inj_submseteq `{finA: Finite A} `{finB: Finite B} (f: A → B) `{!Inj (=) (=) f} : f <$> enum A ⊆+ enum B. Proof. intros. destruct finA, finB. apply NoDup_submseteq; auto using NoDup_fmap_2. Qed. Lemma finite_inj_Permutation `{Finite A} `{Finite B} (f : A → B) `{!Inj (=) (=) f} : card A = card B → f <$> enum A ≡ₚ enum B. Proof. intros. apply submseteq_length_Permutation. - by apply finite_inj_submseteq. - rewrite fmap_length. by apply Nat.eq_le_incl. Qed. Lemma finite_inj_surj `{Finite A} `{Finite B} (f : A → B) `{!Inj (=) (=) f} : card A = card B → Surj (=) f. Proof. intros HAB y. destruct (elem_of_list_fmap_2 f (enum A) y) as (x&?&?); eauto. rewrite finite_inj_Permutation; auto using elem_of_enum. Qed. Lemma finite_surj A `{Finite A} B `{Finite B} : 0 < card A ≤ card B → ∃ g : B → A, Surj (=) g. Proof. intros [??]. destruct (finite_inhabited A) as [x']; auto with lia. exists (λ y : B, default x' (decode_nat (encode_nat y))). intros x. destruct (encode_decode B (encode_nat x)) as (y&Hy1&Hy2). { pose proof (encode_lt_card x); lia. } exists y. by rewrite Hy2, decode_encode_nat. Qed. Lemma finite_inj A `{Finite A} B `{Finite B} : card A ≤ card B ↔ ∃ f : A → B, Inj (=) (=) f. Proof. split. - intros. destruct (decide (card A = 0)) as [HA|?]. { exists (card_0_inv B HA). intros y. apply (card_0_inv _ HA y). } destruct (finite_surj A B) as (g&?); auto with lia. destruct (surj_cancel g) as (f&?). exists f. apply cancel_inj. - intros [f ?]. unfold card. rewrite <-(fmap_length f). by apply submseteq_length, (finite_inj_submseteq f). Qed. Lemma finite_bijective A `{Finite A} B `{Finite B} : card A = card B ↔ ∃ f : A → B, Inj (=) (=) f ∧ Surj (=) f. Proof. split. - intros; destruct (proj1 (finite_inj A B)) as [f ?]; auto with lia. exists f; split; [done|]. by apply finite_inj_surj. - intros (f&?&?). apply (anti_symm (≤)); apply finite_inj. + by exists f. + destruct (surj_cancel f) as (g&?). exists g. apply cancel_inj. Qed. Lemma inj_card `{Finite A} `{Finite B} (f : A → B) `{!Inj (=) (=) f} : card A ≤ card B. Proof. apply finite_inj. eauto. Qed. Lemma surj_card `{Finite A} `{Finite B} (f : A → B) `{!Surj (=) f} : card B ≤ card A. Proof. destruct (surj_cancel f) as (g&?). apply inj_card with g, cancel_inj. Qed. Lemma bijective_card `{Finite A} `{Finite B} (f : A → B) `{!Inj (=) (=) f} `{!Surj (=) f} : card A = card B. Proof. apply finite_bijective. eauto. Qed. (** Decidability of quantification over finite types *) Section forall_exists. Context `{Finite A} (P : A → Prop). Lemma Forall_finite : Forall P (enum A) ↔ (∀ x, P x). Proof. rewrite Forall_forall. intuition auto using elem_of_enum. Qed. Lemma Exists_finite : Exists P (enum A) ↔ (∃ x, P x). Proof. rewrite Exists_exists. naive_solver eauto using elem_of_enum. Qed. Context `{∀ x, Decision (P x)}. Global Instance forall_dec: Decision (∀ x, P x). Proof using Type*. refine (cast_if (decide (Forall P (enum A)))); abstract by rewrite <-Forall_finite. Defined. Global Instance exists_dec: Decision (∃ x, P x). Proof using Type*. refine (cast_if (decide (Exists P (enum A)))); abstract by rewrite <-Exists_finite. Defined. End forall_exists. (** Instances *) Section enc_finite. Context `{EqDecision A}. Context (to_nat : A → nat) (of_nat : nat → A) (c : nat). Context (of_to_nat : ∀ x, of_nat (to_nat x) = x). Context (to_nat_c : ∀ x, to_nat x < c). Context (to_of_nat : ∀ i, i < c → to_nat (of_nat i) = i). Local Program Instance enc_finite : Finite A := {| enum := of_nat <$> seq 0 c |}. Next Obligation. apply NoDup_alt. intros i j x. rewrite !list_lookup_fmap. intros Hi Hj. destruct (seq _ _ !! i) as [i'|] eqn:Hi', (seq _ _ !! j) as [j'|] eqn:Hj'; simplify_eq/=. apply lookup_seq in Hi' as [-> ?]. apply lookup_seq in Hj' as [-> ?]. rewrite <-(to_of_nat i), <-(to_of_nat j) by done. by f_equal. Qed. Next Obligation. intros x. rewrite elem_of_list_fmap. exists (to_nat x). split; auto. by apply elem_of_list_lookup_2 with (to_nat x), lookup_seq. Qed. Lemma enc_finite_card : card A = c. Proof. unfold card. simpl. by rewrite fmap_length, seq_length. Qed. End enc_finite. (** If we have a surjection [f : A → B] and [A] is finite, then [B] is finite too. The surjection [f] could map multiple [x : A] on the same [B], so we need to remove duplicates in [enum]. If [f] is injective, we do not need to do that, leading to a potentially faster implementation of [enum], see [bijective_finite] below. *) Section surjective_finite. Context `{Finite A, EqDecision B} (f : A → B). Context `{!Surj (=) f}. Program Definition surjective_finite: Finite B := {| enum := remove_dups (f <$> enum A) |}. Next Obligation. apply NoDup_remove_dups. Qed. Next Obligation. intros y. rewrite elem_of_remove_dups, elem_of_list_fmap. destruct (surj f y). eauto using elem_of_enum. Qed. End surjective_finite. Section bijective_finite. Context `{Finite A, EqDecision B} (f : A → B). Context `{!Inj (=) (=) f, !Surj (=) f}. Program Definition bijective_finite : Finite B := {| enum := f <$> enum A |}. Next Obligation. apply (NoDup_fmap f), NoDup_enum. Qed. Next Obligation. intros b. rewrite elem_of_list_fmap. destruct (surj f b). eauto using elem_of_enum. Qed. End bijective_finite. Global Program Instance option_finite `{Finite A} : Finite (option A) := {| enum := None :: (Some <$> enum A) |}. Next Obligation. constructor. - rewrite elem_of_list_fmap. by intros (?&?&?). - apply (NoDup_fmap_2 _); auto using NoDup_enum. Qed. Next Obligation. intros ??? [x|]; [right|left]; auto. apply elem_of_list_fmap. eauto using elem_of_enum. Qed. Lemma option_cardinality `{Finite A} : card (option A) = S (card A). Proof. unfold card. simpl. by rewrite fmap_length. Qed. Global Program Instance Empty_set_finite : Finite Empty_set := {| enum := [] |}. Next Obligation. by apply NoDup_nil. Qed. Next Obligation. intros []. Qed. Lemma Empty_set_card : card Empty_set = 0. Proof. done. Qed. Global Program Instance unit_finite : Finite () := {| enum := [tt] |}. Next Obligation. apply NoDup_singleton. Qed. Next Obligation. intros []. by apply elem_of_list_singleton. Qed. Lemma unit_card : card unit = 1. Proof. done. Qed. Global Program Instance bool_finite : Finite bool := {| enum := [true; false] |}. Next Obligation. constructor; [ by rewrite elem_of_list_singleton | apply NoDup_singleton ]. Qed. Next Obligation. intros [|]; [ left | right; left ]. Qed. Lemma bool_card : card bool = 2. Proof. done. Qed. Global Program Instance sum_finite `{Finite A, Finite B} : Finite (A + B)%type := {| enum := (inl <$> enum A) ++ (inr <$> enum B) |}. Next Obligation. intros. apply NoDup_app; split_and?. - apply (NoDup_fmap_2 _). by apply NoDup_enum. - intro. rewrite !elem_of_list_fmap. intros (?&?&?) (?&?&?); congruence. - apply (NoDup_fmap_2 _). by apply NoDup_enum. Qed. Next Obligation. intros ?????? [x|y]; rewrite elem_of_app, !elem_of_list_fmap; [left|right]; (eexists; split; [done|apply elem_of_enum]). Qed. Lemma sum_card `{Finite A, Finite B} : card (A + B) = card A + card B. Proof. unfold card. simpl. by rewrite app_length, !fmap_length. Qed. Global Program Instance prod_finite `{Finite A, Finite B} : Finite (A * B)%type := {| enum := a ← enum A; (a,.) <$> enum B |}. Next Obligation. intros A ?????. apply NoDup_bind. - intros a1 a2 [a b] ?? (?&?&_)%elem_of_list_fmap (?&?&_)%elem_of_list_fmap. naive_solver. - intros a ?. rewrite (NoDup_fmap _). apply NoDup_enum. - apply NoDup_enum. Qed. Next Obligation. intros ?????? [a b]. apply elem_of_list_bind. exists a. eauto using elem_of_enum, elem_of_list_fmap_1. Qed. Lemma prod_card `{Finite A} `{Finite B} : card (A * B) = card A * card B. Proof. unfold card; simpl. induction (enum A); simpl; auto. rewrite app_length, fmap_length. auto. Qed. Fixpoint vec_enum {A} (l : list A) (n : nat) : list (vec A n) := match n with | 0 => [[#]] | S m => a ← l; vcons a <$> vec_enum l m end. Global Program Instance vec_finite `{Finite A} n : Finite (vec A n) := {| enum := vec_enum (enum A) n |}. Next Obligation. intros A ?? n. induction n as [|n IH]; csimpl; [apply NoDup_singleton|]. apply NoDup_bind. - intros x1 x2 y ?? (?&?&_)%elem_of_list_fmap (?&?&_)%elem_of_list_fmap. congruence. - intros x ?. rewrite NoDup_fmap by (intros ?; apply vcons_inj_2). done. - apply NoDup_enum. Qed. Next Obligation. intros A ?? n v. induction v as [|x n v IH]; csimpl; [apply elem_of_list_here|]. apply elem_of_list_bind. eauto using elem_of_enum, elem_of_list_fmap_1. Qed. Lemma vec_card `{Finite A} n : card (vec A n) = card A ^ n. Proof. unfold card; simpl. induction n as [|n IH]; simpl; [done|]. rewrite <-IH. clear IH. generalize (vec_enum (enum A) n). induction (enum A) as [|x xs IH]; intros l; csimpl; auto. by rewrite app_length, fmap_length, IH. Qed. Global Instance list_finite `{Finite A} n : Finite { l : list A | length l = n }. Proof. refine (bijective_finite (λ v : vec A n, vec_to_list v ↾ vec_to_list_length _)). - abstract (by intros v1 v2 [= ?%vec_to_list_inj2]). - abstract (intros [l <-]; exists (list_to_vec l); apply (sig_eq_pi _), vec_to_list_to_vec). Defined. Lemma list_card `{Finite A} n : card { l : list A | length l = n } = card A ^ n. Proof. unfold card; simpl. rewrite fmap_length. apply vec_card. Qed. Fixpoint fin_enum (n : nat) : list (fin n) := match n with 0 => [] | S n => 0%fin :: (FS <$> fin_enum n) end. Global Program Instance fin_finite n : Finite (fin n) := {| enum := fin_enum n |}. Next Obligation. intros n. induction n; simpl; constructor. - rewrite elem_of_list_fmap. by intros (?&?&?). - by apply (NoDup_fmap _). Qed. Next Obligation. intros n i. induction i as [|n i IH]; simpl; rewrite elem_of_cons, ?elem_of_list_fmap; eauto. Qed. Lemma fin_card n : card (fin n) = n. Proof. unfold card; simpl. induction n; simpl; rewrite ?fmap_length; auto. Qed. (* shouldn’t be an instance (cycle with [sig_finite]): *) Lemma finite_sig_dec `{!EqDecision A} (P : A → Prop) `{Finite (sig P)} x : Decision (P x). Proof. assert {xs : list A | ∀ x, P x ↔ x ∈ xs} as [xs ?]. { clear x. exists (proj1_sig <$> enum _). intros x. split; intros Hx. - apply elem_of_list_fmap_1_alt with (x ↾ Hx); [apply elem_of_enum|]; done. - apply elem_of_list_fmap in Hx as [[x' Hx'] [-> _]]; done. } destruct (decide (x ∈ xs)); [left | right]; naive_solver. Qed. (* <- could be Defined but this lemma will probably not be used for computing *) Section sig_finite. Context {A} (P : A → Prop) `{∀ x, Decision (P x)}. Fixpoint list_filter_sig (l : list A) : list (sig P) := match l with | [] => [] | x :: l => match decide (P x) with | left H => x ↾ H :: list_filter_sig l | _ => list_filter_sig l end end. Lemma list_filter_sig_filter (l : list A) : proj1_sig <$> list_filter_sig l = filter P l. Proof. induction l as [| a l IH]; [done |]. simpl; rewrite filter_cons. destruct (decide _); csimpl; by rewrite IH. Qed. Context `{Finite A} `{∀ x, ProofIrrel (P x)}. Global Program Instance sig_finite : Finite (sig P) := {| enum := list_filter_sig (enum A) |}. Next Obligation. eapply NoDup_fmap_1. rewrite list_filter_sig_filter. apply NoDup_filter, NoDup_enum. Qed. Next Obligation. intros p. apply (elem_of_list_fmap_2_inj proj1_sig). rewrite list_filter_sig_filter, elem_of_list_filter. split; [by destruct p | apply elem_of_enum]. Qed. Lemma sig_card : card (sig P) = length (filter P (enum A)). Proof. by rewrite <-list_filter_sig_filter, fmap_length. Qed. End sig_finite. Lemma finite_pigeonhole `{Finite A} `{Finite B} (f : A → B) : card B < card A → ∃ x1 x2, x1 ≠ x2 ∧ f x1 = f x2. Proof. intros. apply dec_stable; intros Heq. cut (Inj eq eq f); [intros ?%inj_card; lia|]. intros x1 x2 ?. apply dec_stable. naive_solver. Qed. Lemma nat_pigeonhole (f : nat → nat) (n1 n2 : nat) : n2 < n1 → (∀ i, i < n1 → f i < n2) → ∃ i1 i2, i1 < i2 < n1 ∧ f i1 = f i2. Proof. intros Hn Hf. pose (f' (i : fin n1) := nat_to_fin (Hf _ (fin_to_nat_lt i))). destruct (finite_pigeonhole f') as (i1&i2&Hi&Hf'); [by rewrite !fin_card|]. apply (not_inj (f:=fin_to_nat)) in Hi. apply (f_equal fin_to_nat) in Hf'. unfold f' in Hf'. rewrite !fin_to_nat_to_fin in Hf'. pose proof (fin_to_nat_lt i1); pose proof (fin_to_nat_lt i2). destruct (decide (i1 < i2)); [exists i1, i2|exists i2, i1]; lia. Qed. Lemma list_pigeonhole {A} (l1 l2 : list A) : l1 ⊆ l2 → length l2 < length l1 → ∃ i1 i2 x, i1 < i2 ∧ l1 !! i1 = Some x ∧ l1 !! i2 = Some x. Proof. intros Hl Hlen. assert (∀ i : fin (length l1), ∃ (j : fin (length l2)) x, l1 !! (fin_to_nat i) = Some x ∧ l2 !! (fin_to_nat j) = Some x) as [f Hf]%fin_choice. { intros i. destruct (lookup_lt_is_Some_2 l1 i) as [x Hix]; [apply fin_to_nat_lt|]. assert (x ∈ l2) as [j Hjx]%elem_of_list_lookup_1 by (by eapply Hl, elem_of_list_lookup_2). exists (nat_to_fin (lookup_lt_Some _ _ _ Hjx)), x. by rewrite fin_to_nat_to_fin. } destruct (finite_pigeonhole f) as (i1&i2&Hi&Hf'); [by rewrite !fin_card|]. destruct (Hf i1) as (x1&?&?), (Hf i2) as (x2&?&?). assert (x1 = x2) as -> by congruence. apply (not_inj (f:=fin_to_nat)) in Hi. apply (f_equal fin_to_nat) in Hf'. destruct (decide (i1 < i2)); [exists i1, i2|exists i2, i1]; eauto with lia. Qed. stdpp-coq-stdpp-1.9.0/stdpp/functions.v000066400000000000000000000024331451153341500201200ustar00rootroot00000000000000From stdpp Require Export base tactics. From stdpp Require Import options. Section definitions. Context {A T : Type} `{EqDecision A}. Global Instance fn_insert : Insert A T (A → T) := λ a t f b, if decide (a = b) then t else f b. Global Instance fn_alter : Alter A T (A → T) := λ (g : T → T) a f b, if decide (a = b) then g (f a) else f b. End definitions. (* TODO: For now, we only have the properties here that do not need a notion of equality of functions. *) Section functions. Context {A T : Type} `{!EqDecision A}. Lemma fn_lookup_insert (f : A → T) a t : <[a:=t]>f a = t. Proof. unfold insert, fn_insert. by destruct (decide (a = a)). Qed. Lemma fn_lookup_insert_rev (f : A → T) a t1 t2 : <[a:=t1]>f a = t2 → t1 = t2. Proof. rewrite fn_lookup_insert. congruence. Qed. Lemma fn_lookup_insert_ne (f : A → T) a b t : a ≠ b → <[a:=t]>f b = f b. Proof. unfold insert, fn_insert. by destruct (decide (a = b)). Qed. Lemma fn_lookup_alter (g : T → T) (f : A → T) a : alter g a f a = g (f a). Proof. unfold alter, fn_alter. by destruct (decide (a = a)). Qed. Lemma fn_lookup_alter_ne (g : T → T) (f : A → T) a b : a ≠ b → alter g a f b = f b. Proof. unfold alter, fn_alter. by destruct (decide (a = b)). Qed. End functions. stdpp-coq-stdpp-1.9.0/stdpp/gmap.v000066400000000000000000001047721451153341500170450ustar00rootroot00000000000000(** This files implements an efficient implementation of finite maps whose keys range over Coq's data type of any countable type [K]. The data structure is similar to [Pmap], which in turn is based on the "canonical" binary tries representation by Appel and Leroy, https://hal.inria.fr/hal-03372247. It thus has the same good properties: - It guarantees logarithmic-time [lookup] and [partial_alter], and linear-time [merge]. It has a low constant factor for computation in Coq compared to other versions (see the Appel and Leroy paper for benchmarks). - It satisfies extensional equality [(∀ i, m1 !! i = m2 !! i) → m1 = m2]. - It can be used in nested recursive definitions, e.g., [Inductive test := Test : gmap test → test]. This is possible because we do _not_ use a Sigma type to ensure canonical representations (a Sigma type would break Coq's strict positivity check). Compared to [Pmap], we not only need to make sure the trie representation is canonical, we also need to make sure that all positions (of type positive) are valid encodings of [K]. That is, for each position [q] in the trie, we have: encode <$> decode q = Some q Instead of formalizing this condition using a Sigma type (which would break the strict positivity check in nested recursive definitions), we make [gmap_dep_ne A P] dependent on a predicate [P : positive → Prop] that describes the subset of valid positions, and instantiate it with [gmap_key K]. The predicate [P : positive → Prop] is considered irrelevant by extraction, so after extraction, the resulting data structure is identical to [Pmap]. *) From stdpp Require Export countable infinite fin_maps fin_map_dom. From stdpp Require Import mapset pmap. From stdpp Require Import options. Local Open Scope positive_scope. Local Notation "P ~ 0" := (λ p, P p~0) : function_scope. Local Notation "P ~ 1" := (λ p, P p~1) : function_scope. Implicit Type P : positive → Prop. (** * The tree data structure *) Inductive gmap_dep_ne (A : Type) (P : positive → Prop) := | GNode001 : gmap_dep_ne A P~1 → gmap_dep_ne A P | GNode010 : P 1 → A → gmap_dep_ne A P | GNode011 : P 1 → A → gmap_dep_ne A P~1 → gmap_dep_ne A P | GNode100 : gmap_dep_ne A P~0 → gmap_dep_ne A P | GNode101 : gmap_dep_ne A P~0 → gmap_dep_ne A P~1 → gmap_dep_ne A P | GNode110 : gmap_dep_ne A P~0 → P 1 → A → gmap_dep_ne A P | GNode111 : gmap_dep_ne A P~0 → P 1 → A → gmap_dep_ne A P~1 → gmap_dep_ne A P. Global Arguments GNode001 {A P} _ : assert. Global Arguments GNode010 {A P} _ _ : assert. Global Arguments GNode011 {A P} _ _ _ : assert. Global Arguments GNode100 {A P} _ : assert. Global Arguments GNode101 {A P} _ _ : assert. Global Arguments GNode110 {A P} _ _ _ : assert. Global Arguments GNode111 {A P} _ _ _ _ : assert. (** Using [Variant] we supress the generation of the induction scheme. We use the induction scheme [gmap_ind] in terms of the smart constructors to reduce the number of cases, similar to Appel and Leroy. *) Variant gmap_dep (A : Type) (P : positive → Prop) := | GEmpty : gmap_dep A P | GNodes : gmap_dep_ne A P → gmap_dep A P. Global Arguments GEmpty {A P}. Global Arguments GNodes {A P} _. Record gmap_key K `{Countable K} (q : positive) := GMapKey { _ : encode (A:=K) <$> decode q = Some q }. Global Arguments GMapKey {_ _ _ _} _. Lemma gmap_key_encode `{Countable K} (k : K) : gmap_key K (encode k). Proof. constructor. by rewrite decode_encode. Qed. Global Instance gmap_key_pi `{Countable K} q : ProofIrrel (gmap_key K q). Proof. intros [?] [?]. f_equal. apply (proof_irrel _). Qed. Record gmap K `{Countable K} A := GMap { gmap_car : gmap_dep A (gmap_key K) }. Global Arguments GMap {_ _ _ _} _. Global Arguments gmap_car {_ _ _ _} _. Global Instance gmap_dep_ne_eq_dec {A P} : EqDecision A → (∀ i, ProofIrrel (P i)) → EqDecision (gmap_dep_ne A P). Proof. intros ? Hirr t1 t2. revert P t1 t2 Hirr. refine (fix go {P} (t1 t2 : gmap_dep_ne A P) {Hirr : _} : Decision (t1 = t2) := match t1, t2 with | GNode001 r1, GNode001 r2 => cast_if (go r1 r2) | GNode010 _ x1, GNode010 _ x2 => cast_if (decide (x1 = x2)) | GNode011 _ x1 r1, GNode011 _ x2 r2 => cast_if_and (decide (x1 = x2)) (go r1 r2) | GNode100 l1, GNode100 l2 => cast_if (go l1 l2) | GNode101 l1 r1, GNode101 l2 r2 => cast_if_and (go l1 l2) (go r1 r2) | GNode110 l1 _ x1, GNode110 l2 _ x2 => cast_if_and (go l1 l2) (decide (x1 = x2)) | GNode111 l1 _ x1 r1, GNode111 l2 _ x2 r2 => cast_if_and3 (go l1 l2) (decide (x1 = x2)) (go r1 r2) | _, _ => right _ end); clear go; abstract first [congruence|f_equal; done || apply Hirr|idtac]. Defined. Global Instance gmap_dep_eq_dec {A P} : (∀ i, ProofIrrel (P i)) → EqDecision A → EqDecision (gmap_dep A P). Proof. intros. solve_decision. Defined. Global Instance gmap_eq_dec `{Countable K} {A} : EqDecision A → EqDecision (gmap K A). Proof. intros. solve_decision. Defined. (** The smart constructor [GNode] and eliminator [gmap_dep_ne_case] are used to reduce the number of cases, similar to Appel and Leroy. *) Local Definition GNode {A P} (ml : gmap_dep A P~0) (mx : option (P 1 * A)) (mr : gmap_dep A P~1) : gmap_dep A P := match ml, mx, mr with | GEmpty, None, GEmpty => GEmpty | GEmpty, None, GNodes r => GNodes (GNode001 r) | GEmpty, Some (p,x), GEmpty => GNodes (GNode010 p x) | GEmpty, Some (p,x), GNodes r => GNodes (GNode011 p x r) | GNodes l, None, GEmpty => GNodes (GNode100 l) | GNodes l, None, GNodes r => GNodes (GNode101 l r) | GNodes l, Some (p,x), GEmpty => GNodes (GNode110 l p x) | GNodes l, Some (p,x), GNodes r => GNodes (GNode111 l p x r) end. Local Definition gmap_dep_ne_case {A P B} (t : gmap_dep_ne A P) (f : gmap_dep A P~0 → option (P 1 * A) → gmap_dep A P~1 → B) : B := match t with | GNode001 r => f GEmpty None (GNodes r) | GNode010 p x => f GEmpty (Some (p,x)) GEmpty | GNode011 p x r => f GEmpty (Some (p,x)) (GNodes r) | GNode100 l => f (GNodes l) None GEmpty | GNode101 l r => f (GNodes l) None (GNodes r) | GNode110 l p x => f (GNodes l) (Some (p,x)) GEmpty | GNode111 l p x r => f (GNodes l) (Some (p,x)) (GNodes r) end. (** Operations *) Local Definition gmap_dep_ne_lookup {A} : ∀ {P}, positive → gmap_dep_ne A P → option A := fix go {P} i t {struct t} := match t, i with | (GNode010 _ x | GNode011 _ x _ | GNode110 _ _ x | GNode111 _ _ x _), 1 => Some x | (GNode100 l | GNode110 l _ _ | GNode101 l _ | GNode111 l _ _ _), i~0 => go i l | (GNode001 r | GNode011 _ _ r | GNode101 _ r | GNode111 _ _ _ r), i~1 => go i r | _, _ => None end. Local Definition gmap_dep_lookup {A P} (i : positive) (mt : gmap_dep A P) : option A := match mt with GEmpty => None | GNodes t => gmap_dep_ne_lookup i t end. Global Instance gmap_lookup `{Countable K} {A} : Lookup K A (gmap K A) := λ k mt, gmap_dep_lookup (encode k) (gmap_car mt). Global Instance gmap_empty `{Countable K} {A} : Empty (gmap K A) := GMap GEmpty. (** Block reduction, even on concrete [gmap]s. Marking [gmap_empty] as [simpl never] would not be enough, because of https://github.com/coq/coq/issues/2972 and https://github.com/coq/coq/issues/2986. And marking [gmap] consumers as [simpl never] does not work either, see: https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/171#note_53216 *) Global Opaque gmap_empty. Local Fixpoint gmap_dep_ne_singleton {A P} (i : positive) : P i → A → gmap_dep_ne A P := match i with | 1 => GNode010 | i~0 => λ p x, GNode100 (gmap_dep_ne_singleton i p x) | i~1 => λ p x, GNode001 (gmap_dep_ne_singleton i p x) end. Local Definition gmap_partial_alter_aux {A P} (go : ∀ i, P i → gmap_dep_ne A P → gmap_dep A P) (f : option A → option A) (i : positive) (p : P i) (mt : gmap_dep A P) : gmap_dep A P := match mt with | GEmpty => match f None with | None => GEmpty | Some x => GNodes (gmap_dep_ne_singleton i p x) end | GNodes t => go i p t end. Local Definition gmap_dep_ne_partial_alter {A} (f : option A → option A) : ∀ {P} (i : positive), P i → gmap_dep_ne A P → gmap_dep A P := Eval lazy -[gmap_dep_ne_singleton] in fix go {P} i p t {struct t} := gmap_dep_ne_case t $ λ ml mx mr, match i with | 1 => λ p, GNode ml ((p,.) <$> f (snd <$> mx)) mr | i~0 => λ p, GNode (gmap_partial_alter_aux go f i p ml) mx mr | i~1 => λ p, GNode ml mx (gmap_partial_alter_aux go f i p mr) end p. Local Definition gmap_dep_partial_alter {A P} (f : option A → option A) : ∀ i : positive, P i → gmap_dep A P → gmap_dep A P := gmap_partial_alter_aux (gmap_dep_ne_partial_alter f) f. Global Instance gmap_partial_alter `{Countable K} {A} : PartialAlter K A (gmap K A) := λ f k '(GMap mt), GMap $ gmap_dep_partial_alter f (encode k) (gmap_key_encode k) mt. Local Definition gmap_dep_ne_fmap {A B} (f : A → B) : ∀ {P}, gmap_dep_ne A P → gmap_dep_ne B P := fix go {P} t := match t with | GNode001 r => GNode001 (go r) | GNode010 p x => GNode010 p (f x) | GNode011 p x r => GNode011 p (f x) (go r) | GNode100 l => GNode100 (go l) | GNode101 l r => GNode101 (go l) (go r) | GNode110 l p x => GNode110 (go l) p (f x) | GNode111 l p x r => GNode111 (go l) p (f x) (go r) end. Local Definition gmap_dep_fmap {A B P} (f : A → B) (mt : gmap_dep A P) : gmap_dep B P := match mt with GEmpty => GEmpty | GNodes t => GNodes (gmap_dep_ne_fmap f t) end. Global Instance gmap_fmap `{Countable K} : FMap (gmap K) := λ {A B} f '(GMap mt), GMap $ gmap_dep_fmap f mt. Local Definition gmap_dep_omap_aux {A B P} (go : gmap_dep_ne A P → gmap_dep B P) (tm : gmap_dep A P) : gmap_dep B P := match tm with GEmpty => GEmpty | GNodes t' => go t' end. Local Definition gmap_dep_ne_omap {A B} (f : A → option B) : ∀ {P}, gmap_dep_ne A P → gmap_dep B P := fix go {P} t := gmap_dep_ne_case t $ λ ml mx mr, GNode (gmap_dep_omap_aux go ml) ('(p,x) ← mx; (p,.) <$> f x) (gmap_dep_omap_aux go mr). Local Definition gmap_dep_omap {A B P} (f : A → option B) : gmap_dep A P → gmap_dep B P := gmap_dep_omap_aux (gmap_dep_ne_omap f). Global Instance gmap_omap `{Countable K} : OMap (gmap K) := λ {A B} f '(GMap mt), GMap $ gmap_dep_omap f mt. Local Definition gmap_merge_aux {A B C P} (go : gmap_dep_ne A P → gmap_dep_ne B P → gmap_dep C P) (f : option A → option B → option C) (mt1 : gmap_dep A P) (mt2 : gmap_dep B P) : gmap_dep C P := match mt1, mt2 with | GEmpty, GEmpty => GEmpty | GNodes t1', GEmpty => gmap_dep_ne_omap (λ x, f (Some x) None) t1' | GEmpty, GNodes t2' => gmap_dep_ne_omap (λ x, f None (Some x)) t2' | GNodes t1', GNodes t2' => go t1' t2' end. Local Definition diag_None' {A B C} {P : Prop} (f : option A → option B → option C) (mx : option (P * A)) (my : option (P * B)) : option (P * C) := match mx, my with | None, None => None | Some (p,x), None => (p,.) <$> f (Some x) None | None, Some (p,y) => (p,.) <$> f None (Some y) | Some (p,x), Some (_,y) => (p,.) <$> f (Some x) (Some y) end. Local Definition gmap_dep_ne_merge {A B C} (f : option A → option B → option C) : ∀ {P}, gmap_dep_ne A P → gmap_dep_ne B P → gmap_dep C P := fix go {P} t1 t2 {struct t1} := gmap_dep_ne_case t1 $ λ ml1 mx1 mr1, gmap_dep_ne_case t2 $ λ ml2 mx2 mr2, GNode (gmap_merge_aux go f ml1 ml2) (diag_None' f mx1 mx2) (gmap_merge_aux go f mr1 mr2). Local Definition gmap_dep_merge {A B C P} (f : option A → option B → option C) : gmap_dep A P → gmap_dep B P → gmap_dep C P := gmap_merge_aux (gmap_dep_ne_merge f) f. Global Instance gmap_merge `{Countable K} : Merge (gmap K) := λ {A B C} f '(GMap mt1) '(GMap mt2), GMap $ gmap_dep_merge f mt1 mt2. Local Definition gmap_fold_aux {A B P} (go : positive → B → gmap_dep_ne A P → B) (i : positive) (y : B) (mt : gmap_dep A P) : B := match mt with GEmpty => y | GNodes t => go i y t end. Local Definition gmap_dep_ne_fold {A B} (f : positive → A → B → B) : ∀ {P}, positive → B → gmap_dep_ne A P → B := fix go {P} i y t := gmap_dep_ne_case t $ λ ml mx mr, gmap_fold_aux go i~1 (gmap_fold_aux go i~0 match mx with None => y | Some (p,x) => f (Pos.reverse i) x y end ml) mr. Local Definition gmap_dep_fold {A B P} (f : positive → A → B → B) : positive → B → gmap_dep A P → B := gmap_fold_aux (gmap_dep_ne_fold f). Global Instance gmap_fold `{Countable K} {A} : MapFold K A (gmap K A) := λ {B} f y '(GMap mt), gmap_dep_fold (λ i x, match decode i with Some k => f k x | None => id end) 1 y mt. (** Proofs *) Local Definition GNode_valid {A P} (ml : gmap_dep A P~0) (mx : option (P 1 * A)) (mr : gmap_dep A P~1) := match ml, mx, mr with GEmpty, None, GEmpty => False | _, _, _ => True end. Local Lemma gmap_dep_ind A (Q : ∀ P, gmap_dep A P → Prop) : (∀ P, Q P GEmpty) → (∀ P ml mx mr, GNode_valid ml mx mr → Q _ ml → Q _ mr → Q P (GNode ml mx mr)) → ∀ P mt, Q P mt. Proof. intros Hemp Hnode P [|t]; [done|]. induction t. - by apply (Hnode _ GEmpty None (GNodes _)). - by apply (Hnode _ GEmpty (Some (_,_)) GEmpty). - by apply (Hnode _ GEmpty (Some (_,_)) (GNodes _)). - by apply (Hnode _ (GNodes _) None GEmpty). - by apply (Hnode _ (GNodes _) None (GNodes _)). - by apply (Hnode _ (GNodes _) (Some (_,_)) GEmpty). - by apply (Hnode _ (GNodes _) (Some (_,_)) (GNodes _)). Qed. Local Lemma gmap_dep_lookup_GNode {A P} (ml : gmap_dep A P~0) mr mx i : gmap_dep_lookup i (GNode ml mx mr) = match i with | 1 => snd <$> mx | i~0 => gmap_dep_lookup i ml | i~1 => gmap_dep_lookup i mr end. Proof. by destruct ml, mx as [[]|], mr, i. Qed. Local Lemma gmap_dep_ne_lookup_not_None {A P} (t : gmap_dep_ne A P) : ∃ i, P i ∧ gmap_dep_ne_lookup i t ≠ None. Proof. induction t; repeat select (∃ _, _) (fun H => destruct H); try first [by eexists 1|by eexists _~0|by eexists _~1]. Qed. Local Lemma gmap_dep_eq_empty {A P} (mt : gmap_dep A P) : (∀ i, P i → gmap_dep_lookup i mt = None) → mt = GEmpty. Proof. intros Hlookup. destruct mt as [|t]; [done|]. destruct (gmap_dep_ne_lookup_not_None t); naive_solver. Qed. Local Lemma gmap_dep_eq {A P} (mt1 mt2 : gmap_dep A P) : (∀ i, ProofIrrel (P i)) → (∀ i, P i → gmap_dep_lookup i mt1 = gmap_dep_lookup i mt2) → mt1 = mt2. Proof. revert mt2. induction mt1 as [|P ml1 mx1 mr1 _ IHl IHr] using gmap_dep_ind; intros mt2 ? Hlookup; destruct mt2 as [|? ml2 mx2 mr2 _ _ _] using gmap_dep_ind. - done. - symmetry. apply gmap_dep_eq_empty. naive_solver. - apply gmap_dep_eq_empty. naive_solver. - f_equal. + apply (IHl _ _). intros i. generalize (Hlookup (i~0)). by rewrite !gmap_dep_lookup_GNode. + generalize (Hlookup 1). rewrite !gmap_dep_lookup_GNode. destruct mx1 as [[]|], mx2 as [[]|]; intros; simplify_eq/=; repeat f_equal; try apply proof_irrel; naive_solver. + apply (IHr _ _). intros i. generalize (Hlookup (i~1)). by rewrite !gmap_dep_lookup_GNode. Qed. Local Lemma gmap_dep_ne_lookup_singleton {A P} i (p : P i) (x : A) : gmap_dep_ne_lookup i (gmap_dep_ne_singleton i p x) = Some x. Proof. revert P p. induction i; by simpl. Qed. Local Lemma gmap_dep_ne_lookup_singleton_ne {A P} i j (p : P i) (x : A) : i ≠ j → gmap_dep_ne_lookup j (gmap_dep_ne_singleton i p x) = None. Proof. revert P j p. induction i; intros ? [?|?|]; naive_solver. Qed. Local Lemma gmap_dep_partial_alter_GNode {A P} (f : option A → option A) i (p : P i) (ml : gmap_dep A P~0) mx mr : GNode_valid ml mx mr → gmap_dep_partial_alter f i p (GNode ml mx mr) = match i with | 1 => λ p, GNode ml ((p,.) <$> f (snd <$> mx)) mr | i~0 => λ p, GNode (gmap_dep_partial_alter f i p ml) mx mr | i~1 => λ p, GNode ml mx (gmap_dep_partial_alter f i p mr) end p. Proof. by destruct ml, mx as [[]|], mr. Qed. Local Lemma gmap_dep_lookup_partial_alter {A P} (f : option A → option A) (mt : gmap_dep A P) i (p : P i) : gmap_dep_lookup i (gmap_dep_partial_alter f i p mt) = f (gmap_dep_lookup i mt). Proof. revert i p. induction mt using gmap_dep_ind. { intros i p; simpl. destruct (f None); simpl; [|done]. by rewrite gmap_dep_ne_lookup_singleton. } intros [] ?; rewrite gmap_dep_partial_alter_GNode, !gmap_dep_lookup_GNode by done; done || by destruct (f _). Qed. Local Lemma gmap_dep_lookup_partial_alter_ne {A P} (f : option A → option A) (mt : gmap_dep A P) i (p : P i) j : i ≠ j → gmap_dep_lookup j (gmap_dep_partial_alter f i p mt) = gmap_dep_lookup j mt. Proof. revert i p j; induction mt using gmap_dep_ind. { intros i p j ?; simpl. destruct (f None); simpl; [|done]. by rewrite gmap_dep_ne_lookup_singleton_ne. } intros [] ? [] ?; rewrite gmap_dep_partial_alter_GNode, !gmap_dep_lookup_GNode by done; auto with lia. Qed. Local Lemma gmap_dep_lookup_fmap {A B P} (f : A → B) (mt : gmap_dep A P) i : gmap_dep_lookup i (gmap_dep_fmap f mt) = f <$> gmap_dep_lookup i mt. Proof. destruct mt as [|t]; simpl; [done|]. revert i. induction t; intros []; by simpl. Qed. Local Lemma gmap_dep_omap_GNode {A B P} (f : A → option B) (ml : gmap_dep A P~0) mx mr : GNode_valid ml mx mr → gmap_dep_omap f (GNode ml mx mr) = GNode (gmap_dep_omap f ml) ('(p,x) ← mx; (p,.) <$> f x) (gmap_dep_omap f mr). Proof. by destruct ml, mx as [[]|], mr. Qed. Local Lemma gmap_dep_lookup_omap {A B P} (f : A → option B) (mt : gmap_dep A P) i : gmap_dep_lookup i (gmap_dep_omap f mt) = gmap_dep_lookup i mt ≫= f. Proof. revert i. induction mt using gmap_dep_ind; [done|]. intros []; rewrite gmap_dep_omap_GNode, !gmap_dep_lookup_GNode by done; [done..|]. destruct select (option _) as [[]|]; simpl; by try destruct (f _). Qed. Section gmap_merge. Context {A B C} (f : option A → option B → option C). Local Lemma gmap_dep_merge_GNode_GEmpty {P} (ml : gmap_dep A P~0) mx mr : GNode_valid ml mx mr → gmap_dep_merge f (GNode ml mx mr) GEmpty = GNode (gmap_dep_omap (λ x, f (Some x) None) ml) (diag_None' f mx None) (gmap_dep_omap (λ x, f (Some x) None) mr). Proof. by destruct ml, mx as [[]|], mr. Qed. Local Lemma gmap_dep_merge_GEmpty_GNode {P} (ml : gmap_dep B P~0) mx mr : GNode_valid ml mx mr → gmap_dep_merge f GEmpty (GNode ml mx mr) = GNode (gmap_dep_omap (λ x, f None (Some x)) ml) (diag_None' f None mx) (gmap_dep_omap (λ x, f None (Some x)) mr). Proof. by destruct ml, mx as [[]|], mr. Qed. Local Lemma gmap_dep_merge_GNode_GNode {P} (ml1 : gmap_dep A P~0) ml2 mx1 mx2 mr1 mr2 : GNode_valid ml1 mx1 mr1 → GNode_valid ml2 mx2 mr2 → gmap_dep_merge f (GNode ml1 mx1 mr1) (GNode ml2 mx2 mr2) = GNode (gmap_dep_merge f ml1 ml2) (diag_None' f mx1 mx2) (gmap_dep_merge f mr1 mr2). Proof. by destruct ml1, mx1 as [[]|], mr1, ml2, mx2 as [[]|], mr2. Qed. Local Lemma gmap_dep_lookup_merge {P} (mt1 : gmap_dep A P) (mt2 : gmap_dep B P) i : gmap_dep_lookup i (gmap_dep_merge f mt1 mt2) = diag_None f (gmap_dep_lookup i mt1) (gmap_dep_lookup i mt2). Proof. revert mt2 i; induction mt1 using gmap_dep_ind; intros mt2 i. { induction mt2 using gmap_dep_ind; [done|]. rewrite gmap_dep_merge_GEmpty_GNode, gmap_dep_lookup_GNode by done. destruct i as [i|i|]; rewrite ?gmap_dep_lookup_omap, gmap_dep_lookup_GNode; simpl; [by destruct (gmap_dep_lookup i _)..|]. destruct select (option _) as [[]|]; simpl; by try destruct (f _). } destruct mt2 using gmap_dep_ind. { rewrite gmap_dep_merge_GNode_GEmpty, gmap_dep_lookup_GNode by done. destruct i as [i|i|]; rewrite ?gmap_dep_lookup_omap, gmap_dep_lookup_GNode; simpl; [by destruct (gmap_dep_lookup i _)..|]. destruct select (option _) as [[]|]; simpl; by try destruct (f _). } rewrite gmap_dep_merge_GNode_GNode by done. destruct i; rewrite ?gmap_dep_lookup_GNode; [done..|]. repeat destruct select (option _) as [[]|]; simpl; by try destruct (f _). Qed. End gmap_merge. Section gmap_fold. Context {A B} (f : positive → A → B → B). Local Lemma gmap_dep_fold_GNode {P} i y (ml : gmap_dep A P~0) mx mr : GNode_valid ml mx mr → gmap_dep_fold f i y (GNode ml mx mr) = gmap_dep_fold f i~1 (gmap_dep_fold f i~0 match mx with None => y | Some (_,x) => f (Pos.reverse i) x y end ml) mr. Proof. by destruct ml, mx as [[]|], mr. Qed. Local Lemma gmap_dep_fold_ind {P} (Q : B → gmap_dep A P → Prop) (b : B) j : Q b GEmpty → (∀ i p x mt r, gmap_dep_lookup i mt = None → Q r mt → Q (f (Pos.reverse_go i j) x r) (gmap_dep_partial_alter (λ _, Some x) i p mt)) → ∀ mt, Q (gmap_dep_fold f j b mt) mt. Proof. intros Hemp Hinsert mt. revert Q b j Hemp Hinsert. induction mt as [|P ml mx mr ? IHl IHr] using gmap_dep_ind; intros Q b j Hemp Hinsert; [done|]. rewrite gmap_dep_fold_GNode by done. apply (IHr (λ y mt, Q y (GNode ml mx mt))). { apply (IHl (λ y mt, Q y (GNode mt mx GEmpty))). { destruct mx as [[p x]|]; [|done]. replace (GNode GEmpty (Some (p,x)) GEmpty) with (gmap_dep_partial_alter (λ _, Some x) 1 p GEmpty) by done. by apply Hinsert. } intros i p x mt r ??. replace (GNode (gmap_dep_partial_alter (λ _, Some x) i p mt) mx GEmpty) with (gmap_dep_partial_alter (λ _, Some x) (i~0) p (GNode mt mx GEmpty)) by (by destruct mt, mx as [[]|]). apply Hinsert; by rewrite ?gmap_dep_lookup_GNode. } intros i p x mt r ??. replace (GNode ml mx (gmap_dep_partial_alter (λ _, Some x) i p mt)) with (gmap_dep_partial_alter (λ _, Some x) (i~1) p (GNode ml mx mt)) by (by destruct ml, mx as [[]|], mt). apply Hinsert; by rewrite ?gmap_dep_lookup_GNode. Qed. End gmap_fold. (** Instance of the finite map type class *) Global Instance gmap_finmap `{Countable K} : FinMap K (gmap K). Proof. split. - intros A [mt1] [mt2] Hlookup. f_equal. apply (gmap_dep_eq _ _ _). intros i [Hk]. destruct (decode i) as [k|]; simplify_eq/=. apply Hlookup. - done. - intros A f [mt] i. apply gmap_dep_lookup_partial_alter. - intros A f [mt] i j ?. apply gmap_dep_lookup_partial_alter_ne. naive_solver. - intros A b f [mt] i. apply gmap_dep_lookup_fmap. - intros A B f [mt] i. apply gmap_dep_lookup_omap. - intros A B C f [mt1] [mt2] i. apply gmap_dep_lookup_merge. - intros A B P f b Hemp Hinsert [mt]. apply (gmap_dep_fold_ind _ (λ r mt, P r (GMap mt))); clear mt; [done|]. intros i [Hk] x mt r ??; simpl. destruct (fmap_Some_1 _ _ _ Hk) as (k&->&->). assert (GMapKey Hk = gmap_key_encode k) as -> by (apply proof_irrel). by apply (Hinsert _ _ (GMap mt)). Qed. Global Program Instance gmap_countable `{Countable K, Countable A} : Countable (gmap K A) := { encode m := encode (map_to_list m : list (K * A)); decode p := list_to_map <$> decode p }. Next Obligation. intros K ?? A ?? m; simpl. rewrite decode_encode; simpl. by rewrite list_to_map_to_list. Qed. (** Conversion to/from [Pmap] *) Local Definition gmap_dep_ne_to_pmap_ne {A} : ∀ {P}, gmap_dep_ne A P → Pmap_ne A := fix go {P} t := match t with | GNode001 r => PNode001 (go r) | GNode010 _ x => PNode010 x | GNode011 _ x r => PNode011 x (go r) | GNode100 l => PNode100 (go l) | GNode101 l r => PNode101 (go l) (go r) | GNode110 l _ x => PNode110 (go l) x | GNode111 l _ x r => PNode111 (go l) x (go r) end. Local Definition gmap_dep_to_pmap {A P} (mt : gmap_dep A P) : Pmap A := match mt with | GEmpty => PEmpty | GNodes t => PNodes (gmap_dep_ne_to_pmap_ne t) end. Definition gmap_to_pmap {A} (m : gmap positive A) : Pmap A := let '(GMap mt) := m in gmap_dep_to_pmap mt. Local Lemma lookup_gmap_dep_ne_to_pmap_ne {A P} (t : gmap_dep_ne A P) i : gmap_dep_ne_to_pmap_ne t !! i = gmap_dep_ne_lookup i t. Proof. revert i; induction t; intros []; by simpl. Qed. Lemma lookup_gmap_to_pmap {A} (m : gmap positive A) i : gmap_to_pmap m !! i = m !! i. Proof. destruct m as [[|t]]; [done|]. apply lookup_gmap_dep_ne_to_pmap_ne. Qed. Local Definition pmap_ne_to_gmap_dep_ne {A} : ∀ {P}, (∀ i, P i) → Pmap_ne A → gmap_dep_ne A P := fix go {P} (p : ∀ i, P i) t := match t with | PNode001 r => GNode001 (go p~1 r) | PNode010 x => GNode010 (p 1) x | PNode011 x r => GNode011 (p 1) x (go p~1 r) | PNode100 l => GNode100 (go p~0 l) | PNode101 l r => GNode101 (go p~0 l) (go p~1 r) | PNode110 l x => GNode110 (go p~0 l) (p 1) x | PNode111 l x r => GNode111 (go p~0 l) (p 1) x (go p~1 r) end%function. Local Definition pmap_to_gmap_dep {A P} (p : ∀ i, P i) (mt : Pmap A) : gmap_dep A P := match mt with | PEmpty => GEmpty | PNodes t => GNodes (pmap_ne_to_gmap_dep_ne p t) end. Definition pmap_to_gmap {A} (m : Pmap A) : gmap positive A := GMap $ pmap_to_gmap_dep gmap_key_encode m. Local Lemma lookup_pmap_ne_to_gmap_dep_ne {A P} (p : ∀ i, P i) (t : Pmap_ne A) i : gmap_dep_ne_lookup i (pmap_ne_to_gmap_dep_ne p t) = t !! i. Proof. revert P i p; induction t; intros ? [] ?; by simpl. Qed. Lemma lookup_pmap_to_gmap {A} (m : Pmap A) i : pmap_to_gmap m !! i = m !! i. Proof. destruct m as [|t]; [done|]. apply lookup_pmap_ne_to_gmap_dep_ne. Qed. (** * Curry and uncurry *) Definition gmap_uncurry `{Countable K1, Countable K2} {A} : gmap K1 (gmap K2 A) → gmap (K1 * K2) A := map_fold (λ i1 m' macc, map_fold (λ i2 x, <[(i1,i2):=x]>) macc m') ∅. Definition gmap_curry `{Countable K1, Countable K2} {A} : gmap (K1 * K2) A → gmap K1 (gmap K2 A) := map_fold (λ '(i1, i2) x, partial_alter (Some ∘ <[i2:=x]> ∘ default ∅) i1) ∅. Section curry_uncurry. Context `{Countable K1, Countable K2} {A : Type}. Lemma lookup_gmap_uncurry (m : gmap K1 (gmap K2 A)) i j : gmap_uncurry m !! (i,j) = m !! i ≫= (.!! j). Proof. apply (map_fold_ind (λ mr m, mr !! (i,j) = m !! i ≫= (.!! j))). { by rewrite !lookup_empty. } clear m; intros i' m2 m m12 Hi' IH. apply (map_fold_ind (λ m2r m2, m2r !! (i,j) = <[i':=m2]> m !! i ≫= (.!! j))). { rewrite IH. destruct (decide (i' = i)) as [->|]. - rewrite lookup_insert, Hi'; simpl; by rewrite lookup_empty. - by rewrite lookup_insert_ne by done. } intros j' y m2' m12' Hj' IH'. destruct (decide (i = i')) as [->|]. - rewrite lookup_insert; simpl. destruct (decide (j = j')) as [->|]. + by rewrite !lookup_insert. + by rewrite !lookup_insert_ne, IH', lookup_insert by congruence. - by rewrite !lookup_insert_ne, IH', lookup_insert_ne by congruence. Qed. Lemma lookup_gmap_curry (m : gmap (K1 * K2) A) i j : gmap_curry m !! i ≫= (.!! j) = m !! (i, j). Proof. apply (map_fold_ind (λ mr m, mr !! i ≫= (.!! j) = m !! (i, j))). { by rewrite !lookup_empty. } clear m; intros [i' j'] x m12 mr Hij' IH. destruct (decide (i = i')) as [->|]. - rewrite lookup_partial_alter. destruct (decide (j = j')) as [->|]. + destruct (mr !! i'); simpl; by rewrite !lookup_insert. + destruct (mr !! i'); simpl; by rewrite !lookup_insert_ne by congruence. - by rewrite lookup_partial_alter_ne, lookup_insert_ne by congruence. Qed. Lemma lookup_gmap_curry_None (m : gmap (K1 * K2) A) i : gmap_curry m !! i = None ↔ (∀ j, m !! (i, j) = None). Proof. apply (map_fold_ind (λ mr m, mr !! i = None ↔ (∀ j, m !! (i, j) = None))); [done|]. clear m; intros [i' j'] x m12 mr Hij' IH. destruct (decide (i = i')) as [->|]. - split; [by rewrite lookup_partial_alter|]. intros Hi. specialize (Hi j'). by rewrite lookup_insert in Hi. - rewrite lookup_partial_alter_ne, IH; [|done]. apply forall_proper. intros j. rewrite lookup_insert_ne; [done|congruence]. Qed. Lemma gmap_uncurry_curry (m : gmap (K1 * K2) A) : gmap_uncurry (gmap_curry m) = m. Proof. apply map_eq; intros [i j]. by rewrite lookup_gmap_uncurry, lookup_gmap_curry. Qed. Lemma gmap_curry_non_empty (m : gmap (K1 * K2) A) i x : gmap_curry m !! i = Some x → x ≠ ∅. Proof. intros Hm ->. eapply eq_None_not_Some; [|by eexists]. eapply lookup_gmap_curry_None; intros j. by rewrite <-lookup_gmap_curry, Hm. Qed. Lemma gmap_curry_uncurry_non_empty (m : gmap K1 (gmap K2 A)) : (∀ i x, m !! i = Some x → x ≠ ∅) → gmap_curry (gmap_uncurry m) = m. Proof. intros Hne. apply map_eq; intros i. destruct (m !! i) as [m2|] eqn:Hm. - destruct (gmap_curry (gmap_uncurry m) !! i) as [m2'|] eqn:Hcurry. + f_equal. apply map_eq. intros j. trans (gmap_curry (gmap_uncurry m) !! i ≫= (.!! j)). { by rewrite Hcurry. } by rewrite lookup_gmap_curry, lookup_gmap_uncurry, Hm. + rewrite lookup_gmap_curry_None in Hcurry. exfalso; apply (Hne i m2), map_eq; [done|intros j]. by rewrite lookup_empty, <-(Hcurry j), lookup_gmap_uncurry, Hm. - apply lookup_gmap_curry_None; intros j. by rewrite lookup_gmap_uncurry, Hm. Qed. End curry_uncurry. (** * Finite sets *) Definition gset K `{Countable K} := mapset (gmap K). Section gset. Context `{Countable K}. (* Lift instances of operational TCs from [mapset] and mark them [simpl never]. *) Global Instance gset_elem_of: ElemOf K (gset K) := _. Global Instance gset_empty : Empty (gset K) := _. Global Instance gset_singleton : Singleton K (gset K) := _. Global Instance gset_union: Union (gset K) := _. Global Instance gset_intersection: Intersection (gset K) := _. Global Instance gset_difference: Difference (gset K) := _. Global Instance gset_elements: Elements K (gset K) := _. Global Instance gset_eq_dec : EqDecision (gset K) := _. Global Instance gset_countable : Countable (gset K) := _. Global Instance gset_equiv_dec : RelDecision (≡@{gset K}) | 1 := _. Global Instance gset_elem_of_dec : RelDecision (∈@{gset K}) | 1 := _. Global Instance gset_disjoint_dec : RelDecision (##@{gset K}) := _. Global Instance gset_subseteq_dec : RelDecision (⊆@{gset K}) := _. (** We put in an eta expansion to avoid [injection] from unfolding equalities like [dom (gset _) m1 = dom (gset _) m2]. *) Global Instance gset_dom {A} : Dom (gmap K A) (gset K) := λ m, let '(GMap mt) := m in mapset_dom (GMap mt). Global Arguments gset_elem_of : simpl never. Global Arguments gset_empty : simpl never. Global Arguments gset_singleton : simpl never. Global Arguments gset_union : simpl never. Global Arguments gset_intersection : simpl never. Global Arguments gset_difference : simpl never. Global Arguments gset_elements : simpl never. Global Arguments gset_eq_dec : simpl never. Global Arguments gset_countable : simpl never. Global Arguments gset_equiv_dec : simpl never. Global Arguments gset_elem_of_dec : simpl never. Global Arguments gset_disjoint_dec : simpl never. Global Arguments gset_subseteq_dec : simpl never. Global Arguments gset_dom : simpl never. (* Lift instances of other TCs. *) Global Instance gset_leibniz : LeibnizEquiv (gset K) := _. Global Instance gset_semi_set : SemiSet K (gset K) | 1 := _. Global Instance gset_set : Set_ K (gset K) | 1 := _. Global Instance gset_fin_set : FinSet K (gset K) := _. Global Instance gset_dom_spec : FinMapDom K (gmap K) (gset K). Proof. pose proof (mapset_dom_spec (M:=gmap K)) as [?? Hdom]; split; auto. intros A m. specialize (Hdom A m). by destruct m. Qed. (** If you are looking for a lemma showing that [gset] is extensional, see [sets.set_eq]. *) (** The function [gset_to_gmap x X] converts a set [X] to a map with domain [X] where each key has value [x]. Compared to the generic conversion [set_to_map], the function [gset_to_gmap] has [O(n)] instead of [O(n log n)] complexity and has an easier and better developed theory. *) Definition gset_to_gmap {A} (x : A) (X : gset K) : gmap K A := (λ _, x) <$> mapset_car X. Lemma lookup_gset_to_gmap {A} (x : A) (X : gset K) i : gset_to_gmap x X !! i = guard (i ∈ X); Some x. Proof. destruct X as [X]. unfold gset_to_gmap, gset_elem_of, elem_of, mapset_elem_of; simpl. rewrite lookup_fmap. case_option_guard; destruct (X !! i) as [[]|]; naive_solver. Qed. Lemma lookup_gset_to_gmap_Some {A} (x : A) (X : gset K) i y : gset_to_gmap x X !! i = Some y ↔ i ∈ X ∧ x = y. Proof. rewrite lookup_gset_to_gmap. simplify_option_eq; naive_solver. Qed. Lemma lookup_gset_to_gmap_None {A} (x : A) (X : gset K) i : gset_to_gmap x X !! i = None ↔ i ∉ X. Proof. rewrite lookup_gset_to_gmap. simplify_option_eq; naive_solver. Qed. Lemma gset_to_gmap_empty {A} (x : A) : gset_to_gmap x ∅ = ∅. Proof. apply fmap_empty. Qed. Lemma gset_to_gmap_union_singleton {A} (x : A) i Y : gset_to_gmap x ({[ i ]} ∪ Y) = <[i:=x]>(gset_to_gmap x Y). Proof. apply map_eq; intros j; apply option_eq; intros y. rewrite lookup_insert_Some, !lookup_gset_to_gmap_Some, elem_of_union, elem_of_singleton; destruct (decide (i = j)); intuition. Qed. Lemma gset_to_gmap_difference_singleton {A} (x : A) i Y : gset_to_gmap x (Y ∖ {[i]}) = delete i (gset_to_gmap x Y). Proof. apply map_eq; intros j; apply option_eq; intros y. rewrite lookup_delete_Some, !lookup_gset_to_gmap_Some, elem_of_difference, elem_of_singleton; destruct (decide (i = j)); intuition. Qed. Lemma fmap_gset_to_gmap {A B} (f : A → B) (X : gset K) (x : A) : f <$> gset_to_gmap x X = gset_to_gmap (f x) X. Proof. apply map_eq; intros j. rewrite lookup_fmap, !lookup_gset_to_gmap. by simplify_option_eq. Qed. Lemma gset_to_gmap_dom {A B} (m : gmap K A) (y : B) : gset_to_gmap y (dom m) = const y <$> m. Proof. apply map_eq; intros j. rewrite lookup_fmap, lookup_gset_to_gmap. destruct (m !! j) as [x|] eqn:?. - by rewrite option_guard_True by (rewrite elem_of_dom; eauto). - by rewrite option_guard_False by (rewrite not_elem_of_dom; eauto). Qed. Lemma dom_gset_to_gmap {A} (X : gset K) (x : A) : dom (gset_to_gmap x X) = X. Proof. induction X as [| y X not_in IH] using set_ind_L. - rewrite gset_to_gmap_empty, dom_empty_L; done. - rewrite gset_to_gmap_union_singleton, dom_insert_L, IH; done. Qed. Lemma gset_to_gmap_set_to_map {A} (X : gset K) (x : A) : gset_to_gmap x X = set_to_map (.,x) X. Proof. apply map_eq; intros k. apply option_eq; intros y. rewrite lookup_gset_to_gmap_Some, lookup_set_to_map; naive_solver. Qed. Lemma map_to_list_gset_to_gmap {A} (X : gset K) (x : A) : map_to_list (gset_to_gmap x X) ≡ₚ (., x) <$> elements X. Proof. induction X as [| y X not_in IH] using set_ind_L. - rewrite gset_to_gmap_empty, elements_empty, map_to_list_empty. done. - rewrite gset_to_gmap_union_singleton, elements_union_singleton by done. rewrite map_to_list_insert. 2:{ rewrite lookup_gset_to_gmap_None. done. } rewrite IH. done. Qed. End gset. Global Typeclasses Opaque gset. stdpp-coq-stdpp-1.9.0/stdpp/gmultiset.v000066400000000000000000001054021451153341500201250ustar00rootroot00000000000000From stdpp Require Export countable. From stdpp Require Import gmap. From stdpp Require ssreflect. (* don't import yet, but we'll later do that to use ssreflect rewrite *) From stdpp Require Import options. (** Multisets [gmultiset A] are represented as maps from [A] to natural numbers, which represent the multiplicity. To ensure we have canonical representations, the multiplicity is a [positive]. Therefore, [gmultiset_car !! x = None] means [x] has multiplicity [0] and [gmultiset_car !! x = Some 1] means [x] has multiplicity 1. *) Record gmultiset A `{Countable A} := GMultiSet { gmultiset_car : gmap A positive }. Global Arguments GMultiSet {_ _ _} _ : assert. Global Arguments gmultiset_car {_ _ _} _ : assert. Global Instance gmultiset_eq_dec `{Countable A} : EqDecision (gmultiset A). Proof. solve_decision. Defined. Global Program Instance gmultiset_countable `{Countable A} : Countable (gmultiset A) := {| encode X := encode (gmultiset_car X); decode p := GMultiSet <$> decode p |}. Next Obligation. intros A ?? [X]; simpl. by rewrite decode_encode. Qed. Section definitions. Context `{Countable A}. Definition multiplicity (x : A) (X : gmultiset A) : nat := match gmultiset_car X !! x with Some n => Pos.to_nat n | None => 0 end. Global Instance gmultiset_elem_of : ElemOf A (gmultiset A) := λ x X, 0 < multiplicity x X. Global Instance gmultiset_subseteq : SubsetEq (gmultiset A) := λ X Y, ∀ x, multiplicity x X ≤ multiplicity x Y. Global Instance gmultiset_equiv : Equiv (gmultiset A) := λ X Y, ∀ x, multiplicity x X = multiplicity x Y. Global Instance gmultiset_elements : Elements A (gmultiset A) := λ X, let (X) := X in '(x,n) ← map_to_list X; replicate (Pos.to_nat n) x. Global Instance gmultiset_size : Size (gmultiset A) := length ∘ elements. Global Instance gmultiset_empty : Empty (gmultiset A) := GMultiSet ∅. Global Instance gmultiset_singleton : SingletonMS A (gmultiset A) := λ x, GMultiSet {[ x := 1%positive ]}. Global Instance gmultiset_union : Union (gmultiset A) := λ X Y, let (X) := X in let (Y) := Y in GMultiSet $ union_with (λ x y, Some (x `max` y)%positive) X Y. Global Instance gmultiset_intersection : Intersection (gmultiset A) := λ X Y, let (X) := X in let (Y) := Y in GMultiSet $ intersection_with (λ x y, Some (x `min` y)%positive) X Y. (** Often called the "sum" *) Global Instance gmultiset_disj_union : DisjUnion (gmultiset A) := λ X Y, let (X) := X in let (Y) := Y in GMultiSet $ union_with (λ x y, Some (x + y)%positive) X Y. Global Instance gmultiset_difference : Difference (gmultiset A) := λ X Y, let (X) := X in let (Y) := Y in GMultiSet $ difference_with (λ x y, guard (y < x)%positive; Some (x - y)%positive) X Y. Global Instance gmultiset_scalar_mul : ScalarMul nat (gmultiset A) := λ n X, let (X) := X in GMultiSet $ match n with 0 => ∅ | _ => fmap (λ m, m * Pos.of_nat n)%positive X end. Global Instance gmultiset_dom : Dom (gmultiset A) (gset A) := λ X, let (X) := X in dom X. End definitions. Global Typeclasses Opaque gmultiset_elem_of gmultiset_subseteq. Global Typeclasses Opaque gmultiset_elements gmultiset_size gmultiset_empty. Global Typeclasses Opaque gmultiset_singleton gmultiset_union gmultiset_difference. Global Typeclasses Opaque gmultiset_scalar_mul gmultiset_dom. Section basic_lemmas. Context `{Countable A}. Implicit Types x y : A. Implicit Types X Y : gmultiset A. Lemma gmultiset_eq X Y : X = Y ↔ ∀ x, multiplicity x X = multiplicity x Y. Proof. split; [by intros ->|intros HXY]. destruct X as [X], Y as [Y]; f_equal; apply map_eq; intros x. specialize (HXY x); unfold multiplicity in *; simpl in *. repeat case_match; naive_solver lia. Qed. Global Instance gmultiset_leibniz : LeibnizEquiv (gmultiset A). Proof. intros X Y. by rewrite gmultiset_eq. Qed. Global Instance gmultiset_equiv_equivalence : Equivalence (≡@{gmultiset A}). Proof. constructor; repeat intro; naive_solver. Qed. (* Multiplicity *) Lemma multiplicity_empty x : multiplicity x ∅ = 0. Proof. done. Qed. Lemma multiplicity_singleton x : multiplicity x {[+ x +]} = 1. Proof. unfold multiplicity; simpl. by rewrite lookup_singleton. Qed. Lemma multiplicity_singleton_ne x y : x ≠ y → multiplicity x {[+ y +]} = 0. Proof. intros. unfold multiplicity; simpl. by rewrite lookup_singleton_ne. Qed. Lemma multiplicity_singleton' x y : multiplicity x {[+ y +]} = if decide (x = y) then 1 else 0. Proof. destruct (decide _) as [->|]. - by rewrite multiplicity_singleton. - by rewrite multiplicity_singleton_ne. Qed. Lemma multiplicity_union X Y x : multiplicity x (X ∪ Y) = multiplicity x X `max` multiplicity x Y. Proof. destruct X as [X], Y as [Y]; unfold multiplicity; simpl. rewrite lookup_union_with. destruct (X !! _), (Y !! _); simpl; lia. Qed. Lemma multiplicity_intersection X Y x : multiplicity x (X ∩ Y) = multiplicity x X `min` multiplicity x Y. Proof. destruct X as [X], Y as [Y]; unfold multiplicity; simpl. rewrite lookup_intersection_with. destruct (X !! _), (Y !! _); simpl; lia. Qed. Lemma multiplicity_disj_union X Y x : multiplicity x (X ⊎ Y) = multiplicity x X + multiplicity x Y. Proof. destruct X as [X], Y as [Y]; unfold multiplicity; simpl. rewrite lookup_union_with. destruct (X !! _), (Y !! _); simpl; lia. Qed. Lemma multiplicity_difference X Y x : multiplicity x (X ∖ Y) = multiplicity x X - multiplicity x Y. Proof. destruct X as [X], Y as [Y]; unfold multiplicity; simpl. rewrite lookup_difference_with. destruct (X !! _), (Y !! _); simplify_option_eq; lia. Qed. Lemma multiplicity_scalar_mul n X x : multiplicity x (n *: X) = n * multiplicity x X. Proof. destruct X as [X]; unfold multiplicity; simpl. destruct n as [|n]; [done|]. rewrite lookup_fmap. destruct (X !! _); simpl; lia. Qed. (* Set *) Lemma elem_of_multiplicity x X : x ∈ X ↔ 0 < multiplicity x X. Proof. done. Qed. Lemma gmultiset_elem_of_empty x : x ∈@{gmultiset A} ∅ ↔ False. Proof. rewrite elem_of_multiplicity, multiplicity_empty. lia. Qed. Lemma gmultiset_elem_of_singleton x y : x ∈@{gmultiset A} {[+ y +]} ↔ x = y. Proof. rewrite elem_of_multiplicity, multiplicity_singleton'. case_decide; naive_solver lia. Qed. Lemma gmultiset_elem_of_union X Y x : x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y. Proof. rewrite !elem_of_multiplicity, multiplicity_union. lia. Qed. Lemma gmultiset_elem_of_disj_union X Y x : x ∈ X ⊎ Y ↔ x ∈ X ∨ x ∈ Y. Proof. rewrite !elem_of_multiplicity, multiplicity_disj_union. lia. Qed. Lemma gmultiset_elem_of_intersection X Y x : x ∈ X ∩ Y ↔ x ∈ X ∧ x ∈ Y. Proof. rewrite !elem_of_multiplicity, multiplicity_intersection. lia. Qed. Lemma gmultiset_elem_of_scalar_mul n X x : x ∈ n *: X ↔ n ≠ 0 ∧ x ∈ X. Proof. rewrite !elem_of_multiplicity, multiplicity_scalar_mul. lia. Qed. Global Instance gmultiset_elem_of_dec : RelDecision (∈@{gmultiset A}). Proof. refine (λ x X, cast_if (decide (0 < multiplicity x X))); done. Defined. End basic_lemmas. (** * A solver for multisets *) (** We define a tactic [multiset_solver] that solves goals involving multisets. The strategy of this tactic is as follows: 1. Turn all equalities ([=]), equivalences ([≡]), inclusions ([⊆] and [⊂]), and set membership relations ([∈]) into arithmetic (in)equalities involving [multiplicity]. The multiplicities of [∅], [∪], [∩], [⊎] and [∖] are turned into [0], [max], [min], [+], and [-], respectively. 2. Decompose the goal into smaller subgoals through intuitionistic reasoning. 3. Instantiate universally quantified hypotheses in hypotheses to obtain a goal that can be solved using [lia]. 4. Simplify multiplicities of singletons [{[ x ]}]. Step (1) and (2) are implemented using the [set_solver] tactic, which internally calls [naive_solver] for step (2). Step (1) is implemented by extending the [SetUnfold] mechanism with a class [MultisetUnfold]. Step (3) is implemented using the tactic [multiset_instantiate], which instantiates universally quantified hypotheses [H : ∀ x : A, P x] in two ways: - If the goal or some hypothesis contains [multiplicity y X] it adds the hypothesis [H y]. - If [P] contains a multiset singleton [{[ y ]}] it adds the hypothesis [H y]. This is needed, for example, to prove [¬ ({[ x ]} ⊆ ∅)], which is turned into hypothesis [H : ∀ y, multiplicity y {[ x ]} ≤ 0] and goal [False]. The only way to make progress is to instantiate [H] with the singleton appearing in [H], so variable [x]. Step (4) is implemented using the tactic [multiset_simplify_singletons], which simplifies occurences of [multiplicity x {[ y ]}] as follows: - First, we try to turn these occurencess into [1] or [0] if either [x = y] or [x ≠ y] can be proved using [done], respectively. - Second, we try to turn these occurences into a fresh [z ≤ 1] if [y] does not occur elsewhere in the hypotheses or goal. - Finally, we make a case distinction between [x = y] or [x ≠ y]. This step is done last so as to avoid needless exponential blow-ups. The tests [test_big_X] in [tests/multiset_solver.v] show the second step reduces the running time significantly (from >10 seconds to <1 second). *) Class MultisetUnfold `{Countable A} (x : A) (X : gmultiset A) (n : nat) := { multiset_unfold : multiplicity x X = n }. Global Arguments multiset_unfold {_ _ _} _ _ _ {_} : assert. Global Hint Mode MultisetUnfold + + + - + - : typeclass_instances. Section multiset_unfold. Context `{Countable A}. Implicit Types x y : A. Implicit Types X Y : gmultiset A. Global Instance multiset_unfold_default x X : MultisetUnfold x X (multiplicity x X) | 1000. Proof. done. Qed. Global Instance multiset_unfold_empty x : MultisetUnfold x ∅ 0. Proof. constructor. by rewrite multiplicity_empty. Qed. Global Instance multiset_unfold_singleton x : MultisetUnfold x {[+ x +]} 1. Proof. constructor. by rewrite multiplicity_singleton. Qed. Global Instance multiset_unfold_union x X Y n m : MultisetUnfold x X n → MultisetUnfold x Y m → MultisetUnfold x (X ∪ Y) (n `max` m). Proof. intros [HX] [HY]; constructor. by rewrite multiplicity_union, HX, HY. Qed. Global Instance multiset_unfold_intersection x X Y n m : MultisetUnfold x X n → MultisetUnfold x Y m → MultisetUnfold x (X ∩ Y) (n `min` m). Proof. intros [HX] [HY]; constructor. by rewrite multiplicity_intersection, HX, HY. Qed. Global Instance multiset_unfold_disj_union x X Y n m : MultisetUnfold x X n → MultisetUnfold x Y m → MultisetUnfold x (X ⊎ Y) (n + m). Proof. intros [HX] [HY]; constructor. by rewrite multiplicity_disj_union, HX, HY. Qed. Global Instance multiset_unfold_difference x X Y n m : MultisetUnfold x X n → MultisetUnfold x Y m → MultisetUnfold x (X ∖ Y) (n - m). Proof. intros [HX] [HY]; constructor. by rewrite multiplicity_difference, HX, HY. Qed. Global Instance multiset_unfold_scalar_mul x m X n : MultisetUnfold x X n → MultisetUnfold x (m *: X) (m * n). Proof. intros [HX]; constructor. by rewrite multiplicity_scalar_mul, HX. Qed. Global Instance set_unfold_multiset_equiv X Y f g : (∀ x, MultisetUnfold x X (f x)) → (∀ x, MultisetUnfold x Y (g x)) → SetUnfold (X ≡ Y) (∀ x, f x = g x) | 0. Proof. constructor. apply forall_proper; intros x. by rewrite (multiset_unfold x X (f x)), (multiset_unfold x Y (g x)). Qed. Global Instance set_unfold_multiset_eq X Y f g : (∀ x, MultisetUnfold x X (f x)) → (∀ x, MultisetUnfold x Y (g x)) → SetUnfold (X = Y) (∀ x, f x = g x) | 0. Proof. constructor. unfold_leibniz. by apply set_unfold_multiset_equiv. Qed. Global Instance set_unfold_multiset_subseteq X Y f g : (∀ x, MultisetUnfold x X (f x)) → (∀ x, MultisetUnfold x Y (g x)) → SetUnfold (X ⊆ Y) (∀ x, f x ≤ g x) | 0. Proof. constructor. apply forall_proper; intros x. by rewrite (multiset_unfold x X (f x)), (multiset_unfold x Y (g x)). Qed. Global Instance set_unfold_multiset_subset X Y f g : (∀ x, MultisetUnfold x X (f x)) → (∀ x, MultisetUnfold x Y (g x)) → SetUnfold (X ⊂ Y) ((∀ x, f x ≤ g x) ∧ (¬∀ x, g x ≤ f x)) | 0. Proof. constructor. unfold strict. f_equiv. - by apply set_unfold_multiset_subseteq. - f_equiv. by apply set_unfold_multiset_subseteq. Qed. Global Instance set_unfold_multiset_elem_of X x n : MultisetUnfold x X n → SetUnfoldElemOf x X (0 < n) | 100. Proof. constructor. by rewrite <-(multiset_unfold x X n). Qed. Global Instance set_unfold_gmultiset_empty x : SetUnfoldElemOf x (∅ : gmultiset A) False. Proof. constructor. apply gmultiset_elem_of_empty. Qed. Global Instance set_unfold_gmultiset_singleton x y : SetUnfoldElemOf x ({[+ y +]} : gmultiset A) (x = y). Proof. constructor; apply gmultiset_elem_of_singleton. Qed. Global Instance set_unfold_gmultiset_union x X Y P Q : SetUnfoldElemOf x X P → SetUnfoldElemOf x Y Q → SetUnfoldElemOf x (X ∪ Y) (P ∨ Q). Proof. intros ??; constructor. by rewrite gmultiset_elem_of_union, (set_unfold_elem_of x X P), (set_unfold_elem_of x Y Q). Qed. Global Instance set_unfold_gmultiset_disj_union x X Y P Q : SetUnfoldElemOf x X P → SetUnfoldElemOf x Y Q → SetUnfoldElemOf x (X ⊎ Y) (P ∨ Q). Proof. intros ??; constructor. rewrite gmultiset_elem_of_disj_union. by rewrite <-(set_unfold_elem_of x X P), <-(set_unfold_elem_of x Y Q). Qed. Global Instance set_unfold_gmultiset_intersection x X Y P Q : SetUnfoldElemOf x X P → SetUnfoldElemOf x Y Q → SetUnfoldElemOf x (X ∩ Y) (P ∧ Q). Proof. intros ??; constructor. rewrite gmultiset_elem_of_intersection. by rewrite (set_unfold_elem_of x X P), (set_unfold_elem_of x Y Q). Qed. End multiset_unfold. (** Step 3: instantiate hypotheses *) (** For these tactics we want to use ssreflect rewrite. ssreflect matching interacts better with canonical structures (see ). *) Module Export tactics. Import ssreflect. Ltac multiset_instantiate := repeat match goal with | H : (∀ x : ?A, @?P x) |- _ => let e := mk_evar A in lazymatch constr:(P e) with | context [ {[+ ?y +]} ] => unify y e; learn_hyp (H y) end | H : (∀ x : ?A, _), _ : context [multiplicity ?y _] |- _ => learn_hyp (H y) | H : (∀ x : ?A, _) |- context [multiplicity ?y _] => learn_hyp (H y) end. (** Step 4: simplify singletons *) (** This lemma results in information loss if there are other occurences of [y] in the goal. In the tactic [multiset_simplify_singletons] we use [clear y] to ensure we do not use the lemma if it leads to information loss. *) Local Lemma multiplicity_singleton_forget `{Countable A} x y : ∃ n, multiplicity (A:=A) x {[+ y +]} = n ∧ n ≤ 1. Proof. rewrite multiplicity_singleton'. case_decide; eauto with lia. Qed. Ltac multiset_simplify_singletons := repeat match goal with | H : context [multiplicity ?x {[+ ?y +]}] |- _ => first [progress rewrite ?multiplicity_singleton ?multiplicity_singleton_ne in H; [|done..] (* This second case does *not* use ssreflect matching (due to [destruct] and the [->] pattern). If the default Coq matching goes wrong it will fail and fall back to the third case, which is strictly more general, just slower. *) |destruct (multiplicity_singleton_forget x y) as (?&->&?); clear y |rewrite multiplicity_singleton' in H; destruct (decide (x = y)); simplify_eq/=] | |- context [multiplicity ?x {[+ ?y +]}] => first [progress rewrite ?multiplicity_singleton ?multiplicity_singleton_ne; [|done..] (* Similar to above, this second case does *not* use ssreflect matching. *) |destruct (multiplicity_singleton_forget x y) as (?&->&?); clear y |rewrite multiplicity_singleton'; destruct (decide (x = y)); simplify_eq/=] end. End tactics. (** Putting it all together *) (** Similar to [set_solver] and [naive_solver], [multiset_solver] has a [by] parameter whose default is [eauto]. *) Tactic Notation "multiset_solver" "by" tactic3(tac) := set_solver by (multiset_instantiate; multiset_simplify_singletons; (* [fast_done] to solve trivial equalities or contradictions, [lia] for the common case that involves arithmetic, [tac] if all else fails *) solve [fast_done|lia|tac]). Tactic Notation "multiset_solver" := multiset_solver by eauto. Section more_lemmas. Context `{Countable A}. Implicit Types x y : A. Implicit Types X Y : gmultiset A. (* Algebraic laws *) (** For union *) Global Instance gmultiset_union_comm : Comm (=@{gmultiset A}) (∪). Proof. unfold Comm. multiset_solver. Qed. Global Instance gmultiset_union_assoc : Assoc (=@{gmultiset A}) (∪). Proof. unfold Assoc. multiset_solver. Qed. Global Instance gmultiset_union_left_id : LeftId (=@{gmultiset A}) ∅ (∪). Proof. unfold LeftId. multiset_solver. Qed. Global Instance gmultiset_union_right_id : RightId (=@{gmultiset A}) ∅ (∪). Proof. unfold RightId. multiset_solver. Qed. Global Instance gmultiset_union_idemp : IdemP (=@{gmultiset A}) (∪). Proof. unfold IdemP. multiset_solver. Qed. (** For intersection *) Global Instance gmultiset_intersection_comm : Comm (=@{gmultiset A}) (∩). Proof. unfold Comm. multiset_solver. Qed. Global Instance gmultiset_intersection_assoc : Assoc (=@{gmultiset A}) (∩). Proof. unfold Assoc. multiset_solver. Qed. Global Instance gmultiset_intersection_left_absorb : LeftAbsorb (=@{gmultiset A}) ∅ (∩). Proof. unfold LeftAbsorb. multiset_solver. Qed. Global Instance gmultiset_intersection_right_absorb : RightAbsorb (=@{gmultiset A}) ∅ (∩). Proof. unfold RightAbsorb. multiset_solver. Qed. Global Instance gmultiset_intersection_idemp : IdemP (=@{gmultiset A}) (∩). Proof. unfold IdemP. multiset_solver. Qed. Lemma gmultiset_union_intersection_l X Y Z : X ∪ (Y ∩ Z) = (X ∪ Y) ∩ (X ∪ Z). Proof. multiset_solver. Qed. Lemma gmultiset_union_intersection_r X Y Z : (X ∩ Y) ∪ Z = (X ∪ Z) ∩ (Y ∪ Z). Proof. multiset_solver. Qed. Lemma gmultiset_intersection_union_l X Y Z : X ∩ (Y ∪ Z) = (X ∩ Y) ∪ (X ∩ Z). Proof. multiset_solver. Qed. Lemma gmultiset_intersection_union_r X Y Z : (X ∪ Y) ∩ Z = (X ∩ Z) ∪ (Y ∩ Z). Proof. multiset_solver. Qed. (** For disjoint union (aka sum) *) Global Instance gmultiset_disj_union_comm : Comm (=@{gmultiset A}) (⊎). Proof. unfold Comm. multiset_solver. Qed. Global Instance gmultiset_disj_union_assoc : Assoc (=@{gmultiset A}) (⊎). Proof. unfold Assoc. multiset_solver. Qed. Global Instance gmultiset_disj_union_left_id : LeftId (=@{gmultiset A}) ∅ (⊎). Proof. unfold LeftId. multiset_solver. Qed. Global Instance gmultiset_disj_union_right_id : RightId (=@{gmultiset A}) ∅ (⊎). Proof. unfold RightId. multiset_solver. Qed. Global Instance gmultiset_disj_union_inj_1 X : Inj (=) (=) (X ⊎.). Proof. unfold Inj. multiset_solver. Qed. Global Instance gmultiset_disj_union_inj_2 X : Inj (=) (=) (.⊎ X). Proof. unfold Inj. multiset_solver. Qed. Lemma gmultiset_disj_union_intersection_l X Y Z : X ⊎ (Y ∩ Z) = (X ⊎ Y) ∩ (X ⊎ Z). Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_intersection_r X Y Z : (X ∩ Y) ⊎ Z = (X ⊎ Z) ∩ (Y ⊎ Z). Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_union_l X Y Z : X ⊎ (Y ∪ Z) = (X ⊎ Y) ∪ (X ⊎ Z). Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_union_r X Y Z : (X ∪ Y) ⊎ Z = (X ⊎ Z) ∪ (Y ⊎ Z). Proof. multiset_solver. Qed. (** Element of operation *) Lemma gmultiset_not_elem_of_empty x : x ∉@{gmultiset A} ∅. Proof. multiset_solver. Qed. Lemma gmultiset_not_elem_of_singleton x y : x ∉@{gmultiset A} {[+ y +]} ↔ x ≠ y. Proof. multiset_solver. Qed. Lemma gmultiset_not_elem_of_union x X Y : x ∉ X ∪ Y ↔ x ∉ X ∧ x ∉ Y. Proof. multiset_solver. Qed. Lemma gmultiset_not_elem_of_intersection x X Y : x ∉ X ∩ Y ↔ x ∉ X ∨ x ∉ Y. Proof. multiset_solver. Qed. (** Misc *) Global Instance gmultiset_singleton_inj : Inj (=) (=@{gmultiset A}) singletonMS. Proof. intros x1 x2 Hx. rewrite gmultiset_eq in Hx. specialize (Hx x1). rewrite multiplicity_singleton, multiplicity_singleton' in Hx. case_decide; [done|lia]. Qed. Lemma gmultiset_non_empty_singleton x : {[+ x +]} ≠@{gmultiset A} ∅. Proof. multiset_solver. Qed. (** Scalar *) Lemma gmultiset_scalar_mul_0 X : 0 *: X = ∅. Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_S_l n X : S n *: X = X ⊎ (n *: X). Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_S_r n X : S n *: X = (n *: X) ⊎ X. Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_1 X : 1 *: X = X. Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_2 X : 2 *: X = X ⊎ X. Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_empty n : n *: ∅ =@{gmultiset A} ∅. Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_disj_union n X Y : n *: (X ⊎ Y) =@{gmultiset A} (n *: X) ⊎ (n *: Y). Proof. multiset_solver. Qed. Lemma gmultiset_scalar_mul_union n X Y : n *: (X ∪ Y) =@{gmultiset A} (n *: X) ∪ (n *: Y). Proof. set_unfold. intros x; by rewrite Nat.mul_max_distr_l. Qed. Lemma gmultiset_scalar_mul_intersection n X Y : n *: (X ∩ Y) =@{gmultiset A} (n *: X) ∩ (n *: Y). Proof. set_unfold. intros x; by rewrite Nat.mul_min_distr_l. Qed. Lemma gmultiset_scalar_mul_difference n X Y : n *: (X ∖ Y) =@{gmultiset A} (n *: X) ∖ (n *: Y). Proof. set_unfold. intros x; by rewrite Nat.mul_sub_distr_l. Qed. Lemma gmultiset_scalar_mul_inj_ne_0 n X1 X2 : n ≠ 0 → n *: X1 = n *: X2 → X1 = X2. Proof. set_unfold. intros ? HX x. apply (Nat.mul_reg_l _ _ n); auto. Qed. (** Specialized to [S n] so that type class search can find it. *) Global Instance gmultiset_scalar_mul_inj_S n : Inj (=) (=@{gmultiset A}) (S n *:.). Proof. intros x1 x2. apply gmultiset_scalar_mul_inj_ne_0. lia. Qed. (** Conversion from lists *) Lemma list_to_set_disj_nil : list_to_set_disj [] =@{gmultiset A} ∅. Proof. done. Qed. Lemma list_to_set_disj_cons x l : list_to_set_disj (x :: l) =@{gmultiset A} {[+ x +]} ⊎ list_to_set_disj l. Proof. done. Qed. Lemma list_to_set_disj_app l1 l2 : list_to_set_disj (l1 ++ l2) =@{gmultiset A} list_to_set_disj l1 ⊎ list_to_set_disj l2. Proof. induction l1; multiset_solver. Qed. Lemma elem_of_list_to_set_disj x l : x ∈@{gmultiset A} list_to_set_disj l ↔ x ∈ l. Proof. induction l; set_solver. Qed. Global Instance list_to_set_disj_perm : Proper ((≡ₚ) ==> (=)) (list_to_set_disj (C:=gmultiset A)). Proof. induction 1; multiset_solver. Qed. (** Properties of the elements operation *) Lemma gmultiset_elements_empty : elements (∅ : gmultiset A) = []. Proof. unfold elements, gmultiset_elements; simpl. by rewrite map_to_list_empty. Qed. Lemma gmultiset_elements_empty_iff X : elements X = [] ↔ X = ∅. Proof. split; [|intros ->; by rewrite gmultiset_elements_empty]. destruct X as [X]; unfold elements, gmultiset_elements; simpl. intros; apply (f_equal GMultiSet). destruct (map_to_list X) as [|[x p]] eqn:?; simpl in *. - by apply map_to_list_empty_iff. - pose proof (Pos2Nat.is_pos p). destruct (Pos.to_nat); naive_solver lia. Qed. Lemma gmultiset_elements_empty_inv X : elements X = [] → X = ∅. Proof. apply gmultiset_elements_empty_iff. Qed. Lemma gmultiset_elements_singleton x : elements ({[+ x +]} : gmultiset A) = [ x ]. Proof. unfold elements, gmultiset_elements; simpl. by rewrite map_to_list_singleton. Qed. Lemma gmultiset_elements_disj_union X Y : elements (X ⊎ Y) ≡ₚ elements X ++ elements Y. Proof. destruct X as [X], Y as [Y]; unfold elements, gmultiset_elements. set (f xn := let '(x, n) := xn in replicate (Pos.to_nat n) x); simpl. revert Y; induction X as [|x n X HX IH] using map_ind; intros Y. { by rewrite (left_id_L _ _ Y), map_to_list_empty. } destruct (Y !! x) as [n'|] eqn:HY. - rewrite <-(insert_delete Y x n') by done. erewrite <-insert_union_with by done. rewrite !map_to_list_insert, !bind_cons by (by rewrite ?lookup_union_with, ?lookup_delete, ?HX). rewrite (assoc_L _), <-(comm (++) (f (_,n'))), <-!(assoc_L _), <-IH. rewrite (assoc_L _). f_equiv. rewrite (comm _); simpl. by rewrite Pos2Nat.inj_add, replicate_add. - rewrite <-insert_union_with_l, !map_to_list_insert, !bind_cons by (by rewrite ?lookup_union_with, ?HX, ?HY). by rewrite <-(assoc_L (++)), <-IH. Qed. Lemma gmultiset_elements_scalar_mul n X : elements (n *: X) ≡ₚ mjoin (replicate n (elements X)). Proof. induction n as [|n IH]; simpl. - by rewrite gmultiset_scalar_mul_0, gmultiset_elements_empty. - by rewrite gmultiset_scalar_mul_S_l, gmultiset_elements_disj_union, IH. Qed. Lemma gmultiset_elem_of_elements x X : x ∈ elements X ↔ x ∈ X. Proof. destruct X as [X]. unfold elements, gmultiset_elements. set (f xn := let '(x, n) := xn in replicate (Pos.to_nat n) x); simpl. unfold elem_of at 2, gmultiset_elem_of, multiplicity; simpl. rewrite elem_of_list_bind. split. - intros [[??] [[<- ?]%elem_of_replicate ->%elem_of_map_to_list]]; lia. - intros. destruct (X !! x) as [n|] eqn:Hx; [|lia]. exists (x,n); split; [|by apply elem_of_map_to_list]. apply elem_of_replicate; auto with lia. Qed. Lemma gmultiset_elem_of_dom x X : x ∈ dom X ↔ x ∈ X. Proof. unfold dom, gmultiset_dom, elem_of at 2, gmultiset_elem_of, multiplicity. destruct X as [X]; simpl; rewrite elem_of_dom, <-not_eq_None_Some. destruct (X !! x); naive_solver lia. Qed. (** Properties of the set_fold operation *) Lemma gmultiset_set_fold_empty {B} (f : A → B → B) (b : B) : set_fold f b (∅ : gmultiset A) = b. Proof. by unfold set_fold; simpl; rewrite gmultiset_elements_empty. Qed. Lemma gmultiset_set_fold_singleton {B} (f : A → B → B) (b : B) (a : A) : set_fold f b ({[+ a +]} : gmultiset A) = f a b. Proof. by unfold set_fold; simpl; rewrite gmultiset_elements_singleton. Qed. Lemma gmultiset_set_fold_disj_union_strong {B} (R : relation B) `{!PreOrder R} (f : A → B → B) (b : B) X Y : (∀ x, Proper (R ==> R) (f x)) → (∀ x1 x2 c, x1 ∈ X ⊎ Y → x2 ∈ X ⊎ Y → R (f x1 (f x2 c)) (f x2 (f x1 c))) → R (set_fold f b (X ⊎ Y)) (set_fold f (set_fold f b X) Y). Proof. intros ? Hf. unfold set_fold; simpl. rewrite <-foldr_app. apply (foldr_permutation R f b). - intros j1 a1 j2 a2 c ? Ha1%elem_of_list_lookup_2 Ha2%elem_of_list_lookup_2. rewrite gmultiset_elem_of_elements in Ha1, Ha2. eauto. - rewrite (comm (++)). apply gmultiset_elements_disj_union. Qed. Lemma gmultiset_set_fold_disj_union (f : A → A → A) (b : A) X Y : Comm (=) f → Assoc (=) f → set_fold f b (X ⊎ Y) = set_fold f (set_fold f b X) Y. Proof. intros ??; apply gmultiset_set_fold_disj_union_strong; [apply _..|]. intros x1 x2 ? _ _. by rewrite 2!assoc, (comm f x1 x2). Qed. Lemma gmultiset_set_fold_scalar_mul (f : A → A → A) (b : A) n X : Comm (=) f → Assoc (=) f → set_fold f b (n *: X) = Nat.iter n (flip (set_fold f) X) b. Proof. intros Hcomm Hassoc. induction n as [|n IH]; simpl. - by rewrite gmultiset_scalar_mul_0, gmultiset_set_fold_empty. - rewrite gmultiset_scalar_mul_S_r. by rewrite (gmultiset_set_fold_disj_union _ _ _ _ _ _), IH. Qed. Lemma gmultiset_set_fold_comm_acc_strong {B} (R : relation B) `{!PreOrder R} (f : A → B → B) (g : B → B) b X : (∀ x, Proper (R ==> R) (f x)) → (∀ x (y : B), x ∈ X → R (f x (g y)) (g (f x y))) → R (set_fold f (g b) X) (g (set_fold f b X)). Proof. intros ? Hfg. unfold set_fold; simpl. apply foldr_comm_acc_strong; [done|solve_proper|]. intros. by apply Hfg, gmultiset_elem_of_elements. Qed. Lemma gmultiset_set_fold_comm_acc (f : A → A → A) (g : A → A) (a : A) X : (∀ x c, g (f x c) = f x (g c)) → set_fold f (g a) X = g (set_fold f a X). Proof. intros. apply (gmultiset_set_fold_comm_acc_strong _); [solve_proper|done]. Qed. (** Properties of the size operation *) Lemma gmultiset_size_empty : size (∅ : gmultiset A) = 0. Proof. done. Qed. Lemma gmultiset_size_empty_iff X : size X = 0 ↔ X = ∅. Proof. unfold size, gmultiset_size; simpl. by rewrite length_zero_iff_nil, gmultiset_elements_empty_iff. Qed. Lemma gmultiset_size_empty_inv X : size X = 0 → X = ∅. Proof. apply gmultiset_size_empty_iff. Qed. Lemma gmultiset_size_non_empty_iff X : size X ≠ 0 ↔ X ≠ ∅. Proof. by rewrite gmultiset_size_empty_iff. Qed. Lemma gmultiset_choose_or_empty X : (∃ x, x ∈ X) ∨ X = ∅. Proof. destruct (elements X) as [|x l] eqn:HX; [right|left]. - by apply gmultiset_elements_empty_iff. - exists x. rewrite <-gmultiset_elem_of_elements, HX. by left. Qed. Lemma gmultiset_choose X : X ≠ ∅ → ∃ x, x ∈ X. Proof. intros. by destruct (gmultiset_choose_or_empty X). Qed. Lemma gmultiset_size_pos_elem_of X : 0 < size X → ∃ x, x ∈ X. Proof. intros Hsz. destruct (gmultiset_choose_or_empty X) as [|HX]; [done|]. contradict Hsz. rewrite HX, gmultiset_size_empty; lia. Qed. Lemma gmultiset_size_singleton x : size ({[+ x +]} : gmultiset A) = 1. Proof. unfold size, gmultiset_size; simpl. by rewrite gmultiset_elements_singleton. Qed. Lemma gmultiset_size_disj_union X Y : size (X ⊎ Y) = size X + size Y. Proof. unfold size, gmultiset_size; simpl. by rewrite gmultiset_elements_disj_union, app_length. Qed. Lemma gmultiset_size_scalar_mul n X : size (n *: X) = n * size X. Proof. induction n as [|n IH]. - by rewrite gmultiset_scalar_mul_0, gmultiset_size_empty. - rewrite gmultiset_scalar_mul_S_l, gmultiset_size_disj_union, IH. lia. Qed. (** Order stuff *) Global Instance gmultiset_po : PartialOrder (⊆@{gmultiset A}). Proof. repeat split; repeat intro; multiset_solver. Qed. Local Lemma gmultiset_subseteq_alt X Y : X ⊆ Y ↔ map_relation Pos.le (λ _, False) (λ _, True) (gmultiset_car X) (gmultiset_car Y). Proof. apply forall_proper; intros x. unfold multiplicity. destruct (gmultiset_car X !! x), (gmultiset_car Y !! x); naive_solver lia. Qed. Global Instance gmultiset_subseteq_dec : RelDecision (⊆@{gmultiset A}). Proof. refine (λ X Y, cast_if (decide (map_relation Pos.le (λ _, False) (λ _, True) (gmultiset_car X) (gmultiset_car Y)))); by rewrite gmultiset_subseteq_alt. Defined. Lemma gmultiset_subset_subseteq X Y : X ⊂ Y → X ⊆ Y. Proof. multiset_solver. Qed. Lemma gmultiset_empty_subseteq X : ∅ ⊆ X. Proof. multiset_solver. Qed. Lemma gmultiset_union_subseteq_l X Y : X ⊆ X ∪ Y. Proof. multiset_solver. Qed. Lemma gmultiset_union_subseteq_r X Y : Y ⊆ X ∪ Y. Proof. multiset_solver. Qed. Lemma gmultiset_union_mono X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∪ Y1 ⊆ X2 ∪ Y2. Proof. multiset_solver. Qed. Lemma gmultiset_union_mono_l X Y1 Y2 : Y1 ⊆ Y2 → X ∪ Y1 ⊆ X ∪ Y2. Proof. multiset_solver. Qed. Lemma gmultiset_union_mono_r X1 X2 Y : X1 ⊆ X2 → X1 ∪ Y ⊆ X2 ∪ Y. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_subseteq_l X Y : X ⊆ X ⊎ Y. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_subseteq_r X Y : Y ⊆ X ⊎ Y. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_mono X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ⊎ Y1 ⊆ X2 ⊎ Y2. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_mono_l X Y1 Y2 : Y1 ⊆ Y2 → X ⊎ Y1 ⊆ X ⊎ Y2. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_mono_r X1 X2 Y : X1 ⊆ X2 → X1 ⊎ Y ⊆ X2 ⊎ Y. Proof. multiset_solver. Qed. Lemma gmultiset_subset X Y : X ⊆ Y → size X < size Y → X ⊂ Y. Proof. intros. apply strict_spec_alt; split; naive_solver auto with lia. Qed. Lemma gmultiset_disj_union_subset_l X Y : Y ≠ ∅ → X ⊂ X ⊎ Y. Proof. multiset_solver. Qed. Lemma gmultiset_union_subset_r X Y : X ≠ ∅ → Y ⊂ X ⊎ Y. Proof. multiset_solver. Qed. Lemma gmultiset_singleton_subseteq_l x X : {[+ x +]} ⊆ X ↔ x ∈ X. Proof. multiset_solver. Qed. Lemma gmultiset_singleton_subseteq x y : {[+ x +]} ⊆@{gmultiset A} {[+ y +]} ↔ x = y. Proof. multiset_solver. Qed. Lemma gmultiset_elem_of_subseteq X1 X2 x : x ∈ X1 → X1 ⊆ X2 → x ∈ X2. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_difference X Y : X ⊆ Y → Y = X ⊎ Y ∖ X. Proof. multiset_solver. Qed. Lemma gmultiset_disj_union_difference' x Y : x ∈ Y → Y = {[+ x +]} ⊎ Y ∖ {[+ x +]}. Proof. multiset_solver. Qed. Lemma gmultiset_size_difference X Y : Y ⊆ X → size (X ∖ Y) = size X - size Y. Proof. intros HX%gmultiset_disj_union_difference. rewrite HX at 2; rewrite gmultiset_size_disj_union. lia. Qed. Lemma gmultiset_empty_difference X Y : Y ⊆ X → Y ∖ X = ∅. Proof. multiset_solver. Qed. Lemma gmultiset_non_empty_difference X Y : X ⊂ Y → Y ∖ X ≠ ∅. Proof. multiset_solver. Qed. Lemma gmultiset_difference_diag X : X ∖ X = ∅. Proof. multiset_solver. Qed. Lemma gmultiset_difference_subset X Y : X ≠ ∅ → X ⊆ Y → Y ∖ X ⊂ Y. Proof. multiset_solver. Qed. Lemma gmultiset_difference_disj_union_r X Y Z : X ∖ Y = (X ⊎ Z) ∖ (Y ⊎ Z). Proof. multiset_solver. Qed. Lemma gmultiset_difference_disj_union_l X Y Z : X ∖ Y = (Z ⊎ X) ∖ (Z ⊎ Y). Proof. multiset_solver. Qed. (** Mononicity *) Lemma gmultiset_elements_submseteq X Y : X ⊆ Y → elements X ⊆+ elements Y. Proof. intros ->%gmultiset_disj_union_difference. rewrite gmultiset_elements_disj_union. by apply submseteq_inserts_r. Qed. Lemma gmultiset_subseteq_size X Y : X ⊆ Y → size X ≤ size Y. Proof. intros. by apply submseteq_length, gmultiset_elements_submseteq. Qed. Lemma gmultiset_subset_size X Y : X ⊂ Y → size X < size Y. Proof. intros HXY. assert (size (Y ∖ X) ≠ 0). { by apply gmultiset_size_non_empty_iff, gmultiset_non_empty_difference. } rewrite (gmultiset_disj_union_difference X Y), gmultiset_size_disj_union by auto using gmultiset_subset_subseteq. lia. Qed. (** Well-foundedness *) Lemma gmultiset_wf : wf (⊂@{gmultiset A}). Proof. apply (wf_projected (<) size); auto using gmultiset_subset_size, lt_wf. Qed. Lemma gmultiset_ind (P : gmultiset A → Prop) : P ∅ → (∀ x X, P X → P ({[+ x +]} ⊎ X)) → ∀ X, P X. Proof. intros Hemp Hinsert X. induction (gmultiset_wf X) as [X _ IH]. destruct (gmultiset_choose_or_empty X) as [[x Hx]| ->]; auto. rewrite (gmultiset_disj_union_difference' x X) by done. apply Hinsert, IH; multiset_solver. Qed. End more_lemmas. stdpp-coq-stdpp-1.9.0/stdpp/hashset.v000066400000000000000000000162541451153341500175550ustar00rootroot00000000000000(** This file implements finite set using hash maps. Hash sets are represented using radix-2 search trees. Each hash bucket is thus indexed using an binary integer of type [Z], and contains an unordered list without duplicates. *) From stdpp Require Export fin_maps listset. From stdpp Require Import zmap. From stdpp Require Import options. Record hashset {A} (hash : A → Z) := Hashset { hashset_car : Zmap (list A); hashset_prf : map_Forall (λ n l, Forall (λ x, hash x = n) l ∧ NoDup l) hashset_car }. Global Arguments Hashset {_ _} _ _ : assert. Global Arguments hashset_car {_ _} _ : assert. Section hashset. Context `{EqDecision A} (hash : A → Z). Global Instance hashset_elem_of: ElemOf A (hashset hash) := λ x m, ∃ l, hashset_car m !! hash x = Some l ∧ x ∈ l. Global Program Instance hashset_empty: Empty (hashset hash) := Hashset ∅ _. Next Obligation. by intros n X; simpl_map. Qed. Global Program Instance hashset_singleton: Singleton A (hashset hash) := λ x, Hashset {[ hash x := [x] ]} _. Next Obligation. intros x n l [<- <-]%lookup_singleton_Some. rewrite Forall_singleton; auto using NoDup_singleton. Qed. Global Program Instance hashset_union: Union (hashset hash) := λ m1 m2, let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in Hashset (union_with (λ l k, Some (list_union l k)) m1 m2) _. Next Obligation. intros _ _ m1 Hm1 m2 Hm2 n l'; rewrite lookup_union_with_Some. intros [[??]|[[??]|(l&k&?&?&?)]]; simplify_eq/=; auto. split; [apply Forall_list_union|apply NoDup_list_union]; first [by eapply Hm1; eauto | by eapply Hm2; eauto]. Qed. Global Program Instance hashset_intersection: Intersection (hashset hash) := λ m1 m2, let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in Hashset (intersection_with (λ l k, let l' := list_intersection l k in guard (l' ≠ []); Some l') m1 m2) _. Next Obligation. intros _ _ m1 Hm1 m2 Hm2 n l'. rewrite lookup_intersection_with_Some. intros (?&?&?&?&?); simplify_option_eq. split; [apply Forall_list_intersection|apply NoDup_list_intersection]; first [by eapply Hm1; eauto | by eapply Hm2; eauto]. Qed. Global Program Instance hashset_difference: Difference (hashset hash) := λ m1 m2, let (m1,Hm1) := m1 in let (m2,Hm2) := m2 in Hashset (difference_with (λ l k, let l' := list_difference l k in guard (l' ≠ []); Some l') m1 m2) _. Next Obligation. intros _ _ m1 Hm1 m2 Hm2 n l'. rewrite lookup_difference_with_Some. intros [[??]|(?&?&?&?&?)]; simplify_option_eq; auto. split; [apply Forall_list_difference|apply NoDup_list_difference]; first [by eapply Hm1; eauto | by eapply Hm2; eauto]. Qed. Global Instance hashset_elements: Elements A (hashset hash) := λ m, map_to_list (hashset_car m) ≫= snd. Global Instance hashset_fin_set : FinSet A (hashset hash). Proof. split; [split; [split| |]| |]. - intros ? (?&?&?); simplify_map_eq/=. - unfold elem_of, hashset_elem_of, singleton, hashset_singleton; simpl. intros x y. setoid_rewrite lookup_singleton_Some. split. { by intros (?&[? <-]&?); decompose_elem_of_list. } intros ->; eexists [y]. by rewrite elem_of_list_singleton. - unfold elem_of, hashset_elem_of, union, hashset_union. intros [m1 Hm1] [m2 Hm2] x; simpl; setoid_rewrite lookup_union_with_Some. split. { intros (?&[[]|[[]|(l&k&?&?&?)]]&Hx); simplify_eq/=; eauto. rewrite elem_of_list_union in Hx; destruct Hx; eauto. } intros [(l&?&?)|(k&?&?)]. + destruct (m2 !! hash x) as [k|]; eauto. exists (list_union l k). rewrite elem_of_list_union. naive_solver. + destruct (m1 !! hash x) as [l|]; eauto 6. exists (list_union l k). rewrite elem_of_list_union. naive_solver. - unfold elem_of, hashset_elem_of, intersection, hashset_intersection. intros [m1 ?] [m2 ?] x; simpl. setoid_rewrite lookup_intersection_with_Some. split. { intros (?&(l&k&?&?&?)&Hx); simplify_option_eq. rewrite elem_of_list_intersection in Hx; naive_solver. } intros [(l&?&?) (k&?&?)]. assert (x ∈ list_intersection l k) by (by rewrite elem_of_list_intersection). exists (list_intersection l k); split; [exists l, k|]; split_and?; auto. by rewrite option_guard_True by eauto using elem_of_not_nil. - unfold elem_of, hashset_elem_of, intersection, hashset_intersection. intros [m1 ?] [m2 ?] x; simpl. setoid_rewrite lookup_difference_with_Some. split. { intros (l'&[[??]|(l&k&?&?&?)]&Hx); simplify_option_eq; rewrite ?elem_of_list_difference in Hx; naive_solver. } intros [(l&?&?) Hm2]; destruct (m2 !! hash x) as [k|] eqn:?; eauto. destruct (decide (x ∈ k)); [destruct Hm2; eauto|]. assert (x ∈ list_difference l k) by (by rewrite elem_of_list_difference). exists (list_difference l k); split; [right; exists l,k|]; split_and?; auto. by rewrite option_guard_True by eauto using elem_of_not_nil. - unfold elem_of at 2, hashset_elem_of, elements, hashset_elements. intros [m Hm] x; simpl. setoid_rewrite elem_of_list_bind. split. { intros ([n l]&Hx&Hn); simpl in *; rewrite elem_of_map_to_list in Hn. cut (hash x = n); [intros <-; eauto|]. eapply (Forall_forall (λ x, hash x = n) l); eauto. eapply Hm; eauto. } intros (l&?&?). exists (hash x, l); simpl. by rewrite elem_of_map_to_list. - unfold elements, hashset_elements. intros [m Hm]; simpl. rewrite map_Forall_to_list in Hm. generalize (NoDup_fst_map_to_list m). induction Hm as [|[n l] m' [??] Hm]; csimpl; inversion_clear 1 as [|?? Hn]; [constructor|]. apply NoDup_app; split_and?; eauto. setoid_rewrite elem_of_list_bind; intros x ? ([n' l']&?&?); simpl in *. assert (hash x = n ∧ hash x = n') as [??]; subst. { split; [eapply (Forall_forall (λ x, hash x = n) l); eauto|]. eapply (Forall_forall (λ x, hash x = n') l'); eauto. rewrite Forall_forall in Hm. eapply (Hm (_,_)); eauto. } destruct Hn; rewrite elem_of_list_fmap; exists (hash x, l'); eauto. Qed. End hashset. Global Typeclasses Opaque hashset_elem_of. Section remove_duplicates. Context `{EqDecision A} (hash : A → Z). Definition remove_dups_fast (l : list A) : list A := match l with | [] => [] | [x] => [x] | _ => let n : Z := Z.of_nat (length l) in elements (foldr (λ x, ({[ x ]} ∪.)) ∅ l : hashset (λ x, hash x `mod` (2 * n))%Z) end. Lemma elem_of_remove_dups_fast l x : x ∈ remove_dups_fast l ↔ x ∈ l. Proof. destruct l as [|x1 [|x2 l]]; try reflexivity. unfold remove_dups_fast; generalize (x1 :: x2 :: l); clear l; intros l. generalize (λ x, hash x `mod` (2 * Z.of_nat (length l)))%Z; intros f. rewrite elem_of_elements; split. - revert x. induction l as [|y l IH]; intros x; simpl. { by rewrite elem_of_empty. } rewrite elem_of_union, elem_of_singleton. intros [->|]; [left|right]; eauto. - induction 1; set_solver. Qed. Lemma NoDup_remove_dups_fast l : NoDup (remove_dups_fast l). Proof. unfold remove_dups_fast; destruct l as [|x1 [|x2 l]]. - apply NoDup_nil_2. - apply NoDup_singleton. - apply NoDup_elements. Qed. Definition listset_normalize (X : listset A) : listset A := let (l) := X in Listset (remove_dups_fast l). Lemma listset_normalize_correct X : listset_normalize X ≡ X. Proof. destruct X as [l]. apply set_equiv; intro; apply elem_of_remove_dups_fast. Qed. End remove_duplicates. stdpp-coq-stdpp-1.9.0/stdpp/hlist.v000066400000000000000000000042251451153341500172340ustar00rootroot00000000000000From stdpp Require Import tactics. From stdpp Require Import options. Local Set Universe Polymorphism. (* Not using [list Type] in order to avoid universe inconsistencies *) Inductive tlist := tnil : tlist | tcons : Type → tlist → tlist. Inductive hlist : tlist → Type := | hnil : hlist tnil | hcons {A As} : A → hlist As → hlist (tcons A As). Fixpoint tapp (As Bs : tlist) : tlist := match As with tnil => Bs | tcons A As => tcons A (tapp As Bs) end. Fixpoint happ {As Bs} (xs : hlist As) (ys : hlist Bs) : hlist (tapp As Bs) := match xs with hnil => ys | hcons x xs => hcons x (happ xs ys) end. Definition hhead {A As} (xs : hlist (tcons A As)) : A := match xs with hnil => () | hcons x _ => x end. Definition htail {A As} (xs : hlist (tcons A As)) : hlist As := match xs with hnil => () | hcons _ xs => xs end. Fixpoint hheads {As Bs} : hlist (tapp As Bs) → hlist As := match As with | tnil => λ _, hnil | tcons _ _ => λ xs, hcons (hhead xs) (hheads (htail xs)) end. Fixpoint htails {As Bs} : hlist (tapp As Bs) → hlist Bs := match As with | tnil => id | tcons _ _ => λ xs, htails (htail xs) end. Fixpoint himpl (As : tlist) (B : Type) : Type := match As with tnil => B | tcons A As => A → himpl As B end. Definition hinit {B} (y : B) : himpl tnil B := y. Definition hlam {A As B} (f : A → himpl As B) : himpl (tcons A As) B := f. Global Arguments hlam _ _ _ _ _ / : assert. Definition huncurry {As B} (f : himpl As B) (xs : hlist As) : B := (fix go {As} xs := match xs in hlist As return himpl As B → B with | hnil => λ f, f | hcons x xs => λ f, go xs (f x) end) _ xs f. Coercion huncurry : himpl >-> Funclass. Fixpoint hcurry {As B} : (hlist As → B) → himpl As B := match As with | tnil => λ f, f hnil | tcons x xs => λ f, hlam (λ x, hcurry (f ∘ hcons x)) end. Lemma huncurry_curry {As B} (f : hlist As → B) xs : huncurry (hcurry f) xs = f xs. Proof. by induction xs as [|A As x xs IH]; simpl; rewrite ?IH. Qed. Fixpoint hcompose {As B C} (f : B → C) {struct As} : himpl As B → himpl As C := match As with | tnil => f | tcons A As => λ g, hlam (λ x, hcompose f (g x)) end. stdpp-coq-stdpp-1.9.0/stdpp/infinite.v000066400000000000000000000144431451153341500177210ustar00rootroot00000000000000From stdpp Require Export list. From stdpp Require Import relations pretty. From stdpp Require Import options. (* Pick up extra assumptions from section parameters. *) Set Default Proof Using "Type*". (** * Generic constructions *) (** If [A] is infinite, and there is an injection from [A] to [B], then [B] is also infinite. Note that due to constructivity we need a rather strong notion of being injective, we also need a partial function [B → option A] back. *) Program Definition inj_infinite `{Infinite A} {B} (f : A → B) (g : B → option A) (Hgf : ∀ x, g (f x) = Some x) : Infinite B := {| infinite_fresh := f ∘ fresh ∘ omap g |}. Next Obligation. intros A ? B f g Hfg xs Hxs; simpl in *. apply (infinite_is_fresh (omap g xs)), elem_of_list_omap; eauto. Qed. Next Obligation. solve_proper. Qed. (** If there is an injective function [f : nat → B], then [B] is infinite. This construction works as follows: to obtain an element not in [xs], we return the first element [f 0], [f 1], [f 2], ... that is not in [xs]. This construction has a nice computational behavior to e.g. find fresh strings. Given some prefix [s], we use [f n := if n is S n' then s +:+ pretty n else s]. The construction then finds the first string starting with [s] followed by a number that's not in the input list. For example, given [["H", "H1", "H4"]] and [s := "H"], it would find ["H2"]. *) Section search_infinite. Context {B} (f : nat → B). Let R (xs : list B) (n1 n2 : nat) := n2 < n1 ∧ (f (n1 - 1)) ∈ xs. Lemma search_infinite_step xs n : f n ∈ xs → R xs (1 + n) n. Proof. split; [lia|]. replace (1 + n - 1) with n by lia; eauto. Qed. Context `{!Inj (=) (=) f, !EqDecision B}. Lemma search_infinite_R_wf xs : wf (R xs). Proof. revert xs. assert (help : ∀ xs n n', Acc (R (filter (.≠ f n') xs)) n → n' < n → Acc (R xs) n). { induction 1 as [n _ IH]. constructor; intros n2 [??]. apply IH; [|lia]. split; [done|]. apply elem_of_list_filter; naive_solver lia. } intros xs. induction (well_founded_ltof _ length xs) as [xs _ IH]. intros n1; constructor; intros n2 [Hn Hs]. apply help with (n2 - 1); [|lia]. apply IH. eapply filter_length_lt; eauto. Qed. Definition search_infinite_go (xs : list B) (n : nat) (go : ∀ n', R xs n' n → B) : B := let x := f n in match decide (x ∈ xs) with | left Hx => go (S n) (search_infinite_step xs n Hx) | right _ => x end. Program Definition search_infinite : Infinite B := {| infinite_fresh xs := Fix_F _ (search_infinite_go xs) (wf_guard 32 (search_infinite_R_wf xs) 0) |}. Next Obligation. intros xs. unfold fresh. generalize 0 (wf_guard 32 (search_infinite_R_wf xs) 0). revert xs. fix FIX 3; intros xs n [?]; simpl; unfold search_infinite_go at 1; simpl. destruct (decide _); auto. Qed. Next Obligation. intros xs1 xs2 Hxs. unfold fresh. generalize (wf_guard 32 (search_infinite_R_wf xs1) 0). generalize (wf_guard 32 (search_infinite_R_wf xs2) 0). generalize 0. fix FIX 2. intros n [acc1] [acc2]; simpl; unfold search_infinite_go. destruct (decide ( _ ∈ xs1)) as [H1|H1], (decide (_ ∈ xs2)) as [H2|H2]; auto. - destruct H2. by rewrite <-Hxs. - destruct H1. by rewrite Hxs. Qed. End search_infinite. (** To select a fresh number from a given list [x₀ ... xₙ], a possible approach is to compute [(S x₀) `max` ... `max` (S xₙ) `max` 0]. For non-empty lists of non-negative numbers this is equal to taking the maximal element [xᵢ] and adding one. The construction below generalizes this construction to any type [A], function [f : A → A → A]. and initial value [a]. The fresh element is computed as [x₀ `f` ... `f` xₙ `f` a]. For numbers, the prototypical instance is [f x y := S x `max` y] and [a:=0], which gives the behavior described before. Note that this gives [a] (i.e. [0] for numbers) for the empty list. *) Section max_infinite. Context {A} (f : A → A → A) (a : A) (lt : relation A). Context (HR : ∀ x, ¬lt x x). Context (HR1 : ∀ x y, lt x (f x y)). Context (HR2 : ∀ x x' y, lt x x' → lt x (f y x')). Context (Hf : ∀ x x' y, f x (f x' y) = f x' (f x y)). Program Definition max_infinite: Infinite A := {| infinite_fresh := foldr f a |}. Next Obligation. cut (∀ xs x, x ∈ xs → lt x (foldr f a xs)). { intros help xs []%help%HR. } induction 1; simpl; auto. Qed. Next Obligation. by apply (foldr_permutation_proper _ _ _). Qed. End max_infinite. (** Instances for number types *) Global Program Instance nat_infinite : Infinite nat := max_infinite (Nat.max ∘ S) 0 (<) _ _ _ _. Solve Obligations with (intros; simpl; lia). Global Program Instance N_infinite : Infinite N := max_infinite (N.max ∘ N.succ) 0%N N.lt _ _ _ _. Solve Obligations with (intros; simpl; lia). Global Program Instance positive_infinite : Infinite positive := max_infinite (Pos.max ∘ Pos.succ) 1%positive Pos.lt _ _ _ _. Solve Obligations with (intros; simpl; lia). Global Program Instance Z_infinite: Infinite Z := max_infinite (Z.max ∘ Z.succ) 0%Z Z.lt _ _ _ _. Solve Obligations with (intros; simpl; lia). (** Instances for option, sum, products *) Global Instance option_infinite `{Infinite A} : Infinite (option A) := inj_infinite Some id (λ _, eq_refl). Global Instance sum_infinite_l `{Infinite A} {B} : Infinite (A + B) := inj_infinite inl (maybe inl) (λ _, eq_refl). Global Instance sum_infinite_r {A} `{Infinite B} : Infinite (A + B) := inj_infinite inr (maybe inr) (λ _, eq_refl). Global Instance prod_infinite_l `{Infinite A, Inhabited B} : Infinite (A * B) := inj_infinite (., inhabitant) (Some ∘ fst) (λ _, eq_refl). Global Instance prod_infinite_r `{Inhabited A, Infinite B} : Infinite (A * B) := inj_infinite (inhabitant ,.) (Some ∘ snd) (λ _, eq_refl). (** Instance for lists *) Global Program Instance list_infinite `{Inhabited A} : Infinite (list A) := {| infinite_fresh xxs := replicate (fresh (length <$> xxs)) inhabitant |}. Next Obligation. intros A ? xs ?. destruct (infinite_is_fresh (length <$> xs)). apply elem_of_list_fmap. eexists; split; [|done]. unfold fresh. by rewrite replicate_length. Qed. Next Obligation. unfold fresh. by intros A ? xs1 xs2 ->. Qed. (** Instance for strings *) Global Program Instance string_infinite : Infinite string := search_infinite pretty. stdpp-coq-stdpp-1.9.0/stdpp/lexico.v000066400000000000000000000136451451153341500174020ustar00rootroot00000000000000(** This files defines a lexicographic order on various common data structures and proves that it is a partial order having a strong variant of trichotomy. *) From stdpp Require Import numbers. From stdpp Require Import options. Notation cast_trichotomy T := match T with | inleft (left _) => inleft (left _) | inleft (right _) => inleft (right _) | inright _ => inright _ end. Global Instance prod_lexico `{Lexico A, Lexico B} : Lexico (A * B) := λ p1 p2, (**i 1.) *) lexico (p1.1) (p2.1) ∨ (**i 2.) *) p1.1 = p2.1 ∧ lexico (p1.2) (p2.2). Global Instance bool_lexico : Lexico bool := λ b1 b2, match b1, b2 with false, true => True | _, _ => False end. Global Instance nat_lexico : Lexico nat := (<). Global Instance N_lexico : Lexico N := (<)%N. Global Instance Z_lexico : Lexico Z := (<)%Z. Global Typeclasses Opaque bool_lexico nat_lexico N_lexico Z_lexico. Global Instance list_lexico `{Lexico A} : Lexico (list A) := fix go l1 l2 := let _ : Lexico (list A) := @go in match l1, l2 with | [], _ :: _ => True | x1 :: l1, x2 :: l2 => lexico (x1,l1) (x2,l2) | _, _ => False end. Global Instance sig_lexico `{Lexico A} (P : A → Prop) `{∀ x, ProofIrrel (P x)} : Lexico (sig P) := λ x1 x2, lexico (`x1) (`x2). Lemma prod_lexico_irreflexive `{Lexico A, Lexico B, !Irreflexive (@lexico A _)} (x : A) (y : B) : complement lexico y y → complement lexico (x,y) (x,y). Proof. intros ? [?|[??]]; [|done]. by apply (irreflexivity lexico x). Qed. Lemma prod_lexico_transitive `{Lexico A, Lexico B, !Transitive (@lexico A _)} (x1 x2 x3 : A) (y1 y2 y3 : B) : lexico (x1,y1) (x2,y2) → lexico (x2,y2) (x3,y3) → (lexico y1 y2 → lexico y2 y3 → lexico y1 y3) → lexico (x1,y1) (x3,y3). Proof. intros Hx12 Hx23 ?; revert Hx12 Hx23. unfold lexico, prod_lexico. intros [|[??]] [?|[??]]; simplify_eq/=; auto. by left; trans x2. Qed. Global Instance prod_lexico_po `{Lexico A, Lexico B, !StrictOrder (@lexico A _)} `{!StrictOrder (@lexico B _)} : StrictOrder (@lexico (A * B) _). Proof. split. - intros [x y]. apply prod_lexico_irreflexive. by apply (irreflexivity lexico y). - intros [??] [??] [??] ??. eapply prod_lexico_transitive; eauto. apply transitivity. Qed. Global Instance prod_lexico_trichotomyT `{Lexico A, tA : !TrichotomyT (@lexico A _)} `{Lexico B, tB : !TrichotomyT (@lexico B _)}: TrichotomyT (@lexico (A * B) _). Proof. red; refine (λ p1 p2, match trichotomyT lexico (p1.1) (p2.1) with | inleft (left _) => inleft (left _) | inleft (right _) => cast_trichotomy (trichotomyT lexico (p1.2) (p2.2)) | inright _ => inright _ end); clear tA tB; abstract (unfold lexico, prod_lexico; auto using injective_projections). Defined. Global Instance bool_lexico_po : StrictOrder (@lexico bool _). Proof. split. - by intros [] ?. - by intros [] [] [] ??. Qed. Global Instance bool_lexico_trichotomy: TrichotomyT (@lexico bool _). Proof. red; refine (λ b1 b2, match b1, b2 with | false, false => inleft (right _) | false, true => inleft (left _) | true, false => inright _ | true, true => inleft (right _) end); abstract (unfold strict, lexico, bool_lexico; naive_solver). Defined. Global Instance nat_lexico_po : StrictOrder (@lexico nat _). Proof. unfold lexico, nat_lexico. apply _. Qed. Global Instance nat_lexico_trichotomy: TrichotomyT (@lexico nat _). Proof. red; refine (λ n1 n2, match Nat.compare n1 n2 as c return Nat.compare n1 n2 = c → _ with | Lt => λ H, inleft (left (nat_compare_Lt_lt _ _ H)) | Eq => λ H, inleft (right (nat_compare_eq _ _ H)) | Gt => λ H, inright (nat_compare_Gt_gt _ _ H) end eq_refl). Defined. Global Instance N_lexico_po : StrictOrder (@lexico N _). Proof. unfold lexico, N_lexico. apply _. Qed. Global Instance N_lexico_trichotomy: TrichotomyT (@lexico N _). Proof. red; refine (λ n1 n2, match N.compare n1 n2 as c return N.compare n1 n2 = c → _ with | Lt => λ H, inleft (left (proj2 (N.compare_lt_iff _ _) H)) | Eq => λ H, inleft (right (N.compare_eq _ _ H)) | Gt => λ H, inright (proj1 (N.compare_gt_iff _ _) H) end eq_refl). Defined. Global Instance Z_lexico_po : StrictOrder (@lexico Z _). Proof. unfold lexico, Z_lexico. apply _. Qed. Global Instance Z_lexico_trichotomy: TrichotomyT (@lexico Z _). Proof. red; refine (λ n1 n2, match Z.compare n1 n2 as c return Z.compare n1 n2 = c → _ with | Lt => λ H, inleft (left (proj2 (Z.compare_lt_iff _ _) H)) | Eq => λ H, inleft (right (Z.compare_eq _ _ H)) | Gt => λ H, inright (proj1 (Z.compare_gt_iff _ _) H) end eq_refl). Defined. Global Instance list_lexico_po `{Lexico A, !StrictOrder (@lexico A _)} : StrictOrder (@lexico (list A) _). Proof. split. - intros l. induction l; [by intros ? | by apply prod_lexico_irreflexive]. - intros l1. induction l1 as [|x1 l1]; intros [|x2 l2] [|x3 l3] ??; try done. eapply prod_lexico_transitive; eauto. Qed. Global Instance list_lexico_trichotomy `{Lexico A, tA : !TrichotomyT (@lexico A _)} : TrichotomyT (@lexico (list A) _). Proof. refine ( fix go l1 l2 := let go' : TrichotomyT (@lexico (list A) _) := @go in match l1, l2 with | [], [] => inleft (right _) | [], _ :: _ => inleft (left _) | _ :: _, [] => inright _ | x1 :: l1, x2 :: l2 => cast_trichotomy (trichotomyT lexico (x1,l1) (x2,l2)) end); clear tA go go'; abstract (repeat (done || constructor || congruence || by inversion 1)). Defined. Global Instance sig_lexico_po `{Lexico A, !StrictOrder (@lexico A _)} (P : A → Prop) `{∀ x, ProofIrrel (P x)} : StrictOrder (@lexico (sig P) _). Proof. unfold lexico, sig_lexico. split. - intros [x ?] ?. by apply (irreflexivity lexico x). - intros [x1 ?] [x2 ?] [x3 ?] ??. by trans x2. Qed. Global Instance sig_lexico_trichotomy `{Lexico A, tA : !TrichotomyT (@lexico A _)} (P : A → Prop) `{∀ x, ProofIrrel (P x)} : TrichotomyT (@lexico (sig P) _). Proof. red; refine (λ x1 x2, cast_trichotomy (trichotomyT lexico (`x1) (`x2))); abstract (repeat (done || constructor || apply (sig_eq_pi P))). Defined. stdpp-coq-stdpp-1.9.0/stdpp/list.v000066400000000000000000007062501451153341500170730ustar00rootroot00000000000000(** This file collects general purpose definitions and theorems on lists that are not in the Coq standard library. *) From Coq Require Export Permutation. From stdpp Require Export numbers base option. From stdpp Require Import options. Global Arguments length {_} _ : assert. Global Arguments cons {_} _ _ : assert. Global Arguments app {_} _ _ : assert. Global Instance: Params (@length) 1 := {}. Global Instance: Params (@cons) 1 := {}. Global Instance: Params (@app) 1 := {}. (** [head] and [tail] are defined as [parsing only] for [hd_error] and [tl] in the Coq standard library. We redefine these notations to make sure they also pretty print properly. *) Notation head := hd_error. Notation tail := tl. Notation take := firstn. Notation drop := skipn. Global Arguments head {_} _ : assert. Global Arguments tail {_} _ : assert. Global Arguments take {_} !_ !_ / : assert. Global Arguments drop {_} !_ !_ / : assert. Global Instance: Params (@head) 1 := {}. Global Instance: Params (@tail) 1 := {}. Global Instance: Params (@take) 1 := {}. Global Instance: Params (@drop) 1 := {}. Global Instance: Params (@Forall) 1 := {}. Global Instance: Params (@Exists) 1 := {}. Global Instance: Params (@NoDup) 1 := {}. Global Arguments Permutation {_} _ _ : assert. Global Arguments Forall_cons {_} _ _ _ _ _ : assert. Notation "(::)" := cons (only parsing) : list_scope. Notation "( x ::.)" := (cons x) (only parsing) : list_scope. Notation "(.:: l )" := (λ x, cons x l) (only parsing) : list_scope. Notation "(++)" := app (only parsing) : list_scope. Notation "( l ++.)" := (app l) (only parsing) : list_scope. Notation "(.++ k )" := (λ l, app l k) (only parsing) : list_scope. Infix "≡ₚ" := Permutation (at level 70, no associativity) : stdpp_scope. Notation "(≡ₚ)" := Permutation (only parsing) : stdpp_scope. Notation "( x ≡ₚ.)" := (Permutation x) (only parsing) : stdpp_scope. Notation "(.≡ₚ x )" := (λ y, y ≡ₚ x) (only parsing) : stdpp_scope. Notation "(≢ₚ)" := (λ x y, ¬x ≡ₚ y) (only parsing) : stdpp_scope. Notation "x ≢ₚ y":= (¬x ≡ₚ y) (at level 70, no associativity) : stdpp_scope. Notation "( x ≢ₚ.)" := (λ y, x ≢ₚ y) (only parsing) : stdpp_scope. Notation "(.≢ₚ x )" := (λ y, y ≢ₚ x) (only parsing) : stdpp_scope. Infix "≡ₚ@{ A }" := (@Permutation A) (at level 70, no associativity, only parsing) : stdpp_scope. Notation "(≡ₚ@{ A } )" := (@Permutation A) (only parsing) : stdpp_scope. Global Instance maybe_cons {A} : Maybe2 (@cons A) := λ l, match l with x :: l => Some (x,l) | _ => None end. (** * Definitions *) (** Setoid equality lifted to lists *) Inductive list_equiv `{Equiv A} : Equiv (list A) := | nil_equiv : [] ≡ [] | cons_equiv x y l k : x ≡ y → l ≡ k → x :: l ≡ y :: k. Global Existing Instance list_equiv. (** The operation [l !! i] gives the [i]th element of the list [l], or [None] in case [i] is out of bounds. *) Global Instance list_lookup {A} : Lookup nat A (list A) := fix go i l {struct l} : option A := let _ : Lookup _ _ _ := @go in match l with | [] => None | x :: l => match i with 0 => Some x | S i => l !! i end end. (** The operation [l !!! i] is a total version of the lookup operation [l !! i]. *) Global Instance list_lookup_total `{!Inhabited A} : LookupTotal nat A (list A) := fix go i l {struct l} : A := let _ : LookupTotal _ _ _ := @go in match l with | [] => inhabitant | x :: l => match i with 0 => x | S i => l !!! i end end. (** The operation [alter f i l] applies the function [f] to the [i]th element of [l]. In case [i] is out of bounds, the list is returned unchanged. *) Global Instance list_alter {A} : Alter nat A (list A) := λ f, fix go i l {struct l} := match l with | [] => [] | x :: l => match i with 0 => f x :: l | S i => x :: go i l end end. (** The operation [<[i:=x]> l] overwrites the element at position [i] with the value [x]. In case [i] is out of bounds, the list is returned unchanged. *) Global Instance list_insert {A} : Insert nat A (list A) := fix go i y l {struct l} := let _ : Insert _ _ _ := @go in match l with | [] => [] | x :: l => match i with 0 => y :: l | S i => x :: <[i:=y]>l end end. Fixpoint list_inserts {A} (i : nat) (k l : list A) : list A := match k with | [] => l | y :: k => <[i:=y]>(list_inserts (S i) k l) end. Global Instance: Params (@list_inserts) 1 := {}. (** The operation [delete i l] removes the [i]th element of [l] and moves all consecutive elements one position ahead. In case [i] is out of bounds, the list is returned unchanged. *) Global Instance list_delete {A} : Delete nat (list A) := fix go (i : nat) (l : list A) {struct l} : list A := match l with | [] => [] | x :: l => match i with 0 => l | S i => x :: @delete _ _ go i l end end. (** The function [option_list o] converts an element [Some x] into the singleton list [[x]], and [None] into the empty list [[]]. *) Definition option_list {A} : option A → list A := option_rect _ (λ x, [x]) []. Global Instance: Params (@option_list) 1 := {}. Global Instance maybe_list_singleton {A} : Maybe (λ x : A, [x]) := λ l, match l with [x] => Some x | _ => None end. (** The function [filter P l] returns the list of elements of [l] that satisfies [P]. The order remains unchanged. *) Global Instance list_filter {A} : Filter A (list A) := fix go P _ l := let _ : Filter _ _ := @go in match l with | [] => [] | x :: l => if decide (P x) then x :: filter P l else filter P l end. (** The function [list_find P l] returns the first index [i] whose element satisfies the predicate [P]. *) Definition list_find {A} P `{∀ x, Decision (P x)} : list A → option (nat * A) := fix go l := match l with | [] => None | x :: l => if decide (P x) then Some (0,x) else prod_map S id <$> go l end. Global Instance: Params (@list_find) 3 := {}. (** The function [replicate n x] generates a list with length [n] of elements with value [x]. *) Fixpoint replicate {A} (n : nat) (x : A) : list A := match n with 0 => [] | S n => x :: replicate n x end. Global Instance: Params (@replicate) 2 := {}. (** The function [rotate n l] rotates the list [l] by [n], e.g., [rotate 1 [x0; x1; ...; xm]] becomes [x1; ...; xm; x0]. Rotating by a multiple of [length l] is the identity function. **) Definition rotate {A} (n : nat) (l : list A) : list A := drop (n `mod` length l) l ++ take (n `mod` length l) l. Global Instance: Params (@rotate) 2 := {}. (** The function [rotate_take s e l] returns the range between the indices [s] (inclusive) and [e] (exclusive) of [l]. If [e ≤ s], all elements after [s] and before [e] are returned. *) Definition rotate_take {A} (s e : nat) (l : list A) : list A := take (rotate_nat_sub s e (length l)) (rotate s l). Global Instance: Params (@rotate_take) 3 := {}. (** The function [reverse l] returns the elements of [l] in reverse order. *) Definition reverse {A} (l : list A) : list A := rev_append l []. Global Instance: Params (@reverse) 1 := {}. (** The function [last l] returns the last element of the list [l], or [None] if the list [l] is empty. *) Fixpoint last {A} (l : list A) : option A := match l with [] => None | [x] => Some x | _ :: l => last l end. Global Instance: Params (@last) 1 := {}. Global Arguments last : simpl nomatch. (** The function [resize n y l] takes the first [n] elements of [l] in case [length l ≤ n], and otherwise appends elements with value [x] to [l] to obtain a list of length [n]. *) Fixpoint resize {A} (n : nat) (y : A) (l : list A) : list A := match l with | [] => replicate n y | x :: l => match n with 0 => [] | S n => x :: resize n y l end end. Global Arguments resize {_} !_ _ !_ : assert. Global Instance: Params (@resize) 2 := {}. (** The function [reshape k l] transforms [l] into a list of lists whose sizes are specified by [k]. In case [l] is too short, the resulting list will be padded with empty lists. In case [l] is too long, it will be truncated. *) Fixpoint reshape {A} (szs : list nat) (l : list A) : list (list A) := match szs with | [] => [] | sz :: szs => take sz l :: reshape szs (drop sz l) end. Global Instance: Params (@reshape) 2 := {}. Definition sublist_lookup {A} (i n : nat) (l : list A) : option (list A) := guard (i + n ≤ length l); Some (take n (drop i l)). Definition sublist_alter {A} (f : list A → list A) (i n : nat) (l : list A) : list A := take i l ++ f (take n (drop i l)) ++ drop (i + n) l. (** Functions to fold over a list. We redefine [foldl] with the arguments in the same order as in Haskell. *) Notation foldr := fold_right. Definition foldl {A B} (f : A → B → A) : A → list B → A := fix go a l := match l with [] => a | x :: l => go (f a x) l end. (** The monadic operations. *) Global Instance list_ret: MRet list := λ A x, x :: @nil A. Global Instance list_fmap : FMap list := λ A B f, fix go (l : list A) := match l with [] => [] | x :: l => f x :: go l end. Global Instance list_omap : OMap list := λ A B f, fix go (l : list A) := match l with | [] => [] | x :: l => match f x with Some y => y :: go l | None => go l end end. Global Instance list_bind : MBind list := λ A B f, fix go (l : list A) := match l with [] => [] | x :: l => f x ++ go l end. Global Instance list_join: MJoin list := fix go A (ls : list (list A)) : list A := match ls with [] => [] | l :: ls => l ++ @mjoin _ go _ ls end. Definition mapM `{MBind M, MRet M} {A B} (f : A → M B) : list A → M (list B) := fix go l := match l with [] => mret [] | x :: l => y ← f x; k ← go l; mret (y :: k) end. Global Instance: Params (@mapM) 5 := {}. (** We define stronger variants of the map function that allow the mapped function to use the index of the elements. *) Fixpoint imap {A B} (f : nat → A → B) (l : list A) : list B := match l with | [] => [] | x :: l => f 0 x :: imap (f ∘ S) l end. Global Instance: Params (@imap) 2 := {}. Definition zipped_map {A B} (f : list A → list A → A → B) : list A → list A → list B := fix go l k := match k with | [] => [] | x :: k => f l k x :: go (x :: l) k end. Global Instance: Params (@zipped_map) 2 := {}. Fixpoint imap2 {A B C} (f : nat → A → B → C) (l : list A) (k : list B) : list C := match l, k with | [], _ | _, [] => [] | x :: l, y :: k => f 0 x y :: imap2 (f ∘ S) l k end. Global Instance: Params (@imap2) 3 := {}. Inductive zipped_Forall {A} (P : list A → list A → A → Prop) : list A → list A → Prop := | zipped_Forall_nil l : zipped_Forall P l [] | zipped_Forall_cons l k x : P l k x → zipped_Forall P (x :: l) k → zipped_Forall P l (x :: k). Global Arguments zipped_Forall_nil {_ _} _ : assert. Global Arguments zipped_Forall_cons {_ _} _ _ _ _ _ : assert. (** The function [mask f βs l] applies the function [f] to elements in [l] at positions that are [true] in [βs]. *) Fixpoint mask {A} (f : A → A) (βs : list bool) (l : list A) : list A := match βs, l with | β :: βs, x :: l => (if β then f x else x) :: mask f βs l | _, _ => l end. (** The function [permutations l] yields all permutations of [l]. *) Fixpoint interleave {A} (x : A) (l : list A) : list (list A) := match l with | [] => [[x]]| y :: l => (x :: y :: l) :: ((y ::.) <$> interleave x l) end. Fixpoint permutations {A} (l : list A) : list (list A) := match l with [] => [[]] | x :: l => permutations l ≫= interleave x end. (** The predicate [suffix] holds if the first list is a suffix of the second. The predicate [prefix] holds if the first list is a prefix of the second. *) Definition suffix {A} : relation (list A) := λ l1 l2, ∃ k, l2 = k ++ l1. Definition prefix {A} : relation (list A) := λ l1 l2, ∃ k, l2 = l1 ++ k. Infix "`suffix_of`" := suffix (at level 70) : stdpp_scope. Infix "`prefix_of`" := prefix (at level 70) : stdpp_scope. Global Hint Extern 0 (_ `prefix_of` _) => reflexivity : core. Global Hint Extern 0 (_ `suffix_of` _) => reflexivity : core. Section prefix_suffix_ops. Context `{EqDecision A}. Definition max_prefix : list A → list A → list A * list A * list A := fix go l1 l2 := match l1, l2 with | [], l2 => ([], l2, []) | l1, [] => (l1, [], []) | x1 :: l1, x2 :: l2 => if decide_rel (=) x1 x2 then prod_map id (x1 ::.) (go l1 l2) else (x1 :: l1, x2 :: l2, []) end. Definition max_suffix (l1 l2 : list A) : list A * list A * list A := match max_prefix (reverse l1) (reverse l2) with | (k1, k2, k3) => (reverse k1, reverse k2, reverse k3) end. Definition strip_prefix (l1 l2 : list A) := (max_prefix l1 l2).1.2. Definition strip_suffix (l1 l2 : list A) := (max_suffix l1 l2).1.2. End prefix_suffix_ops. (** A list [l1] is a sublist of [l2] if [l2] is obtained by removing elements from [l1] without changing the order. *) Inductive sublist {A} : relation (list A) := | sublist_nil : sublist [] [] | sublist_skip x l1 l2 : sublist l1 l2 → sublist (x :: l1) (x :: l2) | sublist_cons x l1 l2 : sublist l1 l2 → sublist l1 (x :: l2). Infix "`sublist_of`" := sublist (at level 70) : stdpp_scope. Global Hint Extern 0 (_ `sublist_of` _) => reflexivity : core. (** A list [l2] submseteq a list [l1] if [l2] is obtained by removing elements from [l1] while possiblity changing the order. *) Inductive submseteq {A} : relation (list A) := | submseteq_nil : submseteq [] [] | submseteq_skip x l1 l2 : submseteq l1 l2 → submseteq (x :: l1) (x :: l2) | submseteq_swap x y l : submseteq (y :: x :: l) (x :: y :: l) | submseteq_cons x l1 l2 : submseteq l1 l2 → submseteq l1 (x :: l2) | submseteq_trans l1 l2 l3 : submseteq l1 l2 → submseteq l2 l3 → submseteq l1 l3. Infix "⊆+" := submseteq (at level 70) : stdpp_scope. Global Hint Extern 0 (_ ⊆+ _) => reflexivity : core. (** Removes [x] from the list [l]. The function returns a [Some] when the removal succeeds and [None] when [x] is not in [l]. *) Fixpoint list_remove `{EqDecision A} (x : A) (l : list A) : option (list A) := match l with | [] => None | y :: l => if decide (x = y) then Some l else (y ::.) <$> list_remove x l end. (** Removes all elements in the list [k] from the list [l]. The function returns a [Some] when the removal succeeds and [None] some element of [k] is not in [l]. *) Fixpoint list_remove_list `{EqDecision A} (k : list A) (l : list A) : option (list A) := match k with | [] => Some l | x :: k => list_remove x l ≫= list_remove_list k end. Inductive Forall3 {A B C} (P : A → B → C → Prop) : list A → list B → list C → Prop := | Forall3_nil : Forall3 P [] [] [] | Forall3_cons x y z l k k' : P x y z → Forall3 P l k k' → Forall3 P (x :: l) (y :: k) (z :: k'). (** Set operations on lists *) Global Instance list_subseteq {A} : SubsetEq (list A) := λ l1 l2, ∀ x, x ∈ l1 → x ∈ l2. Section list_set. Context `{dec : EqDecision A}. Global Instance elem_of_list_dec : RelDecision (∈@{list A}). Proof using Type*. refine ( fix go x l := match l return Decision (x ∈ l) with | [] => right _ | y :: l => cast_if_or (decide (x = y)) (go x l) end); clear go dec; subst; try (by constructor); abstract by inversion 1. Defined. Fixpoint remove_dups (l : list A) : list A := match l with | [] => [] | x :: l => if decide_rel (∈) x l then remove_dups l else x :: remove_dups l end. Fixpoint list_difference (l k : list A) : list A := match l with | [] => [] | x :: l => if decide_rel (∈) x k then list_difference l k else x :: list_difference l k end. Definition list_union (l k : list A) : list A := list_difference l k ++ k. Fixpoint list_intersection (l k : list A) : list A := match l with | [] => [] | x :: l => if decide_rel (∈) x k then x :: list_intersection l k else list_intersection l k end. Definition list_intersection_with (f : A → A → option A) : list A → list A → list A := fix go l k := match l with | [] => [] | x :: l => foldr (λ y, match f x y with None => id | Some z => (z ::.) end) (go l k) k end. End list_set. (** These next functions allow to efficiently encode lists of positives (bit strings) into a single positive and go in the other direction as well. This is for example used for the countable instance of lists and in namespaces. The main functions are [positives_flatten] and [positives_unflatten]. *) Fixpoint positives_flatten_go (xs : list positive) (acc : positive) : positive := match xs with | [] => acc | x :: xs => positives_flatten_go xs (acc~1~0 ++ Pos.reverse (Pos.dup x)) end. (** Flatten a list of positives into a single positive by duplicating the bits of each element, so that: - [0 -> 00] - [1 -> 11] and then separating each element with [10]. *) Definition positives_flatten (xs : list positive) : positive := positives_flatten_go xs 1. Fixpoint positives_unflatten_go (p : positive) (acc_xs : list positive) (acc_elm : positive) : option (list positive) := match p with | 1 => Some acc_xs | p'~0~0 => positives_unflatten_go p' acc_xs (acc_elm~0) | p'~1~1 => positives_unflatten_go p' acc_xs (acc_elm~1) | p'~1~0 => positives_unflatten_go p' (acc_elm :: acc_xs) 1 | _ => None end%positive. (** Unflatten a positive into a list of positives, assuming the encoding used by [positives_flatten]. *) Definition positives_unflatten (p : positive) : option (list positive) := positives_unflatten_go p [] 1. (** * Basic tactics on lists *) (** The tactic [discriminate_list] discharges a goal if it submseteq a list equality involving [(::)] and [(++)] of two lists that have a different length as one of its hypotheses. *) Tactic Notation "discriminate_list" hyp(H) := apply (f_equal length) in H; repeat (csimpl in H || rewrite app_length in H); exfalso; lia. Tactic Notation "discriminate_list" := match goal with H : _ =@{list _} _ |- _ => discriminate_list H end. (** The tactic [simplify_list_eq] simplifies hypotheses involving equalities on lists using injectivity of [(::)] and [(++)]. Also, it simplifies lookups in singleton lists. *) Lemma app_inj_1 {A} (l1 k1 l2 k2 : list A) : length l1 = length k1 → l1 ++ l2 = k1 ++ k2 → l1 = k1 ∧ l2 = k2. Proof. revert k1. induction l1; intros [|??]; naive_solver. Qed. Lemma app_inj_2 {A} (l1 k1 l2 k2 : list A) : length l2 = length k2 → l1 ++ l2 = k1 ++ k2 → l1 = k1 ∧ l2 = k2. Proof. intros ? Hl. apply app_inj_1; auto. apply (f_equal length) in Hl. rewrite !app_length in Hl. lia. Qed. Ltac simplify_list_eq := repeat match goal with | _ => progress simplify_eq/= | H : _ ++ _ = _ ++ _ |- _ => first [ apply app_inv_head in H | apply app_inv_tail in H | apply app_inj_1 in H; [destruct H|done] | apply app_inj_2 in H; [destruct H|done] ] | H : [?x] !! ?i = Some ?y |- _ => destruct i; [change (Some x = Some y) in H | discriminate] end. (** * General theorems *) Section general_properties. Context {A : Type}. Implicit Types x y z : A. Implicit Types l k : list A. Global Instance cons_eq_inj : Inj2 (=) (=) (=) (@cons A). Proof. by injection 1. Qed. Global Instance: ∀ k, Inj (=) (=) (k ++.). Proof. intros ???. apply app_inv_head. Qed. Global Instance: ∀ k, Inj (=) (=) (.++ k). Proof. intros ???. apply app_inv_tail. Qed. Global Instance: Assoc (=) (@app A). Proof. intros ???. apply app_assoc. Qed. Global Instance: LeftId (=) [] (@app A). Proof. done. Qed. Global Instance: RightId (=) [] (@app A). Proof. intro. apply app_nil_r. Qed. Lemma app_nil l1 l2 : l1 ++ l2 = [] ↔ l1 = [] ∧ l2 = []. Proof. split; [apply app_eq_nil|]. by intros [-> ->]. Qed. Lemma app_singleton l1 l2 x : l1 ++ l2 = [x] ↔ l1 = [] ∧ l2 = [x] ∨ l1 = [x] ∧ l2 = []. Proof. split; [apply app_eq_unit|]. by intros [[-> ->]|[-> ->]]. Qed. Lemma cons_middle x l1 l2 : l1 ++ x :: l2 = l1 ++ [x] ++ l2. Proof. done. Qed. Lemma list_eq l1 l2 : (∀ i, l1 !! i = l2 !! i) → l1 = l2. Proof. revert l2. induction l1 as [|x l1 IH]; intros [|y l2] H. - done. - discriminate (H 0). - discriminate (H 0). - f_equal; [by injection (H 0)|]. apply (IH _ $ λ i, H (S i)). Qed. Global Instance list_eq_dec {dec : EqDecision A} : EqDecision (list A) := list_eq_dec dec. Global Instance list_eq_nil_dec l : Decision (l = []). Proof. by refine match l with [] => left _ | _ => right _ end. Defined. Lemma list_singleton_reflect l : option_reflect (λ x, l = [x]) (length l ≠ 1) (maybe (λ x, [x]) l). Proof. by destruct l as [|? []]; constructor. Defined. Lemma list_eq_Forall2 l1 l2 : l1 = l2 ↔ Forall2 eq l1 l2. Proof. split. - intros <-. induction l1; eauto using Forall2. - induction 1; naive_solver. Qed. Definition nil_length : length (@nil A) = 0 := eq_refl. Definition cons_length x l : length (x :: l) = S (length l) := eq_refl. Lemma nil_or_length_pos l : l = [] ∨ length l ≠ 0. Proof. destruct l; simpl; auto with lia. Qed. Lemma nil_length_inv l : length l = 0 → l = []. Proof. by destruct l. Qed. Lemma lookup_cons_ne_0 l x i : i ≠ 0 → (x :: l) !! i = l !! pred i. Proof. by destruct i. Qed. Lemma lookup_total_cons_ne_0 `{!Inhabited A} l x i : i ≠ 0 → (x :: l) !!! i = l !!! pred i. Proof. by destruct i. Qed. Lemma lookup_nil i : @nil A !! i = None. Proof. by destruct i. Qed. Lemma lookup_total_nil `{!Inhabited A} i : @nil A !!! i = inhabitant. Proof. by destruct i. Qed. Lemma lookup_tail l i : tail l !! i = l !! S i. Proof. by destruct l. Qed. Lemma lookup_total_tail `{!Inhabited A} l i : tail l !!! i = l !!! S i. Proof. by destruct l. Qed. Lemma lookup_lt_Some l i x : l !! i = Some x → i < length l. Proof. revert i. induction l; intros [|?] ?; naive_solver auto with arith. Qed. Lemma lookup_lt_is_Some_1 l i : is_Some (l !! i) → i < length l. Proof. intros [??]; eauto using lookup_lt_Some. Qed. Lemma lookup_lt_is_Some_2 l i : i < length l → is_Some (l !! i). Proof. revert i. induction l; intros [|?] ?; naive_solver auto with lia. Qed. Lemma lookup_lt_is_Some l i : is_Some (l !! i) ↔ i < length l. Proof. split; auto using lookup_lt_is_Some_1, lookup_lt_is_Some_2. Qed. Lemma lookup_ge_None l i : l !! i = None ↔ length l ≤ i. Proof. rewrite eq_None_not_Some, lookup_lt_is_Some. lia. Qed. Lemma lookup_ge_None_1 l i : l !! i = None → length l ≤ i. Proof. by rewrite lookup_ge_None. Qed. Lemma lookup_ge_None_2 l i : length l ≤ i → l !! i = None. Proof. by rewrite lookup_ge_None. Qed. Lemma list_eq_same_length l1 l2 n : length l2 = n → length l1 = n → (∀ i x y, i < n → l1 !! i = Some x → l2 !! i = Some y → x = y) → l1 = l2. Proof. intros <- Hlen Hl; apply list_eq; intros i. destruct (l2 !! i) as [x|] eqn:Hx. - destruct (lookup_lt_is_Some_2 l1 i) as [y Hy]. { rewrite Hlen; eauto using lookup_lt_Some. } rewrite Hy; f_equal; apply (Hl i); eauto using lookup_lt_Some. - by rewrite lookup_ge_None, Hlen, <-lookup_ge_None. Qed. Lemma nth_lookup l i d : nth i l d = default d (l !! i). Proof. revert i. induction l as [|x l IH]; intros [|i]; simpl; auto. Qed. Lemma nth_lookup_Some l i d x : l !! i = Some x → nth i l d = x. Proof. rewrite nth_lookup. by intros ->. Qed. Lemma nth_lookup_or_length l i d : {l !! i = Some (nth i l d)} + {length l ≤ i}. Proof. rewrite nth_lookup. destruct (l !! i) eqn:?; eauto using lookup_ge_None_1. Qed. Lemma list_lookup_total_alt `{!Inhabited A} l i : l !!! i = default inhabitant (l !! i). Proof. revert i. induction l; intros []; naive_solver. Qed. Lemma list_lookup_total_correct `{!Inhabited A} l i x : l !! i = Some x → l !!! i = x. Proof. rewrite list_lookup_total_alt. by intros ->. Qed. Lemma list_lookup_lookup_total `{!Inhabited A} l i : is_Some (l !! i) → l !! i = Some (l !!! i). Proof. rewrite list_lookup_total_alt; by intros [x ->]. Qed. Lemma list_lookup_lookup_total_lt `{!Inhabited A} l i : i < length l → l !! i = Some (l !!! i). Proof. intros ?. by apply list_lookup_lookup_total, lookup_lt_is_Some_2. Qed. Lemma list_lookup_alt `{!Inhabited A} l i x : l !! i = Some x ↔ i < length l ∧ l !!! i = x. Proof. naive_solver eauto using list_lookup_lookup_total_lt, list_lookup_total_correct, lookup_lt_Some. Qed. Lemma lookup_app l1 l2 i : (l1 ++ l2) !! i = match l1 !! i with Some x => Some x | None => l2 !! (i - length l1) end. Proof. revert i. induction l1 as [|x l1 IH]; intros [|i]; naive_solver. Qed. Lemma lookup_app_l l1 l2 i : i < length l1 → (l1 ++ l2) !! i = l1 !! i. Proof. rewrite lookup_app. by intros [? ->]%lookup_lt_is_Some. Qed. Lemma lookup_total_app_l `{!Inhabited A} l1 l2 i : i < length l1 → (l1 ++ l2) !!! i = l1 !!! i. Proof. intros. by rewrite !list_lookup_total_alt, lookup_app_l. Qed. Lemma lookup_app_l_Some l1 l2 i x : l1 !! i = Some x → (l1 ++ l2) !! i = Some x. Proof. rewrite lookup_app. by intros ->. Qed. Lemma lookup_app_r l1 l2 i : length l1 ≤ i → (l1 ++ l2) !! i = l2 !! (i - length l1). Proof. rewrite lookup_app. by intros ->%lookup_ge_None. Qed. Lemma lookup_total_app_r `{!Inhabited A} l1 l2 i : length l1 ≤ i → (l1 ++ l2) !!! i = l2 !!! (i - length l1). Proof. intros. by rewrite !list_lookup_total_alt, lookup_app_r. Qed. Lemma lookup_app_Some l1 l2 i x : (l1 ++ l2) !! i = Some x ↔ l1 !! i = Some x ∨ length l1 ≤ i ∧ l2 !! (i - length l1) = Some x. Proof. rewrite lookup_app. destruct (l1 !! i) eqn:Hi. - apply lookup_lt_Some in Hi. naive_solver lia. - apply lookup_ge_None in Hi. naive_solver lia. Qed. Lemma lookup_cons x l i : (x :: l) !! i = match i with 0 => Some x | S i => l !! i end. Proof. reflexivity. Qed. Lemma lookup_cons_Some x l i y : (x :: l) !! i = Some y ↔ (i = 0 ∧ x = y) ∨ (1 ≤ i ∧ l !! (i - 1) = Some y). Proof. rewrite lookup_cons. destruct i as [|i]. - naive_solver lia. - replace (S i - 1) with i by lia. naive_solver lia. Qed. Lemma list_lookup_singleton x i : [x] !! i = match i with 0 => Some x | S _ => None end. Proof. reflexivity. Qed. Lemma list_lookup_singleton_Some x i y : [x] !! i = Some y ↔ i = 0 ∧ x = y. Proof. rewrite lookup_cons_Some. naive_solver. Qed. Lemma lookup_snoc_Some x l i y : (l ++ [x]) !! i = Some y ↔ (i < length l ∧ l !! i = Some y) ∨ (i = length l ∧ x = y). Proof. rewrite lookup_app_Some, list_lookup_singleton_Some. naive_solver auto using lookup_lt_is_Some_1 with lia. Qed. Lemma list_lookup_middle l1 l2 x n : n = length l1 → (l1 ++ x :: l2) !! n = Some x. Proof. intros ->. by induction l1. Qed. Lemma list_lookup_total_middle `{!Inhabited A} l1 l2 x n : n = length l1 → (l1 ++ x :: l2) !!! n = x. Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_middle. Qed. Lemma list_insert_alter l i x : <[i:=x]>l = alter (λ _, x) i l. Proof. by revert i; induction l; intros []; intros; f_equal/=. Qed. Lemma alter_length f l i : length (alter f i l) = length l. Proof. revert i. by induction l; intros [|?]; f_equal/=. Qed. Lemma insert_length l i x : length (<[i:=x]>l) = length l. Proof. revert i. by induction l; intros [|?]; f_equal/=. Qed. Lemma list_lookup_alter f l i : alter f i l !! i = f <$> l !! i. Proof. revert i. induction l as [|?? IHl]; [done|]. intros [|i]; [done|]. apply (IHl i). Qed. Lemma list_lookup_total_alter `{!Inhabited A} f l i : i < length l → alter f i l !!! i = f (l !!! i). Proof. intros [x Hx]%lookup_lt_is_Some_2. by rewrite !list_lookup_total_alt, list_lookup_alter, Hx. Qed. Lemma list_lookup_alter_ne f l i j : i ≠ j → alter f i l !! j = l !! j. Proof. revert i j. induction l; [done|]. intros [] []; naive_solver. Qed. Lemma list_lookup_total_alter_ne `{!Inhabited A} f l i j : i ≠ j → alter f i l !!! j = l !!! j. Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_alter_ne. Qed. Lemma list_lookup_insert l i x : i < length l → <[i:=x]>l !! i = Some x. Proof. revert i. induction l; intros [|?] ?; f_equal/=; auto with lia. Qed. Lemma list_lookup_total_insert `{!Inhabited A} l i x : i < length l → <[i:=x]>l !!! i = x. Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_insert. Qed. Lemma list_lookup_insert_ne l i j x : i ≠ j → <[i:=x]>l !! j = l !! j. Proof. revert i j. induction l; [done|]. intros [] []; naive_solver. Qed. Lemma list_lookup_total_insert_ne `{!Inhabited A} l i j x : i ≠ j → <[i:=x]>l !!! j = l !!! j. Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_insert_ne. Qed. Lemma list_lookup_insert_Some l i x j y : <[i:=x]>l !! j = Some y ↔ i = j ∧ x = y ∧ j < length l ∨ i ≠ j ∧ l !! j = Some y. Proof. destruct (decide (i = j)) as [->|]; [split|rewrite list_lookup_insert_ne by done; tauto]. - intros Hy. assert (j < length l). { rewrite <-(insert_length l j x); eauto using lookup_lt_Some. } rewrite list_lookup_insert in Hy by done; naive_solver. - intros [(?&?&?)|[??]]; rewrite ?list_lookup_insert; naive_solver. Qed. Lemma list_insert_commute l i j x y : i ≠ j → <[i:=x]>(<[j:=y]>l) = <[j:=y]>(<[i:=x]>l). Proof. revert i j. by induction l; intros [|?] [|?] ?; f_equal/=; auto. Qed. Lemma list_insert_id' l i x : (i < length l → l !! i = Some x) → <[i:=x]>l = l. Proof. revert i. induction l; intros [|i] ?; f_equal/=; naive_solver lia. Qed. Lemma list_insert_id l i x : l !! i = Some x → <[i:=x]>l = l. Proof. intros ?. by apply list_insert_id'. Qed. Lemma list_insert_ge l i x : length l ≤ i → <[i:=x]>l = l. Proof. revert i. induction l; intros [|i] ?; f_equal/=; auto with lia. Qed. Lemma list_insert_insert l i x y : <[i:=x]> (<[i:=y]> l) = <[i:=x]> l. Proof. revert i. induction l; intros [|i]; f_equal/=; auto. Qed. Lemma list_lookup_other l i x : length l ≠ 1 → l !! i = Some x → ∃ j y, j ≠ i ∧ l !! j = Some y. Proof. intros. destruct i, l as [|x0 [|x1 l]]; simplify_eq/=. - by exists 1, x1. - by exists 0, x0. Qed. Lemma alter_app_l f l1 l2 i : i < length l1 → alter f i (l1 ++ l2) = alter f i l1 ++ l2. Proof. revert i. induction l1; intros [|?] ?; f_equal/=; auto with lia. Qed. Lemma alter_app_r f l1 l2 i : alter f (length l1 + i) (l1 ++ l2) = l1 ++ alter f i l2. Proof. revert i. induction l1; intros [|?]; f_equal/=; auto. Qed. Lemma alter_app_r_alt f l1 l2 i : length l1 ≤ i → alter f i (l1 ++ l2) = l1 ++ alter f (i - length l1) l2. Proof. intros. assert (i = length l1 + (i - length l1)) as Hi by lia. rewrite Hi at 1. by apply alter_app_r. Qed. Lemma list_alter_id f l i : (∀ x, f x = x) → alter f i l = l. Proof. intros ?. revert i. induction l; intros [|?]; f_equal/=; auto. Qed. Lemma list_alter_ext f g l k i : (∀ x, l !! i = Some x → f x = g x) → l = k → alter f i l = alter g i k. Proof. intros H ->. revert i H. induction k; intros [|?] ?; f_equal/=; auto. Qed. Lemma list_alter_compose f g l i : alter (f ∘ g) i l = alter f i (alter g i l). Proof. revert i. induction l; intros [|?]; f_equal/=; auto. Qed. Lemma list_alter_commute f g l i j : i ≠ j → alter f i (alter g j l) = alter g j (alter f i l). Proof. revert i j. induction l; intros [|?][|?] ?; f_equal/=; auto with lia. Qed. Lemma insert_app_l l1 l2 i x : i < length l1 → <[i:=x]>(l1 ++ l2) = <[i:=x]>l1 ++ l2. Proof. revert i. induction l1; intros [|?] ?; f_equal/=; auto with lia. Qed. Lemma insert_app_r l1 l2 i x : <[length l1+i:=x]>(l1 ++ l2) = l1 ++ <[i:=x]>l2. Proof. revert i. induction l1; intros [|?]; f_equal/=; auto. Qed. Lemma insert_app_r_alt l1 l2 i x : length l1 ≤ i → <[i:=x]>(l1 ++ l2) = l1 ++ <[i - length l1:=x]>l2. Proof. intros. assert (i = length l1 + (i - length l1)) as Hi by lia. rewrite Hi at 1. by apply insert_app_r. Qed. Lemma delete_middle l1 l2 x : delete (length l1) (l1 ++ x :: l2) = l1 ++ l2. Proof. induction l1; f_equal/=; auto. Qed. Lemma length_delete l i : is_Some (l !! i) → length (delete i l) = length l - 1. Proof. rewrite lookup_lt_is_Some. revert i. induction l as [|x l IH]; intros [|i] ?; simpl in *; [lia..|]. rewrite IH by lia. lia. Qed. Lemma lookup_delete_lt l i j : j < i → delete i l !! j = l !! j. Proof. revert i j; induction l; intros [] []; naive_solver eauto with lia. Qed. Lemma lookup_total_delete_lt `{!Inhabited A} l i j : j < i → delete i l !!! j = l !!! j. Proof. intros. by rewrite !list_lookup_total_alt, lookup_delete_lt. Qed. Lemma lookup_delete_ge l i j : i ≤ j → delete i l !! j = l !! S j. Proof. revert i j; induction l; intros [] []; naive_solver eauto with lia. Qed. Lemma lookup_total_delete_ge `{!Inhabited A} l i j : i ≤ j → delete i l !!! j = l !!! S j. Proof. intros. by rewrite !list_lookup_total_alt, lookup_delete_ge. Qed. Lemma inserts_length l i k : length (list_inserts i k l) = length l. Proof. revert i. induction k; intros ?; csimpl; rewrite ?insert_length; auto. Qed. Lemma list_lookup_inserts l i k j : i ≤ j < i + length k → j < length l → list_inserts i k l !! j = k !! (j - i). Proof. revert i j. induction k as [|y k IH]; csimpl; intros i j ??; [lia|]. destruct (decide (i = j)) as [->|]. { by rewrite list_lookup_insert, Nat.sub_diag by (rewrite inserts_length; lia). } rewrite list_lookup_insert_ne, IH by lia. by replace (j - i) with (S (j - S i)) by lia. Qed. Lemma list_lookup_total_inserts `{!Inhabited A} l i k j : i ≤ j < i + length k → j < length l → list_inserts i k l !!! j = k !!! (j - i). Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_inserts. Qed. Lemma list_lookup_inserts_lt l i k j : j < i → list_inserts i k l !! j = l !! j. Proof. revert i j. induction k; intros i j ?; csimpl; rewrite ?list_lookup_insert_ne by lia; auto with lia. Qed. Lemma list_lookup_total_inserts_lt `{!Inhabited A}l i k j : j < i → list_inserts i k l !!! j = l !!! j. Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_inserts_lt. Qed. Lemma list_lookup_inserts_ge l i k j : i + length k ≤ j → list_inserts i k l !! j = l !! j. Proof. revert i j. induction k; csimpl; intros i j ?; rewrite ?list_lookup_insert_ne by lia; auto with lia. Qed. Lemma list_lookup_total_inserts_ge `{!Inhabited A} l i k j : i + length k ≤ j → list_inserts i k l !!! j = l !!! j. Proof. intros. by rewrite !list_lookup_total_alt, list_lookup_inserts_ge. Qed. Lemma list_lookup_inserts_Some l i k j y : list_inserts i k l !! j = Some y ↔ (j < i ∨ i + length k ≤ j) ∧ l !! j = Some y ∨ i ≤ j < i + length k ∧ j < length l ∧ k !! (j - i) = Some y. Proof. destruct (decide (j < i)). { rewrite list_lookup_inserts_lt by done; intuition lia. } destruct (decide (i + length k ≤ j)). { rewrite list_lookup_inserts_ge by done; intuition lia. } split. - intros Hy. assert (j < length l). { rewrite <-(inserts_length l i k); eauto using lookup_lt_Some. } rewrite list_lookup_inserts in Hy by lia. intuition lia. - intuition. by rewrite list_lookup_inserts by lia. Qed. Lemma list_insert_inserts_lt l i j x k : i < j → <[i:=x]>(list_inserts j k l) = list_inserts j k (<[i:=x]>l). Proof. revert i j. induction k; intros i j ?; simpl; rewrite 1?list_insert_commute by lia; auto with f_equal. Qed. Lemma list_inserts_app_l l1 l2 l3 i : list_inserts i (l1 ++ l2) l3 = list_inserts (length l1 + i) l2 (list_inserts i l1 l3). Proof. revert i; induction l1 as [|x l1 IH]; [done|]. intro i. simpl. rewrite IH, Nat.add_succ_r. apply list_insert_inserts_lt. lia. Qed. Lemma list_inserts_app_r l1 l2 l3 i : list_inserts (length l2 + i) l1 (l2 ++ l3) = l2 ++ list_inserts i l1 l3. Proof. revert i; induction l1 as [|x l1 IH]; [done|]. intros i. simpl. by rewrite plus_n_Sm, IH, insert_app_r. Qed. Lemma list_inserts_nil l1 i : list_inserts i l1 [] = []. Proof. revert i; induction l1 as [|x l1 IH]; [done|]. intro i. simpl. by rewrite IH. Qed. Lemma list_inserts_cons l1 l2 i x : list_inserts (S i) l1 (x :: l2) = x :: list_inserts i l1 l2. Proof. revert i; induction l1 as [|y l1 IH]; [done|]. intro i. simpl. by rewrite IH. Qed. Lemma list_inserts_0_r l1 l2 l3 : length l1 = length l2 → list_inserts 0 l1 (l2 ++ l3) = l1 ++ l3. Proof. revert l2. induction l1 as [|x l1 IH]; intros [|y l2] ?; simplify_eq/=; [done|]. rewrite list_inserts_cons. simpl. by rewrite IH. Qed. Lemma list_inserts_0_l l1 l2 l3 : length l1 = length l3 → list_inserts 0 (l1 ++ l2) l3 = l1. Proof. revert l3. induction l1 as [|x l1 IH]; intros [|z l3] ?; simplify_eq/=. { by rewrite list_inserts_nil. } rewrite list_inserts_cons. simpl. by rewrite IH. Qed. (** ** Properties of the [reverse] function *) Lemma reverse_nil : reverse [] =@{list A} []. Proof. done. Qed. Lemma reverse_singleton x : reverse [x] = [x]. Proof. done. Qed. Lemma reverse_cons l x : reverse (x :: l) = reverse l ++ [x]. Proof. unfold reverse. by rewrite <-!rev_alt. Qed. Lemma reverse_snoc l x : reverse (l ++ [x]) = x :: reverse l. Proof. unfold reverse. by rewrite <-!rev_alt, rev_unit. Qed. Lemma reverse_app l1 l2 : reverse (l1 ++ l2) = reverse l2 ++ reverse l1. Proof. unfold reverse. rewrite <-!rev_alt. apply rev_app_distr. Qed. Lemma reverse_length l : length (reverse l) = length l. Proof. unfold reverse. rewrite <-!rev_alt. apply rev_length. Qed. Lemma reverse_involutive l : reverse (reverse l) = l. Proof. unfold reverse. rewrite <-!rev_alt. apply rev_involutive. Qed. Lemma reverse_lookup l i : i < length l → reverse l !! i = l !! (length l - S i). Proof. revert i. induction l as [|x l IH]; simpl; intros i Hi; [done|]. rewrite reverse_cons. destruct (decide (i = length l)); subst. + by rewrite list_lookup_middle, Nat.sub_diag by by rewrite reverse_length. + rewrite lookup_app_l by (rewrite reverse_length; lia). rewrite IH by lia. by assert (length l - i = S (length l - S i)) as -> by lia. Qed. Lemma reverse_lookup_Some l i x : reverse l !! i = Some x ↔ l !! (length l - S i) = Some x ∧ i < length l. Proof. split. - destruct (decide (i < length l)); [ by rewrite reverse_lookup|]. rewrite lookup_ge_None_2; [done|]. rewrite reverse_length. lia. - intros [??]. by rewrite reverse_lookup. Qed. Global Instance: Inj (=) (=) (@reverse A). Proof. intros l1 l2 Hl. by rewrite <-(reverse_involutive l1), <-(reverse_involutive l2), Hl. Qed. (** ** Properties of the [elem_of] predicate *) Lemma not_elem_of_nil x : x ∉ []. Proof. by inversion 1. Qed. Lemma elem_of_nil x : x ∈ [] ↔ False. Proof. intuition. by destruct (not_elem_of_nil x). Qed. Lemma elem_of_nil_inv l : (∀ x, x ∉ l) → l = []. Proof. destruct l; [done|]. by edestruct 1; constructor. Qed. Lemma elem_of_not_nil x l : x ∈ l → l ≠ []. Proof. intros ? ->. by apply (elem_of_nil x). Qed. Lemma elem_of_cons l x y : x ∈ y :: l ↔ x = y ∨ x ∈ l. Proof. by split; [inversion 1; subst|intros [->|?]]; constructor. Qed. Lemma not_elem_of_cons l x y : x ∉ y :: l ↔ x ≠ y ∧ x ∉ l. Proof. rewrite elem_of_cons. tauto. Qed. Lemma elem_of_app l1 l2 x : x ∈ l1 ++ l2 ↔ x ∈ l1 ∨ x ∈ l2. Proof. induction l1 as [|y l1 IH]; simpl. - rewrite elem_of_nil. naive_solver. - rewrite !elem_of_cons, IH. naive_solver. Qed. Lemma not_elem_of_app l1 l2 x : x ∉ l1 ++ l2 ↔ x ∉ l1 ∧ x ∉ l2. Proof. rewrite elem_of_app. tauto. Qed. Lemma elem_of_list_singleton x y : x ∈ [y] ↔ x = y. Proof. rewrite elem_of_cons, elem_of_nil. tauto. Qed. Lemma elem_of_reverse_2 x l : x ∈ l → x ∈ reverse l. Proof. induction 1; rewrite reverse_cons, elem_of_app, ?elem_of_list_singleton; intuition. Qed. Lemma elem_of_reverse x l : x ∈ reverse l ↔ x ∈ l. Proof. split; auto using elem_of_reverse_2. intros. rewrite <-(reverse_involutive l). by apply elem_of_reverse_2. Qed. Lemma elem_of_list_lookup_1 l x : x ∈ l → ∃ i, l !! i = Some x. Proof. induction 1 as [|???? IH]; [by exists 0 |]. destruct IH as [i ?]; auto. by exists (S i). Qed. Lemma elem_of_list_lookup_total_1 `{!Inhabited A} l x : x ∈ l → ∃ i, i < length l ∧ l !!! i = x. Proof. intros [i Hi]%elem_of_list_lookup_1. eauto using lookup_lt_Some, list_lookup_total_correct. Qed. Lemma elem_of_list_lookup_2 l i x : l !! i = Some x → x ∈ l. Proof. revert i. induction l; intros [|i] ?; simplify_eq/=; constructor; eauto. Qed. Lemma elem_of_list_lookup_total_2 `{!Inhabited A} l i : i < length l → l !!! i ∈ l. Proof. intros. by eapply elem_of_list_lookup_2, list_lookup_lookup_total_lt. Qed. Lemma elem_of_list_lookup l x : x ∈ l ↔ ∃ i, l !! i = Some x. Proof. firstorder eauto using elem_of_list_lookup_1, elem_of_list_lookup_2. Qed. Lemma elem_of_list_lookup_total `{!Inhabited A} l x : x ∈ l ↔ ∃ i, i < length l ∧ l !!! i = x. Proof. naive_solver eauto using elem_of_list_lookup_total_1, elem_of_list_lookup_total_2. Qed. Lemma elem_of_list_split_length l i x : l !! i = Some x → ∃ l1 l2, l = l1 ++ x :: l2 ∧ i = length l1. Proof. revert i; induction l as [|y l IH]; intros [|i] Hl; simplify_eq/=. - exists []; eauto. - destruct (IH _ Hl) as (?&?&?&?); simplify_eq/=. eexists (y :: _); eauto. Qed. Lemma elem_of_list_split l x : x ∈ l → ∃ l1 l2, l = l1 ++ x :: l2. Proof. intros [? (?&?&?&_)%elem_of_list_split_length]%elem_of_list_lookup_1; eauto. Qed. Lemma elem_of_list_split_l `{EqDecision A} l x : x ∈ l → ∃ l1 l2, l = l1 ++ x :: l2 ∧ x ∉ l1. Proof. induction 1 as [x l|x y l ? IH]. { exists [], l. rewrite elem_of_nil. naive_solver. } destruct (decide (x = y)) as [->|?]. - exists [], l. rewrite elem_of_nil. naive_solver. - destruct IH as (l1 & l2 & -> & ?). exists (y :: l1), l2. rewrite elem_of_cons. naive_solver. Qed. Lemma elem_of_list_split_r `{EqDecision A} l x : x ∈ l → ∃ l1 l2, l = l1 ++ x :: l2 ∧ x ∉ l2. Proof. induction l as [|y l IH] using rev_ind. { by rewrite elem_of_nil. } destruct (decide (x = y)) as [->|]. - exists l, []. rewrite elem_of_nil. naive_solver. - rewrite elem_of_app, elem_of_list_singleton. intros [?| ->]; try done. destruct IH as (l1 & l2 & -> & ?); auto. exists l1, (l2 ++ [y]). rewrite elem_of_app, elem_of_list_singleton, <-(assoc_L (++)). naive_solver. Qed. Lemma list_elem_of_insert l i x : i < length l → x ∈ <[i:=x]>l. Proof. intros. by eapply elem_of_list_lookup_2, list_lookup_insert. Qed. Lemma nth_elem_of l i d : i < length l → nth i l d ∈ l. Proof. intros; eapply elem_of_list_lookup_2. destruct (nth_lookup_or_length l i d); [done | by lia]. Qed. Lemma not_elem_of_app_cons_inv_l x y l1 l2 k1 k2 : x ∉ k1 → y ∉ l1 → l1 ++ x :: l2 = k1 ++ y :: k2 → l1 = k1 ∧ x = y ∧ l2 = k2. Proof. revert k1. induction l1 as [|x' l1 IH]; intros [|y' k1] Hx Hy ?; simplify_eq/=; try apply not_elem_of_cons in Hx as [??]; try apply not_elem_of_cons in Hy as [??]; naive_solver. Qed. Lemma not_elem_of_app_cons_inv_r x y l1 l2 k1 k2 : x ∉ k2 → y ∉ l2 → l1 ++ x :: l2 = k1 ++ y :: k2 → l1 = k1 ∧ x = y ∧ l2 = k2. Proof. intros. destruct (not_elem_of_app_cons_inv_l x y (reverse l2) (reverse l1) (reverse k2) (reverse k1)); [..|naive_solver]. - by rewrite elem_of_reverse. - by rewrite elem_of_reverse. - rewrite <-!reverse_snoc, <-!reverse_app, <-!(assoc_L (++)). by f_equal. Qed. (** ** Properties of the [NoDup] predicate *) Lemma NoDup_nil : NoDup (@nil A) ↔ True. Proof. split; constructor. Qed. Lemma NoDup_cons x l : NoDup (x :: l) ↔ x ∉ l ∧ NoDup l. Proof. split; [by inversion 1|]. intros [??]. by constructor. Qed. Lemma NoDup_cons_1_1 x l : NoDup (x :: l) → x ∉ l. Proof. rewrite NoDup_cons. by intros [??]. Qed. Lemma NoDup_cons_1_2 x l : NoDup (x :: l) → NoDup l. Proof. rewrite NoDup_cons. by intros [??]. Qed. Lemma NoDup_singleton x : NoDup [x]. Proof. constructor; [apply not_elem_of_nil | constructor]. Qed. Lemma NoDup_app l k : NoDup (l ++ k) ↔ NoDup l ∧ (∀ x, x ∈ l → x ∉ k) ∧ NoDup k. Proof. induction l; simpl. - rewrite NoDup_nil. setoid_rewrite elem_of_nil. naive_solver. - rewrite !NoDup_cons. setoid_rewrite elem_of_cons. setoid_rewrite elem_of_app. naive_solver. Qed. Lemma NoDup_lookup l i j x : NoDup l → l !! i = Some x → l !! j = Some x → i = j. Proof. intros Hl. revert i j. induction Hl as [|x' l Hx Hl IH]. { intros; simplify_eq. } intros [|i] [|j] ??; simplify_eq/=; eauto with f_equal; exfalso; eauto using elem_of_list_lookup_2. Qed. Lemma NoDup_alt l : NoDup l ↔ ∀ i j x, l !! i = Some x → l !! j = Some x → i = j. Proof. split; eauto using NoDup_lookup. induction l as [|x l IH]; intros Hl; constructor. - rewrite elem_of_list_lookup. intros [i ?]. opose proof* (Hl (S i) 0); by auto. - apply IH. intros i j x' ??. by apply (inj S), (Hl (S i) (S j) x'). Qed. Section no_dup_dec. Context `{!EqDecision A}. Global Instance NoDup_dec: ∀ l, Decision (NoDup l) := fix NoDup_dec l := match l return Decision (NoDup l) with | [] => left NoDup_nil_2 | x :: l => match decide_rel (∈) x l with | left Hin => right (λ H, NoDup_cons_1_1 _ _ H Hin) | right Hin => match NoDup_dec l with | left H => left (NoDup_cons_2 _ _ Hin H) | right H => right (H ∘ NoDup_cons_1_2 _ _) end end end. Lemma elem_of_remove_dups l x : x ∈ remove_dups l ↔ x ∈ l. Proof. split; induction l; simpl; repeat case_decide; rewrite ?elem_of_cons; intuition (simplify_eq; auto). Qed. Lemma NoDup_remove_dups l : NoDup (remove_dups l). Proof. induction l; simpl; repeat case_decide; try constructor; auto. by rewrite elem_of_remove_dups. Qed. End no_dup_dec. (** ** Set operations on lists *) Section list_set. Lemma elem_of_list_intersection_with f l k x : x ∈ list_intersection_with f l k ↔ ∃ x1 x2, x1 ∈ l ∧ x2 ∈ k ∧ f x1 x2 = Some x. Proof. split. - induction l as [|x1 l IH]; simpl; [by rewrite elem_of_nil|]. intros Hx. setoid_rewrite elem_of_cons. cut ((∃ x2, x2 ∈ k ∧ f x1 x2 = Some x) ∨ x ∈ list_intersection_with f l k); [naive_solver|]. clear IH. revert Hx. generalize (list_intersection_with f l k). induction k; simpl; [by auto|]. case_match; setoid_rewrite elem_of_cons; naive_solver. - intros (x1&x2&Hx1&Hx2&Hx). induction Hx1 as [x1 l|x1 ? l ? IH]; simpl. + generalize (list_intersection_with f l k). induction Hx2; simpl; [by rewrite Hx; left |]. case_match; simpl; try setoid_rewrite elem_of_cons; auto. + generalize (IH Hx). clear Hx IH Hx2. generalize (list_intersection_with f l k). induction k; simpl; intros; [done|]. case_match; simpl; rewrite ?elem_of_cons; auto. Qed. Context `{!EqDecision A}. Lemma elem_of_list_difference l k x : x ∈ list_difference l k ↔ x ∈ l ∧ x ∉ k. Proof. split; induction l; simpl; try case_decide; rewrite ?elem_of_nil, ?elem_of_cons; intuition congruence. Qed. Lemma NoDup_list_difference l k : NoDup l → NoDup (list_difference l k). Proof. induction 1; simpl; try case_decide. - constructor. - done. - constructor; [|done]. rewrite elem_of_list_difference; intuition. Qed. Lemma elem_of_list_union l k x : x ∈ list_union l k ↔ x ∈ l ∨ x ∈ k. Proof. unfold list_union. rewrite elem_of_app, elem_of_list_difference. intuition. case (decide (x ∈ k)); intuition. Qed. Lemma NoDup_list_union l k : NoDup l → NoDup k → NoDup (list_union l k). Proof. intros. apply NoDup_app. repeat split. - by apply NoDup_list_difference. - intro. rewrite elem_of_list_difference. intuition. - done. Qed. Lemma elem_of_list_intersection l k x : x ∈ list_intersection l k ↔ x ∈ l ∧ x ∈ k. Proof. split; induction l; simpl; repeat case_decide; rewrite ?elem_of_nil, ?elem_of_cons; intuition congruence. Qed. Lemma NoDup_list_intersection l k : NoDup l → NoDup (list_intersection l k). Proof. induction 1; simpl; try case_decide. - constructor. - constructor; [|done]. rewrite elem_of_list_intersection; intuition. - done. Qed. End list_set. (** ** Properties of the [last] function *) Lemma last_nil : last [] =@{option A} None. Proof. done. Qed. Lemma last_singleton x : last [x] = Some x. Proof. done. Qed. Lemma last_cons_cons x1 x2 l : last (x1 :: x2 :: l) = last (x2 :: l). Proof. done. Qed. Lemma last_app_cons l1 l2 x : last (l1 ++ x :: l2) = last (x :: l2). Proof. induction l1 as [|y [|y' l1] IHl]; done. Qed. Lemma last_snoc x l : last (l ++ [x]) = Some x. Proof. induction l as [|? []]; simpl; auto. Qed. Lemma last_None l : last l = None ↔ l = []. Proof. split; [|by intros ->]. induction l as [|x1 [|x2 l] IH]; naive_solver. Qed. Lemma last_Some l x : last l = Some x ↔ ∃ l', l = l' ++ [x]. Proof. split. - destruct l as [|x' l'] using rev_ind; [done|]. rewrite last_snoc. naive_solver. - intros [l' ->]. by rewrite last_snoc. Qed. Lemma last_is_Some l : is_Some (last l) ↔ l ≠ []. Proof. rewrite <-not_eq_None_Some, last_None. naive_solver. Qed. Lemma last_app l1 l2 : last (l1 ++ l2) = match last l2 with Some y => Some y | None => last l1 end. Proof. destruct l2 as [|x l2 _] using rev_ind. - by rewrite (right_id_L _ (++)). - by rewrite (assoc_L (++)), !last_snoc. Qed. Lemma last_cons x l : last (x :: l) = match last l with Some y => Some y | None => Some x end. Proof. by apply (last_app [x]). Qed. Lemma last_cons_Some_ne x y l : x ≠ y → last (x :: l) = Some y → last l = Some y. Proof. rewrite last_cons. destruct (last l); naive_solver. Qed. Lemma last_lookup l : last l = l !! pred (length l). Proof. by induction l as [| ?[]]. Qed. Lemma last_reverse l : last (reverse l) = head l. Proof. destruct l as [|x l]; simpl; by rewrite ?reverse_cons, ?last_snoc. Qed. Lemma last_Some_elem_of l x : last l = Some x → x ∈ l. Proof. rewrite last_Some. intros [l' ->]. apply elem_of_app. right. by apply elem_of_list_singleton. Qed. (** ** Properties of the [head] function *) Lemma head_nil : head [] =@{option A} None. Proof. done. Qed. Lemma head_cons x l : head (x :: l) = Some x. Proof. done. Qed. Lemma head_None l : head l = None ↔ l = []. Proof. split; [|by intros ->]. by destruct l. Qed. Lemma head_Some l x : head l = Some x ↔ ∃ l', l = x :: l'. Proof. split; [destruct l as [|x' l]; naive_solver | by intros [l' ->]]. Qed. Lemma head_is_Some l : is_Some (head l) ↔ l ≠ []. Proof. rewrite <-not_eq_None_Some, head_None. naive_solver. Qed. Lemma head_snoc x l : head (l ++ [x]) = match head l with Some y => Some y | None => Some x end. Proof. by destruct l. Qed. Lemma head_snoc_snoc x1 x2 l : head (l ++ [x1; x2]) = head (l ++ [x1]). Proof. by destruct l. Qed. Lemma head_lookup l : head l = l !! 0. Proof. by destruct l. Qed. Lemma head_reverse l : head (reverse l) = last l. Proof. by rewrite <-last_reverse, reverse_involutive. Qed. Lemma head_Some_elem_of l x : head l = Some x → x ∈ l. Proof. rewrite head_Some. intros [l' ->]. left. Qed. (** ** Properties of the [take] function *) Definition take_drop i l : take i l ++ drop i l = l := firstn_skipn i l. Lemma take_drop_middle l i x : l !! i = Some x → take i l ++ x :: drop (S i) l = l. Proof. revert i x. induction l; intros [|?] ??; simplify_eq/=; f_equal; auto. Qed. Lemma take_0 l : take 0 l = []. Proof. reflexivity. Qed. Lemma take_nil n : take n [] =@{list A} []. Proof. by destruct n. Qed. Lemma take_S_r l n x : l !! n = Some x → take (S n) l = take n l ++ [x]. Proof. revert n. induction l; intros []; naive_solver eauto with f_equal. Qed. Lemma take_ge l n : length l ≤ n → take n l = l. Proof. revert n. induction l; intros [|?] ?; f_equal/=; auto with lia. Qed. (** [take_app] is the most general lemma for [take] and [app]. Below that we establish a number of useful corollaries. *) Lemma take_app l k n : take n (l ++ k) = take n l ++ take (n - length l) k. Proof. apply firstn_app. Qed. Lemma take_app_ge l k n : length l ≤ n → take n (l ++ k) = l ++ take (n - length l) k. Proof. intros. by rewrite take_app, take_ge. Qed. Lemma take_app_le l k n : n ≤ length l → take n (l ++ k) = take n l. Proof. intros. by rewrite take_app, (proj2 (Nat.sub_0_le _ _)), take_0, (right_id _ _). Qed. Lemma take_app_add l k m : take (length l + m) (l ++ k) = l ++ take m k. Proof. rewrite take_app, take_ge by lia. repeat f_equal; lia. Qed. Lemma take_app_add' l k n m : n = length l → take (n + m) (l ++ k) = l ++ take m k. Proof. intros ->. apply take_app_add. Qed. Lemma take_app_length l k : take (length l) (l ++ k) = l. Proof. by rewrite take_app, take_ge, Nat.sub_diag, take_0, (right_id _ _). Qed. Lemma take_app_length' l k n : n = length l → take n (l ++ k) = l. Proof. intros ->. by apply take_app_length. Qed. Lemma take_app3_length l1 l2 l3 : take (length l1) ((l1 ++ l2) ++ l3) = l1. Proof. by rewrite <-(assoc_L (++)), take_app_length. Qed. Lemma take_app3_length' l1 l2 l3 n : n = length l1 → take n ((l1 ++ l2) ++ l3) = l1. Proof. intros ->. by apply take_app3_length. Qed. Lemma take_take l n m : take n (take m l) = take (min n m) l. Proof. revert n m. induction l; intros [|?] [|?]; f_equal/=; auto. Qed. Lemma take_idemp l n : take n (take n l) = take n l. Proof. by rewrite take_take, Nat.min_id. Qed. Lemma take_length l n : length (take n l) = min n (length l). Proof. revert n. induction l; intros [|?]; f_equal/=; done. Qed. Lemma take_length_le l n : n ≤ length l → length (take n l) = n. Proof. rewrite take_length. apply Nat.min_l. Qed. Lemma take_length_ge l n : length l ≤ n → length (take n l) = length l. Proof. rewrite take_length. apply Nat.min_r. Qed. Lemma take_drop_commute l n m : take n (drop m l) = drop m (take (m + n) l). Proof. revert n m. induction l; intros [|?][|?]; simpl; auto using take_nil with lia. Qed. Lemma lookup_take l n i : i < n → take n l !! i = l !! i. Proof. revert n i. induction l; intros [|n] [|i] ?; simpl; auto with lia. Qed. Lemma lookup_total_take `{!Inhabited A} l n i : i < n → take n l !!! i = l !!! i. Proof. intros. by rewrite !list_lookup_total_alt, lookup_take. Qed. Lemma lookup_take_ge l n i : n ≤ i → take n l !! i = None. Proof. revert n i. induction l; intros [|?] [|?] ?; simpl; auto with lia. Qed. Lemma lookup_total_take_ge `{!Inhabited A} l n i : n ≤ i → take n l !!! i = inhabitant. Proof. intros. by rewrite list_lookup_total_alt, lookup_take_ge. Qed. Lemma lookup_take_Some l n i a : take n l !! i = Some a ↔ l !! i = Some a ∧ i < n. Proof. split. - destruct (decide (i < n)). + rewrite lookup_take; naive_solver. + rewrite lookup_take_ge; [done|lia]. - intros [??]. by rewrite lookup_take. Qed. Lemma elem_of_take x n l : x ∈ take n l ↔ ∃ i, l !! i = Some x ∧ i < n. Proof. rewrite elem_of_list_lookup. setoid_rewrite lookup_take_Some. naive_solver. Qed. Lemma take_alter f l n i : n ≤ i → take n (alter f i l) = take n l. Proof. intros. apply list_eq. intros j. destruct (le_lt_dec n j). - by rewrite !lookup_take_ge. - by rewrite !lookup_take, !list_lookup_alter_ne by lia. Qed. Lemma take_insert l n i x : n ≤ i → take n (<[i:=x]>l) = take n l. Proof. intros. apply list_eq. intros j. destruct (le_lt_dec n j). - by rewrite !lookup_take_ge. - by rewrite !lookup_take, !list_lookup_insert_ne by lia. Qed. Lemma take_insert_lt l n i x : i < n → take n (<[i:=x]>l) = <[i:=x]>(take n l). Proof. revert l i. induction n as [|? IHn]; auto; simpl. intros [|] [|] ?; auto; simpl. by rewrite IHn by lia. Qed. (** ** Properties of the [drop] function *) Lemma drop_0 l : drop 0 l = l. Proof. done. Qed. Lemma drop_nil n : drop n [] =@{list A} []. Proof. by destruct n. Qed. Lemma drop_S l x n : l !! n = Some x → drop n l = x :: drop (S n) l. Proof. revert n. induction l; intros []; naive_solver. Qed. Lemma drop_length l n : length (drop n l) = length l - n. Proof. revert n. by induction l; intros [|i]; f_equal/=. Qed. Lemma drop_ge l n : length l ≤ n → drop n l = []. Proof. revert n. induction l; intros [|?]; simpl in *; auto with lia. Qed. Lemma drop_all l : drop (length l) l = []. Proof. by apply drop_ge. Qed. Lemma drop_drop l n1 n2 : drop n1 (drop n2 l) = drop (n2 + n1) l. Proof. revert n2. induction l; intros [|?]; simpl; rewrite ?drop_nil; auto. Qed. (** [drop_app] is the most general lemma for [drop] and [app]. Below we prove a number of useful corollaries. *) Lemma drop_app l k n : drop n (l ++ k) = drop n l ++ drop (n - length l) k. Proof. apply skipn_app. Qed. Lemma drop_app_ge l k n : length l ≤ n → drop n (l ++ k) = drop (n - length l) k. Proof. intros. by rewrite drop_app, drop_ge. Qed. Lemma drop_app_le l k n : n ≤ length l → drop n (l ++ k) = drop n l ++ k. Proof. intros. by rewrite drop_app, (proj2 (Nat.sub_0_le _ _)), drop_0. Qed. Lemma drop_app_add l k m : drop (length l + m) (l ++ k) = drop m k. Proof. rewrite drop_app, drop_ge by lia. simpl. f_equal; lia. Qed. Lemma drop_app_add' l k n m : n = length l → drop (n + m) (l ++ k) = drop m k. Proof. intros ->. apply drop_app_add. Qed. Lemma drop_app_length l k : drop (length l) (l ++ k) = k. Proof. by rewrite drop_app_le, drop_all. Qed. Lemma drop_app_length' l k n : n = length l → drop n (l ++ k) = k. Proof. intros ->. by apply drop_app_length. Qed. Lemma drop_app3_length l1 l2 l3 : drop (length l1) ((l1 ++ l2) ++ l3) = l2 ++ l3. Proof. by rewrite <-(assoc_L (++)), drop_app_length. Qed. Lemma drop_app3_length' l1 l2 l3 n : n = length l1 → drop n ((l1 ++ l2) ++ l3) = l2 ++ l3. Proof. intros ->. apply drop_app3_length. Qed. Lemma lookup_drop l n i : drop n l !! i = l !! (n + i). Proof. revert n i. induction l; intros [|i] ?; simpl; auto. Qed. Lemma lookup_total_drop `{!Inhabited A} l n i : drop n l !!! i = l !!! (n + i). Proof. by rewrite !list_lookup_total_alt, lookup_drop. Qed. Lemma drop_alter f l n i : i < n → drop n (alter f i l) = drop n l. Proof. intros. apply list_eq. intros j. by rewrite !lookup_drop, !list_lookup_alter_ne by lia. Qed. Lemma drop_insert_le l n i x : n ≤ i → drop n (<[i:=x]>l) = <[i-n:=x]>(drop n l). Proof. revert i n. induction l; intros [] []; naive_solver lia. Qed. Lemma drop_insert_gt l n i x : i < n → drop n (<[i:=x]>l) = drop n l. Proof. intros. apply list_eq. intros j. by rewrite !lookup_drop, !list_lookup_insert_ne by lia. Qed. Lemma delete_take_drop l i : delete i l = take i l ++ drop (S i) l. Proof. revert i. induction l; intros [|?]; f_equal/=; auto. Qed. Lemma take_take_drop l n m : take n l ++ take m (drop n l) = take (n + m) l. Proof. revert n m. induction l; intros [|?] [|?]; f_equal/=; auto. Qed. Lemma drop_take_drop l n m : n ≤ m → drop n (take m l) ++ drop m l = drop n l. Proof. revert n m. induction l; intros [|?] [|?] ?; f_equal/=; auto using take_drop with lia. Qed. Lemma insert_take_drop l i x : i < length l → <[i:=x]> l = take i l ++ x :: drop (S i) l. Proof. intros Hi. rewrite <-(take_drop_middle (<[i:=x]> l) i x). 2:{ by rewrite list_lookup_insert. } rewrite take_insert by done. rewrite drop_insert_gt by lia. done. Qed. (** ** Interaction between the [take]/[drop]/[reverse] functions *) Lemma take_reverse l n : take n (reverse l) = reverse (drop (length l - n) l). Proof. unfold reverse; rewrite <-!rev_alt. apply firstn_rev. Qed. Lemma drop_reverse l n : drop n (reverse l) = reverse (take (length l - n) l). Proof. unfold reverse; rewrite <-!rev_alt. apply skipn_rev. Qed. Lemma reverse_take l n : reverse (take n l) = drop (length l - n) (reverse l). Proof. rewrite drop_reverse. destruct (decide (n ≤ length l)). - repeat f_equal; lia. - by rewrite !take_ge by lia. Qed. Lemma reverse_drop l n : reverse (drop n l) = take (length l - n) (reverse l). Proof. rewrite take_reverse. destruct (decide (n ≤ length l)). - repeat f_equal; lia. - by rewrite !drop_ge by lia. Qed. (** ** Other lemmas that use [take]/[drop] in their proof. *) Lemma app_eq_inv l1 l2 k1 k2 : l1 ++ l2 = k1 ++ k2 → (∃ k, l1 = k1 ++ k ∧ k2 = k ++ l2) ∨ (∃ k, k1 = l1 ++ k ∧ l2 = k ++ k2). Proof. intros Hlk. destruct (decide (length l1 < length k1)). - right. rewrite <-(take_drop (length l1) k1), <-(assoc_L _) in Hlk. apply app_inj_1 in Hlk as [Hl1 Hl2]; [|rewrite take_length; lia]. exists (drop (length l1) k1). by rewrite Hl1 at 1; rewrite take_drop. - left. rewrite <-(take_drop (length k1) l1), <-(assoc_L _) in Hlk. apply app_inj_1 in Hlk as [Hk1 Hk2]; [|rewrite take_length; lia]. exists (drop (length k1) l1). by rewrite <-Hk1 at 1; rewrite take_drop. Qed. (** ** Properties of the [replicate] function *) Lemma replicate_length n x : length (replicate n x) = n. Proof. induction n; simpl; auto. Qed. Lemma lookup_replicate n x y i : replicate n x !! i = Some y ↔ y = x ∧ i < n. Proof. split. - revert i. induction n; intros [|?]; naive_solver auto with lia. - intros [-> Hi]. revert i Hi. induction n; intros [|?]; naive_solver auto with lia. Qed. Lemma elem_of_replicate n x y : y ∈ replicate n x ↔ y = x ∧ n ≠ 0. Proof. rewrite elem_of_list_lookup, Nat.neq_0_lt_0. setoid_rewrite lookup_replicate; naive_solver eauto with lia. Qed. Lemma lookup_replicate_1 n x y i : replicate n x !! i = Some y → y = x ∧ i < n. Proof. by rewrite lookup_replicate. Qed. Lemma lookup_replicate_2 n x i : i < n → replicate n x !! i = Some x. Proof. by rewrite lookup_replicate. Qed. Lemma lookup_total_replicate_2 `{!Inhabited A} n x i : i < n → replicate n x !!! i = x. Proof. intros. by rewrite list_lookup_total_alt, lookup_replicate_2. Qed. Lemma lookup_replicate_None n x i : n ≤ i ↔ replicate n x !! i = None. Proof. rewrite eq_None_not_Some, Nat.le_ngt. split. - intros Hin [x' Hx']; destruct Hin. rewrite lookup_replicate in Hx'; tauto. - intros Hx ?. destruct Hx. exists x; auto using lookup_replicate_2. Qed. Lemma insert_replicate x n i : <[i:=x]>(replicate n x) = replicate n x. Proof. revert i. induction n; intros [|?]; f_equal/=; auto. Qed. Lemma insert_replicate_lt x y n i : i < n → <[i:=y]>(replicate n x) = replicate i x ++ y :: replicate (n - S i) x. Proof. revert i. induction n as [|n IH]; intros [|i] Hi; simpl; [lia..| |]. - by rewrite Nat.sub_0_r. - by rewrite IH by lia. Qed. Lemma elem_of_replicate_inv x n y : x ∈ replicate n y → x = y. Proof. induction n; simpl; rewrite ?elem_of_nil, ?elem_of_cons; intuition. Qed. Lemma replicate_S n x : replicate (S n) x = x :: replicate n x. Proof. done. Qed. Lemma replicate_S_end n x : replicate (S n) x = replicate n x ++ [x]. Proof. induction n; f_equal/=; auto. Qed. Lemma replicate_add n m x : replicate (n + m) x = replicate n x ++ replicate m x. Proof. induction n; f_equal/=; auto. Qed. Lemma replicate_cons_app n x : x :: replicate n x = replicate n x ++ [x]. Proof. induction n; f_equal/=; eauto. Qed. Lemma take_replicate n m x : take n (replicate m x) = replicate (min n m) x. Proof. revert m. by induction n; intros [|?]; f_equal/=. Qed. Lemma take_replicate_add n m x : take n (replicate (n + m) x) = replicate n x. Proof. by rewrite take_replicate, min_l by lia. Qed. Lemma drop_replicate n m x : drop n (replicate m x) = replicate (m - n) x. Proof. revert m. by induction n; intros [|?]; f_equal/=. Qed. Lemma drop_replicate_add n m x : drop n (replicate (n + m) x) = replicate m x. Proof. rewrite drop_replicate. f_equal. lia. Qed. Lemma replicate_as_elem_of x n l : replicate n x = l ↔ length l = n ∧ ∀ y, y ∈ l → y = x. Proof. split; [intros <-; eauto using elem_of_replicate_inv, replicate_length|]. intros [<- Hl]. symmetry. induction l as [|y l IH]; f_equal/=. - apply Hl. by left. - apply IH. intros ??. apply Hl. by right. Qed. Lemma reverse_replicate n x : reverse (replicate n x) = replicate n x. Proof. symmetry. apply replicate_as_elem_of. rewrite reverse_length, replicate_length. split; auto. intros y. rewrite elem_of_reverse. by apply elem_of_replicate_inv. Qed. Lemma replicate_false βs n : length βs = n → replicate n false =.>* βs. Proof. intros <-. by induction βs; simpl; constructor. Qed. Lemma tail_replicate x n : tail (replicate n x) = replicate (pred n) x. Proof. by destruct n. Qed. Lemma head_replicate_Some x n : head (replicate n x) = Some x ↔ 0 < n. Proof. destruct n; naive_solver lia. Qed. (** ** Properties of the [resize] function *) Lemma resize_spec l n x : resize n x l = take n l ++ replicate (n - length l) x. Proof. revert n. induction l; intros [|?]; f_equal/=; auto. Qed. Lemma resize_0 l x : resize 0 x l = []. Proof. by destruct l. Qed. Lemma resize_nil n x : resize n x [] = replicate n x. Proof. rewrite resize_spec. rewrite take_nil. f_equal/=. lia. Qed. Lemma resize_ge l n x : length l ≤ n → resize n x l = l ++ replicate (n - length l) x. Proof. intros. by rewrite resize_spec, take_ge. Qed. Lemma resize_le l n x : n ≤ length l → resize n x l = take n l. Proof. intros. rewrite resize_spec, (proj2 (Nat.sub_0_le _ _)) by done. simpl. by rewrite (right_id_L [] (++)). Qed. Lemma resize_all l x : resize (length l) x l = l. Proof. intros. by rewrite resize_le, take_ge. Qed. Lemma resize_all_alt l n x : n = length l → resize n x l = l. Proof. intros ->. by rewrite resize_all. Qed. Lemma resize_add l n m x : resize (n + m) x l = resize n x l ++ resize m x (drop n l). Proof. revert n m. induction l; intros [|?] [|?]; f_equal/=; auto. - by rewrite Nat.add_0_r, (right_id_L [] (++)). - by rewrite replicate_add. Qed. Lemma resize_add_eq l n m x : length l = n → resize (n + m) x l = l ++ replicate m x. Proof. intros <-. by rewrite resize_add, resize_all, drop_all, resize_nil. Qed. Lemma resize_app_le l1 l2 n x : n ≤ length l1 → resize n x (l1 ++ l2) = resize n x l1. Proof. intros. by rewrite !resize_le, take_app_le by (rewrite ?app_length; lia). Qed. Lemma resize_app l1 l2 n x : n = length l1 → resize n x (l1 ++ l2) = l1. Proof. intros ->. by rewrite resize_app_le, resize_all. Qed. Lemma resize_app_ge l1 l2 n x : length l1 ≤ n → resize n x (l1 ++ l2) = l1 ++ resize (n - length l1) x l2. Proof. intros. rewrite !resize_spec, take_app_ge, (assoc_L (++)) by done. do 2 f_equal. rewrite app_length. lia. Qed. Lemma resize_length l n x : length (resize n x l) = n. Proof. rewrite resize_spec, app_length, replicate_length, take_length. lia. Qed. Lemma resize_replicate x n m : resize n x (replicate m x) = replicate n x. Proof. revert m. induction n; intros [|?]; f_equal/=; auto. Qed. Lemma resize_resize l n m x : n ≤ m → resize n x (resize m x l) = resize n x l. Proof. revert n m. induction l; simpl. - intros. by rewrite !resize_nil, resize_replicate. - intros [|?] [|?] ?; f_equal/=; auto with lia. Qed. Lemma resize_idemp l n x : resize n x (resize n x l) = resize n x l. Proof. by rewrite resize_resize. Qed. Lemma resize_take_le l n m x : n ≤ m → resize n x (take m l) = resize n x l. Proof. revert n m. induction l; intros [|?][|?] ?; f_equal/=; auto with lia. Qed. Lemma resize_take_eq l n x : resize n x (take n l) = resize n x l. Proof. by rewrite resize_take_le. Qed. Lemma take_resize l n m x : take n (resize m x l) = resize (min n m) x l. Proof. revert n m. induction l; intros [|?][|?]; f_equal/=; auto using take_replicate. Qed. Lemma take_resize_le l n m x : n ≤ m → take n (resize m x l) = resize n x l. Proof. intros. by rewrite take_resize, Nat.min_l. Qed. Lemma take_resize_eq l n x : take n (resize n x l) = resize n x l. Proof. intros. by rewrite take_resize, Nat.min_l. Qed. Lemma take_resize_add l n m x : take n (resize (n + m) x l) = resize n x l. Proof. by rewrite take_resize, min_l by lia. Qed. Lemma drop_resize_le l n m x : n ≤ m → drop n (resize m x l) = resize (m - n) x (drop n l). Proof. revert n m. induction l; simpl. - intros. by rewrite drop_nil, !resize_nil, drop_replicate. - intros [|?] [|?] ?; simpl; try case_match; auto with lia. Qed. Lemma drop_resize_add l n m x : drop n (resize (n + m) x l) = resize m x (drop n l). Proof. rewrite drop_resize_le by lia. f_equal. lia. Qed. Lemma lookup_resize l n x i : i < n → i < length l → resize n x l !! i = l !! i. Proof. intros ??. destruct (decide (n < length l)). - by rewrite resize_le, lookup_take by lia. - by rewrite resize_ge, lookup_app_l by lia. Qed. Lemma lookup_total_resize `{!Inhabited A} l n x i : i < n → i < length l → resize n x l !!! i = l !!! i. Proof. intros. by rewrite !list_lookup_total_alt, lookup_resize. Qed. Lemma lookup_resize_new l n x i : length l ≤ i → i < n → resize n x l !! i = Some x. Proof. intros ??. rewrite resize_ge by lia. replace i with (length l + (i - length l)) by lia. by rewrite lookup_app_r, lookup_replicate_2 by lia. Qed. Lemma lookup_total_resize_new `{!Inhabited A} l n x i : length l ≤ i → i < n → resize n x l !!! i = x. Proof. intros. by rewrite !list_lookup_total_alt, lookup_resize_new. Qed. Lemma lookup_resize_old l n x i : n ≤ i → resize n x l !! i = None. Proof. intros ?. apply lookup_ge_None_2. by rewrite resize_length. Qed. Lemma lookup_total_resize_old `{!Inhabited A} l n x i : n ≤ i → resize n x l !!! i = inhabitant. Proof. intros. by rewrite !list_lookup_total_alt, lookup_resize_old. Qed. (** ** Properties of the [rotate] function *) Lemma rotate_replicate n1 n2 x: rotate n1 (replicate n2 x) = replicate n2 x. Proof. unfold rotate. rewrite drop_replicate, take_replicate, <-replicate_add. f_equal. lia. Qed. Lemma rotate_length l n: length (rotate n l) = length l. Proof. unfold rotate. rewrite app_length, drop_length, take_length. lia. Qed. Lemma lookup_rotate_r l n i: i < length l → rotate n l !! i = l !! rotate_nat_add n i (length l). Proof. intros Hlen. pose proof (Nat.mod_upper_bound n (length l)) as ?. unfold rotate. rewrite rotate_nat_add_add_mod, rotate_nat_add_alt by lia. remember (n `mod` length l) as n'. case_decide. - by rewrite lookup_app_l, lookup_drop by (rewrite drop_length; lia). - rewrite lookup_app_r, lookup_take, drop_length by (rewrite drop_length; lia). f_equal. lia. Qed. Lemma lookup_rotate_r_Some l n i x: rotate n l !! i = Some x ↔ l !! rotate_nat_add n i (length l) = Some x ∧ i < length l. Proof. split. - intros Hl. pose proof (lookup_lt_Some _ _ _ Hl) as Hlen. rewrite rotate_length in Hlen. by rewrite <-lookup_rotate_r. - intros [??]. by rewrite lookup_rotate_r. Qed. Lemma lookup_rotate_l l n i: i < length l → rotate n l !! rotate_nat_sub n i (length l) = l !! i. Proof. intros ?. rewrite lookup_rotate_r, rotate_nat_add_sub;[done..|]. apply rotate_nat_sub_lt. lia. Qed. Lemma elem_of_rotate l n x: x ∈ rotate n l ↔ x ∈ l. Proof. unfold rotate. rewrite <-(take_drop (n `mod` length l) l) at 5. rewrite !elem_of_app. naive_solver. Qed. Lemma rotate_insert_l l n i x: i < length l → rotate n (<[rotate_nat_add n i (length l):=x]> l) = <[i:=x]> (rotate n l). Proof. intros Hlen. pose proof (Nat.mod_upper_bound n (length l)) as ?. unfold rotate. rewrite insert_length, rotate_nat_add_add_mod, rotate_nat_add_alt by lia. remember (n `mod` length l) as n'. case_decide. - rewrite take_insert, drop_insert_le, insert_app_l by (rewrite ?drop_length; lia). do 2 f_equal. lia. - rewrite take_insert_lt, drop_insert_gt, insert_app_r_alt, drop_length by (rewrite ?drop_length; lia). do 2 f_equal. lia. Qed. Lemma rotate_insert_r l n i x: i < length l → rotate n (<[i:=x]> l) = <[rotate_nat_sub n i (length l):=x]> (rotate n l). Proof. intros ?. rewrite <-rotate_insert_l, rotate_nat_add_sub;[done..|]. apply rotate_nat_sub_lt. lia. Qed. (** ** Properties of the [rotate_take] function *) Lemma rotate_take_insert l s e i x: i < length l → rotate_take s e (<[i:=x]>l) = if decide (rotate_nat_sub s i (length l) < rotate_nat_sub s e (length l)) then <[rotate_nat_sub s i (length l):=x]> (rotate_take s e l) else rotate_take s e l. Proof. intros ?. unfold rotate_take. rewrite rotate_insert_r, insert_length by done. case_decide; [rewrite take_insert_lt | rewrite take_insert]; naive_solver lia. Qed. Lemma rotate_take_add l b i : i < length l → rotate_take b (rotate_nat_add b i (length l)) l = take i (rotate b l). Proof. intros ?. unfold rotate_take. by rewrite rotate_nat_sub_add. Qed. (** ** Properties of the [reshape] function *) Lemma reshape_length szs l : length (reshape szs l) = length szs. Proof. revert l. by induction szs; intros; f_equal/=. Qed. End general_properties. Section more_general_properties. Context {A : Type}. Implicit Types x y z : A. Implicit Types l k : list A. (** ** Properties of [sublist_lookup] and [sublist_alter] *) Lemma sublist_lookup_length l i n k : sublist_lookup i n l = Some k → length k = n. Proof. unfold sublist_lookup; intros; simplify_option_eq. rewrite take_length, drop_length; lia. Qed. Lemma sublist_lookup_all l n : length l = n → sublist_lookup 0 n l = Some l. Proof. intros. unfold sublist_lookup; case_option_guard; [|lia]. by rewrite take_ge by (rewrite drop_length; lia). Qed. Lemma sublist_lookup_Some l i n : i + n ≤ length l → sublist_lookup i n l = Some (take n (drop i l)). Proof. by unfold sublist_lookup; intros; simplify_option_eq. Qed. Lemma sublist_lookup_Some' l i n l' : sublist_lookup i n l = Some l' ↔ l' = take n (drop i l) ∧ i + n ≤ length l. Proof. unfold sublist_lookup. case_option_guard; naive_solver lia. Qed. Lemma sublist_lookup_None l i n : length l < i + n → sublist_lookup i n l = None. Proof. by unfold sublist_lookup; intros; simplify_option_eq by lia. Qed. Lemma sublist_eq l k n : (n | length l) → (n | length k) → (∀ i, sublist_lookup (i * n) n l = sublist_lookup (i * n) n k) → l = k. Proof. revert l k. assert (∀ l i, n ≠ 0 → (n | length l) → ¬n * i `div` n + n ≤ length l → length l ≤ i). { intros l i ? [j ->] Hjn. apply Nat.nlt_ge; contradict Hjn. rewrite <-Nat.mul_succ_r, (Nat.mul_comm n). apply Nat.mul_le_mono_r, Nat.le_succ_l, Nat.div_lt_upper_bound; lia. } intros l k Hl Hk Hlookup. destruct (decide (n = 0)) as [->|]. { by rewrite (nil_length_inv l), (nil_length_inv k) by eauto using Nat.divide_0_l. } apply list_eq; intros i. specialize (Hlookup (i `div` n)). rewrite (Nat.mul_comm _ n) in Hlookup. unfold sublist_lookup in *; simplify_option_eq; [|by rewrite !lookup_ge_None_2 by auto]. apply (f_equal (.!! i `mod` n)) in Hlookup. by rewrite !lookup_take, !lookup_drop, <-!Nat.div_mod in Hlookup by (auto using Nat.mod_upper_bound with lia). Qed. Lemma sublist_eq_same_length l k j n : length l = j * n → length k = j * n → (∀ i,i < j → sublist_lookup (i * n) n l = sublist_lookup (i * n) n k) → l = k. Proof. intros Hl Hk ?. destruct (decide (n = 0)) as [->|]. { by rewrite (nil_length_inv l), (nil_length_inv k) by lia. } apply sublist_eq with n; [by exists j|by exists j|]. intros i. destruct (decide (i < j)); [by auto|]. assert (∀ m, m = j * n → m < i * n + n). { intros ? ->. replace (i * n + n) with (S i * n) by lia. apply Nat.mul_lt_mono_pos_r; lia. } by rewrite !sublist_lookup_None by auto. Qed. Lemma sublist_lookup_reshape l i n m : 0 < n → length l = m * n → reshape (replicate m n) l !! i = sublist_lookup (i * n) n l. Proof. intros Hn Hl. unfold sublist_lookup. apply option_eq; intros x; split. - intros Hx. case_option_guard as Hi. { f_equal. clear Hi. revert i l Hl Hx. induction m as [|m IH]; intros [|i] l ??; simplify_eq/=; auto. rewrite <-drop_drop. apply IH; rewrite ?drop_length; auto with lia. } destruct Hi. rewrite Hl, <-Nat.mul_succ_l. apply Nat.mul_le_mono_r, Nat.le_succ_l. apply lookup_lt_Some in Hx. by rewrite reshape_length, replicate_length in Hx. - intros Hx. case_option_guard as Hi; simplify_eq/=. revert i l Hl Hi. induction m as [|m IH]; [auto with lia|]. intros [|i] l ??; simpl; [done|]. rewrite <-drop_drop. rewrite IH; rewrite ?drop_length; auto with lia. Qed. Lemma sublist_lookup_compose l1 l2 l3 i n j m : sublist_lookup i n l1 = Some l2 → sublist_lookup j m l2 = Some l3 → sublist_lookup (i + j) m l1 = Some l3. Proof. unfold sublist_lookup; intros; simplify_option_eq; repeat match goal with | H : _ ≤ length _ |- _ => rewrite take_length, drop_length in H end; rewrite ?take_drop_commute, ?drop_drop, ?take_take, ?Nat.min_l, Nat.add_assoc by lia; auto with lia. Qed. Lemma sublist_alter_length f l i n k : sublist_lookup i n l = Some k → length (f k) = n → length (sublist_alter f i n l) = length l. Proof. unfold sublist_alter, sublist_lookup. intros Hk ?; simplify_option_eq. rewrite !app_length, Hk, !take_length, !drop_length; lia. Qed. Lemma sublist_lookup_alter f l i n k : sublist_lookup i n l = Some k → length (f k) = n → sublist_lookup i n (sublist_alter f i n l) = f <$> sublist_lookup i n l. Proof. unfold sublist_lookup. intros Hk ?. erewrite sublist_alter_length by eauto. unfold sublist_alter; simplify_option_eq. by rewrite Hk, drop_app_length', take_app_length' by (rewrite ?take_length; lia). Qed. Lemma sublist_lookup_alter_ne f l i j n k : sublist_lookup j n l = Some k → length (f k) = n → i + n ≤ j ∨ j + n ≤ i → sublist_lookup i n (sublist_alter f j n l) = sublist_lookup i n l. Proof. unfold sublist_lookup. intros Hk Hi ?. erewrite sublist_alter_length by eauto. unfold sublist_alter; simplify_option_eq; f_equal; rewrite Hk. apply list_eq; intros ii. destruct (decide (ii < length (f k))); [|by rewrite !lookup_take_ge by lia]. rewrite !lookup_take, !lookup_drop by done. destruct (decide (i + ii < j)). { by rewrite lookup_app_l, lookup_take by (rewrite ?take_length; lia). } rewrite lookup_app_r by (rewrite take_length; lia). rewrite take_length_le, lookup_app_r, lookup_drop by lia. f_equal; lia. Qed. Lemma sublist_alter_all f l n : length l = n → sublist_alter f 0 n l = f l. Proof. intros <-. unfold sublist_alter; simpl. by rewrite drop_all, (right_id_L [] (++)), take_ge. Qed. Lemma sublist_alter_compose f g l i n k : sublist_lookup i n l = Some k → length (f k) = n → length (g k) = n → sublist_alter (f ∘ g) i n l = sublist_alter f i n (sublist_alter g i n l). Proof. unfold sublist_alter, sublist_lookup. intros Hk ??; simplify_option_eq. by rewrite !take_app_length', drop_app_length', !(assoc_L (++)), drop_app_length', take_app_length' by (rewrite ?app_length, ?take_length, ?Hk; lia). Qed. (** ** Properties of the [mask] function *) Lemma mask_nil f βs : mask f βs [] =@{list A} []. Proof. by destruct βs. Qed. Lemma mask_length f βs l : length (mask f βs l) = length l. Proof. revert βs. induction l; intros [|??]; f_equal/=; auto. Qed. Lemma mask_true f l n : length l ≤ n → mask f (replicate n true) l = f <$> l. Proof. revert n. induction l; intros [|?] ?; f_equal/=; auto with lia. Qed. Lemma mask_false f l n : mask f (replicate n false) l = l. Proof. revert l. induction n; intros [|??]; f_equal/=; auto. Qed. Lemma mask_app f βs1 βs2 l : mask f (βs1 ++ βs2) l = mask f βs1 (take (length βs1) l) ++ mask f βs2 (drop (length βs1) l). Proof. revert l. induction βs1;intros [|??]; f_equal/=; auto using mask_nil. Qed. Lemma mask_app_2 f βs l1 l2 : mask f βs (l1 ++ l2) = mask f (take (length l1) βs) l1 ++ mask f (drop (length l1) βs) l2. Proof. revert βs. induction l1; intros [|??]; f_equal/=; auto. Qed. Lemma take_mask f βs l n : take n (mask f βs l) = mask f (take n βs) (take n l). Proof. revert n βs. induction l; intros [|?] [|[] ?]; f_equal/=; auto. Qed. Lemma drop_mask f βs l n : drop n (mask f βs l) = mask f (drop n βs) (drop n l). Proof. revert n βs. induction l; intros [|?] [|[] ?]; f_equal/=; auto using mask_nil. Qed. Lemma sublist_lookup_mask f βs l i n : sublist_lookup i n (mask f βs l) = mask f (take n (drop i βs)) <$> sublist_lookup i n l. Proof. unfold sublist_lookup; rewrite mask_length; simplify_option_eq; auto. by rewrite drop_mask, take_mask. Qed. Lemma mask_mask f g βs1 βs2 l : (∀ x, f (g x) = f x) → βs1 =.>* βs2 → mask f βs2 (mask g βs1 l) = mask f βs2 l. Proof. intros ? Hβs. revert l. by induction Hβs as [|[] []]; intros [|??]; f_equal/=. Qed. Lemma lookup_mask f βs l i : βs !! i = Some true → mask f βs l !! i = f <$> l !! i. Proof. revert i βs. induction l; intros [] [] ?; simplify_eq/=; f_equal; auto. Qed. Lemma lookup_mask_notin f βs l i : βs !! i ≠ Some true → mask f βs l !! i = l !! i. Proof. revert i βs. induction l; intros [] [|[]] ?; simplify_eq/=; auto. Qed. (** ** Properties of the [Permutation] predicate *) Lemma Permutation_nil_r l : l ≡ₚ [] ↔ l = []. Proof. split; [by intro; apply Permutation_nil | by intros ->]. Qed. Lemma Permutation_singleton_r l x : l ≡ₚ [x] ↔ l = [x]. Proof. split; [by intro; apply Permutation_length_1_inv | by intros ->]. Qed. Lemma Permutation_nil_l l : [] ≡ₚ l ↔ [] = l. Proof. by rewrite (symmetry_iff (≡ₚ)), Permutation_nil_r. Qed. Lemma Permutation_singleton_l l x : [x] ≡ₚ l ↔ [x] = l. Proof. by rewrite (symmetry_iff (≡ₚ)), Permutation_singleton_r. Qed. Lemma Permutation_skip x l l' : l ≡ₚ l' → x :: l ≡ₚ x :: l'. Proof. apply perm_skip. Qed. Lemma Permutation_swap x y l : y :: x :: l ≡ₚ x :: y :: l. Proof. apply perm_swap. Qed. Lemma Permutation_singleton_inj x y : [x] ≡ₚ [y] → x = y. Proof. apply Permutation_length_1. Qed. Global Instance length_Permutation_proper : Proper ((≡ₚ) ==> (=)) (@length A). Proof. induction 1; simpl; auto with lia. Qed. Global Instance elem_of_Permutation_proper x : Proper ((≡ₚ) ==> iff) (x ∈.). Proof. induction 1; rewrite ?elem_of_nil, ?elem_of_cons; intuition. Qed. Global Instance NoDup_Permutation_proper: Proper ((≡ₚ) ==> iff) (@NoDup A). Proof. induction 1 as [|x l k Hlk IH | |]. - by rewrite !NoDup_nil. - by rewrite !NoDup_cons, IH, Hlk. - rewrite !NoDup_cons, !elem_of_cons. intuition. - intuition. Qed. Global Instance app_Permutation_comm : Comm (≡ₚ) (@app A). Proof. intros l1. induction l1 as [|x l1 IH]; intros l2; simpl. - by rewrite (right_id_L [] (++)). - rewrite Permutation_middle, IH. simpl. by rewrite Permutation_middle. Qed. Global Instance cons_Permutation_inj_r x : Inj (≡ₚ) (≡ₚ) (x ::.). Proof. red. eauto using Permutation_cons_inv. Qed. Global Instance app_Permutation_inj_r k : Inj (≡ₚ) (≡ₚ) (k ++.). Proof. induction k as [|x k IH]; intros l1 l2; simpl; auto. intros. by apply IH, (inj (x ::.)). Qed. Global Instance cons_Permutation_inj_l k : Inj (=) (≡ₚ) (.:: k). Proof. intros x1 x2 Hperm. apply Permutation_singleton_inj. apply (inj (k ++.)). by rewrite !(comm (++) k). Qed. Global Instance app_Permutation_inj_l k : Inj (≡ₚ) (≡ₚ) (.++ k). Proof. intros l1 l2. rewrite !(comm (++) _ k). by apply (inj (k ++.)). Qed. Lemma replicate_Permutation n x l : replicate n x ≡ₚ l → replicate n x = l. Proof. intros Hl. apply replicate_as_elem_of. split. - by rewrite <-Hl, replicate_length. - intros y. rewrite <-Hl. by apply elem_of_replicate_inv. Qed. Lemma reverse_Permutation l : reverse l ≡ₚ l. Proof. induction l as [|x l IH]; [done|]. by rewrite reverse_cons, (comm (++)), IH. Qed. Lemma delete_Permutation l i x : l !! i = Some x → l ≡ₚ x :: delete i l. Proof. revert i; induction l as [|y l IH]; intros [|i] ?; simplify_eq/=; auto. by rewrite Permutation_swap, <-(IH i). Qed. Lemma elem_of_Permutation l x : x ∈ l ↔ ∃ k, l ≡ₚ x :: k. Proof. split. - intros [i ?]%elem_of_list_lookup. eexists. by apply delete_Permutation. - intros [k ->]. by left. Qed. Lemma Permutation_cons_inv_r l k x : k ≡ₚ x :: l → ∃ k1 k2, k = k1 ++ x :: k2 ∧ l ≡ₚ k1 ++ k2. Proof. intros Hk. assert (∃ i, k !! i = Some x) as [i Hi]. { apply elem_of_list_lookup. rewrite Hk, elem_of_cons; auto. } exists (take i k), (drop (S i) k). split. - by rewrite take_drop_middle. - rewrite <-delete_take_drop. apply (inj (x ::.)). by rewrite <-Hk, <-(delete_Permutation k) by done. Qed. Lemma Permutation_cons_inv_l l k x : x :: l ≡ₚ k → ∃ k1 k2, k = k1 ++ x :: k2 ∧ l ≡ₚ k1 ++ k2. Proof. by intros ?%(symmetry_iff (≡ₚ))%Permutation_cons_inv_r. Qed. Lemma Permutation_cross_split (la lb lc ld : list A) : la ++ lb ≡ₚ lc ++ ld → ∃ lac lad lbc lbd, lac ++ lad ≡ₚ la ∧ lbc ++ lbd ≡ₚ lb ∧ lac ++ lbc ≡ₚ lc ∧ lad ++ lbd ≡ₚ ld. Proof. revert lc ld. induction la as [|x la IH]; simpl; intros lc ld Hperm. { exists [], [], lc, ld. by rewrite !(right_id_L [] (++)). } assert (x ∈ lc ++ ld) as [[lc' Hlc]%elem_of_Permutation|[ld' Hld]%elem_of_Permutation]%elem_of_app. { rewrite <-Hperm, elem_of_cons. auto. } - rewrite Hlc in Hperm. simpl in Hperm. apply (inj (x ::.)) in Hperm. apply IH in Hperm as (lac&lad&lbc&lbd&Ha&Hb&Hc&Hd). exists (x :: lac), lad, lbc, lbd; simpl. by rewrite Ha, Hb, Hc, Hd. - rewrite Hld, <-Permutation_middle in Hperm. apply (inj (x ::.)) in Hperm. apply IH in Hperm as (lac&lad&lbc&lbd&Ha&Hb&Hc&Hd). exists lac, (x :: lad), lbc, lbd; simpl. by rewrite <-Permutation_middle, Ha, Hb, Hc, Hd. Qed. Lemma Permutation_inj l1 l2 : Permutation l1 l2 ↔ length l1 = length l2 ∧ ∃ f : nat → nat, Inj (=) (=) f ∧ ∀ i, l1 !! i = l2 !! f i. Proof. split. - intros Hl; split; [by apply Permutation_length|]. induction Hl as [|x l1 l2 _ [f [??]]|x y l|l1 l2 l3 _ [f [? Hf]] _ [g [? Hg]]]. + exists id; split; [apply _|done]. + exists (λ i, match i with 0 => 0 | S i => S (f i) end); split. * by intros [|i] [|j] ?; simplify_eq/=. * intros [|i]; simpl; auto. + exists (λ i, match i with 0 => 1 | 1 => 0 | _ => i end); split. * intros [|[|i]] [|[|j]]; congruence. * by intros [|[|i]]. + exists (g ∘ f); split; [apply _|]. intros i; simpl. by rewrite <-Hg, <-Hf. - intros (Hlen & f & Hf & Hl). revert l2 f Hlen Hf Hl. induction l1 as [|x l1 IH]; intros l2 f Hlen Hf Hl; [by destruct l2|]. rewrite (delete_Permutation l2 (f 0) x) by (by rewrite <-Hl). pose (g n := let m := f (S n) in if lt_eq_lt_dec m (f 0) then m else m - 1). apply Permutation_skip, (IH _ g). + rewrite length_delete by (rewrite <-Hl; eauto); simpl in *; lia. + unfold g. intros i j Hg. repeat destruct (lt_eq_lt_dec _ _) as [[?|?]|?]; simplify_eq/=; try lia. apply (inj S), (inj f); lia. + intros i. unfold g. destruct (lt_eq_lt_dec _ _) as [[?|?]|?]. * by rewrite lookup_delete_lt, <-Hl. * simplify_eq. * rewrite lookup_delete_ge, <-Nat.sub_succ_l by lia; simpl. by rewrite Nat.sub_0_r, <-Hl. Qed. (** ** Properties of the [filter] function *) Section filter. Context (P : A → Prop) `{∀ x, Decision (P x)}. Local Arguments filter {_ _ _} _ {_} !_ /. Lemma filter_nil : filter P [] = []. Proof. done. Qed. Lemma filter_cons x l : filter P (x :: l) = if decide (P x) then x :: filter P l else filter P l. Proof. done. Qed. Lemma filter_cons_True x l : P x → filter P (x :: l) = x :: filter P l. Proof. intros. by rewrite filter_cons, decide_True. Qed. Lemma filter_cons_False x l : ¬P x → filter P (x :: l) = filter P l. Proof. intros. by rewrite filter_cons, decide_False. Qed. Lemma filter_app l1 l2 : filter P (l1 ++ l2) = filter P l1 ++ filter P l2. Proof. induction l1 as [|x l1 IH]; simpl; [done| ]. case_decide; [|done]. by rewrite IH. Qed. Lemma elem_of_list_filter l x : x ∈ filter P l ↔ P x ∧ x ∈ l. Proof. induction l; simpl; repeat case_decide; rewrite ?elem_of_nil, ?elem_of_cons; naive_solver. Qed. Lemma NoDup_filter l : NoDup l → NoDup (filter P l). Proof. induction 1; simpl; repeat case_decide; rewrite ?NoDup_nil, ?NoDup_cons, ?elem_of_list_filter; tauto. Qed. Global Instance filter_Permutation : Proper ((≡ₚ) ==> (≡ₚ)) (filter P). Proof. induction 1; repeat (simpl; repeat case_decide); by econstructor. Qed. Lemma filter_length l : length (filter P l) ≤ length l. Proof. induction l; simpl; repeat case_decide; simpl; lia. Qed. Lemma filter_length_lt l x : x ∈ l → ¬P x → length (filter P l) < length l. Proof. intros [k ->]%elem_of_Permutation ?; simpl. rewrite decide_False, Nat.lt_succ_r by done. apply filter_length. Qed. Lemma filter_nil_not_elem_of l x : filter P l = [] → P x → x ∉ l. Proof. induction 3; simplify_eq/=; case_decide; naive_solver. Qed. Lemma filter_reverse l : filter P (reverse l) = reverse (filter P l). Proof. induction l as [|x l IHl]; [done|]. rewrite reverse_cons, filter_app, IHl, !filter_cons. case_decide; [by rewrite reverse_cons|by rewrite filter_nil, app_nil_r]. Qed. Lemma filter_app_complement l : filter P l ++ filter (λ x, ¬P x) l ≡ₚ l. Proof. induction l as [|x l IH]; simpl; [done|]. case_decide. - rewrite decide_False by naive_solver. simpl. by rewrite IH. - rewrite decide_True by done. by rewrite <-Permutation_middle, IH. Qed. End filter. Lemma list_filter_iff (P1 P2 : A → Prop) `{!∀ x, Decision (P1 x), !∀ x, Decision (P2 x)} (l : list A) : (∀ x, P1 x ↔ P2 x) → filter P1 l = filter P2 l. Proof. intros HPiff. induction l as [|a l IH]; [done|]. destruct (decide (P1 a)). - rewrite !filter_cons_True by naive_solver. by rewrite IH. - rewrite !filter_cons_False by naive_solver. by rewrite IH. Qed. Lemma list_filter_filter (P1 P2 : A → Prop) `{!∀ x, Decision (P1 x), !∀ x, Decision (P2 x)} (l : list A) : filter P1 (filter P2 l) = filter (λ a, P1 a ∧ P2 a) l. Proof. induction l as [|x l IH]; [done|]. rewrite !filter_cons. case (decide (P2 x)) as [HP2|HP2]. - rewrite filter_cons, IH. apply decide_ext. naive_solver. - rewrite IH. symmetry. apply decide_False. by intros [_ ?]. Qed. Lemma list_filter_filter_l (P1 P2 : A → Prop) `{!∀ x, Decision (P1 x), !∀ x, Decision (P2 x)} (l : list A) : (∀ x, P1 x → P2 x) → filter P1 (filter P2 l) = filter P1 l. Proof. intros HPimp. rewrite list_filter_filter. apply list_filter_iff. naive_solver. Qed. Lemma list_filter_filter_r (P1 P2 : A → Prop) `{!∀ x, Decision (P1 x), !∀ x, Decision (P2 x)} (l : list A) : (∀ x, P2 x → P1 x) → filter P1 (filter P2 l) = filter P2 l. Proof. intros HPimp. rewrite list_filter_filter. apply list_filter_iff. naive_solver. Qed. (** ** Properties of the [prefix] and [suffix] predicates *) Global Instance: PartialOrder (@prefix A). Proof. split; [split|]. - intros ?. eexists []. by rewrite (right_id_L [] (++)). - intros ???[k1->] [k2->]. exists (k1 ++ k2). by rewrite (assoc_L (++)). - intros l1 l2 [k1 ?] [[|x2 k2] ->]; [|discriminate_list]. by rewrite (right_id_L _ _). Qed. Lemma prefix_nil l : [] `prefix_of` l. Proof. by exists l. Qed. Lemma prefix_nil_inv l : l `prefix_of` [] → l = []. Proof. intros [k ?]. by destruct l. Qed. Lemma prefix_nil_not x l : ¬x :: l `prefix_of` []. Proof. by intros [k ?]. Qed. Lemma prefix_cons x l1 l2 : l1 `prefix_of` l2 → x :: l1 `prefix_of` x :: l2. Proof. intros [k ->]. by exists k. Qed. Lemma prefix_cons_alt x y l1 l2 : x = y → l1 `prefix_of` l2 → x :: l1 `prefix_of` y :: l2. Proof. intros ->. apply prefix_cons. Qed. Lemma prefix_cons_inv_1 x y l1 l2 : x :: l1 `prefix_of` y :: l2 → x = y. Proof. by intros [k ?]; simplify_eq/=. Qed. Lemma prefix_cons_inv_2 x y l1 l2 : x :: l1 `prefix_of` y :: l2 → l1 `prefix_of` l2. Proof. intros [k ?]; simplify_eq/=. by exists k. Qed. Lemma prefix_app k l1 l2 : l1 `prefix_of` l2 → k ++ l1 `prefix_of` k ++ l2. Proof. intros [k' ->]. exists k'. by rewrite (assoc_L (++)). Qed. Lemma prefix_app_alt k1 k2 l1 l2 : k1 = k2 → l1 `prefix_of` l2 → k1 ++ l1 `prefix_of` k2 ++ l2. Proof. intros ->. apply prefix_app. Qed. Lemma prefix_app_inv k l1 l2 : k ++ l1 `prefix_of` k ++ l2 → l1 `prefix_of` l2. Proof. intros [k' E]. exists k'. rewrite <-(assoc_L (++)) in E. by simplify_list_eq. Qed. Lemma prefix_app_l l1 l2 l3 : l1 ++ l3 `prefix_of` l2 → l1 `prefix_of` l2. Proof. intros [k ->]. exists (l3 ++ k). by rewrite (assoc_L (++)). Qed. Lemma prefix_app_r l1 l2 l3 : l1 `prefix_of` l2 → l1 `prefix_of` l2 ++ l3. Proof. intros [k ->]. exists (k ++ l3). by rewrite (assoc_L (++)). Qed. Lemma prefix_take l n : take n l `prefix_of` l. Proof. rewrite <-(take_drop n l) at 2. apply prefix_app_r. done. Qed. Lemma prefix_lookup_lt l1 l2 i : i < length l1 → l1 `prefix_of` l2 → l1 !! i = l2 !! i. Proof. intros ? [? ->]. by rewrite lookup_app_l. Qed. Lemma prefix_lookup_Some l1 l2 i x : l1 !! i = Some x → l1 `prefix_of` l2 → l2 !! i = Some x. Proof. intros ? [k ->]. rewrite lookup_app_l; eauto using lookup_lt_Some. Qed. Lemma prefix_length l1 l2 : l1 `prefix_of` l2 → length l1 ≤ length l2. Proof. intros [? ->]. rewrite app_length. lia. Qed. Lemma prefix_snoc_not l x : ¬l ++ [x] `prefix_of` l. Proof. intros [??]. discriminate_list. Qed. Lemma elem_of_prefix l1 l2 x : x ∈ l1 → l1 `prefix_of` l2 → x ∈ l2. Proof. intros Hin [l' ->]. apply elem_of_app. by left. Qed. (* [prefix] is not a total order, but [l1] and [l2] are always comparable if they are both prefixes of some [l3]. *) Lemma prefix_weak_total l1 l2 l3 : l1 `prefix_of` l3 → l2 `prefix_of` l3 → l1 `prefix_of` l2 ∨ l2 `prefix_of` l1. Proof. intros [k1 H1] [k2 H2]. rewrite H2 in H1. apply app_eq_inv in H1 as [(k&?&?)|(k&?&?)]; [left|right]; exists k; eauto. Qed. Global Instance: PartialOrder (@suffix A). Proof. split; [split|]. - intros ?. by eexists []. - intros ???[k1->] [k2->]. exists (k2 ++ k1). by rewrite (assoc_L (++)). - intros l1 l2 [k1 ?] [[|x2 k2] ->]; [done|discriminate_list]. Qed. Global Instance prefix_dec `{!EqDecision A} : RelDecision prefix := fix go l1 l2 := match l1, l2 with | [], _ => left (prefix_nil _) | _, [] => right (prefix_nil_not _ _) | x :: l1, y :: l2 => match decide_rel (=) x y with | left Hxy => match go l1 l2 with | left Hl1l2 => left (prefix_cons_alt _ _ _ _ Hxy Hl1l2) | right Hl1l2 => right (Hl1l2 ∘ prefix_cons_inv_2 _ _ _ _) end | right Hxy => right (Hxy ∘ prefix_cons_inv_1 _ _ _ _) end end. Lemma prefix_not_elem_of_app_cons_inv x y l1 l2 k1 k2 : x ∉ k1 → y ∉ l1 → (l1 ++ x :: l2) `prefix_of` (k1 ++ y :: k2) → l1 = k1 ∧ x = y ∧ l2 `prefix_of` k2. Proof. intros Hin1 Hin2 [k Hle]. rewrite <-(assoc_L (++)) in Hle. apply not_elem_of_app_cons_inv_l in Hle; [|done..]. unfold prefix. naive_solver. Qed. Lemma prefix_length_eq l1 l2 : l1 `prefix_of` l2 → length l2 ≤ length l1 → l1 = l2. Proof. intros Hprefix Hlen. assert (length l1 = length l2). { apply prefix_length in Hprefix. lia. } eapply list_eq_same_length with (length l1); [done..|]. intros i x y _ ??. assert (l2 !! i = Some x) by eauto using prefix_lookup_Some. congruence. Qed. Section prefix_ops. Context `{!EqDecision A}. Lemma max_prefix_fst l1 l2 : l1 = (max_prefix l1 l2).2 ++ (max_prefix l1 l2).1.1. Proof. revert l2. induction l1; intros [|??]; simpl; repeat case_decide; f_equal/=; auto. Qed. Lemma max_prefix_fst_alt l1 l2 k1 k2 k3 : max_prefix l1 l2 = (k1, k2, k3) → l1 = k3 ++ k1. Proof. intros. pose proof (max_prefix_fst l1 l2). by destruct (max_prefix l1 l2) as [[]?]; simplify_eq. Qed. Lemma max_prefix_fst_prefix l1 l2 : (max_prefix l1 l2).2 `prefix_of` l1. Proof. eexists. apply max_prefix_fst. Qed. Lemma max_prefix_fst_prefix_alt l1 l2 k1 k2 k3 : max_prefix l1 l2 = (k1, k2, k3) → k3 `prefix_of` l1. Proof. eexists. eauto using max_prefix_fst_alt. Qed. Lemma max_prefix_snd l1 l2 : l2 = (max_prefix l1 l2).2 ++ (max_prefix l1 l2).1.2. Proof. revert l2. induction l1; intros [|??]; simpl; repeat case_decide; f_equal/=; auto. Qed. Lemma max_prefix_snd_alt l1 l2 k1 k2 k3 : max_prefix l1 l2 = (k1, k2, k3) → l2 = k3 ++ k2. Proof. intro. pose proof (max_prefix_snd l1 l2). by destruct (max_prefix l1 l2) as [[]?]; simplify_eq. Qed. Lemma max_prefix_snd_prefix l1 l2 : (max_prefix l1 l2).2 `prefix_of` l2. Proof. eexists. apply max_prefix_snd. Qed. Lemma max_prefix_snd_prefix_alt l1 l2 k1 k2 k3 : max_prefix l1 l2 = (k1,k2,k3) → k3 `prefix_of` l2. Proof. eexists. eauto using max_prefix_snd_alt. Qed. Lemma max_prefix_max l1 l2 k : k `prefix_of` l1 → k `prefix_of` l2 → k `prefix_of` (max_prefix l1 l2).2. Proof. intros [l1' ->] [l2' ->]. by induction k; simpl; repeat case_decide; simpl; auto using prefix_nil, prefix_cons. Qed. Lemma max_prefix_max_alt l1 l2 k1 k2 k3 k : max_prefix l1 l2 = (k1,k2,k3) → k `prefix_of` l1 → k `prefix_of` l2 → k `prefix_of` k3. Proof. intro. pose proof (max_prefix_max l1 l2 k). by destruct (max_prefix l1 l2) as [[]?]; simplify_eq. Qed. Lemma max_prefix_max_snoc l1 l2 k1 k2 k3 x1 x2 : max_prefix l1 l2 = (x1 :: k1, x2 :: k2, k3) → x1 ≠ x2. Proof. intros Hl ->. destruct (prefix_snoc_not k3 x2). eapply max_prefix_max_alt; eauto. - rewrite (max_prefix_fst_alt _ _ _ _ _ Hl). apply prefix_app, prefix_cons, prefix_nil. - rewrite (max_prefix_snd_alt _ _ _ _ _ Hl). apply prefix_app, prefix_cons, prefix_nil. Qed. End prefix_ops. Lemma prefix_suffix_reverse l1 l2 : l1 `prefix_of` l2 ↔ reverse l1 `suffix_of` reverse l2. Proof. split; intros [k E]; exists (reverse k). - by rewrite E, reverse_app. - by rewrite <-(reverse_involutive l2), E, reverse_app, reverse_involutive. Qed. Lemma suffix_prefix_reverse l1 l2 : l1 `suffix_of` l2 ↔ reverse l1 `prefix_of` reverse l2. Proof. by rewrite prefix_suffix_reverse, !reverse_involutive. Qed. Lemma suffix_nil l : [] `suffix_of` l. Proof. exists l. by rewrite (right_id_L [] (++)). Qed. Lemma suffix_nil_inv l : l `suffix_of` [] → l = []. Proof. by intros [[|?] ?]; simplify_list_eq. Qed. Lemma suffix_cons_nil_inv x l : ¬x :: l `suffix_of` []. Proof. by intros [[] ?]. Qed. Lemma suffix_snoc l1 l2 x : l1 `suffix_of` l2 → l1 ++ [x] `suffix_of` l2 ++ [x]. Proof. intros [k ->]. exists k. by rewrite (assoc_L (++)). Qed. Lemma suffix_snoc_alt x y l1 l2 : x = y → l1 `suffix_of` l2 → l1 ++ [x] `suffix_of` l2 ++ [y]. Proof. intros ->. apply suffix_snoc. Qed. Lemma suffix_app l1 l2 k : l1 `suffix_of` l2 → l1 ++ k `suffix_of` l2 ++ k. Proof. intros [k' ->]. exists k'. by rewrite (assoc_L (++)). Qed. Lemma suffix_app_alt l1 l2 k1 k2 : k1 = k2 → l1 `suffix_of` l2 → l1 ++ k1 `suffix_of` l2 ++ k2. Proof. intros ->. apply suffix_app. Qed. Lemma suffix_snoc_inv_1 x y l1 l2 : l1 ++ [x] `suffix_of` l2 ++ [y] → x = y. Proof. intros [k' E]. rewrite (assoc_L (++)) in E. by simplify_list_eq. Qed. Lemma suffix_snoc_inv_2 x y l1 l2 : l1 ++ [x] `suffix_of` l2 ++ [y] → l1 `suffix_of` l2. Proof. intros [k' E]. exists k'. rewrite (assoc_L (++)) in E. by simplify_list_eq. Qed. Lemma suffix_app_inv l1 l2 k : l1 ++ k `suffix_of` l2 ++ k → l1 `suffix_of` l2. Proof. intros [k' E]. exists k'. rewrite (assoc_L (++)) in E. by simplify_list_eq. Qed. Lemma suffix_cons_l l1 l2 x : x :: l1 `suffix_of` l2 → l1 `suffix_of` l2. Proof. intros [k ->]. exists (k ++ [x]). by rewrite <-(assoc_L (++)). Qed. Lemma suffix_app_l l1 l2 l3 : l3 ++ l1 `suffix_of` l2 → l1 `suffix_of` l2. Proof. intros [k ->]. exists (k ++ l3). by rewrite <-(assoc_L (++)). Qed. Lemma suffix_cons_r l1 l2 x : l1 `suffix_of` l2 → l1 `suffix_of` x :: l2. Proof. intros [k ->]. by exists (x :: k). Qed. Lemma suffix_app_r l1 l2 l3 : l1 `suffix_of` l2 → l1 `suffix_of` l3 ++ l2. Proof. intros [k ->]. exists (l3 ++ k). by rewrite (assoc_L (++)). Qed. Lemma suffix_drop l n : drop n l `suffix_of` l. Proof. rewrite <-(take_drop n l) at 2. apply suffix_app_r. done. Qed. Lemma suffix_cons_inv l1 l2 x y : x :: l1 `suffix_of` y :: l2 → x :: l1 = y :: l2 ∨ x :: l1 `suffix_of` l2. Proof. intros [[|? k] E]; [by left|]. right. simplify_eq/=. by apply suffix_app_r. Qed. Lemma suffix_lookup_lt l1 l2 i : i < length l1 → l1 `suffix_of` l2 → l1 !! i = l2 !! (i + (length l2 - length l1)). Proof. intros Hi [k ->]. rewrite app_length, lookup_app_r by lia. f_equal; lia. Qed. Lemma suffix_lookup_Some l1 l2 i x : l1 !! i = Some x → l1 `suffix_of` l2 → l2 !! (i + (length l2 - length l1)) = Some x. Proof. intros. by rewrite <-suffix_lookup_lt by eauto using lookup_lt_Some. Qed. Lemma suffix_length l1 l2 : l1 `suffix_of` l2 → length l1 ≤ length l2. Proof. intros [? ->]. rewrite app_length. lia. Qed. Lemma suffix_cons_not x l : ¬x :: l `suffix_of` l. Proof. intros [??]. discriminate_list. Qed. Lemma elem_of_suffix l1 l2 x : x ∈ l1 → l1 `suffix_of` l2 → x ∈ l2. Proof. intros Hin [l' ->]. apply elem_of_app. by right. Qed. (* [suffix] is not a total order, but [l1] and [l2] are always comparable if they are both suffixes of some [l3]. *) Lemma suffix_weak_total l1 l2 l3 : l1 `suffix_of` l3 → l2 `suffix_of` l3 → l1 `suffix_of` l2 ∨ l2 `suffix_of` l1. Proof. intros [k1 Hl1] [k2 Hl2]. rewrite Hl1 in Hl2. apply app_eq_inv in Hl2 as [(k&?&?)|(k&?&?)]; [left|right]; exists k; eauto. Qed. Global Instance suffix_dec `{!EqDecision A} : RelDecision (@suffix A). Proof. refine (λ l1 l2, cast_if (decide_rel prefix (reverse l1) (reverse l2))); abstract (by rewrite suffix_prefix_reverse). Defined. Lemma suffix_not_elem_of_app_cons_inv x y l1 l2 k1 k2 : x ∉ k2 → y ∉ l2 → (l1 ++ x :: l2) `suffix_of` (k1 ++ y :: k2) → l1 `suffix_of` k1 ∧ x = y ∧ l2 = k2. Proof. intros Hin1 Hin2 [k Hle]. rewrite (assoc_L (++)) in Hle. apply not_elem_of_app_cons_inv_r in Hle; [|done..]. unfold suffix. naive_solver. Qed. Lemma suffix_length_eq l1 l2 : l1 `suffix_of` l2 → length l2 ≤ length l1 → l1 = l2. Proof. intros. apply (inj reverse), prefix_length_eq. - by apply suffix_prefix_reverse. - by rewrite !reverse_length. Qed. Section max_suffix. Context `{!EqDecision A}. Lemma max_suffix_fst l1 l2 : l1 = (max_suffix l1 l2).1.1 ++ (max_suffix l1 l2).2. Proof. rewrite <-(reverse_involutive l1) at 1. rewrite (max_prefix_fst (reverse l1) (reverse l2)). unfold max_suffix. destruct (max_prefix (reverse l1) (reverse l2)) as ((?&?)&?); simpl. by rewrite reverse_app. Qed. Lemma max_suffix_fst_alt l1 l2 k1 k2 k3 : max_suffix l1 l2 = (k1, k2, k3) → l1 = k1 ++ k3. Proof. intro. pose proof (max_suffix_fst l1 l2). by destruct (max_suffix l1 l2) as [[]?]; simplify_eq. Qed. Lemma max_suffix_fst_suffix l1 l2 : (max_suffix l1 l2).2 `suffix_of` l1. Proof. eexists. apply max_suffix_fst. Qed. Lemma max_suffix_fst_suffix_alt l1 l2 k1 k2 k3 : max_suffix l1 l2 = (k1, k2, k3) → k3 `suffix_of` l1. Proof. eexists. eauto using max_suffix_fst_alt. Qed. Lemma max_suffix_snd l1 l2 : l2 = (max_suffix l1 l2).1.2 ++ (max_suffix l1 l2).2. Proof. rewrite <-(reverse_involutive l2) at 1. rewrite (max_prefix_snd (reverse l1) (reverse l2)). unfold max_suffix. destruct (max_prefix (reverse l1) (reverse l2)) as ((?&?)&?); simpl. by rewrite reverse_app. Qed. Lemma max_suffix_snd_alt l1 l2 k1 k2 k3 : max_suffix l1 l2 = (k1,k2,k3) → l2 = k2 ++ k3. Proof. intro. pose proof (max_suffix_snd l1 l2). by destruct (max_suffix l1 l2) as [[]?]; simplify_eq. Qed. Lemma max_suffix_snd_suffix l1 l2 : (max_suffix l1 l2).2 `suffix_of` l2. Proof. eexists. apply max_suffix_snd. Qed. Lemma max_suffix_snd_suffix_alt l1 l2 k1 k2 k3 : max_suffix l1 l2 = (k1,k2,k3) → k3 `suffix_of` l2. Proof. eexists. eauto using max_suffix_snd_alt. Qed. Lemma max_suffix_max l1 l2 k : k `suffix_of` l1 → k `suffix_of` l2 → k `suffix_of` (max_suffix l1 l2).2. Proof. generalize (max_prefix_max (reverse l1) (reverse l2)). rewrite !suffix_prefix_reverse. unfold max_suffix. destruct (max_prefix (reverse l1) (reverse l2)) as ((?&?)&?); simpl. rewrite reverse_involutive. auto. Qed. Lemma max_suffix_max_alt l1 l2 k1 k2 k3 k : max_suffix l1 l2 = (k1, k2, k3) → k `suffix_of` l1 → k `suffix_of` l2 → k `suffix_of` k3. Proof. intro. pose proof (max_suffix_max l1 l2 k). by destruct (max_suffix l1 l2) as [[]?]; simplify_eq. Qed. Lemma max_suffix_max_snoc l1 l2 k1 k2 k3 x1 x2 : max_suffix l1 l2 = (k1 ++ [x1], k2 ++ [x2], k3) → x1 ≠ x2. Proof. intros Hl ->. destruct (suffix_cons_not x2 k3). eapply max_suffix_max_alt; eauto. - rewrite (max_suffix_fst_alt _ _ _ _ _ Hl). by apply (suffix_app [x2]), suffix_app_r. - rewrite (max_suffix_snd_alt _ _ _ _ _ Hl). by apply (suffix_app [x2]), suffix_app_r. Qed. End max_suffix. (** ** Properties of the [sublist] predicate *) Lemma sublist_length l1 l2 : l1 `sublist_of` l2 → length l1 ≤ length l2. Proof. induction 1; simpl; auto with arith. Qed. Lemma sublist_nil_l l : [] `sublist_of` l. Proof. induction l; try constructor; auto. Qed. Lemma sublist_nil_r l : l `sublist_of` [] ↔ l = []. Proof. split; [by inversion 1|]. intros ->. constructor. Qed. Lemma sublist_app l1 l2 k1 k2 : l1 `sublist_of` l2 → k1 `sublist_of` k2 → l1 ++ k1 `sublist_of` l2 ++ k2. Proof. induction 1; simpl; try constructor; auto. Qed. Lemma sublist_inserts_l k l1 l2 : l1 `sublist_of` l2 → l1 `sublist_of` k ++ l2. Proof. induction k; try constructor; auto. Qed. Lemma sublist_inserts_r k l1 l2 : l1 `sublist_of` l2 → l1 `sublist_of` l2 ++ k. Proof. induction 1; simpl; try constructor; auto using sublist_nil_l. Qed. Lemma sublist_cons_r x l k : l `sublist_of` x :: k ↔ l `sublist_of` k ∨ ∃ l', l = x :: l' ∧ l' `sublist_of` k. Proof. split; [inversion 1; eauto|]. intros [?|(?&->&?)]; constructor; auto. Qed. Lemma sublist_cons_l x l k : x :: l `sublist_of` k ↔ ∃ k1 k2, k = k1 ++ x :: k2 ∧ l `sublist_of` k2. Proof. split. - intros Hlk. induction k as [|y k IH]; inversion Hlk. + eexists [], k. by repeat constructor. + destruct IH as (k1&k2&->&?); auto. by exists (y :: k1), k2. - intros (k1&k2&->&?). by apply sublist_inserts_l, sublist_skip. Qed. Lemma sublist_app_r l k1 k2 : l `sublist_of` k1 ++ k2 ↔ ∃ l1 l2, l = l1 ++ l2 ∧ l1 `sublist_of` k1 ∧ l2 `sublist_of` k2. Proof. split. - revert l k2. induction k1 as [|y k1 IH]; intros l k2; simpl. { eexists [], l. by repeat constructor. } rewrite sublist_cons_r. intros [?|(l' & ? &?)]; subst. + destruct (IH l k2) as (l1&l2&?&?&?); trivial; subst. exists l1, l2. auto using sublist_cons. + destruct (IH l' k2) as (l1&l2&?&?&?); trivial; subst. exists (y :: l1), l2. auto using sublist_skip. - intros (?&?&?&?&?); subst. auto using sublist_app. Qed. Lemma sublist_app_l l1 l2 k : l1 ++ l2 `sublist_of` k ↔ ∃ k1 k2, k = k1 ++ k2 ∧ l1 `sublist_of` k1 ∧ l2 `sublist_of` k2. Proof. split. - revert l2 k. induction l1 as [|x l1 IH]; intros l2 k; simpl. { eexists [], k. by repeat constructor. } rewrite sublist_cons_l. intros (k1 & k2 &?&?); subst. destruct (IH l2 k2) as (h1 & h2 &?&?&?); trivial; subst. exists (k1 ++ x :: h1), h2. rewrite <-(assoc_L (++)). auto using sublist_inserts_l, sublist_skip. - intros (?&?&?&?&?); subst. auto using sublist_app. Qed. Lemma sublist_app_inv_l k l1 l2 : k ++ l1 `sublist_of` k ++ l2 → l1 `sublist_of` l2. Proof. induction k as [|y k IH]; simpl; [done |]. rewrite sublist_cons_r. intros [Hl12|(?&?&?)]; [|simplify_eq; eauto]. rewrite sublist_cons_l in Hl12. destruct Hl12 as (k1&k2&Hk&?). apply IH. rewrite Hk. eauto using sublist_inserts_l, sublist_cons. Qed. Lemma sublist_app_inv_r k l1 l2 : l1 ++ k `sublist_of` l2 ++ k → l1 `sublist_of` l2. Proof. revert l1 l2. induction k as [|y k IH]; intros l1 l2. { by rewrite !(right_id_L [] (++)). } intros. opose proof* (IH (l1 ++ [_]) (l2 ++ [_])) as Hl12. { by rewrite <-!(assoc_L (++)). } rewrite sublist_app_l in Hl12. destruct Hl12 as (k1&k2&E&?&Hk2). destruct k2 as [|z k2] using rev_ind; [inversion Hk2|]. rewrite (assoc_L (++)) in E; simplify_list_eq. eauto using sublist_inserts_r. Qed. Global Instance: PartialOrder (@sublist A). Proof. split; [split|]. - intros l. induction l; constructor; auto. - intros l1 l2 l3 Hl12. revert l3. induction Hl12. + auto using sublist_nil_l. + intros ?. rewrite sublist_cons_l. intros (?&?&?&?); subst. eauto using sublist_inserts_l, sublist_skip. + intros ?. rewrite sublist_cons_l. intros (?&?&?&?); subst. eauto using sublist_inserts_l, sublist_cons. - intros l1 l2 Hl12 Hl21. apply sublist_length in Hl21. induction Hl12 as [| |??? Hl12]; f_equal/=; auto with arith. apply sublist_length in Hl12. lia. Qed. Lemma sublist_take l i : take i l `sublist_of` l. Proof. rewrite <-(take_drop i l) at 2. by apply sublist_inserts_r. Qed. Lemma sublist_drop l i : drop i l `sublist_of` l. Proof. rewrite <-(take_drop i l) at 2. by apply sublist_inserts_l. Qed. Lemma sublist_delete l i : delete i l `sublist_of` l. Proof. revert i. by induction l; intros [|?]; simpl; constructor. Qed. Lemma sublist_foldr_delete l is : foldr delete l is `sublist_of` l. Proof. induction is as [|i is IH]; simpl; [done |]. trans (foldr delete l is); auto using sublist_delete. Qed. Lemma sublist_alt l1 l2 : l1 `sublist_of` l2 ↔ ∃ is, l1 = foldr delete l2 is. Proof. split; [|intros [is ->]; apply sublist_foldr_delete]. intros Hl12. cut (∀ k, ∃ is, k ++ l1 = foldr delete (k ++ l2) is). { intros help. apply (help []). } induction Hl12 as [|x l1 l2 _ IH|x l1 l2 _ IH]; intros k. - by eexists []. - destruct (IH (k ++ [x])) as [is His]. exists is. by rewrite <-!(assoc_L (++)) in His. - destruct (IH k) as [is His]. exists (is ++ [length k]). rewrite fold_right_app. simpl. by rewrite delete_middle. Qed. Lemma Permutation_sublist l1 l2 l3 : l1 ≡ₚ l2 → l2 `sublist_of` l3 → ∃ l4, l1 `sublist_of` l4 ∧ l4 ≡ₚ l3. Proof. intros Hl1l2. revert l3. induction Hl1l2 as [|x l1 l2 ? IH|x y l1|l1 l1' l2 ? IH1 ? IH2]. - intros l3. by exists l3. - intros l3. rewrite sublist_cons_l. intros (l3'&l3''&?&?); subst. destruct (IH l3'') as (l4&?&Hl4); auto. exists (l3' ++ x :: l4). split. + by apply sublist_inserts_l, sublist_skip. + by rewrite Hl4. - intros l3. rewrite sublist_cons_l. intros (l3'&l3''&?& Hl3); subst. rewrite sublist_cons_l in Hl3. destruct Hl3 as (l5'&l5''&?& Hl5); subst. exists (l3' ++ y :: l5' ++ x :: l5''). split. + by do 2 apply sublist_inserts_l, sublist_skip. + by rewrite !Permutation_middle, Permutation_swap. - intros l3 ?. destruct (IH2 l3) as (l3'&?&?); trivial. destruct (IH1 l3') as (l3'' &?&?); trivial. exists l3''. split; [done|]. etrans; eauto. Qed. Lemma sublist_Permutation l1 l2 l3 : l1 `sublist_of` l2 → l2 ≡ₚ l3 → ∃ l4, l1 ≡ₚ l4 ∧ l4 `sublist_of` l3. Proof. intros Hl1l2 Hl2l3. revert l1 Hl1l2. induction Hl2l3 as [|x l2 l3 ? IH|x y l2|l2 l2' l3 ? IH1 ? IH2]. - intros l1. by exists l1. - intros l1. rewrite sublist_cons_r. intros [?|(l1'&l1''&?)]; subst. { destruct (IH l1) as (l4&?&?); trivial. exists l4. split. - done. - by constructor. } destruct (IH l1') as (l4&?&Hl4); auto. exists (x :: l4). split; [ by constructor | by constructor ]. - intros l1. rewrite sublist_cons_r. intros [Hl1|(l1'&l1''&Hl1)]; subst. { exists l1. split; [done|]. rewrite sublist_cons_r in Hl1. destruct Hl1 as [?|(l1'&?&?)]; subst; by repeat constructor. } rewrite sublist_cons_r in Hl1. destruct Hl1 as [?|(l1''&?&?)]; subst. + exists (y :: l1'). by repeat constructor. + exists (x :: y :: l1''). by repeat constructor. - intros l1 ?. destruct (IH1 l1) as (l3'&?&?); trivial. destruct (IH2 l3') as (l3'' &?&?); trivial. exists l3''. split; [|done]. etrans; eauto. Qed. (** Properties of the [submseteq] predicate *) Lemma submseteq_length l1 l2 : l1 ⊆+ l2 → length l1 ≤ length l2. Proof. induction 1; simpl; auto with lia. Qed. Lemma submseteq_nil_l l : [] ⊆+ l. Proof. induction l; constructor; auto. Qed. Lemma submseteq_nil_r l : l ⊆+ [] ↔ l = []. Proof. split; [|intros ->; constructor]. intros Hl. apply submseteq_length in Hl. destruct l; simpl in *; auto with lia. Qed. Global Instance: PreOrder (@submseteq A). Proof. split. - intros l. induction l; constructor; auto. - red. apply submseteq_trans. Qed. Lemma Permutation_submseteq l1 l2 : l1 ≡ₚ l2 → l1 ⊆+ l2. Proof. induction 1; econstructor; eauto. Qed. Lemma sublist_submseteq l1 l2 : l1 `sublist_of` l2 → l1 ⊆+ l2. Proof. induction 1; constructor; auto. Qed. Lemma submseteq_Permutation l1 l2 : l1 ⊆+ l2 → ∃ k, l2 ≡ₚ l1 ++ k. Proof. induction 1 as [|x y l ? [k Hk]| |x l1 l2 ? [k Hk]|l1 l2 l3 ? [k Hk] ? [k' Hk']]. - by eexists []. - exists k. by rewrite Hk. - eexists []. rewrite (right_id_L [] (++)). by constructor. - exists (x :: k). by rewrite Hk, Permutation_middle. - exists (k ++ k'). by rewrite Hk', Hk, (assoc_L (++)). Qed. Global Instance: Proper ((≡ₚ) ==> (≡ₚ) ==> iff) (@submseteq A). Proof. intros l1 l2 ? k1 k2 ?. split; intros. - trans l1; [by apply Permutation_submseteq|]. trans k1; [done|]. by apply Permutation_submseteq. - trans l2; [by apply Permutation_submseteq|]. trans k2; [done|]. by apply Permutation_submseteq. Qed. Lemma submseteq_length_Permutation l1 l2 : l1 ⊆+ l2 → length l2 ≤ length l1 → l1 ≡ₚ l2. Proof. intros Hsub Hlen. destruct (submseteq_Permutation l1 l2) as [[|??] Hk]; auto. - by rewrite Hk, (right_id_L [] (++)). - rewrite Hk, app_length in Hlen. simpl in *; lia. Qed. Global Instance: AntiSymm (≡ₚ) (@submseteq A). Proof. intros l1 l2 ??. apply submseteq_length_Permutation; auto using submseteq_length. Qed. Lemma elem_of_submseteq l k x : x ∈ l → l ⊆+ k → x ∈ k. Proof. intros ? [l' ->]%submseteq_Permutation. apply elem_of_app; auto. Qed. Lemma lookup_submseteq l k i x : l !! i = Some x → l ⊆+ k → ∃ j, k !! j = Some x. Proof. intros Hsub Hlook. eapply elem_of_list_lookup_1, elem_of_submseteq; eauto using elem_of_list_lookup_2. Qed. Lemma submseteq_take l i : take i l ⊆+ l. Proof. auto using sublist_take, sublist_submseteq. Qed. Lemma submseteq_drop l i : drop i l ⊆+ l. Proof. auto using sublist_drop, sublist_submseteq. Qed. Lemma submseteq_delete l i : delete i l ⊆+ l. Proof. auto using sublist_delete, sublist_submseteq. Qed. Lemma submseteq_foldr_delete l is : foldr delete l is `sublist_of` l. Proof. auto using sublist_foldr_delete, sublist_submseteq. Qed. Lemma submseteq_sublist_l l1 l3 : l1 ⊆+ l3 ↔ ∃ l2, l1 `sublist_of` l2 ∧ l2 ≡ₚ l3. Proof. split. { intros Hl13. elim Hl13; clear l1 l3 Hl13. - by eexists []. - intros x l1 l3 ? (l2&?&?). exists (x :: l2). by repeat constructor. - intros x y l. exists (y :: x :: l). by repeat constructor. - intros x l1 l3 ? (l2&?&?). exists (x :: l2). by repeat constructor. - intros l1 l3 l5 ? (l2&?&?) ? (l4&?&?). destruct (Permutation_sublist l2 l3 l4) as (l3'&?&?); trivial. exists l3'. split; etrans; eauto. } intros (l2&?&?). trans l2; auto using sublist_submseteq, Permutation_submseteq. Qed. Lemma submseteq_sublist_r l1 l3 : l1 ⊆+ l3 ↔ ∃ l2, l1 ≡ₚ l2 ∧ l2 `sublist_of` l3. Proof. rewrite submseteq_sublist_l. split; intros (l2&?&?); eauto using sublist_Permutation, Permutation_sublist. Qed. Lemma submseteq_inserts_l k l1 l2 : l1 ⊆+ l2 → l1 ⊆+ k ++ l2. Proof. induction k; try constructor; auto. Qed. Lemma submseteq_inserts_r k l1 l2 : l1 ⊆+ l2 → l1 ⊆+ l2 ++ k. Proof. rewrite (comm (++)). apply submseteq_inserts_l. Qed. Lemma submseteq_skips_l k l1 l2 : l1 ⊆+ l2 → k ++ l1 ⊆+ k ++ l2. Proof. induction k; try constructor; auto. Qed. Lemma submseteq_skips_r k l1 l2 : l1 ⊆+ l2 → l1 ++ k ⊆+ l2 ++ k. Proof. rewrite !(comm (++) _ k). apply submseteq_skips_l. Qed. Lemma submseteq_app l1 l2 k1 k2 : l1 ⊆+ l2 → k1 ⊆+ k2 → l1 ++ k1 ⊆+ l2 ++ k2. Proof. trans (l1 ++ k2); auto using submseteq_skips_l, submseteq_skips_r. Qed. Lemma submseteq_cons_r x l k : l ⊆+ x :: k ↔ l ⊆+ k ∨ ∃ l', l ≡ₚ x :: l' ∧ l' ⊆+ k. Proof. split. - rewrite submseteq_sublist_r. intros (l'&E&Hl'). rewrite sublist_cons_r in Hl'. destruct Hl' as [?|(?&?&?)]; subst. + left. rewrite E. eauto using sublist_submseteq. + right. eauto using sublist_submseteq. - intros [?|(?&E&?)]; [|rewrite E]; by constructor. Qed. Lemma submseteq_cons_l x l k : x :: l ⊆+ k ↔ ∃ k', k ≡ₚ x :: k' ∧ l ⊆+ k'. Proof. split. - rewrite submseteq_sublist_l. intros (l'&Hl'&E). rewrite sublist_cons_l in Hl'. destruct Hl' as (k1&k2&?&?); subst. exists (k1 ++ k2). split; eauto using submseteq_inserts_l, sublist_submseteq. by rewrite Permutation_middle. - intros (?&E&?). rewrite E. by constructor. Qed. Lemma submseteq_app_r l k1 k2 : l ⊆+ k1 ++ k2 ↔ ∃ l1 l2, l ≡ₚ l1 ++ l2 ∧ l1 ⊆+ k1 ∧ l2 ⊆+ k2. Proof. split. - rewrite submseteq_sublist_r. intros (l'&E&Hl'). rewrite sublist_app_r in Hl'. destruct Hl' as (l1&l2&?&?&?); subst. exists l1, l2. eauto using sublist_submseteq. - intros (?&?&E&?&?). rewrite E. eauto using submseteq_app. Qed. Lemma submseteq_app_l l1 l2 k : l1 ++ l2 ⊆+ k ↔ ∃ k1 k2, k ≡ₚ k1 ++ k2 ∧ l1 ⊆+ k1 ∧ l2 ⊆+ k2. Proof. split. - rewrite submseteq_sublist_l. intros (l'&Hl'&E). rewrite sublist_app_l in Hl'. destruct Hl' as (k1&k2&?&?&?); subst. exists k1, k2. split; [done|]. eauto using sublist_submseteq. - intros (?&?&E&?&?). rewrite E. eauto using submseteq_app. Qed. Lemma submseteq_app_inv_l l1 l2 k : k ++ l1 ⊆+ k ++ l2 → l1 ⊆+ l2. Proof. induction k as [|y k IH]; simpl; [done |]. rewrite submseteq_cons_l. intros (?&E%(inj (cons y))&?). apply IH. by rewrite E. Qed. Lemma submseteq_app_inv_r l1 l2 k : l1 ++ k ⊆+ l2 ++ k → l1 ⊆+ l2. Proof. rewrite <-!(comm (++) k). apply submseteq_app_inv_l. Qed. Lemma submseteq_cons_middle x l k1 k2 : l ⊆+ k1 ++ k2 → x :: l ⊆+ k1 ++ x :: k2. Proof. rewrite <-Permutation_middle. by apply submseteq_skip. Qed. Lemma submseteq_app_middle l1 l2 k1 k2 : l2 ⊆+ k1 ++ k2 → l1 ++ l2 ⊆+ k1 ++ l1 ++ k2. Proof. rewrite !(assoc (++)), (comm (++) k1 l1), <-(assoc_L (++)). by apply submseteq_skips_l. Qed. Lemma submseteq_middle l k1 k2 : l ⊆+ k1 ++ l ++ k2. Proof. by apply submseteq_inserts_l, submseteq_inserts_r. Qed. Lemma NoDup_submseteq l k : NoDup l → (∀ x, x ∈ l → x ∈ k) → l ⊆+ k. Proof. intros Hl. revert k. induction Hl as [|x l Hx ? IH]. { intros k Hk. by apply submseteq_nil_l. } intros k Hlk. destruct (elem_of_list_split k x) as (l1&l2&?); subst. { apply Hlk. by constructor. } rewrite <-Permutation_middle. apply submseteq_skip, IH. intros y Hy. rewrite elem_of_app. specialize (Hlk y). rewrite elem_of_app, !elem_of_cons in Hlk. by destruct Hlk as [?|[?|?]]; subst; eauto. Qed. Lemma NoDup_Permutation l k : NoDup l → NoDup k → (∀ x, x ∈ l ↔ x ∈ k) → l ≡ₚ k. Proof. intros. apply (anti_symm submseteq); apply NoDup_submseteq; naive_solver. Qed. Lemma submseteq_insert l1 l2 i j x y : l1 !! i = Some x → l2 !! j = Some x → l1 ⊆+ l2 → (<[i := y]> l1) ⊆+ (<[j := y]> l2). Proof. intros ?? Hsub. rewrite !insert_take_drop, <-!Permutation_middle by eauto using lookup_lt_Some. rewrite <-(take_drop_middle l1 i x), <-(take_drop_middle l2 j x), <-!Permutation_middle in Hsub by done. by apply submseteq_skip, (submseteq_app_inv_l _ _ [x]). Qed. Lemma singleton_submseteq_l l x : [x] ⊆+ l ↔ x ∈ l. Proof. split. - intros Hsub. eapply elem_of_submseteq; [|done]. apply elem_of_list_singleton. done. - intros (l1&l2&->)%elem_of_list_split. apply submseteq_cons_middle, submseteq_nil_l. Qed. Lemma singleton_submseteq x y : [x] ⊆+ [y] ↔ x = y. Proof. rewrite singleton_submseteq_l. apply elem_of_list_singleton. Qed. Section submseteq_dec. Context `{!EqDecision A}. Lemma list_remove_Permutation l1 l2 k1 x : l1 ≡ₚ l2 → list_remove x l1 = Some k1 → ∃ k2, list_remove x l2 = Some k2 ∧ k1 ≡ₚ k2. Proof. intros Hl. revert k1. induction Hl as [|y l1 l2 ? IH|y1 y2 l|l1 l2 l3 ? IH1 ? IH2]; simpl; intros k1 Hk1. - done. - case_decide; simplify_eq; eauto. destruct (list_remove x l1) as [l|] eqn:?; simplify_eq. destruct (IH l) as (?&?&?); simplify_option_eq; eauto. - simplify_option_eq; eauto using Permutation_swap. - destruct (IH1 k1) as (k2&?&?); trivial. destruct (IH2 k2) as (k3&?&?); trivial. exists k3. split; eauto. by trans k2. Qed. Lemma list_remove_Some l k x : list_remove x l = Some k → l ≡ₚ x :: k. Proof. revert k. induction l as [|y l IH]; simpl; intros k ?; [done |]. simplify_option_eq; auto. by rewrite Permutation_swap, <-IH. Qed. Lemma list_remove_Some_inv l k x : l ≡ₚ x :: k → ∃ k', list_remove x l = Some k' ∧ k ≡ₚ k'. Proof. intros. destruct (list_remove_Permutation (x :: k) l k x) as (k'&?&?). - done. - simpl; by case_decide. - by exists k'. Qed. Lemma list_remove_list_submseteq l1 l2 : l1 ⊆+ l2 ↔ is_Some (list_remove_list l1 l2). Proof. split. - revert l2. induction l1 as [|x l1 IH]; simpl. { intros l2 _. by exists l2. } intros l2. rewrite submseteq_cons_l. intros (k&Hk&?). destruct (list_remove_Some_inv l2 k x) as (k2&?&Hk2); trivial. simplify_option_eq. apply IH. by rewrite <-Hk2. - intros [k Hk]. revert l2 k Hk. induction l1 as [|x l1 IH]; simpl; intros l2 k. { intros. apply submseteq_nil_l. } destruct (list_remove x l2) as [k'|] eqn:?; intros; simplify_eq. rewrite submseteq_cons_l. eauto using list_remove_Some. Qed. Global Instance submseteq_dec : RelDecision (submseteq : relation (list A)). Proof using Type*. refine (λ l1 l2, cast_if (decide (is_Some (list_remove_list l1 l2)))); abstract (rewrite list_remove_list_submseteq; tauto). Defined. Global Instance Permutation_dec : RelDecision (≡ₚ@{A}). Proof using Type*. refine (λ l1 l2, cast_if_and (decide (l1 ⊆+ l2)) (decide (length l2 ≤ length l1))); [by apply submseteq_length_Permutation |abstract (intros He; by rewrite He in *)..]. Defined. End submseteq_dec. (** ** Properties of the [Forall] and [Exists] predicate *) Lemma Forall_Exists_dec (P Q : A → Prop) (dec : ∀ x, {P x} + {Q x}) : ∀ l, {Forall P l} + {Exists Q l}. Proof. refine ( fix go l := match l return {Forall P l} + {Exists Q l} with | [] => left _ | x :: l => cast_if_and (dec x) (go l) end); clear go; intuition. Defined. (** Export the Coq stdlib constructors under different names, because we use [Forall_nil] and [Forall_cons] for a version with a biimplication. *) Definition Forall_nil_2 := @Forall_nil A. Definition Forall_cons_2 := @Forall_cons A. Global Instance Forall_proper: Proper (pointwise_relation _ (↔) ==> (=) ==> (↔)) (@Forall A). Proof. split; subst; induction 1; constructor; by firstorder auto. Qed. Global Instance Exists_proper: Proper (pointwise_relation _ (↔) ==> (=) ==> (↔)) (@Exists A). Proof. split; subst; induction 1; constructor; by firstorder auto. Qed. Section Forall_Exists. Context (P : A → Prop). Lemma Forall_forall l : Forall P l ↔ ∀ x, x ∈ l → P x. Proof. split; [induction 1; inversion 1; subst; auto|]. intros Hin; induction l as [|x l IH]; constructor; [apply Hin; constructor|]. apply IH. intros ??. apply Hin. by constructor. Qed. Lemma Forall_nil : Forall P [] ↔ True. Proof. done. Qed. Lemma Forall_cons_1 x l : Forall P (x :: l) → P x ∧ Forall P l. Proof. by inversion 1. Qed. Lemma Forall_cons x l : Forall P (x :: l) ↔ P x ∧ Forall P l. Proof. split; [by inversion 1|]. intros [??]. by constructor. Qed. Lemma Forall_singleton x : Forall P [x] ↔ P x. Proof. rewrite Forall_cons, Forall_nil; tauto. Qed. Lemma Forall_app_2 l1 l2 : Forall P l1 → Forall P l2 → Forall P (l1 ++ l2). Proof. induction 1; simpl; auto. Qed. Lemma Forall_app l1 l2 : Forall P (l1 ++ l2) ↔ Forall P l1 ∧ Forall P l2. Proof. split; [induction l1; inversion 1; intuition|]. intros [??]; auto using Forall_app_2. Qed. Lemma Forall_true l : (∀ x, P x) → Forall P l. Proof. intros ?. induction l; auto. Defined. Lemma Forall_impl (Q : A → Prop) l : Forall P l → (∀ x, P x → Q x) → Forall Q l. Proof. intros H ?. induction H; auto. Defined. Lemma Forall_iff l (Q : A → Prop) : (∀ x, P x ↔ Q x) → Forall P l ↔ Forall Q l. Proof. intros H. apply Forall_proper. { red; apply H. } done. Qed. Lemma Forall_not l : length l ≠ 0 → Forall (not ∘ P) l → ¬Forall P l. Proof. by destruct 2; inversion 1. Qed. Lemma Forall_and {Q} l : Forall (λ x, P x ∧ Q x) l ↔ Forall P l ∧ Forall Q l. Proof. split; [induction 1; constructor; naive_solver|]. intros [Hl Hl']; revert Hl'; induction Hl; inversion_clear 1; auto. Qed. Lemma Forall_and_l {Q} l : Forall (λ x, P x ∧ Q x) l → Forall P l. Proof. rewrite Forall_and; tauto. Qed. Lemma Forall_and_r {Q} l : Forall (λ x, P x ∧ Q x) l → Forall Q l. Proof. rewrite Forall_and; tauto. Qed. Lemma Forall_delete l i : Forall P l → Forall P (delete i l). Proof. intros H. revert i. by induction H; intros [|i]; try constructor. Qed. Lemma Forall_lookup l : Forall P l ↔ ∀ i x, l !! i = Some x → P x. Proof. rewrite Forall_forall. setoid_rewrite elem_of_list_lookup. naive_solver. Qed. Lemma Forall_lookup_total `{!Inhabited A} l : Forall P l ↔ ∀ i, i < length l → P (l !!! i). Proof. rewrite Forall_lookup. setoid_rewrite list_lookup_alt. naive_solver. Qed. Lemma Forall_lookup_1 l i x : Forall P l → l !! i = Some x → P x. Proof. rewrite Forall_lookup. eauto. Qed. Lemma Forall_lookup_total_1 `{!Inhabited A} l i : Forall P l → i < length l → P (l !!! i). Proof. rewrite Forall_lookup_total. eauto. Qed. Lemma Forall_lookup_2 l : (∀ i x, l !! i = Some x → P x) → Forall P l. Proof. by rewrite Forall_lookup. Qed. Lemma Forall_lookup_total_2 `{!Inhabited A} l : (∀ i, i < length l → P (l !!! i)) → Forall P l. Proof. by rewrite Forall_lookup_total. Qed. Lemma Forall_nth d l : Forall P l ↔ ∀ i, i < length l → P (nth i l d). Proof. rewrite Forall_lookup. split. - intros Hl ? [x Hl']%lookup_lt_is_Some_2. rewrite (nth_lookup_Some _ _ _ _ Hl'). by eapply Hl. - intros Hl i x Hl'. specialize (Hl _ (lookup_lt_Some _ _ _ Hl')). by rewrite (nth_lookup_Some _ _ _ _ Hl') in Hl. Qed. Lemma Forall_reverse l : Forall P (reverse l) ↔ Forall P l. Proof. induction l as [|x l IH]; simpl; [done|]. rewrite reverse_cons, Forall_cons, Forall_app, Forall_singleton. naive_solver. Qed. Lemma Forall_tail l : Forall P l → Forall P (tail l). Proof. destruct 1; simpl; auto. Qed. Lemma Forall_alter f l i : Forall P l → (∀ x, l !! i = Some x → P x → P (f x)) → Forall P (alter f i l). Proof. intros Hl. revert i. induction Hl; simpl; intros [|i]; constructor; auto. Qed. Lemma Forall_alter_inv f l i : Forall P (alter f i l) → (∀ x, l !! i = Some x → P (f x) → P x) → Forall P l. Proof. revert i. induction l; intros [|?]; simpl; inversion_clear 1; constructor; eauto. Qed. Lemma Forall_insert l i x : Forall P l → P x → Forall P (<[i:=x]>l). Proof. rewrite list_insert_alter; auto using Forall_alter. Qed. Lemma Forall_inserts l i k : Forall P l → Forall P k → Forall P (list_inserts i k l). Proof. intros Hl Hk; revert i. induction Hk; simpl; auto using Forall_insert. Qed. Lemma Forall_replicate n x : P x → Forall P (replicate n x). Proof. induction n; simpl; constructor; auto. Qed. Lemma Forall_replicate_eq n (x : A) : Forall (x =.) (replicate n x). Proof using -(P). induction n; simpl; constructor; auto. Qed. Lemma Forall_take n l : Forall P l → Forall P (take n l). Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed. Lemma Forall_drop n l : Forall P l → Forall P (drop n l). Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed. Lemma Forall_resize n x l : P x → Forall P l → Forall P (resize n x l). Proof. intros ? Hl. revert n. induction Hl; intros [|?]; simpl; auto using Forall_replicate. Qed. Lemma Forall_resize_inv n x l : length l ≤ n → Forall P (resize n x l) → Forall P l. Proof. intros ?. rewrite resize_ge, Forall_app by done. by intros []. Qed. Lemma Forall_sublist_lookup l i n k : sublist_lookup i n l = Some k → Forall P l → Forall P k. Proof. unfold sublist_lookup. intros; simplify_option_eq. auto using Forall_take, Forall_drop. Qed. Lemma Forall_sublist_alter f l i n k : Forall P l → sublist_lookup i n l = Some k → Forall P (f k) → Forall P (sublist_alter f i n l). Proof. unfold sublist_alter, sublist_lookup. intros; simplify_option_eq. auto using Forall_app_2, Forall_drop, Forall_take. Qed. Lemma Forall_sublist_alter_inv f l i n k : sublist_lookup i n l = Some k → Forall P (sublist_alter f i n l) → Forall P (f k). Proof. unfold sublist_alter, sublist_lookup. intros ?; simplify_option_eq. rewrite !Forall_app; tauto. Qed. Lemma Forall_reshape l szs : Forall P l → Forall (Forall P) (reshape szs l). Proof. revert l. induction szs; simpl; auto using Forall_take, Forall_drop. Qed. Lemma Forall_rev_ind (Q : list A → Prop) : Q [] → (∀ x l, P x → Forall P l → Q l → Q (l ++ [x])) → ∀ l, Forall P l → Q l. Proof. intros ?? l. induction l using rev_ind; auto. rewrite Forall_app, Forall_singleton; intros [??]; auto. Qed. Lemma Exists_exists l : Exists P l ↔ ∃ x, x ∈ l ∧ P x. Proof. split. - induction 1 as [x|y ?? [x [??]]]; exists x; by repeat constructor. - intros [x [Hin ?]]. induction l; [by destruct (not_elem_of_nil x)|]. inversion Hin; subst; [left|right]; auto. Qed. Lemma Exists_inv x l : Exists P (x :: l) → P x ∨ Exists P l. Proof. inversion 1; intuition trivial. Qed. Lemma Exists_app l1 l2 : Exists P (l1 ++ l2) ↔ Exists P l1 ∨ Exists P l2. Proof. split. - induction l1; inversion 1; intuition. - intros [H|H]; [induction H | induction l1]; simpl; intuition. Qed. Lemma Exists_impl (Q : A → Prop) l : Exists P l → (∀ x, P x → Q x) → Exists Q l. Proof. intros H ?. induction H; auto. Defined. Lemma Exists_not_Forall l : Exists (not ∘ P) l → ¬Forall P l. Proof. induction 1; inversion_clear 1; contradiction. Qed. Lemma Forall_not_Exists l : Forall (not ∘ P) l → ¬Exists P l. Proof. induction 1; inversion_clear 1; contradiction. Qed. Lemma Forall_list_difference `{!EqDecision A} l k : Forall P l → Forall P (list_difference l k). Proof. rewrite !Forall_forall. intros ? x; rewrite elem_of_list_difference; naive_solver. Qed. Lemma Forall_list_union `{!EqDecision A} l k : Forall P l → Forall P k → Forall P (list_union l k). Proof. intros. apply Forall_app; auto using Forall_list_difference. Qed. Lemma Forall_list_intersection `{!EqDecision A} l k : Forall P l → Forall P (list_intersection l k). Proof. rewrite !Forall_forall. intros ? x; rewrite elem_of_list_intersection; naive_solver. Qed. Context {dec : ∀ x, Decision (P x)}. Lemma not_Forall_Exists l : ¬Forall P l → Exists (not ∘ P) l. Proof using Type*. intro. by destruct (Forall_Exists_dec P (not ∘ P) dec l). Qed. Lemma not_Exists_Forall l : ¬Exists P l → Forall (not ∘ P) l. Proof using Type*. by destruct (Forall_Exists_dec (not ∘ P) P (λ x : A, swap_if (decide (P x))) l). Qed. Global Instance Forall_dec l : Decision (Forall P l) := match Forall_Exists_dec P (not ∘ P) dec l with | left H => left H | right H => right (Exists_not_Forall _ H) end. Global Instance Exists_dec l : Decision (Exists P l) := match Forall_Exists_dec (not ∘ P) P (λ x, swap_if (decide (P x))) l with | left H => right (Forall_not_Exists _ H) | right H => left H end. End Forall_Exists. Global Instance Forall_Permutation : Proper (pointwise_relation _ (↔) ==> (≡ₚ) ==> (↔)) (@Forall A). Proof. intros P1 P2 HP l1 l2 Hl. rewrite !Forall_forall. apply forall_proper; intros x. by rewrite Hl, (HP x). Qed. Global Instance Exists_Permutation : Proper (pointwise_relation _ (↔) ==> (≡ₚ) ==> (↔)) (@Exists A). Proof. intros P1 P2 HP l1 l2 Hl. rewrite !Exists_exists. f_equiv; intros x. by rewrite Hl, (HP x). Qed. Lemma head_filter_Some P `{!∀ x : A, Decision (P x)} l x : head (filter P l) = Some x → ∃ l1 l2, l = l1 ++ x :: l2 ∧ Forall (λ z, ¬P z) l1. Proof. intros Hl. induction l as [|x' l IH]; [done|]. rewrite filter_cons in Hl. case_decide; simplify_eq/=. - exists [], l. repeat constructor. - destruct IH as (l1&l2&->&?); [done|]. exists (x' :: l1), l2. by repeat constructor. Qed. Lemma last_filter_Some P `{!∀ x : A, Decision (P x)} l x : last (filter P l) = Some x → ∃ l1 l2, l = l1 ++ x :: l2 ∧ Forall (λ z, ¬P z) l2. Proof. rewrite <-(reverse_involutive (filter P l)), last_reverse, <-filter_reverse. intros (l1&l2&Heq&Hl)%head_filter_Some. exists (reverse l2), (reverse l1). rewrite <-(reverse_involutive l), Heq, reverse_app, reverse_cons, <-(assoc_L (++)). split; [done|by apply Forall_reverse]. Qed. Lemma list_exist_dec P l : (∀ x, Decision (P x)) → Decision (∃ x, x ∈ l ∧ P x). Proof. refine (λ _, cast_if (decide (Exists P l))); by rewrite <-Exists_exists. Defined. Lemma list_forall_dec P l : (∀ x, Decision (P x)) → Decision (∀ x, x ∈ l → P x). Proof. refine (λ _, cast_if (decide (Forall P l))); by rewrite <-Forall_forall. Defined. Lemma forallb_True (f : A → bool) xs : forallb f xs ↔ Forall f xs. Proof. split. - induction xs; naive_solver. - induction 1; naive_solver. Qed. Lemma existb_True (f : A → bool) xs : existsb f xs ↔ Exists f xs. Proof. split. - induction xs; naive_solver. - induction 1; naive_solver. Qed. Lemma replicate_as_Forall (x : A) n l : replicate n x = l ↔ length l = n ∧ Forall (x =.) l. Proof. rewrite replicate_as_elem_of, Forall_forall. naive_solver. Qed. Lemma replicate_as_Forall_2 (x : A) n l : length l = n → Forall (x =.) l → replicate n x = l. Proof. by rewrite replicate_as_Forall. Qed. End more_general_properties. Lemma Forall_swap {A B} (Q : A → B → Prop) l1 l2 : Forall (λ y, Forall (Q y) l1) l2 ↔ Forall (λ x, Forall (flip Q x) l2) l1. Proof. repeat setoid_rewrite Forall_forall. simpl. split; eauto. Qed. (** ** Properties of the [Forall2] predicate *) Lemma Forall_Forall2_diag {A} (Q : A → A → Prop) l : Forall (λ x, Q x x) l → Forall2 Q l l. Proof. induction 1; constructor; auto. Qed. Lemma Forall2_forall `{Inhabited A} B C (Q : A → B → C → Prop) l k : Forall2 (λ x y, ∀ z, Q z x y) l k ↔ ∀ z, Forall2 (Q z) l k. Proof. split; [induction 1; constructor; auto|]. intros Hlk. induction (Hlk inhabitant) as [|x y l k _ _ IH]; constructor. - intros z. by oinversion Hlk. - apply IH. intros z. by oinversion Hlk. Qed. Lemma Forall2_same_length {A B} (l : list A) (k : list B) : Forall2 (λ _ _, True) l k ↔ length l = length k. Proof. split; [by induction 1; f_equal/=|]. revert k. induction l; intros [|??] ?; simplify_eq/=; auto. Qed. Lemma Forall2_Forall {A} P (l1 l2 : list A) : Forall2 P l1 l2 → Forall (uncurry P) (zip l1 l2). Proof. induction 1; constructor; auto. Qed. (** Export the Coq stdlib constructors under a different name, because we use [Forall2_nil] and [Forall2_cons] for a version with a biimplication. *) Definition Forall2_nil_2 := @Forall2_nil. Definition Forall2_cons_2 := @Forall2_cons. Section Forall2. Context {A B} (P : A → B → Prop). Implicit Types x : A. Implicit Types y : B. Implicit Types l : list A. Implicit Types k : list B. Lemma Forall2_length l k : Forall2 P l k → length l = length k. Proof. by induction 1; f_equal/=. Qed. Lemma Forall2_length_l l k n : Forall2 P l k → length l = n → length k = n. Proof. intros ? <-; symmetry. by apply Forall2_length. Qed. Lemma Forall2_length_r l k n : Forall2 P l k → length k = n → length l = n. Proof. intros ? <-. by apply Forall2_length. Qed. Lemma Forall2_true l k : (∀ x y, P x y) → length l = length k → Forall2 P l k. Proof. rewrite <-Forall2_same_length. induction 2; naive_solver. Qed. Lemma Forall2_flip l k : Forall2 (flip P) k l ↔ Forall2 P l k. Proof. split; induction 1; constructor; auto. Qed. Lemma Forall2_transitive {C} (Q : B → C → Prop) (R : A → C → Prop) l k lC : (∀ x y z, P x y → Q y z → R x z) → Forall2 P l k → Forall2 Q k lC → Forall2 R l lC. Proof. intros ? Hl. revert lC. induction Hl; inversion_clear 1; eauto. Qed. Lemma Forall2_impl (Q : A → B → Prop) l k : Forall2 P l k → (∀ x y, P x y → Q x y) → Forall2 Q l k. Proof. intros H ?. induction H; auto. Defined. Lemma Forall2_unique l k1 k2 : Forall2 P l k1 → Forall2 P l k2 → (∀ x y1 y2, P x y1 → P x y2 → y1 = y2) → k1 = k2. Proof. intros H. revert k2. induction H; inversion_clear 1; intros; f_equal; eauto. Qed. Lemma Forall_Forall2_l l k : length l = length k → Forall (λ x, ∀ y, P x y) l → Forall2 P l k. Proof. rewrite <-Forall2_same_length. induction 1; inversion 1; auto. Qed. Lemma Forall_Forall2_r l k : length l = length k → Forall (λ y, ∀ x, P x y) k → Forall2 P l k. Proof. rewrite <-Forall2_same_length. induction 1; inversion 1; auto. Qed. Lemma Forall2_Forall_l (Q : A → Prop) l k : Forall2 P l k → Forall (λ y, ∀ x, P x y → Q x) k → Forall Q l. Proof. induction 1; inversion_clear 1; eauto. Qed. Lemma Forall2_Forall_r (Q : B → Prop) l k : Forall2 P l k → Forall (λ x, ∀ y, P x y → Q y) l → Forall Q k. Proof. induction 1; inversion_clear 1; eauto. Qed. Lemma Forall2_nil_inv_l k : Forall2 P [] k → k = []. Proof. by inversion 1. Qed. Lemma Forall2_nil_inv_r l : Forall2 P l [] → l = []. Proof. by inversion 1. Qed. Lemma Forall2_nil : Forall2 P [] [] ↔ True. Proof. done. Qed. Lemma Forall2_cons_1 x l y k : Forall2 P (x :: l) (y :: k) → P x y ∧ Forall2 P l k. Proof. by inversion 1. Qed. Lemma Forall2_cons_inv_l x l k : Forall2 P (x :: l) k → ∃ y k', P x y ∧ Forall2 P l k' ∧ k = y :: k'. Proof. inversion 1; subst; eauto. Qed. Lemma Forall2_cons_inv_r l k y : Forall2 P l (y :: k) → ∃ x l', P x y ∧ Forall2 P l' k ∧ l = x :: l'. Proof. inversion 1; subst; eauto. Qed. Lemma Forall2_cons_nil_inv x l : Forall2 P (x :: l) [] → False. Proof. by inversion 1. Qed. Lemma Forall2_nil_cons_inv y k : Forall2 P [] (y :: k) → False. Proof. by inversion 1. Qed. Lemma Forall2_cons x l y k : Forall2 P (x :: l) (y :: k) ↔ P x y ∧ Forall2 P l k. Proof. split; [by apply Forall2_cons_1|]. intros []. by apply Forall2_cons_2. Qed. Lemma Forall2_app_l l1 l2 k : Forall2 P l1 (take (length l1) k) → Forall2 P l2 (drop (length l1) k) → Forall2 P (l1 ++ l2) k. Proof. intros. rewrite <-(take_drop (length l1) k). by apply Forall2_app. Qed. Lemma Forall2_app_r l k1 k2 : Forall2 P (take (length k1) l) k1 → Forall2 P (drop (length k1) l) k2 → Forall2 P l (k1 ++ k2). Proof. intros. rewrite <-(take_drop (length k1) l). by apply Forall2_app. Qed. Lemma Forall2_app_inv l1 l2 k1 k2 : length l1 = length k1 → Forall2 P (l1 ++ l2) (k1 ++ k2) → Forall2 P l1 k1 ∧ Forall2 P l2 k2. Proof. rewrite <-Forall2_same_length. induction 1; inversion 1; naive_solver. Qed. Lemma Forall2_app_inv_l l1 l2 k : Forall2 P (l1 ++ l2) k ↔ ∃ k1 k2, Forall2 P l1 k1 ∧ Forall2 P l2 k2 ∧ k = k1 ++ k2. Proof. split; [|intros (?&?&?&?&->); by apply Forall2_app]. revert k. induction l1; inversion 1; naive_solver. Qed. Lemma Forall2_app_inv_r l k1 k2 : Forall2 P l (k1 ++ k2) ↔ ∃ l1 l2, Forall2 P l1 k1 ∧ Forall2 P l2 k2 ∧ l = l1 ++ l2. Proof. split; [|intros (?&?&?&?&->); by apply Forall2_app]. revert l. induction k1; inversion 1; naive_solver. Qed. Lemma Forall2_tail l k : Forall2 P l k → Forall2 P (tail l) (tail k). Proof. destruct 1; simpl; auto. Qed. Lemma Forall2_take l k n : Forall2 P l k → Forall2 P (take n l) (take n k). Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed. Lemma Forall2_drop l k n : Forall2 P l k → Forall2 P (drop n l) (drop n k). Proof. intros Hl. revert n. induction Hl; intros [|?]; simpl; auto. Qed. Lemma Forall2_lookup l k : Forall2 P l k ↔ ∀ i, option_Forall2 P (l !! i) (k !! i). Proof. split; [induction 1; intros [|?]; simpl; try constructor; eauto|]. revert k. induction l as [|x l IH]; intros [| y k] H. - done. - oinversion (H 0). - oinversion (H 0). - constructor; [by oinversion (H 0)|]. apply (IH _ $ λ i, H (S i)). Qed. Lemma Forall2_lookup_lr l k i x y : Forall2 P l k → l !! i = Some x → k !! i = Some y → P x y. Proof. rewrite Forall2_lookup; intros H; destruct (H i); naive_solver. Qed. Lemma Forall2_lookup_l l k i x : Forall2 P l k → l !! i = Some x → ∃ y, k !! i = Some y ∧ P x y. Proof. rewrite Forall2_lookup; intros H; destruct (H i); naive_solver. Qed. Lemma Forall2_lookup_r l k i y : Forall2 P l k → k !! i = Some y → ∃ x, l !! i = Some x ∧ P x y. Proof. rewrite Forall2_lookup; intros H; destruct (H i); naive_solver. Qed. Lemma Forall2_same_length_lookup_2 l k : length l = length k → (∀ i x y, l !! i = Some x → k !! i = Some y → P x y) → Forall2 P l k. Proof. rewrite <-Forall2_same_length. intros Hl Hlookup. induction Hl as [|?????? IH]; constructor; [by apply (Hlookup 0)|]. apply IH. apply (λ i, Hlookup (S i)). Qed. Lemma Forall2_same_length_lookup l k : Forall2 P l k ↔ length l = length k ∧ (∀ i x y, l !! i = Some x → k !! i = Some y → P x y). Proof. naive_solver eauto using Forall2_length, Forall2_lookup_lr, Forall2_same_length_lookup_2. Qed. Lemma Forall2_alter_l f l k i : Forall2 P l k → (∀ x y, l !! i = Some x → k !! i = Some y → P x y → P (f x) y) → Forall2 P (alter f i l) k. Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed. Lemma Forall2_alter_r f l k i : Forall2 P l k → (∀ x y, l !! i = Some x → k !! i = Some y → P x y → P x (f y)) → Forall2 P l (alter f i k). Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed. Lemma Forall2_alter f g l k i : Forall2 P l k → (∀ x y, l !! i = Some x → k !! i = Some y → P x y → P (f x) (g y)) → Forall2 P (alter f i l) (alter g i k). Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed. Lemma Forall2_insert l k x y i : Forall2 P l k → P x y → Forall2 P (<[i:=x]> l) (<[i:=y]> k). Proof. intros Hl. revert i. induction Hl; intros [|]; constructor; auto. Qed. Lemma Forall2_inserts l k l' k' i : Forall2 P l k → Forall2 P l' k' → Forall2 P (list_inserts i l' l) (list_inserts i k' k). Proof. intros ? H. revert i. induction H; eauto using Forall2_insert. Qed. Lemma Forall2_delete l k i : Forall2 P l k → Forall2 P (delete i l) (delete i k). Proof. intros Hl. revert i. induction Hl; intros [|]; simpl; intuition. Qed. Lemma Forall2_option_list mx my : option_Forall2 P mx my → Forall2 P (option_list mx) (option_list my). Proof. destruct 1; by constructor. Qed. Lemma Forall2_filter Q1 Q2 `{∀ x, Decision (Q1 x), ∀ y, Decision (Q2 y)} l k: (∀ x y, P x y → Q1 x ↔ Q2 y) → Forall2 P l k → Forall2 P (filter Q1 l) (filter Q2 k). Proof. intros HP; induction 1 as [|x y l k]; unfold filter; simpl; auto. simplify_option_eq by (by rewrite <-(HP x y)); repeat constructor; auto. Qed. Lemma Forall2_replicate_l k n x : length k = n → Forall (P x) k → Forall2 P (replicate n x) k. Proof. intros <-. induction 1; simpl; auto. Qed. Lemma Forall2_replicate_r l n y : length l = n → Forall (flip P y) l → Forall2 P l (replicate n y). Proof. intros <-. induction 1; simpl; auto. Qed. Lemma Forall2_replicate n x y : P x y → Forall2 P (replicate n x) (replicate n y). Proof. induction n; simpl; constructor; auto. Qed. Lemma Forall2_rotate n l k : Forall2 P l k → Forall2 P (rotate n l) (rotate n k). Proof. intros HAll. unfold rotate. rewrite (Forall2_length _ _ HAll). eauto using Forall2_app, Forall2_take, Forall2_drop. Qed. Lemma Forall2_rotate_take s e l k : Forall2 P l k → Forall2 P (rotate_take s e l) (rotate_take s e k). Proof. intros HAll. unfold rotate_take. rewrite (Forall2_length _ _ HAll). eauto using Forall2_take, Forall2_rotate. Qed. Lemma Forall2_reverse l k : Forall2 P l k → Forall2 P (reverse l) (reverse k). Proof. induction 1; rewrite ?reverse_nil, ?reverse_cons; eauto using Forall2_app. Qed. Lemma Forall2_last l k : Forall2 P l k → option_Forall2 P (last l) (last k). Proof. induction 1 as [|????? []]; simpl; repeat constructor; auto. Qed. Lemma Forall2_resize l k x y n : P x y → Forall2 P l k → Forall2 P (resize n x l) (resize n y k). Proof. intros. rewrite !resize_spec, (Forall2_length l k) by done. auto using Forall2_app, Forall2_take, Forall2_replicate. Qed. Lemma Forall2_resize_l l k x y n m : P x y → Forall (flip P y) l → Forall2 P (resize n x l) k → Forall2 P (resize m x l) (resize m y k). Proof. intros. destruct (decide (m ≤ n)). { rewrite <-(resize_resize l m n) by done. by apply Forall2_resize. } intros. assert (n = length k); subst. { by rewrite <-(Forall2_length (resize n x l) k), resize_length. } rewrite (Nat.le_add_sub (length k) m), !resize_add, resize_all, drop_all, resize_nil by lia. auto using Forall2_app, Forall2_replicate_r, Forall_resize, Forall_drop, resize_length. Qed. Lemma Forall2_resize_r l k x y n m : P x y → Forall (P x) k → Forall2 P l (resize n y k) → Forall2 P (resize m x l) (resize m y k). Proof. intros. destruct (decide (m ≤ n)). { rewrite <-(resize_resize k m n) by done. by apply Forall2_resize. } assert (n = length l); subst. { by rewrite (Forall2_length l (resize n y k)), resize_length. } rewrite (Nat.le_add_sub (length l) m), !resize_add, resize_all, drop_all, resize_nil by lia. auto using Forall2_app, Forall2_replicate_l, Forall_resize, Forall_drop, resize_length. Qed. Lemma Forall2_resize_r_flip l k x y n m : P x y → Forall (P x) k → length k = m → Forall2 P l (resize n y k) → Forall2 P (resize m x l) k. Proof. intros ?? <- ?. rewrite <-(resize_all k y) at 2. apply Forall2_resize_r with n; auto using Forall_true. Qed. Lemma Forall2_sublist_lookup_l l k n i l' : Forall2 P l k → sublist_lookup n i l = Some l' → ∃ k', sublist_lookup n i k = Some k' ∧ Forall2 P l' k'. Proof. unfold sublist_lookup. intros Hlk Hl. exists (take i (drop n k)); simplify_option_eq. - auto using Forall2_take, Forall2_drop. - apply Forall2_length in Hlk; lia. Qed. Lemma Forall2_sublist_lookup_r l k n i k' : Forall2 P l k → sublist_lookup n i k = Some k' → ∃ l', sublist_lookup n i l = Some l' ∧ Forall2 P l' k'. Proof. intro. unfold sublist_lookup. erewrite Forall2_length by eauto; intros; simplify_option_eq. eauto using Forall2_take, Forall2_drop. Qed. Lemma Forall2_sublist_alter f g l k i n l' k' : Forall2 P l k → sublist_lookup i n l = Some l' → sublist_lookup i n k = Some k' → Forall2 P (f l') (g k') → Forall2 P (sublist_alter f i n l) (sublist_alter g i n k). Proof. intro. unfold sublist_alter, sublist_lookup. erewrite Forall2_length by eauto; intros; simplify_option_eq. auto using Forall2_app, Forall2_drop, Forall2_take. Qed. Lemma Forall2_sublist_alter_l f l k i n l' k' : Forall2 P l k → sublist_lookup i n l = Some l' → sublist_lookup i n k = Some k' → Forall2 P (f l') k' → Forall2 P (sublist_alter f i n l) k. Proof. intro. unfold sublist_lookup, sublist_alter. erewrite <-Forall2_length by eauto; intros; simplify_option_eq. apply Forall2_app_l; rewrite ?take_length_le by lia; auto using Forall2_take. apply Forall2_app_l; erewrite Forall2_length, take_length, drop_length, <-Forall2_length, Nat.min_l by eauto with lia; [done|]. rewrite drop_drop; auto using Forall2_drop. Qed. Global Instance Forall2_dec `{dec : ∀ x y, Decision (P x y)} : RelDecision (Forall2 P). Proof. refine ( fix go l k : Decision (Forall2 P l k) := match l, k with | [], [] => left _ | x :: l, y :: k => cast_if_and (decide (P x y)) (go l k) | _, _ => right _ end); clear dec go; abstract first [by constructor | by inversion 1]. Defined. End Forall2. Section Forall2_proper. Context {A} (R : relation A). Global Instance: Reflexive R → Reflexive (Forall2 R). Proof. intros ? l. induction l; by constructor. Qed. Global Instance: Symmetric R → Symmetric (Forall2 R). Proof. intros. induction 1; constructor; auto. Qed. Global Instance: Transitive R → Transitive (Forall2 R). Proof. intros ????. apply Forall2_transitive. by apply @transitivity. Qed. Global Instance: Equivalence R → Equivalence (Forall2 R). Proof. split; apply _. Qed. Global Instance: PreOrder R → PreOrder (Forall2 R). Proof. split; apply _. Qed. Global Instance: AntiSymm (=) R → AntiSymm (=) (Forall2 R). Proof. induction 2; inversion_clear 1; f_equal; auto. Qed. Global Instance: Proper (R ==> Forall2 R ==> Forall2 R) (::). Proof. by constructor. Qed. Global Instance: Proper (Forall2 R ==> Forall2 R ==> Forall2 R) (++). Proof. repeat intro. by apply Forall2_app. Qed. Global Instance: Proper (Forall2 R ==> (=)) length. Proof. repeat intro. eauto using Forall2_length. Qed. Global Instance: Proper (Forall2 R ==> Forall2 R) tail. Proof. repeat intro. eauto using Forall2_tail. Qed. Global Instance: ∀ n, Proper (Forall2 R ==> Forall2 R) (take n). Proof. repeat intro. eauto using Forall2_take. Qed. Global Instance: ∀ n, Proper (Forall2 R ==> Forall2 R) (drop n). Proof. repeat intro. eauto using Forall2_drop. Qed. Global Instance: ∀ i, Proper (Forall2 R ==> option_Forall2 R) (lookup i). Proof. repeat intro. by apply Forall2_lookup. Qed. Global Instance: Proper ((R ==> R) ==> (=) ==> Forall2 R ==> Forall2 R) (alter (M:=list A)). Proof. repeat intro. subst. eauto using Forall2_alter. Qed. Global Instance: ∀ i, Proper (R ==> Forall2 R ==> Forall2 R) (insert i). Proof. repeat intro. eauto using Forall2_insert. Qed. Global Instance: ∀ i, Proper (Forall2 R ==> Forall2 R ==> Forall2 R) (list_inserts i). Proof. repeat intro. eauto using Forall2_inserts. Qed. Global Instance: ∀ i, Proper (Forall2 R ==> Forall2 R) (delete i). Proof. repeat intro. eauto using Forall2_delete. Qed. Global Instance: Proper (option_Forall2 R ==> Forall2 R) option_list. Proof. repeat intro. eauto using Forall2_option_list. Qed. Global Instance: ∀ P `{∀ x, Decision (P x)}, Proper (R ==> iff) P → Proper (Forall2 R ==> Forall2 R) (filter P). Proof. repeat intro; eauto using Forall2_filter. Qed. Global Instance: ∀ n, Proper (R ==> Forall2 R) (replicate n). Proof. repeat intro. eauto using Forall2_replicate. Qed. Global Instance: ∀ n, Proper (Forall2 R ==> Forall2 R) (rotate n). Proof. repeat intro. eauto using Forall2_rotate. Qed. Global Instance: ∀ s e, Proper (Forall2 R ==> Forall2 R) (rotate_take s e). Proof. repeat intro. eauto using Forall2_rotate_take. Qed. Global Instance: Proper (Forall2 R ==> Forall2 R) reverse. Proof. repeat intro. eauto using Forall2_reverse. Qed. Global Instance: Proper (Forall2 R ==> option_Forall2 R) last. Proof. repeat intro. eauto using Forall2_last. Qed. Global Instance: ∀ n, Proper (R ==> Forall2 R ==> Forall2 R) (resize n). Proof. repeat intro. eauto using Forall2_resize. Qed. End Forall2_proper. Section Forall3. Context {A B C} (P : A → B → C → Prop). Local Hint Extern 0 (Forall3 _ _ _ _) => constructor : core. Lemma Forall3_app l1 l2 k1 k2 k1' k2' : Forall3 P l1 k1 k1' → Forall3 P l2 k2 k2' → Forall3 P (l1 ++ l2) (k1 ++ k2) (k1' ++ k2'). Proof. induction 1; simpl; auto. Qed. Lemma Forall3_cons_inv_l x l k k' : Forall3 P (x :: l) k k' → ∃ y k2 z k2', k = y :: k2 ∧ k' = z :: k2' ∧ P x y z ∧ Forall3 P l k2 k2'. Proof. inversion_clear 1; naive_solver. Qed. Lemma Forall3_app_inv_l l1 l2 k k' : Forall3 P (l1 ++ l2) k k' → ∃ k1 k2 k1' k2', k = k1 ++ k2 ∧ k' = k1' ++ k2' ∧ Forall3 P l1 k1 k1' ∧ Forall3 P l2 k2 k2'. Proof. revert k k'. induction l1 as [|x l1 IH]; simpl; inversion_clear 1. - by repeat eexists; eauto. - by repeat eexists; eauto. - edestruct IH as (?&?&?&?&?&?&?&?); eauto; naive_solver. Qed. Lemma Forall3_cons_inv_m l y k k' : Forall3 P l (y :: k) k' → ∃ x l2 z k2', l = x :: l2 ∧ k' = z :: k2' ∧ P x y z ∧ Forall3 P l2 k k2'. Proof. inversion_clear 1; naive_solver. Qed. Lemma Forall3_app_inv_m l k1 k2 k' : Forall3 P l (k1 ++ k2) k' → ∃ l1 l2 k1' k2', l = l1 ++ l2 ∧ k' = k1' ++ k2' ∧ Forall3 P l1 k1 k1' ∧ Forall3 P l2 k2 k2'. Proof. revert l k'. induction k1 as [|x k1 IH]; simpl; inversion_clear 1. - by repeat eexists; eauto. - by repeat eexists; eauto. - edestruct IH as (?&?&?&?&?&?&?&?); eauto; naive_solver. Qed. Lemma Forall3_cons_inv_r l k z k' : Forall3 P l k (z :: k') → ∃ x l2 y k2, l = x :: l2 ∧ k = y :: k2 ∧ P x y z ∧ Forall3 P l2 k2 k'. Proof. inversion_clear 1; naive_solver. Qed. Lemma Forall3_app_inv_r l k k1' k2' : Forall3 P l k (k1' ++ k2') → ∃ l1 l2 k1 k2, l = l1 ++ l2 ∧ k = k1 ++ k2 ∧ Forall3 P l1 k1 k1' ∧ Forall3 P l2 k2 k2'. Proof. revert l k. induction k1' as [|x k1' IH]; simpl; inversion_clear 1. - by repeat eexists; eauto. - by repeat eexists; eauto. - edestruct IH as (?&?&?&?&?&?&?&?); eauto; naive_solver. Qed. Lemma Forall3_impl (Q : A → B → C → Prop) l k k' : Forall3 P l k k' → (∀ x y z, P x y z → Q x y z) → Forall3 Q l k k'. Proof. intros Hl ?; induction Hl; auto. Defined. Lemma Forall3_length_lm l k k' : Forall3 P l k k' → length l = length k. Proof. by induction 1; f_equal/=. Qed. Lemma Forall3_length_lr l k k' : Forall3 P l k k' → length l = length k'. Proof. by induction 1; f_equal/=. Qed. Lemma Forall3_lookup_lmr l k k' i x y z : Forall3 P l k k' → l !! i = Some x → k !! i = Some y → k' !! i = Some z → P x y z. Proof. intros H. revert i. induction H; intros [|?] ???; simplify_eq/=; eauto. Qed. Lemma Forall3_lookup_l l k k' i x : Forall3 P l k k' → l !! i = Some x → ∃ y z, k !! i = Some y ∧ k' !! i = Some z ∧ P x y z. Proof. intros H. revert i. induction H; intros [|?] ?; simplify_eq/=; eauto. Qed. Lemma Forall3_lookup_m l k k' i y : Forall3 P l k k' → k !! i = Some y → ∃ x z, l !! i = Some x ∧ k' !! i = Some z ∧ P x y z. Proof. intros H. revert i. induction H; intros [|?] ?; simplify_eq/=; eauto. Qed. Lemma Forall3_lookup_r l k k' i z : Forall3 P l k k' → k' !! i = Some z → ∃ x y, l !! i = Some x ∧ k !! i = Some y ∧ P x y z. Proof. intros H. revert i. induction H; intros [|?] ?; simplify_eq/=; eauto. Qed. Lemma Forall3_alter_lm f g l k k' i : Forall3 P l k k' → (∀ x y z, l !! i = Some x → k !! i = Some y → k' !! i = Some z → P x y z → P (f x) (g y) z) → Forall3 P (alter f i l) (alter g i k) k'. Proof. intros Hl. revert i. induction Hl; intros [|]; auto. Qed. End Forall3. (** ** Properties of [subseteq] *) Section subseteq. Context {A : Type}. Implicit Types x y z : A. Implicit Types l k : list A. Global Instance list_subseteq_po : PreOrder (⊆@{list A}). Proof. split; firstorder. Qed. Lemma list_subseteq_nil l : [] ⊆ l. Proof. intros x. by rewrite elem_of_nil. Qed. Lemma list_nil_subseteq l : l ⊆ [] → l = []. Proof. intro Hl. destruct l as [|x l1]; [done|]. exfalso. rewrite <-(elem_of_nil x). apply Hl, elem_of_cons. by left. Qed. Lemma list_subseteq_skip x l1 l2 : l1 ⊆ l2 → x :: l1 ⊆ x :: l2. Proof. intros Hin y Hy%elem_of_cons. destruct Hy as [-> | Hy]; [by left|]. right. by apply Hin. Qed. Lemma list_subseteq_cons x l1 l2 : l1 ⊆ l2 → l1 ⊆ x :: l2. Proof. intros Hin y Hy. right. by apply Hin. Qed. Lemma list_subseteq_app_l l1 l2 l : l1 ⊆ l2 → l1 ⊆ l2 ++ l. Proof. unfold subseteq, list_subseteq. setoid_rewrite elem_of_app. naive_solver. Qed. Lemma list_subseteq_app_r l1 l2 l : l1 ⊆ l2 → l1 ⊆ l ++ l2. Proof. unfold subseteq, list_subseteq. setoid_rewrite elem_of_app. naive_solver. Qed. Lemma list_subseteq_app_iff_l l1 l2 l : l1 ++ l2 ⊆ l ↔ l1 ⊆ l ∧ l2 ⊆ l. Proof. unfold subseteq, list_subseteq. setoid_rewrite elem_of_app. naive_solver. Qed. Lemma list_subseteq_cons_iff x l1 l2 : x :: l1 ⊆ l2 ↔ x ∈ l2 ∧ l1 ⊆ l2. Proof. unfold subseteq, list_subseteq. setoid_rewrite elem_of_cons. naive_solver. Qed. Lemma list_delete_subseteq i l : delete i l ⊆ l. Proof. revert i. induction l as [|x l IHl]; intros i; [done|]. destruct i as [|i]; [by apply list_subseteq_cons|by apply list_subseteq_skip]. Qed. Lemma list_filter_subseteq P `{!∀ x : A, Decision (P x)} l : filter P l ⊆ l. Proof. induction l as [|x l IHl]; [done|]. rewrite filter_cons. destruct (decide (P x)); [by apply list_subseteq_skip|by apply list_subseteq_cons]. Qed. Lemma subseteq_drop n l : drop n l ⊆ l. Proof. rewrite <-(take_drop n l) at 2. apply list_subseteq_app_r. done. Qed. Lemma subseteq_take n l : take n l ⊆ l. Proof. rewrite <-(take_drop n l) at 2. apply list_subseteq_app_l. done. Qed. Global Instance list_subseteq_Permutation: Proper ((≡ₚ) ==> (≡ₚ) ==> (↔)) (⊆@{list A}) . Proof. intros l1 l2 Hl k1 k2 Hk. apply forall_proper; intros x. by rewrite Hl, Hk. Qed. Global Program Instance list_subseteq_dec `{!EqDecision A} : RelDecision (⊆@{list A}) := λ xs ys, cast_if (decide (Forall (λ x, x ∈ ys) xs)). Next Obligation. intros ???. by rewrite Forall_forall. Qed. Next Obligation. intros ???. by rewrite Forall_forall. Qed. End subseteq. (** Setoids *) Section setoid. Context `{Equiv A}. Implicit Types l k : list A. Lemma list_equiv_Forall2 l k : l ≡ k ↔ Forall2 (≡) l k. Proof. split; induction 1; constructor; auto. Qed. Lemma list_equiv_lookup l k : l ≡ k ↔ ∀ i, l !! i ≡ k !! i. Proof. rewrite list_equiv_Forall2, Forall2_lookup. by setoid_rewrite option_equiv_Forall2. Qed. Global Instance list_equivalence : Equivalence (≡@{A}) → Equivalence (≡@{list A}). Proof. split. - intros l. by apply list_equiv_Forall2. - intros l k; rewrite !list_equiv_Forall2; by intros. - intros l1 l2 l3; rewrite !list_equiv_Forall2; intros; by trans l2. Qed. Global Instance list_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (list A). Proof. induction 1; f_equal; fold_leibniz; auto. Qed. Global Instance cons_proper : Proper ((≡) ==> (≡) ==> (≡@{list A})) cons. Proof. by constructor. Qed. Global Instance app_proper : Proper ((≡) ==> (≡) ==> (≡@{list A})) app. Proof. induction 1; intros ???; simpl; try constructor; auto. Qed. Global Instance length_proper : Proper ((≡@{list A}) ==> (=)) length. Proof. induction 1; f_equal/=; auto. Qed. Global Instance tail_proper : Proper ((≡@{list A}) ==> (≡)) tail. Proof. destruct 1; try constructor; auto. Qed. Global Instance take_proper n : Proper ((≡@{list A}) ==> (≡)) (take n). Proof. induction n; destruct 1; constructor; auto. Qed. Global Instance drop_proper n : Proper ((≡@{list A}) ==> (≡)) (drop n). Proof. induction n; destruct 1; simpl; try constructor; auto. Qed. Global Instance list_lookup_proper i : Proper ((≡@{list A}) ==> (≡)) (lookup i). Proof. induction i; destruct 1; simpl; try constructor; auto. Qed. Global Instance list_lookup_total_proper `{!Inhabited A} i : Proper (≡@{A}) inhabitant → Proper ((≡@{list A}) ==> (≡)) (lookup_total i). Proof. intros ?. induction i; destruct 1; simpl; auto. Qed. Global Instance list_alter_proper : Proper (((≡) ==> (≡)) ==> (=) ==> (≡) ==> (≡@{list A})) alter. Proof. intros f1 f2 Hf i ? <-. induction i; destruct 1; constructor; eauto. Qed. Global Instance list_insert_proper i : Proper ((≡) ==> (≡) ==> (≡@{list A})) (insert i). Proof. intros ???; induction i; destruct 1; constructor; eauto. Qed. Global Instance list_inserts_proper i : Proper ((≡) ==> (≡) ==> (≡@{list A})) (list_inserts i). Proof. intros k1 k2 Hk; revert i. induction Hk; intros ????; simpl; try f_equiv; naive_solver. Qed. Global Instance list_delete_proper i : Proper ((≡) ==> (≡@{list A})) (delete i). Proof. induction i; destruct 1; try constructor; eauto. Qed. Global Instance option_list_proper : Proper ((≡) ==> (≡@{list A})) option_list. Proof. destruct 1; repeat constructor; auto. Qed. Global Instance list_filter_proper P `{∀ x, Decision (P x)} : Proper ((≡) ==> iff) P → Proper ((≡) ==> (≡@{list A})) (filter P). Proof. intros ???. rewrite !list_equiv_Forall2. by apply Forall2_filter. Qed. Global Instance replicate_proper n : Proper ((≡@{A}) ==> (≡)) (replicate n). Proof. induction n; constructor; auto. Qed. Global Instance rotate_proper n : Proper ((≡@{list A}) ==> (≡)) (rotate n). Proof. intros ??. rewrite !list_equiv_Forall2. by apply Forall2_rotate. Qed. Global Instance rotate_take_proper s e : Proper ((≡@{list A}) ==> (≡)) (rotate_take s e). Proof. intros ??. rewrite !list_equiv_Forall2. by apply Forall2_rotate_take. Qed. Global Instance reverse_proper : Proper ((≡) ==> (≡@{list A})) reverse. Proof. induction 1; rewrite ?reverse_cons; simpl; [constructor|]. apply app_proper; repeat constructor; auto. Qed. Global Instance last_proper : Proper ((≡) ==> (≡)) (@last A). Proof. induction 1 as [|????? []]; simpl; repeat constructor; auto. Qed. Global Instance resize_proper n : Proper ((≡) ==> (≡) ==> (≡@{list A})) (resize n). Proof. induction n; destruct 2; simpl; repeat (constructor || f_equiv); auto. Qed. Global Instance cons_equiv_inj : Inj2 (≡) (≡) (≡) (@cons A). Proof. inversion 1; auto. Qed. Lemma nil_equiv_eq l : l ≡ [] ↔ l = []. Proof. split; [by inversion_clear 1|intros ->; constructor]. Qed. Lemma cons_equiv_eq l x k : l ≡ x :: k ↔ ∃ x' k', l = x' :: k' ∧ x' ≡ x ∧ k' ≡ k. Proof. split; [inversion 1; naive_solver|naive_solver (by constructor)]. Qed. Lemma list_singleton_equiv_eq l x : l ≡ [x] ↔ ∃ x', l = [x'] ∧ x' ≡ x. Proof. rewrite cons_equiv_eq. setoid_rewrite nil_equiv_eq. naive_solver. Qed. Lemma app_equiv_eq l k1 k2 : l ≡ k1 ++ k2 ↔ ∃ k1' k2', l = k1' ++ k2' ∧ k1' ≡ k1 ∧ k2' ≡ k2. Proof. split; [|intros (?&?&->&?&?); by f_equiv]. setoid_rewrite list_equiv_Forall2. rewrite Forall2_app_inv_r. naive_solver. Qed. Lemma equiv_Permutation l1 l2 l3 : l1 ≡ l2 → l2 ≡ₚ l3 → ∃ l2', l1 ≡ₚ l2' ∧ l2' ≡ l3. Proof. intros Hequiv Hperm. revert l1 Hequiv. induction Hperm as [|x l2 l3 _ IH|x y l2|l2 l3 l4 _ IH1 _ IH2]; intros l1. - intros ?. by exists l1. - intros (x'&l2'&->&?&(l2''&?&?)%IH)%cons_equiv_eq. exists (x' :: l2''). by repeat constructor. - intros (y'&?&->&?&(x'&l2'&->&?&?)%cons_equiv_eq)%cons_equiv_eq. exists (x' :: y' :: l2'). by repeat constructor. - intros (l2'&?&(l3'&?&?)%IH2)%IH1. exists l3'. split; [by etrans|done]. Qed. Lemma Permutation_equiv `{!Equivalence (≡@{A})} l1 l2 l3 : l1 ≡ₚ l2 → l2 ≡ l3 → ∃ l2', l1 ≡ l2' ∧ l2' ≡ₚ l3. Proof. intros Hperm%symmetry Hequiv%symmetry. destruct (equiv_Permutation _ _ _ Hequiv Hperm) as (l2'&?&?). by exists l2'. Qed. End setoid. (** * Properties of the [find] function *) Section find. Context {A} (P : A → Prop) `{∀ x, Decision (P x)}. Lemma list_find_Some l i x : list_find P l = Some (i,x) ↔ l !! i = Some x ∧ P x ∧ ∀ j y, l !! j = Some y → j < i → ¬P y. Proof. revert i. induction l as [|y l IH]; intros i; csimpl; [naive_solver|]. case_decide. - split; [naive_solver lia|]. intros (Hi&HP&Hlt). destruct i as [|i]; simplify_eq/=; [done|]. destruct (Hlt 0 y); naive_solver lia. - split. + intros ([i' x']&Hl&?)%fmap_Some; simplify_eq/=. apply IH in Hl as (?&?&Hlt). split_and!; [done..|]. intros [|j] ?; naive_solver lia. + intros (?&?&Hlt). destruct i as [|i]; simplify_eq/=; [done|]. rewrite (proj2 (IH i)); [done|]. split_and!; [done..|]. intros j z ???. destruct (Hlt (S j) z); naive_solver lia. Qed. Lemma list_find_elem_of l x : x ∈ l → P x → is_Some (list_find P l). Proof. induction 1 as [|x y l ? IH]; intros; simplify_option_eq; eauto. by destruct IH as [[i x'] ->]; [|exists (S i, x')]. Qed. Lemma list_find_None l : list_find P l = None ↔ Forall (λ x, ¬P x) l. Proof. rewrite eq_None_not_Some, Forall_forall. split. - intros Hl x Hx HP. destruct Hl. eauto using list_find_elem_of. - intros HP [[i x] (?%elem_of_list_lookup_2&?&?)%list_find_Some]; naive_solver. Qed. Lemma list_find_app_None l1 l2 : list_find P (l1 ++ l2) = None ↔ list_find P l1 = None ∧ list_find P l2 = None. Proof. by rewrite !list_find_None, Forall_app. Qed. Lemma list_find_app_Some l1 l2 i x : list_find P (l1 ++ l2) = Some (i,x) ↔ list_find P l1 = Some (i,x) ∨ length l1 ≤ i ∧ list_find P l1 = None ∧ list_find P l2 = Some (i - length l1,x). Proof. split. - intros ([?|[??]]%lookup_app_Some&?&Hleast)%list_find_Some. + left. apply list_find_Some; eauto using lookup_app_l_Some. + right. split; [lia|]. split. { apply list_find_None, Forall_lookup. intros j z ??. assert (j < length l1) by eauto using lookup_lt_Some. naive_solver eauto using lookup_app_l_Some with lia. } apply list_find_Some. split_and!; [done..|]. intros j z ??. eapply (Hleast (length l1 + j)); [|lia]. by rewrite lookup_app_r, Nat.add_sub' by lia. - intros [(?&?&Hleast)%list_find_Some|(?&Hl1&(?&?&Hleast)%list_find_Some)]. + apply list_find_Some. split_and!; [by auto using lookup_app_l_Some..|]. assert (i < length l1) by eauto using lookup_lt_Some. intros j y ?%lookup_app_Some; naive_solver eauto with lia. + rewrite list_find_Some, lookup_app_Some. split_and!; [by auto..|]. intros j y [?|?]%lookup_app_Some ?; [|naive_solver auto with lia]. by eapply (Forall_lookup_1 (not ∘ P) l1); [by apply list_find_None|..]. Qed. Lemma list_find_app_l l1 l2 i x: list_find P l1 = Some (i, x) → list_find P (l1 ++ l2) = Some (i, x). Proof. rewrite list_find_app_Some. auto. Qed. Lemma list_find_app_r l1 l2: list_find P l1 = None → list_find P (l1 ++ l2) = prod_map (λ x, x + length l1) id <$> list_find P l2. Proof. intros. apply option_eq; intros [j y]. rewrite list_find_app_Some. split. - intros [?|(?&?&->)]; naive_solver auto with f_equal lia. - intros ([??]&->&?)%fmap_Some; naive_solver auto with f_equal lia. Qed. Lemma list_find_insert_Some l i j x y : list_find P (<[i:=x]> l) = Some (j,y) ↔ (j < i ∧ list_find P l = Some (j,y)) ∨ (i = j ∧ x = y ∧ j < length l ∧ P x ∧ ∀ k z, l !! k = Some z → k < i → ¬P z) ∨ (i < j ∧ ¬P x ∧ list_find P l = Some (j,y) ∧ ∀ z, l !! i = Some z → ¬P z) ∨ (∃ z, i < j ∧ ¬P x ∧ P y ∧ P z ∧ l !! i = Some z ∧ l !! j = Some y ∧ ∀ k z, l !! k = Some z → k ≠ i → k < j → ¬P z). Proof. split. - intros ([(->&->&?)|[??]]%list_lookup_insert_Some&?&Hleast)%list_find_Some. { right; left. split_and!; [done..|]. intros k z ??. apply (Hleast k); [|lia]. by rewrite list_lookup_insert_ne by lia. } assert (j < i ∨ i < j) as [?|?] by lia. { left. rewrite list_find_Some. split_and!; [by auto..|]. intros k z ??. apply (Hleast k); [|lia]. by rewrite list_lookup_insert_ne by lia. } right; right. assert (j < length l) by eauto using lookup_lt_Some. destruct (lookup_lt_is_Some_2 l i) as [z ?]; [lia|]. destruct (decide (P z)). { right. exists z. split_and!; [done| |done..|]. + apply (Hleast i); [|done]. by rewrite list_lookup_insert by lia. + intros k z' ???. apply (Hleast k); [|lia]. by rewrite list_lookup_insert_ne by lia. } left. split_and!; [done|..|naive_solver]. + apply (Hleast i); [|done]. by rewrite list_lookup_insert by lia. + apply list_find_Some. split_and!; [by auto..|]. intros k z' ??. destruct (decide (k = i)) as [->|]; [naive_solver|]. apply (Hleast k); [|lia]. by rewrite list_lookup_insert_ne by lia. - intros [[? Hl]|[(->&->&?&?&Hleast)|[(?&?&Hl&Hnot)|(z&?&?&?&?&?&?&?Hleast)]]]; apply list_find_Some. + apply list_find_Some in Hl as (?&?&Hleast). rewrite list_lookup_insert_ne by lia. split_and!; [done..|]. intros k z [(->&->&?)|[??]]%list_lookup_insert_Some; eauto with lia. + rewrite list_lookup_insert by done. split_and!; [by auto..|]. intros k z [(->&->&?)|[??]]%list_lookup_insert_Some; eauto with lia. + apply list_find_Some in Hl as (?&?&Hleast). rewrite list_lookup_insert_ne by lia. split_and!; [done..|]. intros k z [(->&->&?)|[??]]%list_lookup_insert_Some; eauto with lia. + rewrite list_lookup_insert_ne by lia. split_and!; [done..|]. intros k z' [(->&->&?)|[??]]%list_lookup_insert_Some; eauto with lia. Qed. Lemma list_find_fmap {B : Type} (f : B → A) (l : list B) : list_find P (f <$> l) = prod_map id f <$> list_find (P ∘ f) l. Proof. induction l as [|x l IH]; [done|]; csimpl. (* csimpl re-folds fmap *) case_decide; [done|]. rewrite IH. by destruct (list_find (P ∘ f) l). Qed. Lemma list_find_ext (Q : A → Prop) `{∀ x, Decision (Q x)} l : (∀ x, P x ↔ Q x) → list_find P l = list_find Q l. Proof. intros HPQ. induction l as [|x l IH]; simpl; [done|]. by rewrite (decide_ext (P x) (Q x)), IH by done. Qed. End find. (** * Properties of the monadic operations *) Lemma list_fmap_id {A} (l : list A) : id <$> l = l. Proof. induction l; f_equal/=; auto. Qed. Global Instance list_fmap_proper `{!Equiv A, !Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{list A}) ==> (≡@{list B})) fmap. Proof. induction 2; csimpl; constructor; auto. Qed. Section fmap. Context {A B : Type} (f : A → B). Implicit Types l : list A. Lemma list_fmap_compose {C} (g : B → C) l : g ∘ f <$> l = g <$> (f <$> l). Proof. induction l; f_equal/=; auto. Qed. Lemma list_fmap_inj_1 f' l x : f <$> l = f' <$> l → x ∈ l → f x = f' x. Proof. intros Hf Hin. induction Hin; naive_solver. Qed. Definition fmap_nil : f <$> [] = [] := eq_refl. Definition fmap_cons x l : f <$> x :: l = f x :: (f <$> l) := eq_refl. Lemma list_fmap_singleton x : f <$> [x] = [f x]. Proof. reflexivity. Qed. Lemma fmap_app l1 l2 : f <$> l1 ++ l2 = (f <$> l1) ++ (f <$> l2). Proof. by induction l1; f_equal/=. Qed. Lemma fmap_snoc l x : f <$> l ++ [x] = (f <$> l) ++ [f x]. Proof. rewrite fmap_app, list_fmap_singleton. done. Qed. Lemma fmap_nil_inv k : f <$> k = [] → k = []. Proof. by destruct k. Qed. Lemma fmap_cons_inv y l k : f <$> l = y :: k → ∃ x l', y = f x ∧ k = f <$> l' ∧ l = x :: l'. Proof. intros. destruct l; simplify_eq/=; eauto. Qed. Lemma fmap_app_inv l k1 k2 : f <$> l = k1 ++ k2 → ∃ l1 l2, k1 = f <$> l1 ∧ k2 = f <$> l2 ∧ l = l1 ++ l2. Proof. revert l. induction k1 as [|y k1 IH]; simpl; [intros l ?; by eexists [],l|]. intros [|x l] ?; simplify_eq/=. destruct (IH l) as (l1&l2&->&->&->); [done|]. by exists (x :: l1), l2. Qed. Lemma fmap_option_list mx : f <$> (option_list mx) = option_list (f <$> mx). Proof. by destruct mx. Qed. Lemma list_fmap_alt l : f <$> l = omap (λ x, Some (f x)) l. Proof. induction l; simplify_eq/=; done. Qed. Lemma fmap_length l : length (f <$> l) = length l. Proof. by induction l; f_equal/=. Qed. Lemma fmap_reverse l : f <$> reverse l = reverse (f <$> l). Proof. induction l as [|?? IH]; csimpl; by rewrite ?reverse_cons, ?fmap_app, ?IH. Qed. Lemma fmap_tail l : f <$> tail l = tail (f <$> l). Proof. by destruct l. Qed. Lemma fmap_last l : last (f <$> l) = f <$> last l. Proof. induction l as [|? []]; simpl; auto. Qed. Lemma fmap_replicate n x : f <$> replicate n x = replicate n (f x). Proof. by induction n; f_equal/=. Qed. Lemma fmap_take n l : f <$> take n l = take n (f <$> l). Proof. revert n. by induction l; intros [|?]; f_equal/=. Qed. Lemma fmap_drop n l : f <$> drop n l = drop n (f <$> l). Proof. revert n. by induction l; intros [|?]; f_equal/=. Qed. Lemma fmap_resize n x l : f <$> resize n x l = resize n (f x) (f <$> l). Proof. revert n. induction l; intros [|?]; f_equal/=; auto using fmap_replicate. Qed. Lemma const_fmap (l : list A) (y : B) : (∀ x, f x = y) → f <$> l = replicate (length l) y. Proof. intros; induction l; f_equal/=; auto. Qed. Lemma list_lookup_fmap l i : (f <$> l) !! i = f <$> (l !! i). Proof. revert i. induction l; intros [|n]; by try revert n. Qed. Lemma list_lookup_fmap_Some l i x : (f <$> l) !! i = Some x ↔ ∃ y, l !! i = Some y ∧ x = f y. Proof. by rewrite list_lookup_fmap, fmap_Some. Qed. Lemma list_lookup_total_fmap `{!Inhabited A, !Inhabited B} l i : i < length l → (f <$> l) !!! i = f (l !!! i). Proof. intros [x Hx]%lookup_lt_is_Some_2. by rewrite !list_lookup_total_alt, list_lookup_fmap, Hx. Qed. Lemma list_lookup_fmap_inv l i x : (f <$> l) !! i = Some x → ∃ y, x = f y ∧ l !! i = Some y. Proof. intros Hi. rewrite list_lookup_fmap in Hi. destruct (l !! i) eqn:?; simplify_eq/=; eauto. Qed. Lemma list_fmap_insert l i x: f <$> <[i:=x]>l = <[i:=f x]>(f <$> l). Proof. revert i. by induction l; intros [|i]; f_equal/=. Qed. Lemma list_alter_fmap (g : A → A) (h : B → B) l i : Forall (λ x, f (g x) = h (f x)) l → f <$> alter g i l = alter h i (f <$> l). Proof. intros Hl. revert i. by induction Hl; intros [|i]; f_equal/=. Qed. Lemma list_fmap_delete l i : f <$> (delete i l) = delete i (f <$> l). Proof. revert i. induction l; intros i; destruct i; csimpl; eauto. naive_solver congruence. Qed. Lemma elem_of_list_fmap_1 l x : x ∈ l → f x ∈ f <$> l. Proof. induction 1; csimpl; rewrite elem_of_cons; intuition. Qed. Lemma elem_of_list_fmap_1_alt l x y : x ∈ l → y = f x → y ∈ f <$> l. Proof. intros. subst. by apply elem_of_list_fmap_1. Qed. Lemma elem_of_list_fmap_2 l x : x ∈ f <$> l → ∃ y, x = f y ∧ y ∈ l. Proof. induction l as [|y l IH]; simpl; inversion_clear 1. - exists y. split; [done | by left]. - destruct IH as [z [??]]; [done|]. exists z. split; [done | by right]. Qed. Lemma elem_of_list_fmap l x : x ∈ f <$> l ↔ ∃ y, x = f y ∧ y ∈ l. Proof. naive_solver eauto using elem_of_list_fmap_1_alt, elem_of_list_fmap_2. Qed. Lemma elem_of_list_fmap_2_inj `{!Inj (=) (=) f} l x : f x ∈ f <$> l → x ∈ l. Proof. intros (y, (E, I))%elem_of_list_fmap_2. by rewrite (inj f) in I. Qed. Lemma elem_of_list_fmap_inj `{!Inj (=) (=) f} l x : f x ∈ f <$> l ↔ x ∈ l. Proof. naive_solver eauto using elem_of_list_fmap_1, elem_of_list_fmap_2_inj. Qed. Lemma list_fmap_inj R1 R2 : Inj R1 R2 f → Inj (Forall2 R1) (Forall2 R2) (fmap f). Proof. intros ? l1. induction l1; intros [|??]; inversion 1; constructor; auto. Qed. Global Instance list_fmap_eq_inj : Inj (=) (=) f → Inj (=@{list A}) (=) (fmap f). Proof. intros ?%list_fmap_inj ?? ?%list_eq_Forall2%(inj _). by apply list_eq_Forall2. Qed. Global Instance list_fmap_equiv_inj `{!Equiv A, !Equiv B} : Inj (≡) (≡) f → Inj (≡@{list A}) (≡) (fmap f). Proof. intros ?%list_fmap_inj ?? ?%list_equiv_Forall2%(inj _). by apply list_equiv_Forall2. Qed. (** A version of [NoDup_fmap_2] that does not require [f] to be injective for *all* inputs. *) Lemma NoDup_fmap_2_strong l : (∀ x y, x ∈ l → y ∈ l → f x = f y → x = y) → NoDup l → NoDup (f <$> l). Proof. intros Hinj. induction 1 as [|x l ?? IH]; simpl; constructor. - intros [y [Hxy ?]]%elem_of_list_fmap. apply Hinj in Hxy; [by subst|by constructor..]. - apply IH. clear- Hinj. intros x' y Hx' Hy. apply Hinj; by constructor. Qed. Lemma NoDup_fmap_1 l : NoDup (f <$> l) → NoDup l. Proof. induction l; simpl; inversion_clear 1; constructor; auto. rewrite elem_of_list_fmap in *. naive_solver. Qed. Lemma NoDup_fmap_2 `{!Inj (=) (=) f} l : NoDup l → NoDup (f <$> l). Proof. apply NoDup_fmap_2_strong. intros ?? _ _. apply (inj f). Qed. Lemma NoDup_fmap `{!Inj (=) (=) f} l : NoDup (f <$> l) ↔ NoDup l. Proof. split; auto using NoDup_fmap_1, NoDup_fmap_2. Qed. Global Instance fmap_sublist: Proper (sublist ==> sublist) (fmap f). Proof. induction 1; simpl; econstructor; eauto. Qed. Global Instance fmap_submseteq: Proper (submseteq ==> submseteq) (fmap f). Proof. induction 1; simpl; econstructor; eauto. Qed. Global Instance fmap_Permutation: Proper ((≡ₚ) ==> (≡ₚ)) (fmap f). Proof. induction 1; simpl; econstructor; eauto. Qed. Lemma Forall_fmap_ext_1 (g : A → B) (l : list A) : Forall (λ x, f x = g x) l → fmap f l = fmap g l. Proof. by induction 1; f_equal/=. Qed. Lemma Forall_fmap_ext (g : A → B) (l : list A) : Forall (λ x, f x = g x) l ↔ fmap f l = fmap g l. Proof. split; [auto using Forall_fmap_ext_1|]. induction l; simpl; constructor; simplify_eq; auto. Qed. Lemma Forall_fmap (P : B → Prop) l : Forall P (f <$> l) ↔ Forall (P ∘ f) l. Proof. split; induction l; inversion_clear 1; constructor; auto. Qed. Lemma Exists_fmap (P : B → Prop) l : Exists P (f <$> l) ↔ Exists (P ∘ f) l. Proof. split; induction l; inversion 1; constructor; by auto. Qed. Lemma Forall2_fmap_l {C} (P : B → C → Prop) l k : Forall2 P (f <$> l) k ↔ Forall2 (P ∘ f) l k. Proof. split; revert k; induction l; inversion_clear 1; constructor; auto. Qed. Lemma Forall2_fmap_r {C} (P : C → B → Prop) k l : Forall2 P k (f <$> l) ↔ Forall2 (λ x, P x ∘ f) k l. Proof. split; revert k; induction l; inversion_clear 1; constructor; auto. Qed. Lemma Forall2_fmap_1 {C D} (g : C → D) (P : B → D → Prop) l k : Forall2 P (f <$> l) (g <$> k) → Forall2 (λ x1 x2, P (f x1) (g x2)) l k. Proof. revert k; induction l; intros [|??]; inversion_clear 1; auto. Qed. Lemma Forall2_fmap_2 {C D} (g : C → D) (P : B → D → Prop) l k : Forall2 (λ x1 x2, P (f x1) (g x2)) l k → Forall2 P (f <$> l) (g <$> k). Proof. induction 1; csimpl; auto. Qed. Lemma Forall2_fmap {C D} (g : C → D) (P : B → D → Prop) l k : Forall2 P (f <$> l) (g <$> k) ↔ Forall2 (λ x1 x2, P (f x1) (g x2)) l k. Proof. split; auto using Forall2_fmap_1, Forall2_fmap_2. Qed. Lemma list_fmap_bind {C} (g : B → list C) l : (f <$> l) ≫= g = l ≫= g ∘ f. Proof. by induction l; f_equal/=. Qed. End fmap. Section ext. Context {A B : Type}. Implicit Types l : list A. Lemma list_fmap_ext (f g : A → B) l : (∀ i x, l !! i = Some x → f x = g x) → f <$> l = g <$> l. Proof. intros Hfg. apply list_eq; intros i. rewrite !list_lookup_fmap. destruct (l !! i) eqn:?; f_equal/=; eauto. Qed. Lemma list_fmap_equiv_ext `{!Equiv B} (f g : A → B) l : (∀ i x, l !! i = Some x → f x ≡ g x) → f <$> l ≡ g <$> l. Proof. intros Hl. apply list_equiv_lookup; intros i. rewrite !list_lookup_fmap. destruct (l !! i) eqn:?; simpl; constructor; eauto. Qed. End ext. Lemma list_alter_fmap_mono {A} (f : A → A) (g : A → A) l i : Forall (λ x, f (g x) = g (f x)) l → f <$> alter g i l = alter g i (f <$> l). Proof. auto using list_alter_fmap. Qed. Lemma NoDup_fmap_fst {A B} (l : list (A * B)) : (∀ x y1 y2, (x,y1) ∈ l → (x,y2) ∈ l → y1 = y2) → NoDup l → NoDup (l.*1). Proof. intros Hunique. induction 1 as [|[x1 y1] l Hin Hnodup IH]; csimpl; constructor. - rewrite elem_of_list_fmap. intros [[x2 y2] [??]]; simpl in *; subst. destruct Hin. rewrite (Hunique x2 y1 y2); rewrite ?elem_of_cons; auto. - apply IH. intros. eapply Hunique; rewrite ?elem_of_cons; eauto. Qed. Global Instance list_omap_proper `{!Equiv A, !Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{list A}) ==> (≡@{list B})) omap. Proof. intros f1 f2 Hf. induction 1 as [|x1 x2 l1 l2 Hx Hl]; csimpl; [constructor|]. destruct (Hf _ _ Hx); by repeat f_equiv. Qed. Section omap. Context {A B : Type} (f : A → option B). Implicit Types l : list A. Lemma list_fmap_omap {C} (g : B → C) l : g <$> omap f l = omap (λ x, g <$> (f x)) l. Proof. induction l as [|x y IH]; [done|]. csimpl. destruct (f x); csimpl; [|done]. by f_equal. Qed. Lemma list_omap_ext {A'} (g : A' → option B) l1 (l2 : list A') : Forall2 (λ a b, f a = g b) l1 l2 → omap f l1 = omap g l2. Proof. induction 1 as [|x y l l' Hfg ? IH]; [done|]. csimpl. rewrite Hfg. destruct (g y); [|done]. by f_equal. Qed. Lemma elem_of_list_omap l y : y ∈ omap f l ↔ ∃ x, x ∈ l ∧ f x = Some y. Proof. split. - induction l as [|x l]; csimpl; repeat case_match; inversion 1; subst; setoid_rewrite elem_of_cons; naive_solver. - intros (x&Hx&?). by induction Hx; csimpl; repeat case_match; simplify_eq; try constructor; auto. Qed. Global Instance omap_Permutation : Proper ((≡ₚ) ==> (≡ₚ)) (omap f). Proof. induction 1; simpl; repeat case_match; econstructor; eauto. Qed. Lemma omap_app l1 l2 : omap f (l1 ++ l2) = omap f l1 ++ omap f l2. Proof. induction l1; csimpl; repeat case_match; naive_solver congruence. Qed. Lemma omap_option_list mx : omap f (option_list mx) = option_list (mx ≫= f). Proof. by destruct mx. Qed. End omap. Global Instance list_bind_proper `{!Equiv A, !Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{list A}) ==> (≡@{list B})) mbind. Proof. induction 2; csimpl; constructor || f_equiv; auto. Qed. Section bind. Context {A B : Type} (f : A → list B). Lemma list_bind_ext (g : A → list B) l1 l2 : (∀ x, f x = g x) → l1 = l2 → l1 ≫= f = l2 ≫= g. Proof. intros ? <-. by induction l1; f_equal/=. Qed. Lemma Forall_bind_ext (g : A → list B) (l : list A) : Forall (λ x, f x = g x) l → l ≫= f = l ≫= g. Proof. by induction 1; f_equal/=. Qed. Global Instance bind_sublist: Proper (sublist ==> sublist) (mbind f). Proof. induction 1; simpl; auto; [by apply sublist_app|by apply sublist_inserts_l]. Qed. Global Instance bind_submseteq: Proper (submseteq ==> submseteq) (mbind f). Proof. induction 1; csimpl; auto. - by apply submseteq_app. - by rewrite !(assoc_L (++)), (comm (++) (f _)). - by apply submseteq_inserts_l. - etrans; eauto. Qed. Global Instance bind_Permutation: Proper ((≡ₚ) ==> (≡ₚ)) (mbind f). Proof. induction 1; csimpl; auto. - by f_equiv. - by rewrite !(assoc_L (++)), (comm (++) (f _)). - etrans; eauto. Qed. Lemma bind_cons x l : (x :: l) ≫= f = f x ++ l ≫= f. Proof. done. Qed. Lemma bind_singleton x : [x] ≫= f = f x. Proof. csimpl. by rewrite (right_id_L _ (++)). Qed. Lemma bind_app l1 l2 : (l1 ++ l2) ≫= f = (l1 ≫= f) ++ (l2 ≫= f). Proof. by induction l1; csimpl; rewrite <-?(assoc_L (++)); f_equal. Qed. Lemma elem_of_list_bind (x : B) (l : list A) : x ∈ l ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ l. Proof. split. - induction l as [|y l IH]; csimpl; [inversion 1|]. rewrite elem_of_app. intros [?|?]. + exists y. split; [done | by left]. + destruct IH as [z [??]]; [done|]. exists z. split; [done | by right]. - intros [y [Hx Hy]]. induction Hy; csimpl; rewrite elem_of_app; intuition. Qed. Lemma Forall_bind (P : B → Prop) l : Forall P (l ≫= f) ↔ Forall (Forall P ∘ f) l. Proof. split. - induction l; csimpl; rewrite ?Forall_app; constructor; csimpl; intuition. - induction 1; csimpl; rewrite ?Forall_app; auto. Qed. Lemma Forall2_bind {C D} (g : C → list D) (P : B → D → Prop) l1 l2 : Forall2 (λ x1 x2, Forall2 P (f x1) (g x2)) l1 l2 → Forall2 P (l1 ≫= f) (l2 ≫= g). Proof. induction 1; csimpl; auto using Forall2_app. Qed. Lemma NoDup_bind l : (∀ x1 x2 y, x1 ∈ l → x2 ∈ l → y ∈ f x1 → y ∈ f x2 → x1 = x2) → (∀ x, x ∈ l → NoDup (f x)) → NoDup l → NoDup (l ≫= f). Proof. intros Hinj Hf. induction 1 as [|x l ?? IH]; csimpl; [constructor|]. apply NoDup_app. split_and!. - eauto 10 using elem_of_list_here. - intros y ? (x'&?&?)%elem_of_list_bind. destruct (Hinj x x' y); auto using elem_of_list_here, elem_of_list_further. - eauto 10 using elem_of_list_further. Qed. End bind. Global Instance list_join_proper `{!Equiv A} : Proper ((≡) ==> (≡@{list A})) mjoin. Proof. induction 1; simpl; [constructor|solve_proper]. Qed. Section ret_join. Context {A : Type}. Lemma list_join_bind (ls : list (list A)) : mjoin ls = ls ≫= id. Proof. by induction ls; f_equal/=. Qed. Global Instance join_Permutation : Proper ((≡ₚ@{list A}) ==> (≡ₚ)) mjoin. Proof. intros ?? E. by rewrite !list_join_bind, E. Qed. Lemma elem_of_list_ret (x y : A) : x ∈ @mret list _ A y ↔ x = y. Proof. apply elem_of_list_singleton. Qed. Lemma elem_of_list_join (x : A) (ls : list (list A)) : x ∈ mjoin ls ↔ ∃ l : list A, x ∈ l ∧ l ∈ ls. Proof. by rewrite list_join_bind, elem_of_list_bind. Qed. Lemma join_nil (ls : list (list A)) : mjoin ls = [] ↔ Forall (.= []) ls. Proof. split; [|by induction 1 as [|[|??] ?]]. by induction ls as [|[|??] ?]; constructor; auto. Qed. Lemma join_nil_1 (ls : list (list A)) : mjoin ls = [] → Forall (.= []) ls. Proof. by rewrite join_nil. Qed. Lemma join_nil_2 (ls : list (list A)) : Forall (.= []) ls → mjoin ls = []. Proof. by rewrite join_nil. Qed. Lemma Forall_join (P : A → Prop) (ls: list (list A)) : Forall (Forall P) ls → Forall P (mjoin ls). Proof. induction 1; simpl; auto using Forall_app_2. Qed. Lemma Forall2_join {B} (P : A → B → Prop) ls1 ls2 : Forall2 (Forall2 P) ls1 ls2 → Forall2 P (mjoin ls1) (mjoin ls2). Proof. induction 1; simpl; auto using Forall2_app. Qed. End ret_join. Global Instance mapM_proper `{!Equiv A, !Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{list A}) ==> (≡@{option (list B)})) mapM. Proof. induction 2; csimpl; repeat (f_equiv || constructor || intro || auto). Qed. Section mapM. Context {A B : Type} (f : A → option B). Lemma mapM_ext (g : A → option B) l : (∀ x, f x = g x) → mapM f l = mapM g l. Proof. intros Hfg. by induction l as [|?? IHl]; simpl; rewrite ?Hfg, ?IHl. Qed. Lemma Forall2_mapM_ext (g : A → option B) l k : Forall2 (λ x y, f x = g y) l k → mapM f l = mapM g k. Proof. induction 1 as [|???? Hfg ? IH]; simpl; [done|]. by rewrite Hfg, IH. Qed. Lemma Forall_mapM_ext (g : A → option B) l : Forall (λ x, f x = g x) l → mapM f l = mapM g l. Proof. induction 1 as [|?? Hfg ? IH]; simpl; [done|]. by rewrite Hfg, IH. Qed. Lemma mapM_Some_1 l k : mapM f l = Some k → Forall2 (λ x y, f x = Some y) l k. Proof. revert k. induction l as [|x l]; intros [|y k]; simpl; try done. - destruct (f x); simpl; [|discriminate]. by destruct (mapM f l). - destruct (f x) eqn:?; intros; simplify_option_eq; auto. Qed. Lemma mapM_Some_2 l k : Forall2 (λ x y, f x = Some y) l k → mapM f l = Some k. Proof. induction 1 as [|???? Hf ? IH]; simpl; [done |]. rewrite Hf. simpl. by rewrite IH. Qed. Lemma mapM_Some l k : mapM f l = Some k ↔ Forall2 (λ x y, f x = Some y) l k. Proof. split; auto using mapM_Some_1, mapM_Some_2. Qed. Lemma mapM_length l k : mapM f l = Some k → length l = length k. Proof. intros. by eapply Forall2_length, mapM_Some_1. Qed. Lemma mapM_None_1 l : mapM f l = None → Exists (λ x, f x = None) l. Proof. induction l as [|x l IH]; simpl; [done|]. destruct (f x) eqn:?; simpl; eauto. by destruct (mapM f l); eauto. Qed. Lemma mapM_None_2 l : Exists (λ x, f x = None) l → mapM f l = None. Proof. induction 1 as [x l Hx|x l ? IH]; simpl; [by rewrite Hx|]. by destruct (f x); simpl; rewrite ?IH. Qed. Lemma mapM_None l : mapM f l = None ↔ Exists (λ x, f x = None) l. Proof. split; auto using mapM_None_1, mapM_None_2. Qed. Lemma mapM_is_Some_1 l : is_Some (mapM f l) → Forall (is_Some ∘ f) l. Proof. unfold compose. setoid_rewrite <-not_eq_None_Some. rewrite mapM_None. apply (not_Exists_Forall _). Qed. Lemma mapM_is_Some_2 l : Forall (is_Some ∘ f) l → is_Some (mapM f l). Proof. unfold compose. setoid_rewrite <-not_eq_None_Some. rewrite mapM_None. apply (Forall_not_Exists _). Qed. Lemma mapM_is_Some l : is_Some (mapM f l) ↔ Forall (is_Some ∘ f) l. Proof. split; auto using mapM_is_Some_1, mapM_is_Some_2. Qed. Lemma mapM_fmap_Forall_Some (g : B → A) (l : list B) : Forall (λ x, f (g x) = Some x) l → mapM f (g <$> l) = Some l. Proof. by induction 1; simpl; simplify_option_eq. Qed. Lemma mapM_fmap_Some (g : B → A) (l : list B) : (∀ x, f (g x) = Some x) → mapM f (g <$> l) = Some l. Proof. intros. by apply mapM_fmap_Forall_Some, Forall_true. Qed. Lemma mapM_fmap_Forall2_Some_inv (g : B → A) (l : list A) (k : list B) : mapM f l = Some k → Forall2 (λ x y, f x = Some y → g y = x) l k → g <$> k = l. Proof. induction 2; simplify_option_eq; naive_solver. Qed. Lemma mapM_fmap_Some_inv (g : B → A) (l : list A) (k : list B) : mapM f l = Some k → (∀ x y, f x = Some y → g y = x) → g <$> k = l. Proof. eauto using mapM_fmap_Forall2_Some_inv, Forall2_true, mapM_length. Qed. End mapM. Lemma imap_const {A B} (f : A → B) l : imap (const f) l = f <$> l. Proof. induction l; f_equal/=; auto. Qed. Global Instance imap_proper `{!Equiv A, !Equiv B} : Proper (pointwise_relation _ ((≡) ==> (≡)) ==> (≡@{list A}) ==> (≡@{list B})) imap. Proof. intros f f' Hf l l' Hl. revert f f' Hf. induction Hl as [|x1 x2 l1 l2 ?? IH]; intros f f' Hf; simpl; constructor. - by apply Hf. - apply IH. intros i y y' ?; simpl. by apply Hf. Qed. Section imap. Context {A B : Type} (f : nat → A → B). Lemma imap_ext g l : (∀ i x, l !! i = Some x → f i x = g i x) → imap f l = imap g l. Proof. revert f g; induction l as [|x l IH]; intros; f_equal/=; eauto. Qed. Lemma imap_nil : imap f [] = []. Proof. done. Qed. Lemma imap_app l1 l2 : imap f (l1 ++ l2) = imap f l1 ++ imap (λ n, f (length l1 + n)) l2. Proof. revert f. induction l1 as [|x l1 IH]; intros f; f_equal/=. by rewrite IH. Qed. Lemma imap_cons x l : imap f (x :: l) = f 0 x :: imap (f ∘ S) l. Proof. done. Qed. Lemma imap_fmap {C} (g : C → A) l : imap f (g <$> l) = imap (λ n, f n ∘ g) l. Proof. revert f. induction l; intros; f_equal/=; eauto. Qed. Lemma fmap_imap {C} (g : B → C) l : g <$> imap f l = imap (λ n, g ∘ f n) l. Proof. revert f. induction l; intros; f_equal/=; eauto. Qed. Lemma list_lookup_imap l i : imap f l !! i = f i <$> l !! i. Proof. revert f i. induction l as [|x l IH]; intros f [|i]; f_equal/=; auto. by rewrite IH. Qed. Lemma list_lookup_imap_Some l i x : imap f l !! i = Some x ↔ ∃ y, l !! i = Some y ∧ x = f i y. Proof. by rewrite list_lookup_imap, fmap_Some. Qed. Lemma list_lookup_total_imap `{!Inhabited A, !Inhabited B} l i : i < length l → imap f l !!! i = f i (l !!! i). Proof. intros [x Hx]%lookup_lt_is_Some_2. by rewrite !list_lookup_total_alt, list_lookup_imap, Hx. Qed. Lemma imap_length l : length (imap f l) = length l. Proof. revert f. induction l; simpl; eauto. Qed. Lemma elem_of_lookup_imap_1 l x : x ∈ imap f l → ∃ i y, x = f i y ∧ l !! i = Some y. Proof. intros [i Hin]%elem_of_list_lookup. rewrite list_lookup_imap in Hin. simplify_option_eq; naive_solver. Qed. Lemma elem_of_lookup_imap_2 l x i : l !! i = Some x → f i x ∈ imap f l. Proof. intros Hl. rewrite elem_of_list_lookup. exists i. by rewrite list_lookup_imap, Hl. Qed. Lemma elem_of_lookup_imap l x : x ∈ imap f l ↔ ∃ i y, x = f i y ∧ l !! i = Some y. Proof. naive_solver eauto using elem_of_lookup_imap_1, elem_of_lookup_imap_2. Qed. End imap. (** ** Properties of the [permutations] function *) Section permutations. Context {A : Type}. Implicit Types x y z : A. Implicit Types l : list A. Lemma interleave_cons x l : x :: l ∈ interleave x l. Proof. destruct l; simpl; rewrite elem_of_cons; auto. Qed. Lemma interleave_Permutation x l l' : l' ∈ interleave x l → l' ≡ₚ x :: l. Proof. revert l'. induction l as [|y l IH]; intros l'; simpl. - rewrite elem_of_list_singleton. by intros ->. - rewrite elem_of_cons, elem_of_list_fmap. intros [->|[? [-> H]]]; [done|]. rewrite (IH _ H). constructor. Qed. Lemma permutations_refl l : l ∈ permutations l. Proof. induction l; simpl; [by apply elem_of_list_singleton|]. apply elem_of_list_bind. eauto using interleave_cons. Qed. Lemma permutations_skip x l l' : l ∈ permutations l' → x :: l ∈ permutations (x :: l'). Proof. intro. apply elem_of_list_bind; eauto using interleave_cons. Qed. Lemma permutations_swap x y l : y :: x :: l ∈ permutations (x :: y :: l). Proof. simpl. apply elem_of_list_bind. exists (y :: l). split; simpl. - destruct l; csimpl; rewrite !elem_of_cons; auto. - apply elem_of_list_bind. simpl. eauto using interleave_cons, permutations_refl. Qed. Lemma permutations_nil l : l ∈ permutations [] ↔ l = []. Proof. simpl. by rewrite elem_of_list_singleton. Qed. Lemma interleave_interleave_toggle x1 x2 l1 l2 l3 : l1 ∈ interleave x1 l2 → l2 ∈ interleave x2 l3 → ∃ l4, l1 ∈ interleave x2 l4 ∧ l4 ∈ interleave x1 l3. Proof. revert l1 l2. induction l3 as [|y l3 IH]; intros l1 l2; simpl. { rewrite !elem_of_list_singleton. intros ? ->. exists [x1]. change (interleave x2 [x1]) with ([[x2; x1]] ++ [[x1; x2]]). by rewrite (comm (++)), elem_of_list_singleton. } rewrite elem_of_cons, elem_of_list_fmap. intros Hl1 [? | [l2' [??]]]; simplify_eq/=. - rewrite !elem_of_cons, elem_of_list_fmap in Hl1. destruct Hl1 as [? | [? | [l4 [??]]]]; subst. + exists (x1 :: y :: l3). csimpl. rewrite !elem_of_cons. tauto. + exists (x1 :: y :: l3). csimpl. rewrite !elem_of_cons. tauto. + exists l4. simpl. rewrite elem_of_cons. auto using interleave_cons. - rewrite elem_of_cons, elem_of_list_fmap in Hl1. destruct Hl1 as [? | [l1' [??]]]; subst. + exists (x1 :: y :: l3). csimpl. rewrite !elem_of_cons, !elem_of_list_fmap. split; [| by auto]. right. right. exists (y :: l2'). rewrite elem_of_list_fmap. naive_solver. + destruct (IH l1' l2') as [l4 [??]]; auto. exists (y :: l4). simpl. rewrite !elem_of_cons, !elem_of_list_fmap. naive_solver. Qed. Lemma permutations_interleave_toggle x l1 l2 l3 : l1 ∈ permutations l2 → l2 ∈ interleave x l3 → ∃ l4, l1 ∈ interleave x l4 ∧ l4 ∈ permutations l3. Proof. revert l1 l2. induction l3 as [|y l3 IH]; intros l1 l2; simpl. { rewrite elem_of_list_singleton. intros Hl1 ->. eexists []. by rewrite elem_of_list_singleton. } rewrite elem_of_cons, elem_of_list_fmap. intros Hl1 [? | [l2' [? Hl2']]]; simplify_eq/=. - rewrite elem_of_list_bind in Hl1. destruct Hl1 as [l1' [??]]. by exists l1'. - rewrite elem_of_list_bind in Hl1. setoid_rewrite elem_of_list_bind. destruct Hl1 as [l1' [??]]. destruct (IH l1' l2') as (l1''&?&?); auto. destruct (interleave_interleave_toggle y x l1 l1' l1'') as (?&?&?); eauto. Qed. Lemma permutations_trans l1 l2 l3 : l1 ∈ permutations l2 → l2 ∈ permutations l3 → l1 ∈ permutations l3. Proof. revert l1 l2. induction l3 as [|x l3 IH]; intros l1 l2; simpl. - rewrite !elem_of_list_singleton. intros Hl1 ->; simpl in *. by rewrite elem_of_list_singleton in Hl1. - rewrite !elem_of_list_bind. intros Hl1 [l2' [Hl2 Hl2']]. destruct (permutations_interleave_toggle x l1 l2 l2') as [? [??]]; eauto. Qed. Lemma permutations_Permutation l l' : l' ∈ permutations l ↔ l ≡ₚ l'. Proof. split. - revert l'. induction l; simpl; intros l''. + rewrite elem_of_list_singleton. by intros ->. + rewrite elem_of_list_bind. intros [l' [Hl'' ?]]. rewrite (interleave_Permutation _ _ _ Hl''). constructor; auto. - induction 1; eauto using permutations_refl, permutations_skip, permutations_swap, permutations_trans. Qed. End permutations. (** ** Properties of the folding functions *) (** Note that [foldr] has much better support, so when in doubt, it should be preferred over [foldl]. *) Definition foldr_app := @fold_right_app. Lemma foldr_cons {A B} (f : B → A → A) (a : A) l x : foldr f a (x :: l) = f x (foldr f a l). Proof. done. Qed. Lemma foldr_snoc {A B} (f : B → A → A) (a : A) l x : foldr f a (l ++ [x]) = foldr f (f x a) l. Proof. rewrite foldr_app. done. Qed. Lemma foldr_fmap {A B C} (f : B → A → A) x (l : list C) g : foldr f x (g <$> l) = foldr (λ b a, f (g b) a) x l. Proof. induction l; f_equal/=; auto. Qed. Lemma foldr_ext {A B} (f1 f2 : B → A → A) x1 x2 l1 l2 : (∀ b a, f1 b a = f2 b a) → l1 = l2 → x1 = x2 → foldr f1 x1 l1 = foldr f2 x2 l2. Proof. intros Hf -> ->. induction l2 as [|x l2 IH]; f_equal/=; by rewrite Hf, IH. Qed. Lemma foldr_permutation {A B} (R : relation B) `{!PreOrder R} (f : A → B → B) (b : B) `{Hf : !∀ x, Proper (R ==> R) (f x)} (l1 l2 : list A) : (∀ j1 a1 j2 a2 b, j1 ≠ j2 → l1 !! j1 = Some a1 → l1 !! j2 = Some a2 → R (f a1 (f a2 b)) (f a2 (f a1 b))) → l1 ≡ₚ l2 → R (foldr f b l1) (foldr f b l2). Proof. intros Hf'. induction 1 as [|x l1 l2 _ IH|x y l|l1 l2 l3 Hl12 IH _ IH']; simpl. - done. - apply Hf, IH; eauto. - apply (Hf' 0 _ 1); eauto. - etrans; [eapply IH, Hf'|]. apply IH'; intros j1 a1 j2 a2 b' ???. symmetry in Hl12; apply Permutation_inj in Hl12 as [_ (g&?&Hg)]. apply (Hf' (g j1) _ (g j2)); [naive_solver|by rewrite <-Hg..]. Qed. Lemma foldr_permutation_proper {A B} (R : relation B) `{!PreOrder R} (f : A → B → B) (b : B) `{!∀ x, Proper (R ==> R) (f x)} (Hf : ∀ a1 a2 b, R (f a1 (f a2 b)) (f a2 (f a1 b))) : Proper ((≡ₚ) ==> R) (foldr f b). Proof. intros l1 l2 Hl. apply foldr_permutation; auto. Qed. Global Instance foldr_permutation_proper' {A} (R : relation A) `{!PreOrder R} (f : A → A → A) (a : A) `{!∀ a, Proper (R ==> R) (f a), !Assoc R f, !Comm R f} : Proper ((≡ₚ) ==> R) (foldr f a). Proof. apply (foldr_permutation_proper R f); [solve_proper|]. assert (Proper (R ==> R ==> R) f). { intros a1 a2 Ha b1 b2 Hb. by rewrite Hb, (comm f a1), Ha, (comm f). } intros a1 a2 b. by rewrite (assoc f), (comm f _ b), (assoc f), (comm f b), (comm f _ a2). Qed. Lemma foldr_cons_permute {A} (R : relation A) `{!PreOrder R} (f : A → A → A) (a : A) `{!∀ a, Proper (R ==> R) (f a), !Assoc R f, !Comm R f} x l : R (foldr f a (x :: l)) (foldr f (f x a) l). Proof. rewrite <-foldr_snoc. eapply foldr_permutation_proper'; [done..|]. rewrite Permutation_app_comm. done. Qed. Lemma foldr_cons_permute_eq {A} (f : A → A → A) (a : A) `{!Assoc (=) f, !Comm (=) f} x l : foldr f a (x :: l) = foldr f (f x a) l. Proof. eapply (foldr_cons_permute eq); apply _. Qed. Lemma foldr_comm_acc_strong {A B} (R : relation B) `{!PreOrder R} (f : A → B → B) (g : B → B) b l : (∀ x, Proper (R ==> R) (f x)) → (∀ x y, x ∈ l → R (f x (g y)) (g (f x y))) → R (foldr f (g b) l) (g (foldr f b l)). Proof. intros ? Hcomm. induction l as [|x l IH]; simpl; [done|]. rewrite <-Hcomm by eauto using elem_of_list_here. by rewrite IH by eauto using elem_of_list_further. Qed. Lemma foldr_comm_acc {A} (f : A → A → A) (g : A → A) (a : A) l : (∀ x y, f x (g y) = g (f x y)) → foldr f (g a) l = g (foldr f a l). Proof. intros. apply (foldr_comm_acc_strong _); [solve_proper|done]. Qed. Lemma foldl_app {A B} (f : A → B → A) (l k : list B) (a : A) : foldl f a (l ++ k) = foldl f (foldl f a l) k. Proof. revert a. induction l; simpl; auto. Qed. Lemma foldl_snoc {A B} (f : A → B → A) (a : A) l x : foldl f a (l ++ [x]) = f (foldl f a l) x. Proof. rewrite foldl_app. done. Qed. Lemma foldl_fmap {A B C} (f : A → B → A) x (l : list C) g : foldl f x (g <$> l) = foldl (λ a b, f a (g b)) x l. Proof. revert x. induction l; f_equal/=; auto. Qed. (** ** Properties of the [zip_with] and [zip] functions *) Global Instance zip_with_proper `{!Equiv A, !Equiv B, !Equiv C} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{list A}) ==> (≡@{list B}) ==> (≡@{list C})) zip_with. Proof. intros f1 f2 Hf. induction 1; destruct 1; simpl; [constructor..|]. f_equiv; [|by auto]. by apply Hf. Qed. Section zip_with. Context {A B C : Type} (f : A → B → C). Implicit Types x : A. Implicit Types y : B. Implicit Types l : list A. Implicit Types k : list B. Lemma zip_with_nil_r l : zip_with f l [] = []. Proof. by destruct l. Qed. Lemma zip_with_app l1 l2 k1 k2 : length l1 = length k1 → zip_with f (l1 ++ l2) (k1 ++ k2) = zip_with f l1 k1 ++ zip_with f l2 k2. Proof. rewrite <-Forall2_same_length. induction 1; f_equal/=; auto. Qed. Lemma zip_with_app_l l1 l2 k : zip_with f (l1 ++ l2) k = zip_with f l1 (take (length l1) k) ++ zip_with f l2 (drop (length l1) k). Proof. revert k. induction l1; intros [|??]; f_equal/=; auto. by destruct l2. Qed. Lemma zip_with_app_r l k1 k2 : zip_with f l (k1 ++ k2) = zip_with f (take (length k1) l) k1 ++ zip_with f (drop (length k1) l) k2. Proof. revert l. induction k1; intros [|??]; f_equal/=; auto. Qed. Lemma zip_with_flip l k : zip_with (flip f) k l = zip_with f l k. Proof. revert k. induction l; intros [|??]; f_equal/=; auto. Qed. Lemma zip_with_ext (g : A → B → C) l1 l2 k1 k2 : (∀ x y, f x y = g x y) → l1 = l2 → k1 = k2 → zip_with f l1 k1 = zip_with g l2 k2. Proof. intros ? <-<-. revert k1. by induction l1; intros [|??]; f_equal/=. Qed. Lemma Forall_zip_with_ext_l (g : A → B → C) l k1 k2 : Forall (λ x, ∀ y, f x y = g x y) l → k1 = k2 → zip_with f l k1 = zip_with g l k2. Proof. intros Hl <-. revert k1. by induction Hl; intros [|??]; f_equal/=. Qed. Lemma Forall_zip_with_ext_r (g : A → B → C) l1 l2 k : l1 = l2 → Forall (λ y, ∀ x, f x y = g x y) k → zip_with f l1 k = zip_with g l2 k. Proof. intros <- Hk. revert l1. by induction Hk; intros [|??]; f_equal/=. Qed. Lemma zip_with_fmap_l {D} (g : D → A) lD k : zip_with f (g <$> lD) k = zip_with (λ z, f (g z)) lD k. Proof. revert k. by induction lD; intros [|??]; f_equal/=. Qed. Lemma zip_with_fmap_r {D} (g : D → B) l kD : zip_with f l (g <$> kD) = zip_with (λ x z, f x (g z)) l kD. Proof. revert kD. by induction l; intros [|??]; f_equal/=. Qed. Lemma zip_with_nil_inv l k : zip_with f l k = [] → l = [] ∨ k = []. Proof. destruct l, k; intros; simplify_eq/=; auto. Qed. Lemma zip_with_cons_inv l k z lC : zip_with f l k = z :: lC → ∃ x y l' k', z = f x y ∧ lC = zip_with f l' k' ∧ l = x :: l' ∧ k = y :: k'. Proof. intros. destruct l, k; simplify_eq/=; repeat eexists. Qed. Lemma zip_with_app_inv l k lC1 lC2 : zip_with f l k = lC1 ++ lC2 → ∃ l1 k1 l2 k2, lC1 = zip_with f l1 k1 ∧ lC2 = zip_with f l2 k2 ∧ l = l1 ++ l2 ∧ k = k1 ++ k2 ∧ length l1 = length k1. Proof. revert l k. induction lC1 as [|z lC1 IH]; simpl. { intros l k ?. by eexists [], [], l, k. } intros [|x l] [|y k] ?; simplify_eq/=. destruct (IH l k) as (l1&k1&l2&k2&->&->&->&->&?); [done |]. exists (x :: l1), (y :: k1), l2, k2; simpl; auto with congruence. Qed. Lemma zip_with_inj `{!Inj2 (=) (=) (=) f} l1 l2 k1 k2 : length l1 = length k1 → length l2 = length k2 → zip_with f l1 k1 = zip_with f l2 k2 → l1 = l2 ∧ k1 = k2. Proof. rewrite <-!Forall2_same_length. intros Hl. revert l2 k2. induction Hl; intros ?? [] ?; f_equal; naive_solver. Qed. Lemma zip_with_length l k : length (zip_with f l k) = min (length l) (length k). Proof. revert k. induction l; intros [|??]; simpl; auto with lia. Qed. Lemma zip_with_length_l l k : length l ≤ length k → length (zip_with f l k) = length l. Proof. rewrite zip_with_length; lia. Qed. Lemma zip_with_length_l_eq l k : length l = length k → length (zip_with f l k) = length l. Proof. rewrite zip_with_length; lia. Qed. Lemma zip_with_length_r l k : length k ≤ length l → length (zip_with f l k) = length k. Proof. rewrite zip_with_length; lia. Qed. Lemma zip_with_length_r_eq l k : length k = length l → length (zip_with f l k) = length k. Proof. rewrite zip_with_length; lia. Qed. Lemma zip_with_length_same_l P l k : Forall2 P l k → length (zip_with f l k) = length l. Proof. induction 1; simpl; auto. Qed. Lemma zip_with_length_same_r P l k : Forall2 P l k → length (zip_with f l k) = length k. Proof. induction 1; simpl; auto. Qed. Lemma lookup_zip_with l k i : zip_with f l k !! i = (x ← l !! i; y ← k !! i; Some (f x y)). Proof. revert k i. induction l; intros [|??] [|?]; f_equal/=; auto. by destruct (_ !! _). Qed. Lemma lookup_total_zip_with `{!Inhabited A, !Inhabited B, !Inhabited C} l k i : i < length l → i < length k → zip_with f l k !!! i = f (l !!! i) (k !!! i). Proof. intros [x Hx]%lookup_lt_is_Some_2 [y Hy]%lookup_lt_is_Some_2. by rewrite !list_lookup_total_alt, lookup_zip_with, Hx, Hy. Qed. Lemma lookup_zip_with_Some l k i z : zip_with f l k !! i = Some z ↔ ∃ x y, z = f x y ∧ l !! i = Some x ∧ k !! i = Some y. Proof. rewrite lookup_zip_with. destruct (l !! i), (k !! i); naive_solver. Qed. Lemma insert_zip_with l k i x y : <[i:=f x y]>(zip_with f l k) = zip_with f (<[i:=x]>l) (<[i:=y]>k). Proof. revert i k. induction l; intros [|?] [|??]; f_equal/=; auto. Qed. Lemma fmap_zip_with_l (g : C → A) l k : (∀ x y, g (f x y) = x) → length l ≤ length k → g <$> zip_with f l k = l. Proof. revert k. induction l; intros [|??] ??; f_equal/=; auto with lia. Qed. Lemma fmap_zip_with_r (g : C → B) l k : (∀ x y, g (f x y) = y) → length k ≤ length l → g <$> zip_with f l k = k. Proof. revert l. induction k; intros [|??] ??; f_equal/=; auto with lia. Qed. Lemma zip_with_zip l k : zip_with f l k = uncurry f <$> zip l k. Proof. revert k. by induction l; intros [|??]; f_equal/=. Qed. Lemma zip_with_fst_snd lk : zip_with f (lk.*1) (lk.*2) = uncurry f <$> lk. Proof. by induction lk as [|[]]; f_equal/=. Qed. Lemma zip_with_replicate n x y : zip_with f (replicate n x) (replicate n y) = replicate n (f x y). Proof. by induction n; f_equal/=. Qed. Lemma zip_with_replicate_l n x k : length k ≤ n → zip_with f (replicate n x) k = f x <$> k. Proof. revert n. induction k; intros [|?] ?; f_equal/=; auto with lia. Qed. Lemma zip_with_replicate_r n y l : length l ≤ n → zip_with f l (replicate n y) = flip f y <$> l. Proof. revert n. induction l; intros [|?] ?; f_equal/=; auto with lia. Qed. Lemma zip_with_replicate_r_eq n y l : length l = n → zip_with f l (replicate n y) = flip f y <$> l. Proof. intros; apply zip_with_replicate_r; lia. Qed. Lemma zip_with_take n l k : take n (zip_with f l k) = zip_with f (take n l) (take n k). Proof. revert n k. by induction l; intros [|?] [|??]; f_equal/=. Qed. Lemma zip_with_drop n l k : drop n (zip_with f l k) = zip_with f (drop n l) (drop n k). Proof. revert n k. induction l; intros [] []; f_equal/=; auto using zip_with_nil_r. Qed. Lemma zip_with_take_l' n l k : length l `min` length k ≤ n → zip_with f (take n l) k = zip_with f l k. Proof. revert n k. induction l; intros [] [] ?; f_equal/=; auto with lia. Qed. Lemma zip_with_take_l l k : zip_with f (take (length k) l) k = zip_with f l k. Proof. apply zip_with_take_l'; lia. Qed. Lemma zip_with_take_r' n l k : length l `min` length k ≤ n → zip_with f l (take n k) = zip_with f l k. Proof. revert n k. induction l; intros [] [] ?; f_equal/=; auto with lia. Qed. Lemma zip_with_take_r l k : zip_with f l (take (length l) k) = zip_with f l k. Proof. apply zip_with_take_r'; lia. Qed. Lemma zip_with_take_both' n1 n2 l k : length l `min` length k ≤ n1 → length l `min` length k ≤ n2 → zip_with f (take n1 l) (take n2 k) = zip_with f l k. Proof. intros. rewrite zip_with_take_l'; [apply zip_with_take_r' | rewrite take_length]; lia. Qed. Lemma zip_with_take_both l k : zip_with f (take (length k) l) (take (length l) k) = zip_with f l k. Proof. apply zip_with_take_both'; lia. Qed. Lemma Forall_zip_with_fst (P : A → Prop) (Q : C → Prop) l k : Forall P l → Forall (λ y, ∀ x, P x → Q (f x y)) k → Forall Q (zip_with f l k). Proof. intros Hl. revert k. induction Hl; destruct 1; simpl in *; auto. Qed. Lemma Forall_zip_with_snd (P : B → Prop) (Q : C → Prop) l k : Forall (λ x, ∀ y, P y → Q (f x y)) l → Forall P k → Forall Q (zip_with f l k). Proof. intros Hl. revert k. induction Hl; destruct 1; simpl in *; auto. Qed. Lemma elem_of_lookup_zip_with_1 l k (z : C) : z ∈ zip_with f l k → ∃ i x y, z = f x y ∧ l !! i = Some x ∧ k !! i = Some y. Proof. intros [i Hin]%elem_of_list_lookup. rewrite lookup_zip_with in Hin. simplify_option_eq; naive_solver. Qed. Lemma elem_of_lookup_zip_with_2 l k x y (z : C) i : l !! i = Some x → k !! i = Some y → f x y ∈ zip_with f l k. Proof. intros Hl Hk. rewrite elem_of_list_lookup. exists i. by rewrite lookup_zip_with, Hl, Hk. Qed. Lemma elem_of_lookup_zip_with l k (z : C) : z ∈ zip_with f l k ↔ ∃ i x y, z = f x y ∧ l !! i = Some x ∧ k !! i = Some y. Proof. naive_solver eauto using elem_of_lookup_zip_with_1, elem_of_lookup_zip_with_2. Qed. Lemma elem_of_zip_with l k (z : C) : z ∈ zip_with f l k → ∃ x y, z = f x y ∧ x ∈ l ∧ y ∈ k. Proof. intros ?%elem_of_lookup_zip_with. naive_solver eauto using elem_of_list_lookup_2. Qed. End zip_with. Lemma zip_with_diag {A C} (f : A → A → C) l : zip_with f l l = (λ x, f x x) <$> l. Proof. induction l as [|?? IH]; [done|]. simpl. rewrite IH. done. Qed. Lemma zip_with_sublist_alter {A B} (f : A → B → A) g l k i n l' k' : length l = length k → sublist_lookup i n l = Some l' → sublist_lookup i n k = Some k' → length (g l') = length k' → zip_with f (g l') k' = g (zip_with f l' k') → zip_with f (sublist_alter g i n l) k = sublist_alter g i n (zip_with f l k). Proof. unfold sublist_lookup, sublist_alter. intros Hlen; rewrite Hlen. intros ?? Hl' Hk'. simplify_option_eq. by rewrite !zip_with_app_l, !zip_with_drop, Hl', drop_drop, !zip_with_take, !take_length_le, Hk' by (rewrite ?drop_length; auto with lia). Qed. Section zip. Context {A B : Type}. Implicit Types l : list A. Implicit Types k : list B. Lemma fst_zip l k : length l ≤ length k → (zip l k).*1 = l. Proof. by apply fmap_zip_with_l. Qed. Lemma snd_zip l k : length k ≤ length l → (zip l k).*2 = k. Proof. by apply fmap_zip_with_r. Qed. Lemma zip_fst_snd (lk : list (A * B)) : zip (lk.*1) (lk.*2) = lk. Proof. by induction lk as [|[]]; f_equal/=. Qed. Lemma Forall2_fst P l1 l2 k1 k2 : length l2 = length k2 → Forall2 P l1 k1 → Forall2 (λ x y, P (x.1) (y.1)) (zip l1 l2) (zip k1 k2). Proof. rewrite <-Forall2_same_length. intros Hlk2 Hlk1. revert l2 k2 Hlk2. induction Hlk1; intros ?? [|??????]; simpl; auto. Qed. Lemma Forall2_snd P l1 l2 k1 k2 : length l1 = length k1 → Forall2 P l2 k2 → Forall2 (λ x y, P (x.2) (y.2)) (zip l1 l2) (zip k1 k2). Proof. rewrite <-Forall2_same_length. intros Hlk1 Hlk2. revert l1 k1 Hlk1. induction Hlk2; intros ?? [|??????]; simpl; auto. Qed. Lemma elem_of_zip_l x1 x2 l k : (x1, x2) ∈ zip l k → x1 ∈ l. Proof. intros ?%elem_of_zip_with. naive_solver. Qed. Lemma elem_of_zip_r x1 x2 l k : (x1, x2) ∈ zip l k → x2 ∈ k. Proof. intros ?%elem_of_zip_with. naive_solver. Qed. End zip. Lemma zip_diag {A} (l : list A) : zip l l = (λ x, (x, x)) <$> l. Proof. apply zip_with_diag. Qed. Lemma elem_of_zipped_map {A B} (f : list A → list A → A → B) l k x : x ∈ zipped_map f l k ↔ ∃ k' k'' y, k = k' ++ [y] ++ k'' ∧ x = f (reverse k' ++ l) k'' y. Proof. split. - revert l. induction k as [|z k IH]; simpl; intros l; inversion_clear 1. { by eexists [], k, z. } destruct (IH (z :: l)) as (k'&k''&y&->&->); [done |]. eexists (z :: k'), k'', y. by rewrite reverse_cons, <-(assoc_L (++)). - intros (k'&k''&y&->&->). revert l. induction k' as [|z k' IH]; [by left|]. intros l; right. by rewrite reverse_cons, <-!(assoc_L (++)). Qed. Section zipped_list_ind. Context {A} (P : list A → list A → Prop). Context (Pnil : ∀ l, P l []) (Pcons : ∀ l k x, P (x :: l) k → P l (x :: k)). Fixpoint zipped_list_ind l k : P l k := match k with | [] => Pnil _ | x :: k => Pcons _ _ _ (zipped_list_ind (x :: l) k) end. End zipped_list_ind. Lemma zipped_Forall_app {A} (P : list A → list A → A → Prop) l k k' : zipped_Forall P l (k ++ k') → zipped_Forall P (reverse k ++ l) k'. Proof. revert l. induction k as [|x k IH]; simpl; [done |]. inversion_clear 1. rewrite reverse_cons, <-(assoc_L (++)). by apply IH. Qed. Lemma TCForall_Forall {A} (P : A → Prop) xs : TCForall P xs ↔ Forall P xs. Proof. split; induction 1; constructor; auto. Qed. Global Instance TCForall_app {A} (P : A → Prop) xs ys : TCForall P xs → TCForall P ys → TCForall P (xs ++ ys). Proof. rewrite !TCForall_Forall. apply Forall_app_2. Qed. Lemma TCForall2_Forall2 {A B} (P : A → B → Prop) xs ys : TCForall2 P xs ys ↔ Forall2 P xs ys. Proof. split; induction 1; constructor; auto. Qed. Lemma TCExists_Exists {A} (P : A → Prop) l : TCExists P l ↔ Exists P l. Proof. split; induction 1; constructor; solve [auto]. Qed. Section positives_flatten_unflatten. Local Open Scope positive_scope. Lemma positives_flatten_go_app xs acc : positives_flatten_go xs acc = acc ++ positives_flatten_go xs 1. Proof. revert acc. induction xs as [|x xs IH]; intros acc; simpl. - reflexivity. - rewrite IH. rewrite (IH (6 ++ _)). rewrite 2!(assoc_L (++)). reflexivity. Qed. Lemma positives_unflatten_go_app p suffix xs acc : positives_unflatten_go (suffix ++ Pos.reverse (Pos.dup p)) xs acc = positives_unflatten_go suffix xs (acc ++ p). Proof. revert suffix acc. induction p as [p IH|p IH|]; intros acc suffix; simpl. - rewrite 2!Pos.reverse_xI. rewrite 2!(assoc_L (++)). rewrite IH. reflexivity. - rewrite 2!Pos.reverse_xO. rewrite 2!(assoc_L (++)). rewrite IH. reflexivity. - reflexivity. Qed. Lemma positives_unflatten_flatten_go suffix xs acc : positives_unflatten_go (suffix ++ positives_flatten_go xs 1) acc 1 = positives_unflatten_go suffix (xs ++ acc) 1. Proof. revert suffix acc. induction xs as [|x xs IH]; intros suffix acc; simpl. - reflexivity. - rewrite positives_flatten_go_app. rewrite (assoc_L (++)). rewrite IH. rewrite (assoc_L (++)). rewrite positives_unflatten_go_app. simpl. rewrite (left_id_L 1 (++)). reflexivity. Qed. Lemma positives_unflatten_flatten xs : positives_unflatten (positives_flatten xs) = Some xs. Proof. unfold positives_flatten, positives_unflatten. replace (positives_flatten_go xs 1) with (1 ++ positives_flatten_go xs 1) by apply (left_id_L 1 (++)). rewrite positives_unflatten_flatten_go. simpl. rewrite (right_id_L [] (++)%list). reflexivity. Qed. Lemma positives_flatten_app xs ys : positives_flatten (xs ++ ys) = positives_flatten xs ++ positives_flatten ys. Proof. unfold positives_flatten. revert ys. induction xs as [|x xs IH]; intros ys; simpl. - rewrite (left_id_L 1 (++)). reflexivity. - rewrite positives_flatten_go_app, (positives_flatten_go_app xs). rewrite IH. rewrite (assoc_L (++)). reflexivity. Qed. Lemma positives_flatten_cons x xs : positives_flatten (x :: xs) = 1~1~0 ++ Pos.reverse (Pos.dup x) ++ positives_flatten xs. Proof. change (x :: xs) with ([x] ++ xs)%list. rewrite positives_flatten_app. rewrite (assoc_L (++)). reflexivity. Qed. Lemma positives_flatten_suffix (l k : list positive) : l `suffix_of` k → ∃ q, positives_flatten k = q ++ positives_flatten l. Proof. intros [l' ->]. exists (positives_flatten l'). apply positives_flatten_app. Qed. Lemma positives_flatten_suffix_eq p1 p2 (xs ys : list positive) : length xs = length ys → p1 ++ positives_flatten xs = p2 ++ positives_flatten ys → xs = ys. Proof. revert p1 p2 ys; induction xs as [|x xs IH]; intros p1 p2 [|y ys] ?; simplify_eq/=; auto. rewrite !positives_flatten_cons, !(assoc _); intros Hl. assert (xs = ys) as <- by eauto; clear IH; f_equal. apply (inj (.++ positives_flatten xs)) in Hl. rewrite 2!Pos.reverse_dup in Hl. apply (Pos.dup_suffix_eq _ _ p1 p2) in Hl. by apply (inj Pos.reverse). Qed. End positives_flatten_unflatten. (** * Reflection over lists *) (** We define a simple data structure [rlist] to capture a syntactic representation of lists consisting of constants, applications and the nil list. Note that we represent [(x ::.)] as [rapp (rnode [x])]. For now, we abstract over the type of constants, but later we use [nat]s and a list representing a corresponding environment. *) Inductive rlist (A : Type) := rnil : rlist A | rnode : A → rlist A | rapp : rlist A → rlist A → rlist A. Global Arguments rnil {_} : assert. Global Arguments rnode {_} _ : assert. Global Arguments rapp {_} _ _ : assert. Module rlist. Fixpoint to_list {A} (t : rlist A) : list A := match t with | rnil => [] | rnode l => [l] | rapp t1 t2 => to_list t1 ++ to_list t2 end. Notation env A := (list (list A)) (only parsing). Definition eval {A} (E : env A) : rlist nat → list A := fix go t := match t with | rnil => [] | rnode i => default [] (E !! i) | rapp t1 t2 => go t1 ++ go t2 end. (** A simple quoting mechanism using type classes. [QuoteLookup E1 E2 x i] means: starting in environment [E1], look up the index [i] corresponding to the constant [x]. In case [x] has a corresponding index [i] in [E1], the original environment is given back as [E2]. Otherwise, the environment [E2] is extended with a binding [i] for [x]. *) Section quote_lookup. Context {A : Type}. Class QuoteLookup (E1 E2 : list A) (x : A) (i : nat) := {}. Global Instance quote_lookup_here E x : QuoteLookup (x :: E) (x :: E) x 0 := {}. Global Instance quote_lookup_end x : QuoteLookup [] [x] x 0 := {}. Global Instance quote_lookup_further E1 E2 x i y : QuoteLookup E1 E2 x i → QuoteLookup (y :: E1) (y :: E2) x (S i) | 1000 := {}. End quote_lookup. Section quote. Context {A : Type}. Class Quote (E1 E2 : env A) (l : list A) (t : rlist nat) := {}. Global Instance quote_nil E1 : Quote E1 E1 [] rnil := {}. Global Instance quote_node E1 E2 l i: QuoteLookup E1 E2 l i → Quote E1 E2 l (rnode i) | 1000 := {}. Global Instance quote_cons E1 E2 E3 x l i t : QuoteLookup E1 E2 [x] i → Quote E2 E3 l t → Quote E1 E3 (x :: l) (rapp (rnode i) t) := {}. Global Instance quote_app E1 E2 E3 l1 l2 t1 t2 : Quote E1 E2 l1 t1 → Quote E2 E3 l2 t2 → Quote E1 E3 (l1 ++ l2) (rapp t1 t2) := {}. End quote. Section eval. Context {A} (E : env A). Lemma eval_alt t : eval E t = to_list t ≫= default [] ∘ (E !!.). Proof. induction t; csimpl. - done. - by rewrite (right_id_L [] (++)). - rewrite bind_app. by f_equal. Qed. Lemma eval_eq t1 t2 : to_list t1 = to_list t2 → eval E t1 = eval E t2. Proof. intros Ht. by rewrite !eval_alt, Ht. Qed. Lemma eval_Permutation t1 t2 : to_list t1 ≡ₚ to_list t2 → eval E t1 ≡ₚ eval E t2. Proof. intros Ht. by rewrite !eval_alt, Ht. Qed. Lemma eval_submseteq t1 t2 : to_list t1 ⊆+ to_list t2 → eval E t1 ⊆+ eval E t2. Proof. intros Ht. by rewrite !eval_alt, Ht. Qed. End eval. End rlist. (** * Tactics *) Ltac quote_Permutation := match goal with | |- ?l1 ≡ₚ ?l2 => match type of (_ : rlist.Quote [] _ l1 _) with rlist.Quote _ ?E2 _ ?t1 => match type of (_ : rlist.Quote E2 _ l2 _) with rlist.Quote _ ?E3 _ ?t2 => change (rlist.eval E3 t1 ≡ₚ rlist.eval E3 t2) end end end. Ltac solve_Permutation := quote_Permutation; apply rlist.eval_Permutation; compute_done. Ltac quote_submseteq := match goal with | |- ?l1 ⊆+ ?l2 => match type of (_ : rlist.Quote [] _ l1 _) with rlist.Quote _ ?E2 _ ?t1 => match type of (_ : rlist.Quote E2 _ l2 _) with rlist.Quote _ ?E3 _ ?t2 => change (rlist.eval E3 t1 ⊆+ rlist.eval E3 t2) end end end. Ltac solve_submseteq := quote_submseteq; apply rlist.eval_submseteq; compute_done. Ltac decompose_elem_of_list := repeat match goal with | H : ?x ∈ [] |- _ => by destruct (not_elem_of_nil x) | H : _ ∈ _ :: _ |- _ => apply elem_of_cons in H; destruct H | H : _ ∈ _ ++ _ |- _ => apply elem_of_app in H; destruct H end. Ltac solve_length := simplify_eq/=; repeat (rewrite fmap_length || rewrite app_length); repeat match goal with | H : _ =@{list _} _ |- _ => apply (f_equal length) in H | H : Forall2 _ _ _ |- _ => apply Forall2_length in H | H : context[length (_ <$> _)] |- _ => rewrite fmap_length in H end; done || congruence. Ltac simplify_list_eq ::= repeat match goal with | _ => progress simplify_eq/= | H : [?x] !! ?i = Some ?y |- _ => destruct i; [change (Some x = Some y) in H | discriminate] | H : _ <$> _ = [] |- _ => apply fmap_nil_inv in H | H : [] = _ <$> _ |- _ => symmetry in H; apply fmap_nil_inv in H | H : zip_with _ _ _ = [] |- _ => apply zip_with_nil_inv in H; destruct H | H : [] = zip_with _ _ _ |- _ => symmetry in H | |- context [(_ ++ _) ++ _] => rewrite <-(assoc_L (++)) | H : context [(_ ++ _) ++ _] |- _ => rewrite <-(assoc_L (++)) in H | H : context [_ <$> (_ ++ _)] |- _ => rewrite fmap_app in H | |- context [_ <$> (_ ++ _)] => rewrite fmap_app | |- context [_ ++ []] => rewrite (right_id_L [] (++)) | H : context [_ ++ []] |- _ => rewrite (right_id_L [] (++)) in H | |- context [take _ (_ <$> _)] => rewrite <-fmap_take | H : context [take _ (_ <$> _)] |- _ => rewrite <-fmap_take in H | |- context [drop _ (_ <$> _)] => rewrite <-fmap_drop | H : context [drop _ (_ <$> _)] |- _ => rewrite <-fmap_drop in H | H : _ ++ _ = _ ++ _ |- _ => repeat (rewrite <-app_comm_cons in H || rewrite <-(assoc_L (++)) in H); apply app_inj_1 in H; [destruct H|solve_length] | H : _ ++ _ = _ ++ _ |- _ => repeat (rewrite app_comm_cons in H || rewrite (assoc_L (++)) in H); apply app_inj_2 in H; [destruct H|solve_length] | |- context [zip_with _ (_ ++ _) (_ ++ _)] => rewrite zip_with_app by solve_length | |- context [take _ (_ ++ _)] => rewrite take_app_length' by solve_length | |- context [drop _ (_ ++ _)] => rewrite drop_app_length' by solve_length | H : context [zip_with _ (_ ++ _) (_ ++ _)] |- _ => rewrite zip_with_app in H by solve_length | H : context [take _ (_ ++ _)] |- _ => rewrite take_app_length' in H by solve_length | H : context [drop _ (_ ++ _)] |- _ => rewrite drop_app_length' in H by solve_length | H : ?l !! ?i = _, H2 : context [(_ <$> ?l) !! ?i] |- _ => rewrite list_lookup_fmap, H in H2 end. Ltac decompose_Forall_hyps := repeat match goal with | H : Forall _ [] |- _ => clear H | H : Forall _ (_ :: _) |- _ => rewrite Forall_cons in H; destruct H | H : Forall _ (_ ++ _) |- _ => rewrite Forall_app in H; destruct H | H : Forall2 _ [] [] |- _ => clear H | H : Forall2 _ (_ :: _) [] |- _ => destruct (Forall2_cons_nil_inv _ _ _ H) | H : Forall2 _ [] (_ :: _) |- _ => destruct (Forall2_nil_cons_inv _ _ _ H) | H : Forall2 _ [] ?k |- _ => apply Forall2_nil_inv_l in H | H : Forall2 _ ?l [] |- _ => apply Forall2_nil_inv_r in H | H : Forall2 _ (_ :: _) (_ :: _) |- _ => apply Forall2_cons_1 in H; destruct H | H : Forall2 _ (_ :: _) ?k |- _ => let k_hd := fresh k "_hd" in let k_tl := fresh k "_tl" in apply Forall2_cons_inv_l in H; destruct H as (k_hd&k_tl&?&?&->); rename k_tl into k | H : Forall2 _ ?l (_ :: _) |- _ => let l_hd := fresh l "_hd" in let l_tl := fresh l "_tl" in apply Forall2_cons_inv_r in H; destruct H as (l_hd&l_tl&?&?&->); rename l_tl into l | H : Forall2 _ (_ ++ _) ?k |- _ => let k1 := fresh k "_1" in let k2 := fresh k "_2" in apply Forall2_app_inv_l in H; destruct H as (k1&k2&?&?&->) | H : Forall2 _ ?l (_ ++ _) |- _ => let l1 := fresh l "_1" in let l2 := fresh l "_2" in apply Forall2_app_inv_r in H; destruct H as (l1&l2&?&?&->) | _ => progress simplify_eq/= | H : Forall3 _ _ (_ :: _) _ |- _ => apply Forall3_cons_inv_m in H; destruct H as (?&?&?&?&?&?&?&?) | H : Forall2 _ (_ :: _) ?k |- _ => apply Forall2_cons_inv_l in H; destruct H as (?&?&?&?&?) | H : Forall2 _ ?l (_ :: _) |- _ => apply Forall2_cons_inv_r in H; destruct H as (?&?&?&?&?) | H : Forall2 _ (_ ++ _) (_ ++ _) |- _ => apply Forall2_app_inv in H; [destruct H|solve_length] | H : Forall2 _ ?l (_ ++ _) |- _ => apply Forall2_app_inv_r in H; destruct H as (?&?&?&?&?) | H : Forall2 _ (_ ++ _) ?k |- _ => apply Forall2_app_inv_l in H; destruct H as (?&?&?&?&?) | H : Forall3 _ _ (_ ++ _) _ |- _ => apply Forall3_app_inv_m in H; destruct H as (?&?&?&?&?&?&?&?) | H : Forall ?P ?l, H1 : ?l !! _ = Some ?x |- _ => (* to avoid some stupid loops, not fool proof *) unless (P x) by auto using Forall_app_2, Forall_nil_2; let E := fresh in assert (P x) as E by (apply (Forall_lookup_1 P _ _ _ H H1)); lazy beta in E | H : Forall2 ?P ?l ?k |- _ => match goal with | H1 : l !! ?i = Some ?x, H2 : k !! ?i = Some ?y |- _ => unless (P x y) by done; let E := fresh in assert (P x y) as E by (by apply (Forall2_lookup_lr P l k i x y)); lazy beta in E | H1 : l !! ?i = Some ?x |- _ => try (match goal with _ : k !! i = Some _ |- _ => fail 2 end); destruct (Forall2_lookup_l P _ _ _ _ H H1) as (?&?&?) | H2 : k !! ?i = Some ?y |- _ => try (match goal with _ : l !! i = Some _ |- _ => fail 2 end); destruct (Forall2_lookup_r P _ _ _ _ H H2) as (?&?&?) end | H : Forall3 ?P ?l ?l' ?k |- _ => lazymatch goal with | H1:l !! ?i = Some ?x, H2:l' !! ?i = Some ?y, H3:k !! ?i = Some ?z |- _ => unless (P x y z) by done; let E := fresh in assert (P x y z) as E by (by apply (Forall3_lookup_lmr P l l' k i x y z)); lazy beta in E | H1 : l !! _ = Some ?x |- _ => destruct (Forall3_lookup_l P _ _ _ _ _ H H1) as (?&?&?&?&?) | H2 : l' !! _ = Some ?y |- _ => destruct (Forall3_lookup_m P _ _ _ _ _ H H2) as (?&?&?&?&?) | H3 : k !! _ = Some ?z |- _ => destruct (Forall3_lookup_r P _ _ _ _ _ H H3) as (?&?&?&?&?) end end. Ltac list_simplifier := simplify_eq/=; repeat match goal with | _ => progress decompose_Forall_hyps | _ => progress simplify_list_eq | H : _ <$> _ = _ :: _ |- _ => apply fmap_cons_inv in H; destruct H as (?&?&?&?&?) | H : _ :: _ = _ <$> _ |- _ => symmetry in H | H : _ <$> _ = _ ++ _ |- _ => apply fmap_app_inv in H; destruct H as (?&?&?&?&?) | H : _ ++ _ = _ <$> _ |- _ => symmetry in H | H : zip_with _ _ _ = _ :: _ |- _ => apply zip_with_cons_inv in H; destruct H as (?&?&?&?&?&?&?&?) | H : _ :: _ = zip_with _ _ _ |- _ => symmetry in H | H : zip_with _ _ _ = _ ++ _ |- _ => apply zip_with_app_inv in H; destruct H as (?&?&?&?&?&?&?&?&?) | H : _ ++ _ = zip_with _ _ _ |- _ => symmetry in H end. Ltac decompose_Forall := repeat match goal with | |- Forall _ _ => by apply Forall_true | |- Forall _ [] => constructor | |- Forall _ (_ :: _) => constructor | |- Forall _ (_ ++ _) => apply Forall_app_2 | |- Forall _ (_ <$> _) => apply Forall_fmap | |- Forall _ (_ ≫= _) => apply Forall_bind | |- Forall2 _ _ _ => apply Forall_Forall2_diag | |- Forall2 _ [] [] => constructor | |- Forall2 _ (_ :: _) (_ :: _) => constructor | |- Forall2 _ (_ ++ _) (_ ++ _) => first [ apply Forall2_app; [by decompose_Forall |] | apply Forall2_app; [| by decompose_Forall]] | |- Forall2 _ (_ <$> _) _ => apply Forall2_fmap_l | |- Forall2 _ _ (_ <$> _) => apply Forall2_fmap_r | _ => progress decompose_Forall_hyps | H : Forall _ (_ <$> _) |- _ => rewrite Forall_fmap in H | H : Forall _ (_ ≫= _) |- _ => rewrite Forall_bind in H | |- Forall _ _ => apply Forall_lookup_2; intros ???; progress decompose_Forall_hyps | |- Forall2 _ _ _ => apply Forall2_same_length_lookup_2; [solve_length|]; intros ?????; progress decompose_Forall_hyps end. (** The [simplify_suffix] tactic removes [suffix] hypotheses that are tautologies, and simplifies [suffix] hypotheses involving [(::)] and [(++)]. *) Ltac simplify_suffix := repeat match goal with | H : suffix (_ :: _) _ |- _ => destruct (suffix_cons_not _ _ H) | H : suffix (_ :: _) [] |- _ => apply suffix_nil_inv in H | H : suffix (_ ++ _) (_ ++ _) |- _ => apply suffix_app_inv in H | H : suffix (_ :: _) (_ :: _) |- _ => destruct (suffix_cons_inv _ _ _ _ H); clear H | H : suffix ?x ?x |- _ => clear H | H : suffix ?x (_ :: ?x) |- _ => clear H | H : suffix ?x (_ ++ ?x) |- _ => clear H | _ => progress simplify_eq/= end. (** The [solve_suffix] tactic tries to solve goals involving [suffix]. It uses [simplify_suffix] to simplify hypotheses and tries to solve [suffix] conclusions. This tactic either fails or proves the goal. *) Ltac solve_suffix := by intuition (repeat match goal with | _ => done | _ => progress simplify_suffix | |- suffix [] _ => apply suffix_nil | |- suffix _ _ => reflexivity | |- suffix _ (_ :: _) => apply suffix_cons_r | |- suffix _ (_ ++ _) => apply suffix_app_r | H : suffix _ _ → False |- _ => destruct H end). stdpp-coq-stdpp-1.9.0/stdpp/list_numbers.v000066400000000000000000000410461451153341500206210ustar00rootroot00000000000000(** This file collects general purpose definitions and theorems on lists of numbers that are not in the Coq standard library. *) From stdpp Require Export list. From stdpp Require Import options. (** * Definitions *) (** [seqZ m n] generates the sequence [m], [m + 1], ..., [m + n - 1] over integers, provided [0 ≤ n]. If [n < 0], then the range is empty. **) Definition seqZ (m len: Z) : list Z := (λ i: nat, Z.add (Z.of_nat i) m) <$> (seq 0 (Z.to_nat len)). Global Arguments seqZ : simpl never. Definition sum_list_with {A} (f : A → nat) : list A → nat := fix go l := match l with | [] => 0 | x :: l => f x + go l end. Notation sum_list := (sum_list_with id). Definition max_list_with {A} (f : A → nat) : list A → nat := fix go l := match l with | [] => 0 | x :: l => f x `max` go l end. Notation max_list := (max_list_with id). (** ** Conversion of integers to and from little endian *) (** [Z_to_little_endian m n z] converts [z] into a list of [m] [n]-bit integers in the little endian format. A negative [z] is encoded using two's-complement. If [z] uses more than [m * n] bits, these additional bits are discarded (see [Z_to_little_endian_to_Z]). [m] and [n] should be non-negative. *) Definition Z_to_little_endian (m n : Z) : Z → list Z := Z.iter m (λ rec z, Z.land z (Z.ones n) :: rec (z ≫ n)%Z) (λ _, []). Global Arguments Z_to_little_endian : simpl never. (** [little_endian_to_Z n bs] converts the list [bs] of [n]-bit integers into a number by interpreting [bs] as the little endian encoding. The integers [b] in [bs] should be in the range [0 ≤ b < 2 ^ n]. *) Fixpoint little_endian_to_Z (n : Z) (bs : list Z) : Z := match bs with | [] => 0 | b :: bs => Z.lor b (little_endian_to_Z n bs ≪ n) end. (** * Properties *) (** ** Properties of the [seq] function *) Section seq. Implicit Types m n i j : nat. Lemma fmap_add_seq j j' n : Nat.add j <$> seq j' n = seq (j + j') n. Proof. revert j'. induction n as [|n IH]; intros j'; csimpl; [reflexivity|]. by rewrite IH, Nat.add_succ_r. Qed. Lemma fmap_S_seq j n : S <$> seq j n = seq (S j) n. Proof. apply (fmap_add_seq 1). Qed. Lemma imap_seq {A B} (l : list A) (g : nat → B) i : imap (λ j _, g (i + j)) l = g <$> seq i (length l). Proof. revert i. induction l as [|x l IH]; [done|]. csimpl. intros n. rewrite <-IH, <-plus_n_O. f_equal. apply imap_ext; simpl; auto with lia. Qed. Lemma imap_seq_0 {A B} (l : list A) (g : nat → B) : imap (λ j _, g j) l = g <$> seq 0 (length l). Proof. rewrite (imap_ext _ (λ i o, g (0 + i))); [|done]. apply imap_seq. Qed. Lemma lookup_seq_lt j n i : i < n → seq j n !! i = Some (j + i). Proof. revert j i. induction n as [|n IH]; intros j [|i] ?; simpl; auto with lia. rewrite IH; auto with lia. Qed. Lemma lookup_total_seq_lt j n i : i < n → seq j n !!! i = j + i. Proof. intros. by rewrite !list_lookup_total_alt, lookup_seq_lt. Qed. Lemma lookup_seq_ge j n i : n ≤ i → seq j n !! i = None. Proof. revert j i. induction n; intros j [|i] ?; simpl; auto with lia. Qed. Lemma lookup_total_seq_ge j n i : n ≤ i → seq j n !!! i = inhabitant. Proof. intros. by rewrite !list_lookup_total_alt, lookup_seq_ge. Qed. Lemma lookup_seq j n i j' : seq j n !! i = Some j' ↔ j' = j + i ∧ i < n. Proof. destruct (le_lt_dec n i). - rewrite lookup_seq_ge by done. naive_solver lia. - rewrite lookup_seq_lt by done. naive_solver lia. Qed. Lemma NoDup_seq j n : NoDup (seq j n). Proof. apply NoDup_ListNoDup, seq_NoDup. Qed. Lemma elem_of_seq j n k : k ∈ seq j n ↔ j ≤ k < j + n. Proof. rewrite elem_of_list_In, in_seq. done. Qed. Lemma Forall_seq (P : nat → Prop) i n : Forall P (seq i n) ↔ ∀ j, i ≤ j < i + n → P j. Proof. rewrite Forall_forall. setoid_rewrite elem_of_seq. auto with lia. Qed. Lemma drop_seq j n m : drop m (seq j n) = seq (j + m) (n - m). Proof. revert j m. induction n as [|n IH]; simpl; intros j m. - rewrite drop_nil. done. - destruct m; simpl. + rewrite Nat.add_0_r. done. + rewrite IH. f_equal; lia. Qed. Lemma take_seq j n m : take m (seq j n) = seq j (m `min` n). Proof. revert j m. induction n as [|n IH]; simpl; intros j m. - rewrite take_nil. replace (m `min` 0) with 0 by lia. done. - destruct m; simpl; auto with f_equal. Qed. End seq. (** ** Properties of the [seqZ] function *) Section seqZ. Implicit Types (m n : Z) (i j : nat). Local Open Scope Z_scope. Lemma seqZ_nil m n : n ≤ 0 → seqZ m n = []. Proof. by destruct n. Qed. Lemma seqZ_cons m n : 0 < n → seqZ m n = m :: seqZ (Z.succ m) (Z.pred n). Proof. intros H. unfold seqZ. replace n with (Z.succ (Z.pred n)) at 1 by lia. rewrite Z2Nat.inj_succ by lia. f_equal/=. rewrite <-fmap_S_seq, <-list_fmap_compose. apply map_ext; naive_solver lia. Qed. Lemma seqZ_length m n : length (seqZ m n) = Z.to_nat n. Proof. unfold seqZ; by rewrite fmap_length, seq_length. Qed. Lemma fmap_add_seqZ m m' n : Z.add m <$> seqZ m' n = seqZ (m + m') n. Proof. revert m'. induction n as [|n ? IH|] using (Z.succ_pred_induction 0); intros m'. - by rewrite seqZ_nil. - rewrite (seqZ_cons m') by lia. rewrite (seqZ_cons (m + m')) by lia. f_equal/=. rewrite Z.pred_succ, IH; simpl. f_equal; lia. - by rewrite !seqZ_nil by lia. Qed. Lemma lookup_seqZ_lt m n i : Z.of_nat i < n → seqZ m n !! i = Some (m + Z.of_nat i). Proof. revert m i. induction n as [|n ? IH|] using (Z.succ_pred_induction 0); intros m i Hi; [lia| |lia]. rewrite seqZ_cons by lia. destruct i as [|i]; simpl. - f_equal; lia. - rewrite Z.pred_succ, IH by lia. f_equal; lia. Qed. Lemma lookup_total_seqZ_lt m n i : Z.of_nat i < n → seqZ m n !!! i = m + Z.of_nat i. Proof. intros. by rewrite !list_lookup_total_alt, lookup_seqZ_lt. Qed. Lemma lookup_seqZ_ge m n i : n ≤ Z.of_nat i → seqZ m n !! i = None. Proof. revert m i. induction n as [|n ? IH|] using (Z.succ_pred_induction 0); intros m i Hi; try lia. - by rewrite seqZ_nil. - rewrite seqZ_cons by lia. destruct i as [|i]; simpl; [lia|]. by rewrite Z.pred_succ, IH by lia. - by rewrite seqZ_nil by lia. Qed. Lemma lookup_total_seqZ_ge m n i : n ≤ Z.of_nat i → seqZ m n !!! i = inhabitant. Proof. intros. by rewrite !list_lookup_total_alt, lookup_seqZ_ge. Qed. Lemma lookup_seqZ m n i m' : seqZ m n !! i = Some m' ↔ m' = m + Z.of_nat i ∧ Z.of_nat i < n. Proof. destruct (Z_le_gt_dec n (Z.of_nat i)). - rewrite lookup_seqZ_ge by lia. naive_solver lia. - rewrite lookup_seqZ_lt by lia. naive_solver lia. Qed. Lemma NoDup_seqZ m n : NoDup (seqZ m n). Proof. apply NoDup_fmap_2, NoDup_seq. intros ???; lia. Qed. Lemma seqZ_app m n1 n2 : 0 ≤ n1 → 0 ≤ n2 → seqZ m (n1 + n2) = seqZ m n1 ++ seqZ (m + n1) n2. Proof. intros. unfold seqZ. rewrite Z2Nat.inj_add, seq_app, fmap_app by done. f_equal. rewrite Nat.add_comm, <-!fmap_add_seq, <-list_fmap_compose. apply list_fmap_ext; intros j n; simpl. rewrite Nat2Z.inj_add, Z2Nat.id by done. lia. Qed. Lemma seqZ_S m i : seqZ m (Z.of_nat (S i)) = seqZ m (Z.of_nat i) ++ [m + Z.of_nat i]. Proof. unfold seqZ. rewrite !Nat2Z.id, seq_S, fmap_app. simpl. by rewrite Z.add_comm. Qed. Lemma elem_of_seqZ m n k : k ∈ seqZ m n ↔ m ≤ k < m + n. Proof. rewrite elem_of_list_lookup. setoid_rewrite lookup_seqZ. split; [naive_solver lia|]. exists (Z.to_nat (k - m)). rewrite Z2Nat.id by lia. lia. Qed. Lemma Forall_seqZ (P : Z → Prop) m n : Forall P (seqZ m n) ↔ ∀ m', m ≤ m' < m + n → P m'. Proof. rewrite Forall_forall. setoid_rewrite elem_of_seqZ. auto with lia. Qed. End seqZ. (** ** Properties of the [sum_list] function *) Section sum_list. Context {A : Type}. Implicit Types x y z : A. Implicit Types l k : list A. Lemma sum_list_with_app (f : A → nat) l k : sum_list_with f (l ++ k) = sum_list_with f l + sum_list_with f k. Proof. induction l; simpl; lia. Qed. Lemma sum_list_with_reverse (f : A → nat) l : sum_list_with f (reverse l) = sum_list_with f l. Proof. induction l; simpl; rewrite ?reverse_cons, ?sum_list_with_app; simpl; lia. Qed. Lemma sum_list_with_in x (f : A → nat) ls : x ∈ ls → f x ≤ sum_list_with f ls. Proof. induction 1; simpl; lia. Qed. Lemma join_reshape szs l : sum_list szs = length l → mjoin (reshape szs l) = l. Proof. revert l. induction szs as [|sz szs IH]; simpl; intros l Hl; [by destruct l|]. by rewrite IH, take_drop by (rewrite drop_length; lia). Qed. Lemma sum_list_replicate n m : sum_list (replicate m n) = m * n. Proof. induction m; simpl; auto. Qed. Lemma sum_list_fmap_same n l f : Forall (λ x, f x = n) l → sum_list (f <$> l) = length l * n. Proof. induction 1; csimpl; lia. Qed. Lemma sum_list_fmap_const l n : sum_list ((λ _, n) <$> l) = length l * n. Proof. by apply sum_list_fmap_same, Forall_true. Qed. End sum_list. (** ** Properties of the [mjoin] function that rely on [sum_list] *) Section mjoin. Context {A : Type}. Implicit Types x y z : A. Implicit Types l k : list A. Implicit Types ls : list (list A). Lemma join_length ls: length (mjoin ls) = sum_list (length <$> ls). Proof. induction ls; [done|]; csimpl. rewrite app_length. lia. Qed. Lemma join_lookup_Some ls i x : mjoin ls !! i = Some x ↔ ∃ j l i', ls !! j = Some l ∧ l !! i' = Some x ∧ i = sum_list (length <$> take j ls) + i'. Proof. revert i. induction ls as [|l ls IH]; csimpl; intros i. { setoid_rewrite lookup_nil. naive_solver. } rewrite lookup_app_Some, IH. split. - destruct 1 as [?|(?&?&?&?&?&?&?)]. + eexists 0. naive_solver. + eexists (S _); naive_solver lia. - destruct 1 as [[|?] ?]; naive_solver lia. Qed. Lemma join_lookup_Some_same_length n ls i x : Forall (λ l, length l = n) ls → mjoin ls !! i = Some x ↔ ∃ j l i', ls !! j = Some l ∧ l !! i' = Some x ∧ i = j * n + i'. Proof. intros Hl. rewrite join_lookup_Some. f_equiv; intros j. f_equiv; intros l. f_equiv; intros i'. assert (ls !! j = Some l → j < length ls) by eauto using lookup_lt_Some. rewrite (sum_list_fmap_same n), take_length by auto using Forall_take. naive_solver lia. Qed. Lemma join_lookup_Some_same_length' n ls j i x : Forall (λ l, length l = n) ls → i < n → mjoin ls !! (j * n + i) = Some x ↔ ∃ l, ls !! j = Some l ∧ l !! i = Some x. Proof. intros. rewrite join_lookup_Some_same_length by done. split; [|naive_solver]. destruct 1 as (j'&l'&i'&?&?&Hj); decompose_Forall. assert (i' < length l') by eauto using lookup_lt_Some. apply Nat.mul_split_l in Hj; naive_solver. Qed. End mjoin. (** ** Properties of the [max_list] function *) Section max_list. Context {A : Type}. Lemma max_list_elem_of_le n ns : n ∈ ns → n ≤ max_list ns. Proof. induction 1; simpl; lia. Qed. Lemma max_list_not_elem_of_gt n ns : max_list ns < n → n ∉ ns. Proof. intros ??%max_list_elem_of_le. lia. Qed. Lemma max_list_elem_of ns : ns ≠ [] → max_list ns ∈ ns. Proof. intros. induction ns as [|n ns IHns]; [done|]. simpl. destruct (Nat.max_spec n (max_list ns)) as [[? ->]|[? ->]]. - destruct ns. + simpl in *. lia. + by apply elem_of_list_further, IHns. - apply elem_of_list_here. Qed. End max_list. (** ** Properties of the [Z_to_little_endian] and [little_endian_to_Z] functions *) Section Z_little_endian. Local Open Scope Z_scope. Implicit Types m n z : Z. Lemma Z_to_little_endian_0 n z : Z_to_little_endian 0 n z = []. Proof. done. Qed. Lemma Z_to_little_endian_succ m n z : 0 ≤ m → Z_to_little_endian (Z.succ m) n z = Z.land z (Z.ones n) :: Z_to_little_endian m n (z ≫ n). Proof. unfold Z_to_little_endian. intros. by rewrite !iter_nat_of_Z, Zabs2Nat.inj_succ by lia. Qed. Lemma Z_to_little_endian_to_Z m n bs : m = Z.of_nat (length bs) → 0 ≤ n → Forall (λ b, 0 ≤ b < 2 ^ n) bs → Z_to_little_endian m n (little_endian_to_Z n bs) = bs. Proof. intros -> ?. induction 1 as [|b bs ? ? IH]; [done|]; simpl. rewrite Nat2Z.inj_succ, Z_to_little_endian_succ by lia. f_equal. - apply Z.bits_inj_iff'. intros z' ?. rewrite !Z.land_spec, Z.lor_spec, Z.ones_spec by lia. case_bool_decide. + rewrite andb_true_r, Z.shiftl_spec_low, orb_false_r by lia. done. + rewrite andb_false_r. symmetry. eapply (Z.bounded_iff_bits_nonneg n); lia. - rewrite <-IH at 3. f_equal. apply Z.bits_inj_iff'. intros z' ?. rewrite Z.shiftr_spec, Z.lor_spec, Z.shiftl_spec by lia. assert (Z.testbit b (z' + n) = false) as ->. { apply (Z.bounded_iff_bits_nonneg n); lia. } rewrite orb_false_l. f_equal. lia. Qed. Lemma little_endian_to_Z_to_little_endian m n z : 0 ≤ n → 0 ≤ m → little_endian_to_Z n (Z_to_little_endian m n z) = z `mod` 2 ^ (m * n). Proof. intros ? Hm. rewrite <-Z.land_ones by lia. revert z. induction m as [|m ? IH|] using (Z.succ_pred_induction 0); intros z; [..|lia]. { Z.bitwise. by rewrite andb_false_r. } rewrite Z_to_little_endian_succ by lia; simpl. rewrite IH by lia. apply Z.bits_inj_iff'. intros z' ?. rewrite Z.land_spec, Z.lor_spec, Z.shiftl_spec, !Z.land_spec by lia. rewrite (Z.ones_spec n z') by lia. case_bool_decide. - rewrite andb_true_r, (Z.testbit_neg_r _ (z' - n)), orb_false_r by lia. simpl. by rewrite Z.ones_spec, bool_decide_true, andb_true_r by lia. - rewrite andb_false_r, orb_false_l. rewrite Z.shiftr_spec by lia. f_equal; [f_equal; lia|]. rewrite !Z.ones_spec by lia. apply bool_decide_ext. lia. Qed. Lemma Z_to_little_endian_length m n z : 0 ≤ m → Z.of_nat (length (Z_to_little_endian m n z)) = m. Proof. intros. revert z. induction m as [|m ? IH|] using (Z.succ_pred_induction 0); intros z; [done| |lia]. rewrite Z_to_little_endian_succ by lia. simpl. by rewrite Nat2Z.inj_succ, IH. Qed. Lemma Z_to_little_endian_bound m n z : 0 ≤ n → 0 ≤ m → Forall (λ b, 0 ≤ b < 2 ^ n) (Z_to_little_endian m n z). Proof. intros. revert z. induction m as [|m ? IH|] using (Z.succ_pred_induction 0); intros z; [..|lia]. { by constructor. } rewrite Z_to_little_endian_succ by lia. constructor; [|by apply IH]. rewrite Z.land_ones by lia. apply Z.mod_pos_bound, Z.pow_pos_nonneg; lia. Qed. Lemma little_endian_to_Z_bound n bs : 0 ≤ n → Forall (λ b, 0 ≤ b < 2 ^ n) bs → 0 ≤ little_endian_to_Z n bs < 2 ^ (Z.of_nat (length bs) * n). Proof. intros ?. induction 1 as [|b bs Hb ? IH]; [done|]; simpl. apply Z.bounded_iff_bits_nonneg'; [lia|..]. { apply Z.lor_nonneg. split; [lia|]. apply Z.shiftl_nonneg. lia. } intros z' ?. rewrite Z.lor_spec. rewrite Z.bounded_iff_bits_nonneg' in Hb by lia. rewrite Hb, orb_false_l, Z.shiftl_spec by lia. apply (Z.bounded_iff_bits_nonneg' (Z.of_nat (length bs) * n)); lia. Qed. Lemma Z_to_little_endian_lookup_Some m n z (i : nat) x : 0 ≤ m → 0 ≤ n → Z_to_little_endian m n z !! i = Some x ↔ Z.of_nat i < m ∧ x = Z.land (z ≫ (Z.of_nat i * n)) (Z.ones n). Proof. revert z i. induction m as [|m ? IH|] using (Z.succ_pred_induction 0); intros z i ??; [..|lia]. { destruct i; simpl; naive_solver lia. } rewrite Z_to_little_endian_succ by lia. destruct i as [|i]; simpl. { naive_solver lia. } rewrite IH, Z.shiftr_shiftr by lia. naive_solver auto with f_equal lia. Qed. Lemma little_endian_to_Z_spec n bs i b : 0 ≤ i → 0 < n → Forall (λ b, 0 ≤ b < 2 ^ n) bs → bs !! Z.to_nat (i `div` n) = Some b → Z.testbit (little_endian_to_Z n bs) i = Z.testbit b (i `mod` n). Proof. intros Hi Hn Hbs. revert i Hi. induction Hbs as [|b' bs [??] ? IH]; intros i ? Hlookup; simplify_eq/=. destruct (decide (i < n)). - rewrite Z.div_small in Hlookup by lia. simplify_eq/=. rewrite Z.lor_spec, Z.shiftl_spec, Z.mod_small by lia. by rewrite (Z.testbit_neg_r _ (i - n)), orb_false_r by lia. - assert (Z.to_nat (i `div` n) = S (Z.to_nat ((i - n) `div` n))) as Hdiv. { rewrite <-Z2Nat.inj_succ by (apply Z.div_pos; lia). rewrite <-Z.add_1_r, <-Z.div_add by lia. do 2 f_equal. lia. } rewrite Hdiv in Hlookup; simplify_eq/=. rewrite Z.lor_spec, Z.shiftl_spec, IH by auto with lia. assert (Z.testbit b' i = false) as ->. { apply (Z.bounded_iff_bits_nonneg n); lia. } by rewrite <-Zminus_mod_idemp_r, Z_mod_same_full, Z.sub_0_r. Qed. End Z_little_endian. stdpp-coq-stdpp-1.9.0/stdpp/listset.v000066400000000000000000000055541451153341500176060ustar00rootroot00000000000000(** This file implements finite set as unordered lists without duplicates removed. This implementation forms a monad. *) From stdpp Require Export sets list. From stdpp Require Import options. Record listset A := Listset { listset_car: list A }. Global Arguments listset_car {_} _ : assert. Global Arguments Listset {_} _ : assert. Section listset. Context {A : Type}. Global Instance listset_elem_of: ElemOf A (listset A) := λ x l, x ∈ listset_car l. Global Instance listset_empty: Empty (listset A) := Listset []. Global Instance listset_singleton: Singleton A (listset A) := λ x, Listset [x]. Global Instance listset_union: Union (listset A) := λ '(Listset l) '(Listset k), Listset (l ++ k). Global Opaque listset_singleton listset_empty. Global Instance listset_simple_set : SemiSet A (listset A). Proof. split. - by apply not_elem_of_nil. - by apply elem_of_list_singleton. - intros [?] [?]. apply elem_of_app. Qed. Lemma listset_empty_alt X : X ≡ ∅ ↔ listset_car X = []. Proof. destruct X as [l]; split; [|by intros; simplify_eq/=]. rewrite elem_of_equiv_empty; intros Hl. destruct l as [|x l]; [done|]. oinversion Hl. left. Qed. Global Instance listset_empty_dec (X : listset A) : Decision (X ≡ ∅). Proof. refine (cast_if (decide (listset_car X = []))); abstract (by rewrite listset_empty_alt). Defined. Context `{Aeq : !EqDecision A}. Global Instance listset_elem_of_dec : RelDecision (∈@{listset A}). Proof using Aeq. refine (λ x X, cast_if (decide (x ∈ listset_car X))); done. Defined. Global Instance listset_intersection: Intersection (listset A) := λ '(Listset l) '(Listset k), Listset (list_intersection l k). Global Instance listset_difference: Difference (listset A) := λ '(Listset l) '(Listset k), Listset (list_difference l k). Local Instance listset_set: Set_ A (listset A). Proof. split. - apply _. - intros [?] [?]. apply elem_of_list_intersection. - intros [?] [?]. apply elem_of_list_difference. Qed. Global Instance listset_elements: Elements A (listset A) := remove_dups ∘ listset_car. Global Instance listset_fin_set : FinSet A (listset A). Proof. split. - apply _. - intros. apply elem_of_remove_dups. - intros. apply NoDup_remove_dups. Qed. End listset. Global Instance listset_ret: MRet listset := λ A x, {[ x ]}. Global Instance listset_fmap: FMap listset := λ A B f '(Listset l), Listset (f <$> l). Global Instance listset_bind: MBind listset := λ A B f '(Listset l), Listset (mbind (listset_car ∘ f) l). Global Instance listset_join: MJoin listset := λ A, mbind id. Global Instance listset_set_monad : MonadSet listset. Proof. split. - intros. apply _. - intros ??? [?] ?. apply elem_of_list_bind. - intros. apply elem_of_list_ret. - intros ??? [?]. apply elem_of_list_fmap. - intros ? [?] ?. unfold mjoin, listset_join, elem_of, listset_elem_of. simpl. by rewrite elem_of_list_bind. Qed. stdpp-coq-stdpp-1.9.0/stdpp/listset_nodup.v000066400000000000000000000034741451153341500210120ustar00rootroot00000000000000(** This file implements finite as unordered lists without duplicates. Although this implementation is slow, it is very useful as decidable equality is the only constraint on the carrier set. *) From stdpp Require Export sets list. From stdpp Require Import options. Record listset_nodup A := ListsetNoDup { listset_nodup_car : list A; listset_nodup_prf : NoDup listset_nodup_car }. Global Arguments ListsetNoDup {_} _ _ : assert. Global Arguments listset_nodup_car {_} _ : assert. Global Arguments listset_nodup_prf {_} _ : assert. Section list_set. Context `{EqDecision A}. Notation C := (listset_nodup A). Global Instance listset_nodup_elem_of: ElemOf A C := λ x l, x ∈ listset_nodup_car l. Global Instance listset_nodup_empty: Empty C := ListsetNoDup [] (@NoDup_nil_2 _). Global Instance listset_nodup_singleton: Singleton A C := λ x, ListsetNoDup [x] (NoDup_singleton x). Global Instance listset_nodup_union: Union C := λ '(ListsetNoDup l Hl) '(ListsetNoDup k Hk), ListsetNoDup _ (NoDup_list_union _ _ Hl Hk). Global Instance listset_nodup_intersection: Intersection C := λ '(ListsetNoDup l Hl) '(ListsetNoDup k Hk), ListsetNoDup _ (NoDup_list_intersection _ k Hl). Global Instance listset_nodup_difference: Difference C := λ '(ListsetNoDup l Hl) '(ListsetNoDup k Hk), ListsetNoDup _ (NoDup_list_difference _ k Hl). Local Instance listset_nodup_set: Set_ A C. Proof. split; [split | | ]. - by apply not_elem_of_nil. - by apply elem_of_list_singleton. - intros [??] [??] ?. apply elem_of_list_union. - intros [??] [??] ?. apply elem_of_list_intersection. - intros [??] [??] ?. apply elem_of_list_difference. Qed. Global Instance listset_nodup_elems: Elements A C := listset_nodup_car. Global Instance listset_nodup_fin_set: FinSet A C. Proof. split; [apply _|done|]. by intros [??]. Qed. End list_set. stdpp-coq-stdpp-1.9.0/stdpp/mapset.v000066400000000000000000000135351451153341500174060ustar00rootroot00000000000000(** This files gives an implementation of finite sets using finite maps with elements of the unit type. Since maps enjoy extensional equality, the constructed finite sets do so as well. *) From stdpp Require Export countable fin_map_dom. From stdpp Require Import options. (* FIXME: This file needs a 'Proof Using' hint, but they need to be set locally (or things moved out of sections) as no default works well enough. *) Unset Default Proof Using. (** Given a type of maps [M : Type → Type], we construct sets as [M ()], i.e., maps with unit values. To avoid unnecessary universe constraints, we first define [mapset' Munit] with [Munit : Type] as a record, and then [mapset M] with [M : Type → Type] as a notation. See [tests/universes.v] for a test case that fails otherwise. *) Record mapset' (Munit : Type) : Type := Mapset { mapset_car: Munit }. Notation mapset M := (mapset' (M unit)). Global Arguments Mapset {_} _ : assert. Global Arguments mapset_car {_} _ : assert. Section mapset. Context `{FinMap K M}. Global Instance mapset_elem_of: ElemOf K (mapset M) := λ x X, mapset_car X !! x = Some (). Global Instance mapset_empty: Empty (mapset M) := Mapset ∅. Global Instance mapset_singleton: Singleton K (mapset M) := λ x, Mapset {[ x := () ]}. Global Instance mapset_union: Union (mapset M) := λ X1 X2, let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∪ m2). Global Instance mapset_intersection: Intersection (mapset M) := λ X1 X2, let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∩ m2). Global Instance mapset_difference: Difference (mapset M) := λ X1 X2, let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∖ m2). Global Instance mapset_elements: Elements K (mapset M) := λ X, let (m) := X in (map_to_list m).*1. Lemma mapset_eq (X1 X2 : mapset M) : X1 = X2 ↔ ∀ x, x ∈ X1 ↔ x ∈ X2. Proof. split; [by intros ->|]. destruct X1 as [m1], X2 as [m2]. simpl. intros E. f_equal. apply map_eq. intros i. apply option_eq. intros []. by apply E. Qed. Local Instance mapset_set: Set_ K (mapset M). Proof. split; [split | | ]. - unfold empty, elem_of, mapset_empty, mapset_elem_of. simpl. intros. by simpl_map. - unfold singleton, elem_of, mapset_singleton, mapset_elem_of. simpl. by split; intros; simplify_map_eq. - unfold union, elem_of, mapset_union, mapset_elem_of. intros [m1] [m2] x. simpl. rewrite lookup_union_Some_raw. destruct (m1 !! x) as [[]|]; tauto. - unfold intersection, elem_of, mapset_intersection, mapset_elem_of. intros [m1] [m2] x. simpl. rewrite lookup_intersection_Some. assert (is_Some (m2 !! x) ↔ m2 !! x = Some ()). { split; eauto. by intros [[] ?]. } naive_solver. - unfold difference, elem_of, mapset_difference, mapset_elem_of. intros [m1] [m2] x. simpl. rewrite lookup_difference_Some. destruct (m2 !! x) as [[]|]; intuition congruence. Qed. Global Instance mapset_leibniz : LeibnizEquiv (mapset M). Proof. intros ??. apply mapset_eq. Qed. Global Instance mapset_fin_set : FinSet K (mapset M). Proof. split. - apply _. - unfold elements, elem_of at 2, mapset_elements, mapset_elem_of. intros [m] x. simpl. rewrite elem_of_list_fmap. split. + intros ([y []] &?& Hy). subst. by rewrite <-elem_of_map_to_list. + intros. exists (x, ()). by rewrite elem_of_map_to_list. - unfold elements, mapset_elements. intros [m]. simpl. apply NoDup_fst_map_to_list. Qed. Section deciders. Context `{EqDecision (M unit)}. Global Instance mapset_eq_dec : EqDecision (mapset M) | 1. Proof. refine (λ X1 X2, match X1, X2 with Mapset m1, Mapset m2 => cast_if (decide (m1 = m2)) end); abstract congruence. Defined. Global Program Instance mapset_countable `{Countable (M ())} : Countable (mapset M) := inj_countable mapset_car (Some ∘ Mapset) _. Next Obligation. by intros ? ? []. Qed. Global Instance mapset_equiv_dec : RelDecision (≡@{mapset M}) | 1. Proof. refine (λ X1 X2, cast_if (decide (X1 = X2))); abstract (by fold_leibniz). Defined. Global Instance mapset_elem_of_dec : RelDecision (∈@{mapset M}) | 1. Proof. refine (λ x X, cast_if (decide (mapset_car X !! x = Some ()))); done. Defined. Global Instance mapset_disjoint_dec : RelDecision (##@{mapset M}). Proof. refine (λ X1 X2, cast_if (decide (X1 ∩ X2 = ∅))); abstract (by rewrite disjoint_intersection_L). Defined. Global Instance mapset_subseteq_dec : RelDecision (⊆@{mapset M}). Proof. refine (λ X1 X2, cast_if (decide (X1 ∪ X2 = X2))); abstract (by rewrite subseteq_union_L). Defined. End deciders. Definition mapset_map_with {A B} (f : bool → A → option B) (X : mapset M) : M A → M B := let (mX) := X in merge (λ x y, match x, y with | Some _, Some a => f true a | None, Some a => f false a | _, None => None end) mX. Definition mapset_dom_with {A} (f : A → bool) (m : M A) : mapset M := Mapset $ omap (λ a, if f a then Some () else None) m. Lemma lookup_mapset_map_with {A B} (f : bool → A → option B) X m i : mapset_map_with f X m !! i = m !! i ≫= f (bool_decide (i ∈ X)). Proof. destruct X as [mX]. unfold mapset_map_with, elem_of, mapset_elem_of. rewrite lookup_merge by done. simpl. by case_bool_decide; destruct (mX !! i) as [[]|], (m !! i). Qed. Lemma elem_of_mapset_dom_with {A} (f : A → bool) m i : i ∈ mapset_dom_with f m ↔ ∃ x, m !! i = Some x ∧ f x. Proof. unfold mapset_dom_with, elem_of, mapset_elem_of. simpl. rewrite lookup_omap. destruct (m !! i) as [a|]; simpl. - destruct (Is_true_reflect (f a)); naive_solver. - naive_solver. Qed. Local Instance mapset_dom {A} : Dom (M A) (mapset M) := λ m, Mapset $ fmap (λ _, ()) m. Local Instance mapset_dom_spec: FinMapDom K M (mapset M). Proof. split; try apply _. intros A m i. unfold dom, mapset_dom, is_Some, elem_of, mapset_elem_of; simpl. rewrite lookup_fmap. destruct (m !! i); naive_solver. Qed. End mapset. Global Arguments mapset_eq_dec : simpl never. stdpp-coq-stdpp-1.9.0/stdpp/namespaces.v000066400000000000000000000142521451153341500202310ustar00rootroot00000000000000From stdpp Require Export countable coPset. From stdpp Require Import options. Definition namespace := list positive. Global Instance namespace_eq_dec : EqDecision namespace := _. Global Instance namespace_countable : Countable namespace := _. Global Typeclasses Opaque namespace. Definition nroot : namespace := nil. Local Definition ndot_def `{Countable A} (N : namespace) (x : A) : namespace := encode x :: N. Local Definition ndot_aux : seal (@ndot_def). by eexists. Qed. Definition ndot {A A_dec A_count}:= unseal ndot_aux A A_dec A_count. Local Definition ndot_unseal : @ndot = @ndot_def := seal_eq ndot_aux. Local Definition nclose_def (N : namespace) : coPset := coPset_suffixes (positives_flatten N). Local Definition nclose_aux : seal (@nclose_def). by eexists. Qed. Global Instance nclose : UpClose namespace coPset := unseal nclose_aux. Local Definition nclose_unseal : @nclose = @nclose_def := seal_eq nclose_aux. Notation "N .@ x" := (ndot N x) (at level 19, left associativity, format "N .@ x") : stdpp_scope. Notation "(.@)" := ndot (only parsing) : stdpp_scope. Global Instance ndisjoint : Disjoint namespace := λ N1 N2, nclose N1 ## nclose N2. Section namespace. Context `{Countable A}. Implicit Types x y : A. Implicit Types N : namespace. Implicit Types E : coPset. Global Instance ndot_inj : Inj2 (=) (=) (=) (@ndot A _ _). Proof. intros N1 x1 N2 x2; rewrite !ndot_unseal; naive_solver. Qed. Lemma nclose_nroot : ↑nroot = (⊤:coPset). Proof. rewrite nclose_unseal. by apply (sig_eq_pi _). Qed. Lemma nclose_subseteq N x : ↑N.@x ⊆ (↑N : coPset). Proof. intros p. unfold up_close. rewrite !nclose_unseal, !ndot_unseal. unfold nclose_def, ndot_def; rewrite !elem_coPset_suffixes. intros [q ->]. destruct (positives_flatten_suffix N (ndot_def N x)) as [q' ?]. { by exists [encode x]. } by exists (q ++ q')%positive; rewrite <-(assoc_L _); f_equal. Qed. Lemma nclose_subseteq' E N x : ↑N ⊆ E → ↑N.@x ⊆ E. Proof. intros. etrans; eauto using nclose_subseteq. Qed. Lemma nclose_infinite N : ¬set_finite (↑ N : coPset). Proof. rewrite nclose_unseal. apply coPset_suffixes_infinite. Qed. Lemma ndot_ne_disjoint N x y : x ≠ y → N.@x ## N.@y. Proof. intros Hxy a. unfold up_close. rewrite !nclose_unseal, !ndot_unseal. unfold nclose_def, ndot_def; rewrite !elem_coPset_suffixes. intros [qx ->] [qy Hqy]. revert Hqy. by intros [= ?%(inj encode)]%positives_flatten_suffix_eq. Qed. Lemma ndot_preserve_disjoint_l N E x : ↑N ## E → ↑N.@x ## E. Proof. intros. pose proof (nclose_subseteq N x). set_solver. Qed. Lemma ndot_preserve_disjoint_r N E x : E ## ↑N → E ## ↑N.@x. Proof. intros. by apply symmetry, ndot_preserve_disjoint_l. Qed. End namespace. (** The hope is that registering these will suffice to solve most goals of the forms: - [N1 ## N2] - [↑N1 ⊆ E ∖ ↑N2 ∖ .. ∖ ↑Nn] - [E1 ∖ ↑N1 ⊆ E2 ∖ ↑N2 ∖ .. ∖ ↑Nn] *) Create HintDb ndisj discriminated. (** Rules for goals of the form [_ ⊆ _] *) (** If-and-only-if rules. Well, not quite, but for the fragment we are considering they are. *) Local Definition coPset_subseteq_difference_r := subseteq_difference_r (C:=coPset). Global Hint Resolve coPset_subseteq_difference_r : ndisj. Local Definition coPset_empty_subseteq := empty_subseteq (C:=coPset). Global Hint Resolve coPset_empty_subseteq : ndisj. Local Definition coPset_union_least := union_least (C:=coPset). Global Hint Resolve coPset_union_least : ndisj. (** For goals like [X ⊆ L ∪ R], backtrack for the two sides. *) Local Definition coPset_union_subseteq_l' := union_subseteq_l' (C:=coPset). Global Hint Resolve coPset_union_subseteq_l' | 50 : ndisj. Local Definition coPset_union_subseteq_r' := union_subseteq_r' (C:=coPset). Global Hint Resolve coPset_union_subseteq_r' | 50 : ndisj. (** Fallback, loses lots of information but lets other rules make progress. *) Local Definition coPset_subseteq_difference_l := subseteq_difference_l (C:=coPset). Global Hint Resolve coPset_subseteq_difference_l | 100 : ndisj. Global Hint Resolve nclose_subseteq' | 100 : ndisj. (** Rules for goals of the form [_ ## _] *) (** The base rule that we want to ultimately get down to. *) Global Hint Extern 0 (_ ## _) => apply ndot_ne_disjoint; congruence : ndisj. (** Trivial cases. *) Local Definition coPset_disjoint_empty_l := disjoint_empty_l (C:=coPset). Global Hint Resolve coPset_disjoint_empty_l : ndisj. Local Definition coPset_disjoint_empty_r := disjoint_empty_r (C:=coPset). Global Hint Resolve coPset_disjoint_empty_r : ndisj. (** If-and-only-if rules for ∪ on the left/right. *) Local Definition coPset_disjoint_union_l X1 X2 Y := proj2 (disjoint_union_l (C:=coPset) X1 X2 Y). Global Hint Resolve coPset_disjoint_union_l : ndisj. Local Definition coPset_disjoint_union_r X Y1 Y2 := proj2 (disjoint_union_r (C:=coPset) X Y1 Y2). Global Hint Resolve coPset_disjoint_union_r : ndisj. (** We prefer ∖ on the left of ## (for the [disjoint_difference] lemmas to apply), so try moving it there. *) Global Hint Extern 10 (_ ## (_ ∖ _)) => lazymatch goal with | |- (_ ∖ _) ## _ => fail (* ∖ on both sides, leave it be *) | |- _ => symmetry end : ndisj. (** Before we apply disjoint_difference, let's make sure we normalize the goal to [_ ∖ (_ ∪ _)]. *) Local Lemma coPset_difference_difference (X1 X2 X3 Y : coPset) : X1 ∖ (X2 ∪ X3) ## Y → X1 ∖ X2 ∖ X3 ## Y. Proof. set_solver. Qed. Global Hint Resolve coPset_difference_difference | 20 : ndisj. (** Fallback, loses lots of information but lets other rules make progress. Tests show trying [disjoint_difference_l1] first gives better performance. *) Local Definition coPset_disjoint_difference_l1 := disjoint_difference_l1 (C:=coPset). Global Hint Resolve coPset_disjoint_difference_l1 | 50 : ndisj. Local Definition coPset_disjoint_difference_l2 := disjoint_difference_l2 (C:=coPset). Global Hint Resolve coPset_disjoint_difference_l2 | 100 : ndisj. Global Hint Resolve ndot_preserve_disjoint_l ndot_preserve_disjoint_r | 100 : ndisj. Ltac solve_ndisj := repeat match goal with | H : _ ∪ _ ⊆ _ |- _ => apply union_subseteq in H as [??] end; solve [eauto 12 with ndisj]. Global Hint Extern 1000 => solve_ndisj : solve_ndisj. stdpp-coq-stdpp-1.9.0/stdpp/nat_cancel.v000066400000000000000000000107701451153341500202020ustar00rootroot00000000000000From stdpp Require Import numbers. From stdpp Require Import options. (** The class [NatCancel m n m' n'] is a simple canceler for natural numbers implemented using type classes. Input: [m], [n]; output: [m'], [n']. It turns an equality [n = m] into an equality [n' = m'] by canceling out terms that appear on both sides of the equality. We provide instances to handle the following connectives over natural numbers: n := 0 | t | n + m | S m Here, [t] represents arbitrary terms that do not fit the grammar. The instances the class perform a depth-first traversal (from left to right) through [n] and try to cancel each leaf in [m]. This implies that the shape of the original expressions [n] and [m] are preserved as much as possible. For example, canceling: S (S m2) + (k1 + (S k2 + k3)) + n1 = 2 + S ((n1 + S n2) + S (S m1 + m2)) Results in: k1 + (k2 + k3) = S (n2 + S (S m1)) The instances are setup up so that canceling is performed in two stages. - In the first stage, using the class [NatCancelL], it traverses [m] w.r.t. [S] and [+]. - In the second stage, for each leaf (i.e. a constant or arbitrary term) obtained by the traversal in stage 1, it uses the class [NatCancelR] to cancel the leaf in [n]. Be warned: Since the canceler is implemented using type classes it should only be used it either of the inputs is relatively small. For bigger inputs, an approach based on reflection would be better, but for small inputs, the overhead of reification will probably not be worth it. *) Class NatCancel (m n m' n' : nat) := nat_cancel : m' + n = m + n'. Global Hint Mode NatCancel ! ! - - : typeclass_instances. Module nat_cancel. Class NatCancelL (m n m' n' : nat) := nat_cancel_l : m' + n = m + n'. Global Hint Mode NatCancelL ! ! - - : typeclass_instances. Class NatCancelR (m n m' n' : nat) := nat_cancel_r : NatCancelL m n m' n'. Global Hint Mode NatCancelR ! ! - - : typeclass_instances. Global Existing Instance nat_cancel_r | 100. (** The implementation of the canceler is highly non-deterministic, but since it will always succeed, no backtracking will ever be performed. In order to avoid issues like: https://gitlab.mpi-sws.org/FP/iris-coq/issues/153 we wrap the entire canceler in the [NoBackTrack] class. *) Global Instance nat_cancel_start m n m' n' : TCNoBackTrack (NatCancelL m n m' n') → NatCancel m n m' n'. Proof. by intros [?]. Qed. Class MakeNatS (n1 n2 m : nat) := make_nat_S : m = n1 + n2. Global Instance make_nat_S_0_l n : MakeNatS 0 n n. Proof. done. Qed. Global Instance make_nat_S_1 n : MakeNatS 1 n (S n). Proof. done. Qed. Class MakeNatAdd (n1 n2 m : nat) := make_nat_add : m = n1 + n2. Global Instance make_nat_add_0_l n : MakeNatAdd 0 n n. Proof. done. Qed. Global Instance make_nat_add_0_r n : MakeNatAdd n 0 n. Proof. unfold MakeNatAdd. by rewrite Nat.add_0_r. Qed. Global Instance make_nat_add_default n1 n2 : MakeNatAdd n1 n2 (n1 + n2) | 100. Proof. done. Qed. Global Instance nat_cancel_leaf_here m : NatCancelR m m 0 0 | 0. Proof. by unfold NatCancelR, NatCancelL. Qed. Global Instance nat_cancel_leaf_else m n : NatCancelR m n m n | 100. Proof. by unfold NatCancelR. Qed. Global Instance nat_cancel_leaf_add m m' m'' n1 n2 n1' n2' n1'n2' : NatCancelR m n1 m' n1' → NatCancelR m' n2 m'' n2' → MakeNatAdd n1' n2' n1'n2' → NatCancelR m (n1 + n2) m'' n1'n2' | 2. Proof. unfold NatCancelR, NatCancelL, MakeNatAdd. lia. Qed. Global Instance nat_cancel_leaf_S_here m n m' n' : NatCancelR m n m' n' → NatCancelR (S m) (S n) m' n' | 3. Proof. unfold NatCancelR, NatCancelL. lia. Qed. Global Instance nat_cancel_leaf_S_else m n m' n' : NatCancelR m n m' n' → NatCancelR m (S n) m' (S n') | 4. Proof. unfold NatCancelR, NatCancelL. lia. Qed. (** The instance [nat_cancel_S_both] is redundant, but may reduce proof search quite a bit, e.g. when canceling constants in constants. *) Global Instance nat_cancel_S_both m n m' n' : NatCancelL m n m' n' → NatCancelL (S m) (S n) m' n' | 1. Proof. unfold NatCancelL. lia. Qed. Global Instance nat_cancel_add m1 m2 m1' m2' m1'm2' n n' n'' : NatCancelL m1 n m1' n' → NatCancelL m2 n' m2' n'' → MakeNatAdd m1' m2' m1'm2' → NatCancelL (m1 + m2) n m1'm2' n'' | 2. Proof. unfold NatCancelL, MakeNatAdd. lia. Qed. Global Instance nat_cancel_S m m' m'' Sm' n n' n'' : NatCancelL m n m' n' → NatCancelR 1 n' m'' n'' → MakeNatS m'' m' Sm' → NatCancelL (S m) n Sm' n'' | 3. Proof. unfold NatCancelR, NatCancelL, MakeNatS. lia. Qed. End nat_cancel. stdpp-coq-stdpp-1.9.0/stdpp/natmap.v000066400000000000000000000376071451153341500174030ustar00rootroot00000000000000(** This files implements a type [natmap A] of finite maps whose keys range over Coq's data type of unary natural numbers [nat]. The implementation equips a list with a proof of canonicity. *) From stdpp Require Import fin_maps mapset. From stdpp Require Import options. Notation natmap_raw A := (list (option A)). Definition natmap_wf {A} (l : natmap_raw A) := match last l with None => True | Some x => is_Some x end. Global Instance natmap_wf_pi {A} (l : natmap_raw A) : ProofIrrel (natmap_wf l). Proof. unfold natmap_wf. case_match; apply _. Qed. Lemma natmap_wf_inv {A} (o : option A) (l : natmap_raw A) : natmap_wf (o :: l) → natmap_wf l. Proof. by destruct l. Qed. Lemma natmap_wf_lookup {A} (l : natmap_raw A) : natmap_wf l → l ≠ [] → ∃ i x, mjoin (l !! i) = Some x. Proof. intros Hwf Hl. induction l as [|[x|] l IH]; simpl; [done| |]. { exists 0. simpl. eauto. } destruct IH as (i&x&?); eauto using natmap_wf_inv; [|by exists (S i), x]. intros ->. by destruct Hwf. Qed. Record natmap (A : Type) : Type := NatMap { natmap_car : natmap_raw A; natmap_prf : natmap_wf natmap_car }. Global Arguments NatMap {_} _ _ : assert. Global Arguments natmap_car {_} _ : assert. Global Arguments natmap_prf {_} _ : assert. Lemma natmap_eq {A} (m1 m2 : natmap A) : m1 = m2 ↔ natmap_car m1 = natmap_car m2. Proof. split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?]. simplify_eq/=; f_equal; apply proof_irrel. Qed. Global Instance natmap_eq_dec `{EqDecision A} : EqDecision (natmap A) := λ m1 m2, match decide (natmap_car m1 = natmap_car m2) with | left H => left (proj2 (natmap_eq m1 m2) H) | right H => right (H ∘ proj1 (natmap_eq m1 m2)) end. Global Instance natmap_empty {A} : Empty (natmap A) := NatMap [] I. Global Instance natmap_lookup {A} : Lookup nat A (natmap A) := λ i m, let (l,_) := m in mjoin (l !! i). Fixpoint natmap_singleton_raw {A} (i : nat) (x : A) : natmap_raw A := match i with 0 => [Some x]| S i => None :: natmap_singleton_raw i x end. Lemma natmap_singleton_wf {A} (i : nat) (x : A) : natmap_wf (natmap_singleton_raw i x). Proof. unfold natmap_wf. induction i as [|[]]; simplify_eq/=; eauto. Qed. Lemma natmap_lookup_singleton_raw {A} (i : nat) (x : A) : mjoin (natmap_singleton_raw i x !! i) = Some x. Proof. induction i; simpl; auto. Qed. Lemma natmap_lookup_singleton_raw_ne {A} (i j : nat) (x : A) : i ≠ j → mjoin (natmap_singleton_raw i x !! j) = None. Proof. revert j; induction i; intros [|?]; simpl; auto with congruence. Qed. Local Hint Rewrite @natmap_lookup_singleton_raw : natmap. Definition natmap_cons_canon {A} (o : option A) (l : natmap_raw A) := match o, l with None, [] => [] | _, _ => o :: l end. Lemma natmap_cons_canon_wf {A} (o : option A) (l : natmap_raw A) : natmap_wf l → natmap_wf (natmap_cons_canon o l). Proof. unfold natmap_wf, last. destruct o, l; simpl; eauto. Qed. Lemma natmap_cons_canon_O {A} (o : option A) (l : natmap_raw A) : mjoin (natmap_cons_canon o l !! 0) = o. Proof. by destruct o, l. Qed. Lemma natmap_cons_canon_S {A} (o : option A) (l : natmap_raw A) i : natmap_cons_canon o l !! S i = l !! i. Proof. by destruct o, l. Qed. Local Hint Rewrite @natmap_cons_canon_O @natmap_cons_canon_S : natmap. Definition natmap_partial_alter_raw {A} (f : option A → option A) : nat → natmap_raw A → natmap_raw A := fix go i l {struct l} := match l with | [] => match f None with | Some x => natmap_singleton_raw i x | None => [] end | o :: l => match i with | 0 => natmap_cons_canon (f o) l | S i => natmap_cons_canon o (go i l) end end. Lemma natmap_partial_alter_wf {A} (f : option A → option A) i l : natmap_wf l → natmap_wf (natmap_partial_alter_raw f i l). Proof. revert i. induction l; [intro | intros [|?]]; simpl; repeat case_match; eauto using natmap_singleton_wf, natmap_cons_canon_wf, natmap_wf_inv. Qed. Global Instance natmap_partial_alter {A} : PartialAlter nat A (natmap A) := λ f i m, let (l,Hl) := m in NatMap _ (natmap_partial_alter_wf f i l Hl). Lemma natmap_lookup_partial_alter_raw {A} (f : option A → option A) i l : mjoin (natmap_partial_alter_raw f i l !! i) = f (mjoin (l !! i)). Proof. revert i. induction l; intros [|?]; simpl; repeat case_match; simpl; autorewrite with natmap; auto. Qed. Lemma natmap_lookup_partial_alter_raw_ne {A} (f : option A → option A) i j l : i ≠ j → mjoin (natmap_partial_alter_raw f i l !! j) = mjoin (l !! j). Proof. revert i j. induction l; intros [|?] [|?] ?; simpl; repeat case_match; simpl; autorewrite with natmap; auto with congruence. rewrite natmap_lookup_singleton_raw_ne; congruence. Qed. Definition natmap_omap_raw {A B} (f : A → option B) : natmap_raw A → natmap_raw B := fix go l := match l with [] => [] | o :: l => natmap_cons_canon (o ≫= f) (go l) end. Lemma natmap_omap_raw_wf {A B} (f : A → option B) l : natmap_wf l → natmap_wf (natmap_omap_raw f l). Proof. induction l; simpl; eauto using natmap_cons_canon_wf, natmap_wf_inv. Qed. Lemma natmap_lookup_omap_raw {A B} (f : A → option B) l i : mjoin (natmap_omap_raw f l !! i) = mjoin (l !! i) ≫= f. Proof. revert i. induction l; intros [|?]; simpl; autorewrite with natmap; auto. Qed. Local Hint Rewrite @natmap_lookup_omap_raw : natmap. Global Instance natmap_omap: OMap natmap := λ A B f m, let (l,Hl) := m in NatMap _ (natmap_omap_raw_wf f _ Hl). Definition natmap_merge_raw {A B C} (f : option A → option B → option C) : natmap_raw A → natmap_raw B → natmap_raw C := fix go l1 l2 := match l1, l2 with | [], l2 => natmap_omap_raw (f None ∘ Some) l2 | l1, [] => natmap_omap_raw (flip f None ∘ Some) l1 | o1 :: l1, o2 :: l2 => natmap_cons_canon (diag_None f o1 o2) (go l1 l2) end. Lemma natmap_merge_wf {A B C} (f : option A → option B → option C) l1 l2 : natmap_wf l1 → natmap_wf l2 → natmap_wf (natmap_merge_raw f l1 l2). Proof. revert l2. induction l1; intros [|??]; simpl; eauto using natmap_omap_raw_wf, natmap_cons_canon_wf, natmap_wf_inv. Qed. Lemma natmap_lookup_merge_raw {A B C} (f : option A → option B → option C) l1 l2 i : mjoin (natmap_merge_raw f l1 l2 !! i) = diag_None f (mjoin (l1 !! i)) (mjoin (l2 !! i)). Proof. intros. revert i l2. induction l1; intros [|?] [|??]; simpl; autorewrite with natmap; auto; match goal with |- context [?o ≫= _] => by destruct o end. Qed. Global Instance natmap_merge: Merge natmap := λ A B C f m1 m2, let (l1, Hl1) := m1 in let (l2, Hl2) := m2 in NatMap (natmap_merge_raw f l1 l2) (natmap_merge_wf _ _ _ Hl1 Hl2). Fixpoint natmap_fold_raw {A B} (f : nat → A → B → B) (j : nat) (d : B) (l : natmap_raw A) : B := match l with | [] => d | mx :: l => natmap_fold_raw f (S j) match mx with Some x => f j x d | None => d end l end. Lemma natmap_fold_raw_ind {A B} (P : B → natmap_raw A → Prop) (f : nat → A → B → B) j (b : B) : P b [] → (∀ i x l b', natmap_wf l → mjoin (l !! i) = None → P b' l → P (f (i + j) x b') (natmap_partial_alter_raw (λ _, Some x) i l)) → ∀ l, natmap_wf l → P (natmap_fold_raw f j b l) l. Proof. intros Hemp Hinsert l Hl. revert P b j Hemp Hinsert. induction l as [|mx l IH]; intros P b j Hemp Hinsert; simpl in *; [done|]. assert (natmap_wf l) as Hl' by (by destruct l). replace (mx :: l) with (natmap_cons_canon mx l) by (destruct mx, l; done || by destruct Hl). apply (IH Hl' (λ r l, P r (natmap_cons_canon mx l)) _ (S j)). { destruct mx as [x|]; [|done]. change (natmap_cons_canon (Some x) []) with (natmap_partial_alter_raw (λ _, Some x) 0 []). by apply (Hinsert 0). } intros i x l' b' ??. rewrite <-Nat.add_succ_comm. replace (natmap_cons_canon mx (natmap_partial_alter_raw (λ _, Some x) i l')) with (natmap_partial_alter_raw (λ _, Some x) (S i) (natmap_cons_canon mx l')) by (by destruct i, mx, l'). apply Hinsert; [by apply natmap_cons_canon_wf|by destruct mx, l']. Qed. Global Instance natmap_fold {A} : MapFold nat A (natmap A) := λ B f d m, let (l,_) := m in natmap_fold_raw f 0 d l. Definition natmap_fmap_raw {A B} (f : A → B) : natmap_raw A → natmap_raw B := fmap (fmap (M:=option) f). Lemma natmap_fmap_wf {A B} (f : A → B) l : natmap_wf l → natmap_wf (natmap_fmap_raw f l). Proof. unfold natmap_fmap_raw, natmap_wf. rewrite fmap_last. destruct (last l); [|done]. by apply fmap_is_Some. Qed. Lemma natmap_lookup_fmap_raw {A B} (f : A → B) i l : mjoin (natmap_fmap_raw f l !! i) = f <$> mjoin (l !! i). Proof. unfold natmap_fmap_raw. rewrite list_lookup_fmap. by destruct (l !! i). Qed. Global Instance natmap_fmap : FMap natmap := λ A B f m, let (l,Hl) := m in NatMap (natmap_fmap_raw f l) (natmap_fmap_wf _ _ Hl). Global Instance natmap_map : FinMap nat natmap. Proof. split. - unfold lookup, natmap_lookup. intros A [l1 Hl1] [l2 Hl2] E. apply natmap_eq. revert l2 Hl1 Hl2 E. simpl. induction l1 as [|[x|] l1 IH]; intros [|[y|] l2] Hl1 Hl2 E; simpl in *. + done. + by specialize (E 0). + destruct (natmap_wf_lookup (None :: l2)) as (i&?&?); auto with congruence. + by specialize (E 0). + f_equal. * apply (E 0). * apply IH; eauto using natmap_wf_inv. intros i. apply (E (S i)). + by specialize (E 0). + destruct (natmap_wf_lookup (None :: l1)) as (i&?&?); auto with congruence. + by specialize (E 0). + f_equal. apply IH; eauto using natmap_wf_inv. intros i. apply (E (S i)). - done. - intros ?? [??] ?. apply natmap_lookup_partial_alter_raw. - intros ?? [??] ??. apply natmap_lookup_partial_alter_raw_ne. - intros ??? [??] ?. apply natmap_lookup_fmap_raw. - intros ??? [??] ?. by apply natmap_lookup_omap_raw. - intros ???? [??] [??] ?. apply natmap_lookup_merge_raw. - intros A B P f b Hemp Hinsert [l Hl]. refine (natmap_fold_raw_ind (λ r l, ∀ Hl, P r (NatMap l Hl)) f 0 b _ _ l Hl Hl); clear l Hl. { intros Hl. by replace (NatMap _ Hl) with (∅ : natmap A) by (by apply natmap_eq). } intros i x l r Hl ? H Hxl. rewrite Nat.add_0_r. replace (NatMap _ Hxl) with (<[i:=x]> (NatMap _ Hl)) by (by apply natmap_eq). by apply Hinsert. Qed. Fixpoint strip_Nones {A} (l : list (option A)) : list (option A) := match l with None :: l => strip_Nones l | _ => l end. Lemma list_to_natmap_wf {A} (l : list (option A)) : natmap_wf (reverse (strip_Nones (reverse l))). Proof. unfold natmap_wf. rewrite last_reverse. induction (reverse l) as [|[]]; simpl; eauto. Qed. Definition list_to_natmap {A} (l : list (option A)) : natmap A := NatMap (reverse (strip_Nones (reverse l))) (list_to_natmap_wf l). Lemma list_to_natmap_spec {A} (l : list (option A)) i : list_to_natmap l !! i = mjoin (l !! i). Proof. unfold lookup at 1, natmap_lookup, list_to_natmap; simpl. rewrite <-(reverse_involutive l) at 2. revert i. induction (reverse l) as [|[x|] l' IH]; intros i; simpl; auto. rewrite reverse_cons, IH. clear IH. revert i. induction (reverse l'); intros [|?]; simpl; auto. Qed. (** Finally, we can construct sets of [nat]s satisfying extensional equality. *) Notation natset := (mapset natmap). Global Instance natmap_dom {A} : Dom (natmap A) natset := mapset_dom. Global Instance: FinMapDom nat natmap natset := mapset_dom_spec. (* Fixpoint avoids this definition from being unfolded *) Definition bools_to_natset (βs : list bool) : natset := let f (β : bool) := if β then Some () else None in Mapset $ list_to_natmap $ f <$> βs. Definition natset_to_bools (sz : nat) (X : natset) : list bool := let f (mu : option ()) := match mu with Some _ => true | None => false end in resize sz false $ f <$> natmap_car (mapset_car X). Lemma bools_to_natset_unfold βs : let f (β : bool) := if β then Some () else None in bools_to_natset βs = Mapset $ list_to_natmap $ f <$> βs. Proof. by destruct βs. Qed. Lemma elem_of_bools_to_natset βs i : i ∈ bools_to_natset βs ↔ βs !! i = Some true. Proof. rewrite bools_to_natset_unfold; unfold elem_of, mapset_elem_of; simpl. rewrite list_to_natmap_spec, list_lookup_fmap. destruct (βs !! i) as [[]|]; compute; intuition congruence. Qed. Lemma bools_to_natset_union βs1 βs2 : length βs1 = length βs2 → bools_to_natset (βs1 ||* βs2) = bools_to_natset βs1 ∪ bools_to_natset βs2. Proof. rewrite <-Forall2_same_length; intros Hβs. apply set_eq. intros i. rewrite elem_of_union, !elem_of_bools_to_natset. revert i. induction Hβs as [|[] []]; intros [|?]; naive_solver. Qed. Lemma natset_to_bools_length (X : natset) sz : length (natset_to_bools sz X) = sz. Proof. apply resize_length. Qed. Lemma lookup_natset_to_bools_ge sz X i : sz ≤ i → natset_to_bools sz X !! i = None. Proof. by apply lookup_resize_old. Qed. Lemma lookup_natset_to_bools sz X i β : i < sz → natset_to_bools sz X !! i = Some β ↔ (i ∈ X ↔ β = true). Proof. unfold natset_to_bools, elem_of, mapset_elem_of, lookup at 2, natmap_lookup; simpl. intros. destruct (mapset_car X) as [l ?]; simpl. destruct (l !! i) as [mu|] eqn:Hmu; simpl. { rewrite lookup_resize, list_lookup_fmap, Hmu by (rewrite ?fmap_length; eauto using lookup_lt_Some). destruct mu as [[]|], β; simpl; intuition congruence. } rewrite lookup_resize_new by (rewrite ?fmap_length; eauto using lookup_ge_None_1); destruct β; intuition congruence. Qed. Lemma lookup_natset_to_bools_true sz X i : i < sz → natset_to_bools sz X !! i = Some true ↔ i ∈ X. Proof. intros. rewrite lookup_natset_to_bools by done. intuition. Qed. Lemma lookup_natset_to_bools_false sz X i : i < sz → natset_to_bools sz X !! i = Some false ↔ i ∉ X. Proof. intros. rewrite lookup_natset_to_bools by done. naive_solver. Qed. Lemma natset_to_bools_union sz X1 X2 : natset_to_bools sz (X1 ∪ X2) = natset_to_bools sz X1 ||* natset_to_bools sz X2. Proof. apply list_eq; intros i; rewrite lookup_zip_with. destruct (decide (i < sz)); [|by rewrite !lookup_natset_to_bools_ge by lia]. apply option_eq; intros β. rewrite lookup_natset_to_bools, elem_of_union by done; intros. destruct (decide (i ∈ X1)), (decide (i ∈ X2)); repeat first [ rewrite (λ X H, proj2 (lookup_natset_to_bools_true sz X i H)) by done | rewrite (λ X H, proj2 (lookup_natset_to_bools_false sz X i H)) by done]; destruct β; naive_solver. Qed. Lemma natset_to_bools_to_natset βs sz : natset_to_bools sz (bools_to_natset βs) = resize sz false βs. Proof. apply list_eq; intros i. destruct (decide (i < sz)); [|by rewrite lookup_natset_to_bools_ge, lookup_resize_old by lia]. apply option_eq; intros β. rewrite lookup_natset_to_bools, elem_of_bools_to_natset by done. destruct (decide (i < length βs)). { rewrite lookup_resize by done. destruct (lookup_lt_is_Some_2 βs i) as [[]]; destruct β; naive_solver. } rewrite lookup_resize_new, lookup_ge_None_2 by lia. destruct β; naive_solver. Qed. (** A [natmap A] forms a stack with elements of type [A] and possible holes *) Definition natmap_push {A} (o : option A) (m : natmap A) : natmap A := let (l,Hl) := m in NatMap _ (natmap_cons_canon_wf o l Hl). Definition natmap_pop_raw {A} (l : natmap_raw A) : natmap_raw A := tail l. Lemma natmap_pop_wf {A} (l : natmap_raw A) : natmap_wf l → natmap_wf (natmap_pop_raw l). Proof. destruct l; simpl; eauto using natmap_wf_inv. Qed. Definition natmap_pop {A} (m : natmap A) : natmap A := let (l,Hl) := m in NatMap _ (natmap_pop_wf _ Hl). Lemma lookup_natmap_push_O {A} o (m : natmap A) : natmap_push o m !! 0 = o. Proof. by destruct o, m as [[|??]]. Qed. Lemma lookup_natmap_push_S {A} o (m : natmap A) i : natmap_push o m !! S i = m !! i. Proof. by destruct o, m as [[|??]]. Qed. Lemma lookup_natmap_pop {A} (m : natmap A) i : natmap_pop m !! i = m !! S i. Proof. by destruct m as [[|??]]. Qed. Lemma natmap_push_pop {A} (m : natmap A) : natmap_push (m !! 0) (natmap_pop m) = m. Proof. apply map_eq. intros i. destruct i. - by rewrite lookup_natmap_push_O. - by rewrite lookup_natmap_push_S, lookup_natmap_pop. Qed. Lemma natmap_pop_push {A} o (m : natmap A) : natmap_pop (natmap_push o m) = m. Proof. apply natmap_eq. by destruct o, m as [[|??]]. Qed. stdpp-coq-stdpp-1.9.0/stdpp/nmap.v000066400000000000000000000054441451153341500170500ustar00rootroot00000000000000(** This files extends the implementation of finite over [positive] to finite maps whose keys range over Coq's data type of binary naturals [N]. *) From stdpp Require Import pmap mapset. From stdpp Require Export prelude fin_maps. From stdpp Require Import options. Local Open Scope N_scope. Record Nmap (A : Type) : Type := NMap { Nmap_0 : option A; Nmap_pos : Pmap A }. Global Arguments Nmap_0 {_} _ : assert. Global Arguments Nmap_pos {_} _ : assert. Global Arguments NMap {_} _ _ : assert. Global Instance Nmap_eq_dec `{EqDecision A} : EqDecision (Nmap A). Proof. refine (λ t1 t2, match t1, t2 with | NMap x t1, NMap y t2 => cast_if_and (decide (x = y)) (decide (t1 = t2)) end); abstract congruence. Defined. Global Instance Nmap_empty {A} : Empty (Nmap A) := NMap None ∅. Global Opaque Nmap_empty. Global Instance Nmap_lookup {A} : Lookup N A (Nmap A) := λ i t, match i with | 0 => Nmap_0 t | N.pos p => Nmap_pos t !! p end. Global Instance Nmap_partial_alter {A} : PartialAlter N A (Nmap A) := λ f i t, match i, t with | 0, NMap o t => NMap (f o) t | N.pos p, NMap o t => NMap o (partial_alter f p t) end. Global Instance Nmap_fmap: FMap Nmap := λ A B f t, match t with NMap o t => NMap (f <$> o) (f <$> t) end. Global Instance Nmap_omap: OMap Nmap := λ A B f t, match t with NMap o t => NMap (o ≫= f) (omap f t) end. Global Instance Nmap_merge: Merge Nmap := λ A B C f t1 t2, match t1, t2 with | NMap o1 t1, NMap o2 t2 => NMap (diag_None f o1 o2) (merge f t1 t2) end. Global Instance Nmap_fold {A} : MapFold N A (Nmap A) := λ B f d t, match t with | NMap mx t => map_fold (f ∘ N.pos) match mx with Some x => f 0 x d | None => d end t end. Global Instance Nmap_map: FinMap N Nmap. Proof. split. - intros ? [??] [??] H. f_equal; [apply (H 0)|]. apply map_eq. intros i. apply (H (N.pos i)). - by intros ? [|?]. - intros ? f [? t] [|i]; simpl; [done |]. apply lookup_partial_alter. - intros ? f [? t] [|i] [|j]; simpl; try intuition congruence. intros. apply lookup_partial_alter_ne. congruence. - intros ??? [??] []; simpl; [done|]. apply lookup_fmap. - intros ?? f [??] [|?]; simpl; [done|]; apply (lookup_omap f). - intros ??? f [??] [??] [|?]; simpl; [done|]; apply (lookup_merge f). - intros A B P f b Hemp Hinsert [mx t]. unfold map_fold; simpl. apply (map_fold_ind (λ r t, P r (NMap mx t))); clear t. { destruct mx as [x|]; [|done]. replace (NMap (Some x) ∅) with (<[0:=x]> ∅ : Nmap _) by done. by apply Hinsert. } intros i x t r ??. by apply (Hinsert (N.pos i) x (NMap mx t)). Qed. (** * Finite sets *) (** We construct sets of [N]s satisfying extensional equality. *) Notation Nset := (mapset Nmap). Global Instance Nmap_dom {A} : Dom (Nmap A) Nset := mapset_dom. Global Instance: FinMapDom N Nmap Nset := mapset_dom_spec. stdpp-coq-stdpp-1.9.0/stdpp/numbers.v000066400000000000000000001750201451153341500175660ustar00rootroot00000000000000(** This file provides various tweaks and extensions to Coq's theory of numbers (natural numbers [nat] and [N], positive numbers [positive], integers [Z], and rationals [Qc]). In addition, this file defines a new type of positive rational numbers [Qp], which is used extensively in Iris to represent fractional permissions. The organization of this file follows mostly Coq's standard library. - We put all results in modules. For example, the module [Nat] collects the results for type [nat]. Since the Coq stdlib already defines a module [Nat], our module [Nat] exports Coq's module so that our module [Nat] contains the union of the results from the Coq stdlib and std++. - We follow the naming convention of Coq's "numbers" library to prefer [succ]/[add]/[sub]/[mul] over [S]/[plus]/[minus]/[mult]. - One typically does not [Import] modules such as [Nat], and refers to the results using [Nat.lem]. As a consequence, all [Hint]s [Instance]s in the modules in this file are [Global] and not [Export]. Other things like [Arguments] are outside the modules, since for them [Global] works like [Export]. The results for [Qc] are not yet in a module. This is in part because they still follow the old/non-module style in Coq's standard library. See also https://gitlab.mpi-sws.org/iris/stdpp/-/issues/147. *) From Coq Require Export EqdepFacts PArith NArith ZArith NPeano. From Coq Require Import QArith Qcanon. From stdpp Require Export base decidable option. From stdpp Require Import options. Local Open Scope nat_scope. Global Instance comparison_eq_dec : EqDecision comparison. Proof. solve_decision. Defined. (** * Notations and properties of [nat] *) Global Arguments Nat.sub !_ !_ / : assert. Global Arguments Nat.max : simpl nomatch. (** We do not make [Nat.lt] since it is an alias for [lt], which contains the actual definition that we want to make opaque. *) Global Typeclasses Opaque lt. Reserved Notation "x ≤ y ≤ z" (at level 70, y at next level). Reserved Notation "x ≤ y < z" (at level 70, y at next level). Reserved Notation "x < y < z" (at level 70, y at next level). Reserved Notation "x < y ≤ z" (at level 70, y at next level). Reserved Notation "x ≤ y ≤ z ≤ z'" (at level 70, y at next level, z at next level). Infix "≤" := le : nat_scope. (** We do *not* add notation for [≥] mapping to [ge], and we do also not use the [>] notation from the Coq standard library. Using such notations leads to annoying problems: if you have [x < y] in the context and need [y > x] for some lemma, [assumption] won't work because [x < y] and [y > x] are not definitionally equal. It is just generally frustrating to deal with this mismatch, and much preferable to state logically equivalent things in syntactically equal ways. As an alternative, we could define [>] and [≥] as [parsing only] notation that maps to [<] and [≤], respectively (similar to math-comp). This would change the notation for [<] from the Coq standard library to something that is not definitionally equal, so we avoid that as well. This concern applies to all number types: [nat], [N], [Z], [positive], [Qc] and [Qp]. *) Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z)%nat : nat_scope. Notation "x ≤ y < z" := (x ≤ y ∧ y < z)%nat : nat_scope. Notation "x < y ≤ z" := (x < y ∧ y ≤ z)%nat : nat_scope. Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z')%nat : nat_scope. Notation "(≤)" := le (only parsing) : nat_scope. Notation "(<)" := lt (only parsing) : nat_scope. Infix "`div`" := Nat.div (at level 35) : nat_scope. Infix "`mod`" := Nat.modulo (at level 35) : nat_scope. Infix "`max`" := Nat.max (at level 35) : nat_scope. Infix "`min`" := Nat.min (at level 35) : nat_scope. (** TODO: Consider removing these notations to avoid populting the global scope? *) Notation lcm := Nat.lcm. Notation divide := Nat.divide. Notation "( x | y )" := (divide x y) : nat_scope. Module Nat. Export PeanoNat.Nat. Global Instance add_assoc' : Assoc (=) Nat.add := Nat.add_assoc. Global Instance add_comm' : Comm (=) Nat.add := Nat.add_comm. Global Instance add_left_id : LeftId (=) 0 Nat.add := Nat.add_0_l. Global Instance add_right_id : RightId (=) 0 Nat.add := Nat.add_0_r. Global Instance sub_right_id : RightId (=) 0 Nat.sub := Nat.sub_0_r. Global Instance mul_assoc' : Assoc (=) Nat.mul := Nat.mul_assoc. Global Instance mul_comm' : Comm (=) Nat.mul := Nat.mul_comm. Global Instance mul_left_id : LeftId (=) 1 Nat.mul := Nat.mul_1_l. Global Instance mul_right_id : RightId (=) 1 Nat.mul := Nat.mul_1_r. Global Instance mul_left_absorb : LeftAbsorb (=) 0 Nat.mul := Nat.mul_0_l. Global Instance mul_right_absorb : RightAbsorb (=) 0 Nat.mul := Nat.mul_0_r. Global Instance div_right_id : RightId (=) 1 Nat.div := Nat.div_1_r. Global Instance eq_dec: EqDecision nat := eq_nat_dec. Global Instance le_dec: RelDecision le := le_dec. Global Instance lt_dec: RelDecision lt := lt_dec. Global Instance inhabited: Inhabited nat := populate 0. Global Instance succ_inj: Inj (=) (=) Nat.succ. Proof. by injection 1. Qed. Global Instance le_po: PartialOrder (≤). Proof. repeat split; repeat intro; auto with lia. Qed. Global Instance le_total: Total (≤). Proof. repeat intro; lia. Qed. Global Instance le_pi: ∀ x y : nat, ProofIrrel (x ≤ y). Proof. assert (∀ x y (p : x ≤ y) y' (q : x ≤ y'), y = y' → eq_dep nat (le x) y p y' q) as aux. { fix FIX 3. intros x ? [|y p] ? [|y' q]. - done. - clear FIX. intros; exfalso; auto with lia. - clear FIX. intros; exfalso; auto with lia. - injection 1. intros Hy. by case (FIX x y p y' q Hy). } intros x y p q. by apply (Eqdep_dec.eq_dep_eq_dec (λ x y, decide (x = y))), aux. Qed. Global Instance lt_pi: ∀ x y : nat, ProofIrrel (x < y). Proof. unfold Peano.lt. apply _. Qed. Lemma le_sum (x y : nat) : x ≤ y ↔ ∃ z, y = x + z. Proof. split; [exists (y - x); lia | intros [z ->]; lia]. Qed. (** This is similar to but slightly different than Coq's [add_sub : ∀ n m : nat, n + m - m = n]. *) Lemma add_sub' n m : n + m - n = m. Proof. lia. Qed. Lemma le_add_sub n m : n ≤ m → m = n + (m - n). Proof. lia. Qed. (** Cancellation for multiplication. Coq's stdlib has these lemmas for [Z], but those for [nat] are missing. We use the naming scheme of Coq's stdlib. *) Lemma mul_reg_l n m p : p ≠ 0 → p * n = p * m → n = m. Proof. pose proof (Z.mul_reg_l (Z.of_nat n) (Z.of_nat m) (Z.of_nat p)). lia. Qed. Lemma mul_reg_r n m p : p ≠ 0 → n * p = m * p → n = m. Proof. rewrite <-!(Nat.mul_comm p). apply mul_reg_l. Qed. Lemma lt_succ_succ n : n < S (S n). Proof. auto with arith. Qed. Lemma mul_split_l n x1 x2 y1 y2 : x2 < n → y2 < n → x1 * n + x2 = y1 * n + y2 → x1 = y1 ∧ x2 = y2. Proof. intros Hx2 Hy2 E. cut (x1 = y1); [intros; subst;lia |]. revert y1 E. induction x1; simpl; intros [|?]; simpl; auto with lia. Qed. Lemma mul_split_r n x1 x2 y1 y2 : x1 < n → y1 < n → x1 + x2 * n = y1 + y2 * n → x1 = y1 ∧ x2 = y2. Proof. intros. destruct (mul_split_l n x2 x1 y2 y1); auto with lia. Qed. Global Instance divide_dec : RelDecision Nat.divide. Proof. refine (λ x y, cast_if (decide (lcm x y = y))); by rewrite Nat.divide_lcm_iff. Defined. Global Instance divide_po : PartialOrder divide. Proof. repeat split; try apply _. intros ??. apply Nat.divide_antisym; lia. Qed. Global Hint Extern 0 (_ | _) => reflexivity : core. Lemma divide_ne_0 x y : (x | y) → y ≠ 0 → x ≠ 0. Proof. intros Hxy Hy ->. by apply Hy, Nat.divide_0_l. Qed. Lemma iter_succ {A} n (f: A → A) x : Nat.iter (S n) f x = f (Nat.iter n f x). Proof. done. Qed. Lemma iter_succ_r {A} n (f: A → A) x : Nat.iter (S n) f x = Nat.iter n f (f x). Proof. induction n; by f_equal/=. Qed. Lemma iter_add {A} n1 n2 (f : A → A) x : Nat.iter (n1 + n2) f x = Nat.iter n1 f (Nat.iter n2 f x). Proof. induction n1; by f_equal/=. Qed. Lemma iter_mul {A} n1 n2 (f : A → A) x : Nat.iter (n1 * n2) f x = Nat.iter n1 (Nat.iter n2 f) x. Proof. intros. induction n1 as [|n1 IHn1]; [done|]. simpl. by rewrite iter_add, IHn1. Qed. Lemma iter_ind {A} (P : A → Prop) f x k : P x → (∀ y, P y → P (f y)) → P (Nat.iter k f x). Proof. induction k; simpl; auto. Qed. (** FIXME: Coq 8.17 deprecated some lemmas in https://github.com/coq/coq/pull/16203. We cannot use the intended replacements since we support Coq 8.16. We also do not want to disable [deprecated-syntactic-definition] everywhere, so instead we provide non-deprecated duplicates of those deprecated lemmas that we need in std++ and Iris. *) Local Set Warnings "-deprecated-syntactic-definition". Lemma add_mod_idemp_l a b n : n ≠ 0 → (a mod n + b) mod n = (a + b) mod n. Proof. auto using add_mod_idemp_l. Qed. Lemma div_lt_upper_bound a b q : b ≠ 0 → a < b * q → a / b < q. Proof. auto using div_lt_upper_bound. Qed. End Nat. (** * Notations and properties of [positive] *) Local Open Scope positive_scope. Global Typeclasses Opaque Pos.le. Global Typeclasses Opaque Pos.lt. Infix "≤" := Pos.le : positive_scope. Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) : positive_scope. Notation "x ≤ y < z" := (x ≤ y ∧ y < z) : positive_scope. Notation "x < y ≤ z" := (x < y ∧ y ≤ z) : positive_scope. Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z') : positive_scope. Notation "(≤)" := Pos.le (only parsing) : positive_scope. Notation "(<)" := Pos.lt (only parsing) : positive_scope. Notation "(~0)" := xO (only parsing) : positive_scope. Notation "(~1)" := xI (only parsing) : positive_scope. Infix "`max`" := Pos.max : positive_scope. Infix "`min`" := Pos.min : positive_scope. Global Arguments Pos.pred : simpl never. Global Arguments Pos.succ : simpl never. Global Arguments Pos.of_nat : simpl never. Global Arguments Pos.to_nat : simpl never. Global Arguments Pos.mul : simpl never. Global Arguments Pos.add : simpl never. Global Arguments Pos.sub : simpl never. Global Arguments Pos.pow : simpl never. Global Arguments Pos.shiftl : simpl never. Global Arguments Pos.shiftr : simpl never. Global Arguments Pos.gcd : simpl never. Global Arguments Pos.min : simpl never. Global Arguments Pos.max : simpl never. Global Arguments Pos.lor : simpl never. Global Arguments Pos.land : simpl never. Global Arguments Pos.lxor : simpl never. Global Arguments Pos.square : simpl never. Module Pos. Export BinPos.Pos. Global Instance add_assoc' : Assoc (=) Pos.add := Pos.add_assoc. Global Instance add_comm' : Comm (=) Pos.add := Pos.add_comm. Global Instance mul_assoc' : Assoc (=) Pos.mul := Pos.mul_assoc. Global Instance mul_comm' : Comm (=) Pos.mul := Pos.mul_comm. Global Instance mul_left_id : LeftId (=) 1 Pos.mul := Pos.mul_1_l. Global Instance mul_right_id : RightId (=) 1 Pos.mul := Pos.mul_1_r. Global Instance eq_dec: EqDecision positive := Pos.eq_dec. Global Instance le_dec: RelDecision Pos.le. Proof. refine (λ x y, decide ((x ?= y) ≠ Gt)). Defined. Global Instance lt_dec: RelDecision Pos.lt. Proof. refine (λ x y, decide ((x ?= y) = Lt)). Defined. Global Instance le_total: Total Pos.le. Proof. repeat intro; lia. Qed. Global Instance inhabited: Inhabited positive := populate 1. Global Instance maybe_xO : Maybe xO := λ p, match p with p~0 => Some p | _ => None end. Global Instance maybe_xI : Maybe xI := λ p, match p with p~1 => Some p | _ => None end. Global Instance xO_inj : Inj (=) (=) (~0). Proof. by injection 1. Qed. Global Instance xI_inj : Inj (=) (=) (~1). Proof. by injection 1. Qed. (** Since [positive] represents lists of bits, we define list operations on it. These operations are in reverse, as positives are treated as snoc lists instead of cons lists. *) Fixpoint app (p1 p2 : positive) : positive := match p2 with | 1 => p1 | p2~0 => (app p1 p2)~0 | p2~1 => (app p1 p2)~1 end. Module Import app_notations. Infix "++" := app : positive_scope. Notation "(++)" := app (only parsing) : positive_scope. Notation "( p ++.)" := (app p) (only parsing) : positive_scope. Notation "(.++ q )" := (λ p, app p q) (only parsing) : positive_scope. End app_notations. Fixpoint reverse_go (p1 p2 : positive) : positive := match p2 with | 1 => p1 | p2~0 => reverse_go (p1~0) p2 | p2~1 => reverse_go (p1~1) p2 end. Definition reverse : positive → positive := reverse_go 1. Global Instance app_1_l : LeftId (=) 1 (++). Proof. intros p. by induction p; intros; f_equal/=. Qed. Global Instance app_1_r : RightId (=) 1 (++). Proof. done. Qed. Global Instance app_assoc : Assoc (=) (++). Proof. intros ?? p. by induction p; intros; f_equal/=. Qed. Global Instance app_inj p : Inj (=) (=) (.++ p). Proof. intros ???. induction p; simplify_eq; auto. Qed. Lemma reverse_go_app p1 p2 p3 : reverse_go p1 (p2 ++ p3) = reverse_go p1 p3 ++ reverse_go 1 p2. Proof. revert p3 p1 p2. cut (∀ p1 p2 p3, reverse_go (p2 ++ p3) p1 = p2 ++ reverse_go p3 p1). { by intros go p3; induction p3; intros p1 p2; simpl; auto; rewrite <-?go. } intros p1; induction p1 as [p1 IH|p1 IH|]; intros p2 p3; simpl; auto. - apply (IH _ (_~1)). - apply (IH _ (_~0)). Qed. Lemma reverse_app p1 p2 : reverse (p1 ++ p2) = reverse p2 ++ reverse p1. Proof. unfold reverse. by rewrite reverse_go_app. Qed. Lemma reverse_xO p : reverse (p~0) = (1~0) ++ reverse p. Proof. apply (reverse_app p (1~0)). Qed. Lemma reverse_xI p : reverse (p~1) = (1~1) ++ reverse p. Proof. apply (reverse_app p (1~1)). Qed. Lemma reverse_involutive p : reverse (reverse p) = p. Proof. induction p as [p IH|p IH|]; simpl. - by rewrite reverse_xI, reverse_app, IH. - by rewrite reverse_xO, reverse_app, IH. - reflexivity. Qed. Global Instance reverse_inj : Inj (=) (=) reverse. Proof. intros p q eq. rewrite <-(reverse_involutive p). rewrite <-(reverse_involutive q). by rewrite eq. Qed. Fixpoint length (p : positive) : nat := match p with 1 => 0%nat | p~0 | p~1 => S (length p) end. Lemma app_length p1 p2 : length (p1 ++ p2) = (length p2 + length p1)%nat. Proof. by induction p2; f_equal/=. Qed. Lemma lt_sum (x y : positive) : x < y ↔ ∃ z, y = x + z. Proof. split. - exists (y - x)%positive. symmetry. apply Pplus_minus. lia. - intros [z ->]. lia. Qed. (** Duplicate the bits of a positive, i.e. 1~0~1 -> 1~0~0~1~1 and 1~1~0~0 -> 1~1~1~0~0~0~0 *) Fixpoint dup (p : positive) : positive := match p with | 1 => 1 | p'~0 => (dup p')~0~0 | p'~1 => (dup p')~1~1 end. Lemma dup_app p q : dup (p ++ q) = dup p ++ dup q. Proof. revert p. induction q as [p IH|p IH|]; intros q; simpl. - by rewrite IH. - by rewrite IH. - reflexivity. Qed. Lemma dup_suffix_eq p q s1 s2 : s1~1~0 ++ dup p = s2~1~0 ++ dup q → p = q. Proof. revert q. induction p as [p IH|p IH|]; intros [q|q|] eq; simplify_eq/=. - by rewrite (IH q). - by rewrite (IH q). - reflexivity. Qed. Global Instance dup_inj : Inj (=) (=) dup. Proof. intros p q eq. apply (dup_suffix_eq _ _ 1 1). by rewrite eq. Qed. Lemma reverse_dup p : reverse (dup p) = dup (reverse p). Proof. induction p as [p IH|p IH|]; simpl. - rewrite 3!reverse_xI. rewrite (assoc_L (++)). rewrite IH. rewrite dup_app. reflexivity. - rewrite 3!reverse_xO. rewrite (assoc_L (++)). rewrite IH. rewrite dup_app. reflexivity. - reflexivity. Qed. End Pos. Export Pos.app_notations. Local Close Scope positive_scope. (** * Notations and properties of [N] *) Local Open Scope N_scope. Global Typeclasses Opaque N.le. Global Typeclasses Opaque N.lt. Infix "≤" := N.le : N_scope. Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z)%N : N_scope. Notation "x ≤ y < z" := (x ≤ y ∧ y < z)%N : N_scope. Notation "x < y ≤ z" := (x < y ∧ y ≤ z)%N : N_scope. Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z')%N : N_scope. Notation "(≤)" := N.le (only parsing) : N_scope. Notation "(<)" := N.lt (only parsing) : N_scope. Infix "`div`" := N.div (at level 35) : N_scope. Infix "`mod`" := N.modulo (at level 35) : N_scope. Infix "`max`" := N.max (at level 35) : N_scope. Infix "`min`" := N.min (at level 35) : N_scope. Global Arguments N.pred : simpl never. Global Arguments N.succ : simpl never. Global Arguments N.of_nat : simpl never. Global Arguments N.to_nat : simpl never. Global Arguments N.mul : simpl never. Global Arguments N.add : simpl never. Global Arguments N.sub : simpl never. Global Arguments N.pow : simpl never. Global Arguments N.div : simpl never. Global Arguments N.modulo : simpl never. Global Arguments N.shiftl : simpl never. Global Arguments N.shiftr : simpl never. Global Arguments N.gcd : simpl never. Global Arguments N.lcm : simpl never. Global Arguments N.min : simpl never. Global Arguments N.max : simpl never. Global Arguments N.lor : simpl never. Global Arguments N.land : simpl never. Global Arguments N.lxor : simpl never. Global Arguments N.lnot : simpl never. Global Arguments N.square : simpl never. Global Hint Extern 0 (_ ≤ _)%N => reflexivity : core. Module N. Export BinNat.N. Global Instance add_assoc' : Assoc (=) N.add := N.add_assoc. Global Instance add_comm' : Comm (=) N.add := N.add_comm. Global Instance add_left_id : LeftId (=) 0 N.add := N.add_0_l. Global Instance add_right_id : RightId (=) 0 N.add := N.add_0_r. Global Instance sub_right_id : RightId (=) 0 N.sub := N.sub_0_r. Global Instance mul_assoc' : Assoc (=) N.mul := N.mul_assoc. Global Instance mul_comm' : Comm (=) N.mul := N.mul_comm. Global Instance mul_left_id : LeftId (=) 1 N.mul := N.mul_1_l. Global Instance mul_right_id : RightId (=) 1 N.mul := N.mul_1_r. Global Instance mul_left_absorb : LeftAbsorb (=) 0 N.mul := N.mul_0_l. Global Instance mul_right_absorb : RightAbsorb (=) 0 N.mul := N.mul_0_r. Global Instance div_right_id : RightId (=) 1 N.div := N.div_1_r. Global Instance pos_inj : Inj (=) (=) N.pos. Proof. by injection 1. Qed. Global Instance eq_dec : EqDecision N := N.eq_dec. Global Program Instance le_dec : RelDecision N.le := λ x y, match N.compare x y with Gt => right _ | _ => left _ end. Solve Obligations with naive_solver. Global Program Instance lt_dec : RelDecision N.lt := λ x y, match N.compare x y with Lt => left _ | _ => right _ end. Solve Obligations with naive_solver. Global Instance inhabited : Inhabited N := populate 1%N. Global Instance lt_pi x y : ProofIrrel (x < y)%N. Proof. unfold N.lt. apply _. Qed. Global Instance le_po : PartialOrder (≤)%N. Proof. repeat split; red; [apply N.le_refl | apply N.le_trans | apply N.le_antisymm]. Qed. Global Instance le_total : Total (≤)%N. Proof. repeat intro; lia. Qed. (** FIXME: Coq 8.17 deprecated some lemmas in https://github.com/coq/coq/pull/16203. We cannot use the intended replacements since we support Coq 8.16. We also do not want to disable [deprecated-syntactic-definition] everywhere, so instead we provide non-deprecated duplicates of those deprecated lemmas that we need in std++ and Iris. *) Local Set Warnings "-deprecated-syntactic-definition". Lemma add_mod_idemp_l a b n : n ≠ 0 → (a mod n + b) mod n = (a + b) mod n. Proof. auto using add_mod_idemp_l. Qed. Lemma div_lt_upper_bound a b q : b ≠ 0 → a < b * q → a / b < q. Proof. auto using div_lt_upper_bound. Qed. End N. Local Close Scope N_scope. (** * Notations and properties of [Z] *) Local Open Scope Z_scope. Global Typeclasses Opaque Z.le. Global Typeclasses Opaque Z.lt. Infix "≤" := Z.le : Z_scope. Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) : Z_scope. Notation "x ≤ y < z" := (x ≤ y ∧ y < z) : Z_scope. Notation "x < y < z" := (x < y ∧ y < z) : Z_scope. Notation "x < y ≤ z" := (x < y ∧ y ≤ z) : Z_scope. Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z') : Z_scope. Notation "(≤)" := Z.le (only parsing) : Z_scope. Notation "(<)" := Z.lt (only parsing) : Z_scope. Infix "`div`" := Z.div (at level 35) : Z_scope. Infix "`mod`" := Z.modulo (at level 35) : Z_scope. Infix "`quot`" := Z.quot (at level 35) : Z_scope. Infix "`rem`" := Z.rem (at level 35) : Z_scope. Infix "≪" := Z.shiftl (at level 35) : Z_scope. Infix "≫" := Z.shiftr (at level 35) : Z_scope. Infix "`max`" := Z.max (at level 35) : Z_scope. Infix "`min`" := Z.min (at level 35) : Z_scope. Global Arguments Z.pred : simpl never. Global Arguments Z.succ : simpl never. Global Arguments Z.of_nat : simpl never. Global Arguments Z.to_nat : simpl never. Global Arguments Z.mul : simpl never. Global Arguments Z.add : simpl never. Global Arguments Z.sub : simpl never. Global Arguments Z.opp : simpl never. Global Arguments Z.pow : simpl never. Global Arguments Z.div : simpl never. Global Arguments Z.modulo : simpl never. Global Arguments Z.quot : simpl never. Global Arguments Z.rem : simpl never. Global Arguments Z.shiftl : simpl never. Global Arguments Z.shiftr : simpl never. Global Arguments Z.gcd : simpl never. Global Arguments Z.lcm : simpl never. Global Arguments Z.min : simpl never. Global Arguments Z.max : simpl never. Global Arguments Z.lor : simpl never. Global Arguments Z.land : simpl never. Global Arguments Z.lxor : simpl never. Global Arguments Z.lnot : simpl never. Global Arguments Z.square : simpl never. Global Arguments Z.abs : simpl never. Module Z. Export BinInt.Z. Global Instance add_assoc' : Assoc (=) Z.add := Z.add_assoc. Global Instance add_comm' : Comm (=) Z.add := Z.add_comm. Global Instance add_left_id : LeftId (=) 0 Z.add := Z.add_0_l. Global Instance add_right_id : RightId (=) 0 Z.add := Z.add_0_r. Global Instance sub_right_id : RightId (=) 0 Z.sub := Z.sub_0_r. Global Instance mul_assoc' : Assoc (=) Z.mul := Z.mul_assoc. Global Instance mul_comm' : Comm (=) Z.mul := Z.mul_comm. Global Instance mul_left_id : LeftId (=) 1 Z.mul := Z.mul_1_l. Global Instance mul_right_id : RightId (=) 1 Z.mul := Z.mul_1_r. Global Instance mul_left_absorb : LeftAbsorb (=) 0 Z.mul := Z.mul_0_l. Global Instance mul_right_absorb : RightAbsorb (=) 0 Z.mul := Z.mul_0_r. Global Instance div_right_id : RightId (=) 1 Z.div := Z.div_1_r. Global Instance pos_inj : Inj (=) (=) Z.pos. Proof. by injection 1. Qed. Global Instance neg_inj : Inj (=) (=) Z.neg. Proof. by injection 1. Qed. Global Instance eq_dec: EqDecision Z := Z.eq_dec. Global Instance le_dec: RelDecision Z.le := Z_le_dec. Global Instance lt_dec: RelDecision Z.lt := Z_lt_dec. Global Instance ge_dec: RelDecision Z.ge := Z_ge_dec. Global Instance gt_dec: RelDecision Z.gt := Z_gt_dec. Global Instance inhabited: Inhabited Z := populate 1. Global Instance lt_pi x y : ProofIrrel (x < y). Proof. unfold Z.lt. apply _. Qed. Global Instance le_po : PartialOrder (≤). Proof. repeat split; red; [apply Z.le_refl | apply Z.le_trans | apply Z.le_antisymm]. Qed. Global Instance le_total: Total Z.le. Proof. repeat intro; lia. Qed. Lemma pow_pred_r n m : 0 < m → n * n ^ (Z.pred m) = n ^ m. Proof. intros. rewrite <-Z.pow_succ_r, Z.succ_pred; [done|]. by apply Z.lt_le_pred. Qed. Lemma quot_range_nonneg k x y : 0 ≤ x < k → 0 < y → 0 ≤ x `quot` y < k. Proof. intros [??] ?. destruct (decide (y = 1)); subst; [rewrite Z.quot_1_r; auto |]. destruct (decide (x = 0)); subst; [rewrite Z.quot_0_l; auto with lia |]. split; [apply Z.quot_pos; lia|]. trans x; auto. apply Z.quot_lt; lia. Qed. Lemma mod_pos x y : 0 < y → 0 ≤ x `mod` y. Proof. apply Z.mod_pos_bound. Qed. Global Hint Resolve Z.lt_le_incl : zpos. Global Hint Resolve Z.add_nonneg_pos Z.add_pos_nonneg Z.add_nonneg_nonneg : zpos. Global Hint Resolve Z.mul_nonneg_nonneg Z.mul_pos_pos : zpos. Global Hint Resolve Z.pow_pos_nonneg Z.pow_nonneg: zpos. Global Hint Resolve Z.mod_pos Z.div_pos : zpos. Global Hint Extern 1000 => lia : zpos. Lemma succ_pred_induction y (P : Z → Prop) : P y → (∀ x, y ≤ x → P x → P (Z.succ x)) → (∀ x, x ≤ y → P x → P (Z.pred x)) → (∀ x, P x). Proof. intros H0 HS HP. by apply (Z.order_induction' _ _ y). Qed. Lemma mod_in_range q a c : q * c ≤ a < (q + 1) * c → a `mod` c = a - q * c. Proof. intros ?. symmetry. apply Z.mod_unique_pos with q; lia. Qed. Lemma ones_spec n m: 0 ≤ m → 0 ≤ n → Z.testbit (Z.ones n) m = bool_decide (m < n). Proof. intros. case_bool_decide. - by rewrite Z.ones_spec_low by lia. - by rewrite Z.ones_spec_high by lia. Qed. Lemma bounded_iff_bits_nonneg k n : 0 ≤ k → 0 ≤ n → n < 2^k ↔ ∀ l, k ≤ l → Z.testbit n l = false. Proof. intros. destruct (decide (n = 0)) as [->|]. { naive_solver eauto using Z.bits_0, Z.pow_pos_nonneg with lia. } split. { intros Hb%Z.log2_lt_pow2 l Hl; [|lia]. apply Z.bits_above_log2; lia. } intros Hl. apply Z.nle_gt; intros ?. assert (Z.testbit n (Z.log2 n) = false) as Hbit. { apply Hl, Z.log2_le_pow2; lia. } by rewrite Z.bit_log2 in Hbit by lia. Qed. (* Goals of the form [0 ≤ n ≤ 2^k] appear often. So we also define the derived version [Z_bounded_iff_bits_nonneg'] that does not require proving [0 ≤ n] twice in that case. *) Lemma bounded_iff_bits_nonneg' k n : 0 ≤ k → 0 ≤ n → 0 ≤ n < 2^k ↔ ∀ l, k ≤ l → Z.testbit n l = false. Proof. intros ??. rewrite <-bounded_iff_bits_nonneg; lia. Qed. Lemma bounded_iff_bits k n : 0 ≤ k → -2^k ≤ n < 2^k ↔ ∀ l, k ≤ l → Z.testbit n l = bool_decide (n < 0). Proof. intros Hk. case_bool_decide; [ | rewrite <-bounded_iff_bits_nonneg; lia]. assert(n = - Z.abs n)%Z as -> by lia. split. { intros [? _] l Hl. rewrite Z.bits_opp, negb_true_iff by lia. apply bounded_iff_bits_nonneg with k; lia. } intros Hbit. split. - rewrite <-Z.opp_le_mono, <-Z.lt_pred_le. apply bounded_iff_bits_nonneg; [lia..|]. intros l Hl. rewrite <-negb_true_iff, <-Z.bits_opp by lia. by apply Hbit. - etrans; [|apply Z.pow_pos_nonneg]; lia. Qed. Lemma add_nocarry_lor a b : Z.land a b = 0 → a + b = Z.lor a b. Proof. intros ?. rewrite <-Z.lxor_lor by done. by rewrite Z.add_nocarry_lxor. Qed. Lemma opp_lnot a : -a - 1 = Z.lnot a. Proof. pose proof (Z.add_lnot_diag a). lia. Qed. End Z. Module Nat2Z. Export Znat.Nat2Z. Global Instance inj' : Inj (=) (=) Z.of_nat. Proof. intros n1 n2. apply Nat2Z.inj. Qed. Lemma divide n m : (Z.of_nat n | Z.of_nat m) ↔ (n | m)%nat. Proof. split. - rewrite <-(Nat2Z.id m) at 2; intros [i ->]; exists (Z.to_nat i). lia. - intros [i ->]. exists (Z.of_nat i). by rewrite Nat2Z.inj_mul. Qed. Lemma inj_div x y : Z.of_nat (x `div` y) = (Z.of_nat x) `div` (Z.of_nat y). Proof. destruct (decide (y = 0%nat)); [by subst; destruct x |]. apply Z.div_unique with (Z.of_nat $ x `mod` y)%nat. { left. rewrite <-(Nat2Z.inj_le 0), <-Nat2Z.inj_lt. apply Nat.mod_bound_pos; lia. } by rewrite <-Nat2Z.inj_mul, <-Nat2Z.inj_add, <-Nat.div_mod. Qed. Lemma inj_mod x y : Z.of_nat (x `mod` y) = (Z.of_nat x) `mod` (Z.of_nat y). Proof. destruct (decide (y = 0%nat)); [by subst; destruct x |]. apply Z.mod_unique with (Z.of_nat $ x `div` y)%nat. { left. rewrite <-(Nat2Z.inj_le 0), <-Nat2Z.inj_lt. apply Nat.mod_bound_pos; lia. } by rewrite <-Nat2Z.inj_mul, <-Nat2Z.inj_add, <-Nat.div_mod. Qed. End Nat2Z. Module Z2Nat. Export Znat.Z2Nat. Lemma neq_0_pos x : Z.to_nat x ≠ 0%nat → 0 < x. Proof. by destruct x. Qed. Lemma neq_0_nonneg x : Z.to_nat x ≠ 0%nat → 0 ≤ x. Proof. by destruct x. Qed. Lemma nonpos x : x ≤ 0 → Z.to_nat x = 0%nat. Proof. destruct x; simpl; auto using Z2Nat.inj_neg. by intros []. Qed. Lemma inj_pow (x y : nat) : Z.of_nat (x ^ y) = (Z.of_nat x) ^ (Z.of_nat y). Proof. induction y as [|y IH]; [by rewrite Z.pow_0_r, Nat.pow_0_r|]. by rewrite Nat.pow_succ_r, Nat2Z.inj_succ, Z.pow_succ_r, Nat2Z.inj_mul, IH by auto with zpos. Qed. Lemma divide n m : 0 ≤ n → 0 ≤ m → (Z.to_nat n | Z.to_nat m)%nat ↔ (n | m). Proof. intros. by rewrite <-Nat2Z.divide, !Z2Nat.id by done. Qed. Lemma inj_div x y : 0 ≤ x → 0 ≤ y → Z.to_nat (x `div` y) = (Z.to_nat x `div` Z.to_nat y)%nat. Proof. intros. destruct (decide (y = Z.of_nat 0%nat)); [by subst; destruct x|]. pose proof (Z.div_pos x y). apply (base.inj Z.of_nat). by rewrite Nat2Z.inj_div, !Z2Nat.id by lia. Qed. Lemma inj_mod x y : 0 ≤ x → 0 ≤ y → Z.to_nat (x `mod` y) = (Z.to_nat x `mod` Z.to_nat y)%nat. Proof. intros. destruct (decide (y = Z.of_nat 0%nat)); [by subst; destruct x|]. pose proof (Z.mod_pos x y). apply (base.inj Z.of_nat). by rewrite Nat2Z.inj_mod, !Z2Nat.id by lia. Qed. End Z2Nat. (** ** [bool_to_Z] *) Definition bool_to_Z (b : bool) : Z := if b then 1 else 0. Lemma bool_to_Z_bound b : 0 ≤ bool_to_Z b < 2. Proof. destruct b; simpl; lia. Qed. Lemma bool_to_Z_eq_0 b : bool_to_Z b = 0 ↔ b = false. Proof. destruct b; naive_solver. Qed. Lemma bool_to_Z_neq_0 b : bool_to_Z b ≠ 0 ↔ b = true. Proof. destruct b; naive_solver. Qed. Lemma bool_to_Z_spec b n : Z.testbit (bool_to_Z b) n = bool_decide (n = 0) && b. Proof. by destruct b, n. Qed. Local Close Scope Z_scope. (** * Injectivity of casts *) Module Nat2N. Export Nnat.Nat2N. Global Instance inj' : Inj (=) (=) N.of_nat := Nat2N.inj. End Nat2N. Module N2Nat. Export Nnat.N2Nat. Global Instance inj' : Inj (=) (=) N.to_nat := N2Nat.inj. End N2Nat. Module Pos2Nat. Export Pnat.Pos2Nat. Global Instance inj' : Inj (=) (=) Pos.to_nat := Pos2Nat.inj. End Pos2Nat. Module SuccNat2Pos. Export Pnat.SuccNat2Pos. Global Instance inj' : Inj (=) (=) Pos.of_succ_nat := SuccNat2Pos.inj. End SuccNat2Pos. Module N2Z. Export Znat.N2Z. Global Instance inj' : Inj (=) (=) Z.of_N := N2Z.inj. End N2Z. (* Add others here. *) (** * Notations and properties of [Qc] *) Global Typeclasses Opaque Qcle. Global Typeclasses Opaque Qclt. Local Open Scope Qc_scope. Delimit Scope Qc_scope with Qc. Notation "1" := (Q2Qc 1) : Qc_scope. Notation "2" := (1+1) : Qc_scope. Notation "- 1" := (Qcopp 1) : Qc_scope. Notation "- 2" := (Qcopp 2) : Qc_scope. Infix "≤" := Qcle : Qc_scope. Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) : Qc_scope. Notation "x ≤ y < z" := (x ≤ y ∧ y < z) : Qc_scope. Notation "x < y < z" := (x < y ∧ y < z) : Qc_scope. Notation "x < y ≤ z" := (x < y ∧ y ≤ z) : Qc_scope. Notation "x ≤ y ≤ z ≤ z'" := (x ≤ y ∧ y ≤ z ∧ z ≤ z') : Qc_scope. Notation "(≤)" := Qcle (only parsing) : Qc_scope. Notation "(<)" := Qclt (only parsing) : Qc_scope. Global Hint Extern 1 (_ ≤ _) => reflexivity || discriminate : core. Global Arguments Qred : simpl never. Global Instance Qcplus_assoc' : Assoc (=) Qcplus := Qcplus_assoc. Global Instance Qcplus_comm' : Comm (=) Qcplus := Qcplus_comm. Global Instance Qcplus_left_id : LeftId (=) 0 Qcplus := Qcplus_0_l. Global Instance Qcplus_right_id : RightId (=) 0 Qcplus := Qcplus_0_r. Global Instance Qcminus_right_id : RightId (=) 0 Qcminus. Proof. unfold RightId. intros. ring. Qed. Global Instance Qcmult_assoc' : Assoc (=) Qcmult := Qcmult_assoc. Global Instance Qcmult_comm' : Comm (=) Qcmult := Qcmult_comm. Global Instance Qcmult_left_id : LeftId (=) 1 Qcmult := Qcmult_1_l. Global Instance Qcmult_right_id : RightId (=) 1 Qcmult := Qcmult_1_r. Global Instance Qcmult_left_absorb : LeftAbsorb (=) 0 Qcmult := Qcmult_0_l. Global Instance Qcmult_right_absorb : RightAbsorb (=) 0 Qcmult := Qcmult_0_r. Global Instance Qcdiv_right_id : RightId (=) 1 Qcdiv. Proof. intros x. rewrite <-(Qcmult_1_l (x / 1)), Qcmult_div_r; done. Qed. Lemma inject_Z_Qred n : Qred (inject_Z n) = inject_Z n. Proof. apply Qred_identity; auto using Z.gcd_1_r. Qed. Definition Qc_of_Z (n : Z) : Qc := Qcmake _ (inject_Z_Qred n). Global Instance Qc_eq_dec: EqDecision Qc := Qc_eq_dec. Global Program Instance Qc_le_dec: RelDecision Qcle := λ x y, if Qclt_le_dec y x then right _ else left _. Next Obligation. intros x y; apply Qclt_not_le. Qed. Next Obligation. done. Qed. Global Program Instance Qc_lt_dec: RelDecision Qclt := λ x y, if Qclt_le_dec x y then left _ else right _. Next Obligation. done. Qed. Next Obligation. intros x y; apply Qcle_not_lt. Qed. Global Instance Qc_lt_pi x y : ProofIrrel (x < y). Proof. unfold Qclt. apply _. Qed. Global Instance Qc_le_po: PartialOrder (≤). Proof. repeat split; red; [apply Qcle_refl | apply Qcle_trans | apply Qcle_antisym]. Qed. Global Instance Qc_lt_strict: StrictOrder (<). Proof. split; red; [|apply Qclt_trans]. intros x Hx. by destruct (Qclt_not_eq x x). Qed. Global Instance Qc_le_total: Total Qcle. Proof. intros x y. destruct (Qclt_le_dec x y); auto using Qclt_le_weak. Qed. Lemma Qcplus_diag x : (x + x)%Qc = (2 * x)%Qc. Proof. ring. Qed. Lemma Qcle_ngt (x y : Qc) : x ≤ y ↔ ¬y < x. Proof. split; auto using Qcle_not_lt, Qcnot_lt_le. Qed. Lemma Qclt_nge (x y : Qc) : x < y ↔ ¬y ≤ x. Proof. split; auto using Qclt_not_le, Qcnot_le_lt. Qed. Lemma Qcplus_le_mono_l (x y z : Qc) : x ≤ y ↔ z + x ≤ z + y. Proof. split; intros. - by apply Qcplus_le_compat. - replace x with ((0 - z) + (z + x)) by ring. replace y with ((0 - z) + (z + y)) by ring. by apply Qcplus_le_compat. Qed. Lemma Qcplus_le_mono_r (x y z : Qc) : x ≤ y ↔ x + z ≤ y + z. Proof. rewrite !(Qcplus_comm _ z). apply Qcplus_le_mono_l. Qed. Lemma Qcplus_lt_mono_l (x y z : Qc) : x < y ↔ z + x < z + y. Proof. by rewrite !Qclt_nge, <-Qcplus_le_mono_l. Qed. Lemma Qcplus_lt_mono_r (x y z : Qc) : x < y ↔ x + z < y + z. Proof. by rewrite !Qclt_nge, <-Qcplus_le_mono_r. Qed. Global Instance Qcopp_inj : Inj (=) (=) Qcopp. Proof. intros x y H. by rewrite <-(Qcopp_involutive x), H, Qcopp_involutive. Qed. Global Instance Qcplus_inj_r z : Inj (=) (=) (Qcplus z). Proof. intros x y H. by apply (anti_symm (≤));rewrite (Qcplus_le_mono_l _ _ z), H. Qed. Global Instance Qcplus_inj_l z : Inj (=) (=) (λ x, x + z). Proof. intros x y H. by apply (anti_symm (≤)); rewrite (Qcplus_le_mono_r _ _ z), H. Qed. Lemma Qcplus_pos_nonneg (x y : Qc) : 0 < x → 0 ≤ y → 0 < x + y. Proof. intros. apply Qclt_le_trans with (x + 0); [by rewrite Qcplus_0_r|]. by apply Qcplus_le_mono_l. Qed. Lemma Qcplus_nonneg_pos (x y : Qc) : 0 ≤ x → 0 < y → 0 < x + y. Proof. rewrite (Qcplus_comm x). auto using Qcplus_pos_nonneg. Qed. Lemma Qcplus_pos_pos (x y : Qc) : 0 < x → 0 < y → 0 < x + y. Proof. auto using Qcplus_pos_nonneg, Qclt_le_weak. Qed. Lemma Qcplus_nonneg_nonneg (x y : Qc) : 0 ≤ x → 0 ≤ y → 0 ≤ x + y. Proof. intros. trans (x + 0); [by rewrite Qcplus_0_r|]. by apply Qcplus_le_mono_l. Qed. Lemma Qcplus_neg_nonpos (x y : Qc) : x < 0 → y ≤ 0 → x + y < 0. Proof. intros. apply Qcle_lt_trans with (x + 0); [|by rewrite Qcplus_0_r]. by apply Qcplus_le_mono_l. Qed. Lemma Qcplus_nonpos_neg (x y : Qc) : x ≤ 0 → y < 0 → x + y < 0. Proof. rewrite (Qcplus_comm x). auto using Qcplus_neg_nonpos. Qed. Lemma Qcplus_neg_neg (x y : Qc) : x < 0 → y < 0 → x + y < 0. Proof. auto using Qcplus_nonpos_neg, Qclt_le_weak. Qed. Lemma Qcplus_nonpos_nonpos (x y : Qc) : x ≤ 0 → y ≤ 0 → x + y ≤ 0. Proof. intros. trans (x + 0); [|by rewrite Qcplus_0_r]. by apply Qcplus_le_mono_l. Qed. Lemma Qcmult_le_mono_nonneg_l x y z : 0 ≤ z → x ≤ y → z * x ≤ z * y. Proof. intros. rewrite !(Qcmult_comm z). by apply Qcmult_le_compat_r. Qed. Lemma Qcmult_le_mono_nonneg_r x y z : 0 ≤ z → x ≤ y → x * z ≤ y * z. Proof. intros. by apply Qcmult_le_compat_r. Qed. Lemma Qcmult_le_mono_pos_l x y z : 0 < z → x ≤ y ↔ z * x ≤ z * y. Proof. split; auto using Qcmult_le_mono_nonneg_l, Qclt_le_weak. rewrite !Qcle_ngt, !(Qcmult_comm z). intuition auto using Qcmult_lt_compat_r. Qed. Lemma Qcmult_le_mono_pos_r x y z : 0 < z → x ≤ y ↔ x * z ≤ y * z. Proof. rewrite !(Qcmult_comm _ z). by apply Qcmult_le_mono_pos_l. Qed. Lemma Qcmult_lt_mono_pos_l x y z : 0 < z → x < y ↔ z * x < z * y. Proof. intros. by rewrite !Qclt_nge, <-Qcmult_le_mono_pos_l. Qed. Lemma Qcmult_lt_mono_pos_r x y z : 0 < z → x < y ↔ x * z < y * z. Proof. intros. by rewrite !Qclt_nge, <-Qcmult_le_mono_pos_r. Qed. Lemma Qcmult_pos_pos x y : 0 < x → 0 < y → 0 < x * y. Proof. intros. apply Qcle_lt_trans with (0 * y); [by rewrite Qcmult_0_l|]. by apply Qcmult_lt_mono_pos_r. Qed. Lemma Qcmult_nonneg_nonneg x y : 0 ≤ x → 0 ≤ y → 0 ≤ x * y. Proof. intros. trans (0 * y); [by rewrite Qcmult_0_l|]. by apply Qcmult_le_mono_nonneg_r. Qed. Lemma Qcinv_pos x : 0 < x → 0 < /x. Proof. intros. assert (0 ≠ x) by (by apply Qclt_not_eq). by rewrite (Qcmult_lt_mono_pos_r _ _ x), Qcmult_0_l, Qcmult_inv_l by done. Qed. Lemma Z2Qc_inj_0 : Qc_of_Z 0 = 0. Proof. by apply Qc_is_canon. Qed. Lemma Z2Qc_inj_1 : Qc_of_Z 1 = 1. Proof. by apply Qc_is_canon. Qed. Lemma Z2Qc_inj_2 : Qc_of_Z 2 = 2. Proof. by apply Qc_is_canon. Qed. Lemma Z2Qc_inj n m : Qc_of_Z n = Qc_of_Z m → n = m. Proof. by injection 1. Qed. Lemma Z2Qc_inj_iff n m : Qc_of_Z n = Qc_of_Z m ↔ n = m. Proof. split; [ auto using Z2Qc_inj | by intros -> ]. Qed. Lemma Z2Qc_inj_le n m : (n ≤ m)%Z ↔ Qc_of_Z n ≤ Qc_of_Z m. Proof. by rewrite Zle_Qle. Qed. Lemma Z2Qc_inj_lt n m : (n < m)%Z ↔ Qc_of_Z n < Qc_of_Z m. Proof. by rewrite Zlt_Qlt. Qed. Lemma Z2Qc_inj_add n m : Qc_of_Z (n + m) = Qc_of_Z n + Qc_of_Z m. Proof. apply Qc_is_canon; simpl. by rewrite Qred_correct, inject_Z_plus. Qed. Lemma Z2Qc_inj_mul n m : Qc_of_Z (n * m) = Qc_of_Z n * Qc_of_Z m. Proof. apply Qc_is_canon; simpl. by rewrite Qred_correct, inject_Z_mult. Qed. Lemma Z2Qc_inj_opp n : Qc_of_Z (-n) = -Qc_of_Z n. Proof. apply Qc_is_canon; simpl. by rewrite Qred_correct, inject_Z_opp. Qed. Lemma Z2Qc_inj_sub n m : Qc_of_Z (n - m) = Qc_of_Z n - Qc_of_Z m. Proof. apply Qc_is_canon; simpl. by rewrite !Qred_correct, <-inject_Z_opp, <-inject_Z_plus. Qed. Local Close Scope Qc_scope. (** * Positive rationals *) Declare Scope Qp_scope. Delimit Scope Qp_scope with Qp. Record Qp := mk_Qp { Qp_to_Qc : Qc ; Qp_prf : (0 < Qp_to_Qc)%Qc }. Add Printing Constructor Qp. Bind Scope Qp_scope with Qp. Global Arguments Qp_to_Qc _%Qp : assert. Program Definition pos_to_Qp (n : positive) : Qp := mk_Qp (Qc_of_Z $ Z.pos n) _. Next Obligation. intros n. by rewrite <-Z2Qc_inj_0, <-Z2Qc_inj_lt. Qed. Global Arguments pos_to_Qp : simpl never. Local Open Scope Qp_scope. Module Qp. Lemma to_Qc_inj_iff p q : Qp_to_Qc p = Qp_to_Qc q ↔ p = q. Proof. split; [|by intros ->]. destruct p, q; intros; simplify_eq/=; f_equal; apply (proof_irrel _). Qed. Global Instance eq_dec : EqDecision Qp. Proof. refine (λ p q, cast_if (decide (Qp_to_Qc p = Qp_to_Qc q))); by rewrite <-to_Qc_inj_iff. Defined. Definition add (p q : Qp) : Qp := let 'mk_Qp p Hp := p in let 'mk_Qp q Hq := q in mk_Qp (p + q) (Qcplus_pos_pos _ _ Hp Hq). Global Arguments add : simpl never. Definition sub (p q : Qp) : option Qp := let 'mk_Qp p Hp := p in let 'mk_Qp q Hq := q in let pq := (p - q)%Qc in guard (0 < pq)%Qc as Hpq; Some (mk_Qp pq Hpq). Global Arguments sub : simpl never. Definition mul (p q : Qp) : Qp := let 'mk_Qp p Hp := p in let 'mk_Qp q Hq := q in mk_Qp (p * q) (Qcmult_pos_pos _ _ Hp Hq). Global Arguments mul : simpl never. Definition inv (q : Qp) : Qp := let 'mk_Qp q Hq := q return _ in mk_Qp (/ q)%Qc (Qcinv_pos _ Hq). Global Arguments inv : simpl never. Definition div (p q : Qp) : Qp := mul p (inv q). Global Typeclasses Opaque div. Global Arguments div : simpl never. Definition le (p q : Qp) : Prop := let 'mk_Qp p _ := p in let 'mk_Qp q _ := q in (p ≤ q)%Qc. Definition lt (p q : Qp) : Prop := let 'mk_Qp p _ := p in let 'mk_Qp q _ := q in (p < q)%Qc. Lemma to_Qc_inj_add p q : Qp_to_Qc (add p q) = (Qp_to_Qc p + Qp_to_Qc q)%Qc. Proof. by destruct p, q. Qed. Lemma to_Qc_inj_mul p q : Qp_to_Qc (mul p q) = (Qp_to_Qc p * Qp_to_Qc q)%Qc. Proof. by destruct p, q. Qed. Lemma to_Qc_inj_le p q : le p q ↔ (Qp_to_Qc p ≤ Qp_to_Qc q)%Qc. Proof. by destruct p, q. Qed. Lemma to_Qc_inj_lt p q : lt p q ↔ (Qp_to_Qc p < Qp_to_Qc q)%Qc. Proof. by destruct p, q. Qed. Global Instance le_dec : RelDecision le. Proof. refine (λ p q, cast_if (decide (Qp_to_Qc p ≤ Qp_to_Qc q)%Qc)); by rewrite to_Qc_inj_le. Qed. Global Instance lt_dec : RelDecision lt. Proof. refine (λ p q, cast_if (decide (Qp_to_Qc p < Qp_to_Qc q)%Qc)); by rewrite to_Qc_inj_lt. Qed. Global Instance lt_pi p q : ProofIrrel (lt p q). Proof. destruct p, q; apply _. Qed. Definition max (q p : Qp) : Qp := if decide (le q p) then p else q. Definition min (q p : Qp) : Qp := if decide (le q p) then q else p. Module Import notations. Infix "+" := add : Qp_scope. Infix "-" := sub : Qp_scope. Infix "*" := mul : Qp_scope. Notation "/ q" := (inv q) : Qp_scope. Infix "/" := div : Qp_scope. Notation "1" := (pos_to_Qp 1) : Qp_scope. Notation "2" := (pos_to_Qp 2) : Qp_scope. Notation "3" := (pos_to_Qp 3) : Qp_scope. Notation "4" := (pos_to_Qp 4) : Qp_scope. Infix "≤" := le : Qp_scope. Infix "<" := lt : Qp_scope. Notation "p ≤ q ≤ r" := (p ≤ q ∧ q ≤ r) : Qp_scope. Notation "p ≤ q < r" := (p ≤ q ∧ q < r) : Qp_scope. Notation "p < q < r" := (p < q ∧ q < r) : Qp_scope. Notation "p < q ≤ r" := (p < q ∧ q ≤ r) : Qp_scope. Notation "p ≤ q ≤ r ≤ r'" := (p ≤ q ∧ q ≤ r ∧ r ≤ r') : Qp_scope. Notation "(≤)" := le (only parsing) : Qp_scope. Notation "(<)" := lt (only parsing) : Qp_scope. Infix "`max`" := max : Qp_scope. Infix "`min`" := min : Qp_scope. End notations. Global Hint Extern 0 (_ ≤ _)%Qp => reflexivity : core. Global Instance inhabited : Inhabited Qp := populate 1. Global Instance add_assoc : Assoc (=) add. Proof. intros [p ?] [q ?] [r ?]; apply to_Qc_inj_iff, Qcplus_assoc. Qed. Global Instance add_comm : Comm (=) add. Proof. intros [p ?] [q ?]; apply to_Qc_inj_iff, Qcplus_comm. Qed. Global Instance add_inj_r p : Inj (=) (=) (add p). Proof. destruct p as [p ?]. intros [q1 ?] [q2 ?]. rewrite <-!to_Qc_inj_iff; simpl. apply (inj (Qcplus p)). Qed. Global Instance add_inj_l p : Inj (=) (=) (λ q, q + p). Proof. destruct p as [p ?]. intros [q1 ?] [q2 ?]. rewrite <-!to_Qc_inj_iff; simpl. apply (inj (λ q, q + p)%Qc). Qed. Global Instance mul_assoc : Assoc (=) mul. Proof. intros [p ?] [q ?] [r ?]. apply Qp.to_Qc_inj_iff, Qcmult_assoc. Qed. Global Instance mul_comm : Comm (=) mul. Proof. intros [p ?] [q ?]; apply Qp.to_Qc_inj_iff, Qcmult_comm. Qed. Global Instance mul_inj_r p : Inj (=) (=) (mul p). Proof. destruct p as [p ?]. intros [q1 ?] [q2 ?]. rewrite <-!Qp.to_Qc_inj_iff; simpl. intros Hpq. apply (anti_symm Qcle); apply (Qcmult_le_mono_pos_l _ _ p); by rewrite ?Hpq. Qed. Global Instance mul_inj_l p : Inj (=) (=) (λ q, q * p). Proof. intros q1 q2 Hpq. apply (inj (mul p)). by rewrite !(comm_L mul p). Qed. Lemma mul_add_distr_l p q r : p * (q + r) = p * q + p * r. Proof. destruct p, q, r; by apply Qp.to_Qc_inj_iff, Qcmult_plus_distr_r. Qed. Lemma mul_add_distr_r p q r : (p + q) * r = p * r + q * r. Proof. destruct p, q, r; by apply Qp.to_Qc_inj_iff, Qcmult_plus_distr_l. Qed. Lemma mul_1_l p : 1 * p = p. Proof. destruct p; apply Qp.to_Qc_inj_iff, Qcmult_1_l. Qed. Lemma mul_1_r p : p * 1 = p. Proof. destruct p; apply Qp.to_Qc_inj_iff, Qcmult_1_r. Qed. Global Instance mul_left_id : LeftId (=) 1 mul := mul_1_l. Global Instance mul_right_id : RightId (=) 1 mul := mul_1_r. Lemma add_1_1 : 1 + 1 = 2. Proof. compute_done. Qed. Lemma add_diag p : p + p = 2 * p. Proof. by rewrite <-add_1_1, mul_add_distr_r, !mul_1_l. Qed. Lemma mul_inv_l p : /p * p = 1. Proof. destruct p as [p ?]; apply Qp.to_Qc_inj_iff; simpl. by rewrite Qcmult_inv_l, Z2Qc_inj_1 by (by apply not_symmetry, Qclt_not_eq). Qed. Lemma mul_inv_r p : p * /p = 1. Proof. by rewrite (comm_L mul), mul_inv_l. Qed. Lemma inv_mul_distr p q : /(p * q) = /p * /q. Proof. apply (inj (mul (p * q))). rewrite mul_inv_r, (comm_L mul p), <-(assoc_L _), (assoc_L mul p). by rewrite mul_inv_r, mul_1_l, mul_inv_r. Qed. Lemma inv_involutive p : / /p = p. Proof. rewrite <-(mul_1_l (/ /p)), <-(mul_inv_r p), <-(assoc_L _). by rewrite mul_inv_r, mul_1_r. Qed. Global Instance inv_inj : Inj (=) (=) inv. Proof. intros p1 p2 Hp. apply (inj (mul (/p1))). by rewrite mul_inv_l, Hp, mul_inv_l. Qed. Lemma inv_1 : /1 = 1. Proof. compute_done. Qed. Lemma inv_half_half : /2 + /2 = 1. Proof. compute_done. Qed. Lemma inv_quarter_quarter : /4 + /4 = /2. Proof. compute_done. Qed. Lemma div_diag p : p / p = 1. Proof. apply mul_inv_r. Qed. Lemma mul_div_l p q : (p / q) * q = p. Proof. unfold div. by rewrite <-(assoc_L _), mul_inv_l, mul_1_r. Qed. Lemma mul_div_r p q : q * (p / q) = p. Proof. by rewrite (comm_L mul q), mul_div_l. Qed. Lemma div_add_distr p q r : (p + q) / r = p / r + q / r. Proof. apply mul_add_distr_r. Qed. Lemma div_div p q r : (p / q) / r = p / (q * r). Proof. unfold div. by rewrite inv_mul_distr, (assoc_L _). Qed. Lemma div_mul_cancel_l p q r : (r * p) / (r * q) = p / q. Proof. rewrite <-div_div. f_equiv. unfold div. by rewrite (comm_L mul r), <-(assoc_L _), mul_inv_r, mul_1_r. Qed. Lemma div_mul_cancel_r p q r : (p * r) / (q * r) = p / q. Proof. by rewrite <-!(comm_L mul r), div_mul_cancel_l. Qed. Lemma div_1 p : p / 1 = p. Proof. by rewrite <-(mul_1_r (p / 1)), mul_div_l. Qed. Lemma div_2 p : p / 2 + p / 2 = p. Proof. rewrite <-div_add_distr, add_diag. rewrite <-(mul_1_r 2) at 2. by rewrite div_mul_cancel_l, div_1. Qed. Lemma div_2_mul p q : p / (2 * q) + p / (2 * q) = p / q. Proof. by rewrite <-div_add_distr, add_diag, div_mul_cancel_l. Qed. Global Instance div_right_id : RightId (=) 1 div := div_1. Lemma half_half : 1 / 2 + 1 / 2 = 1. Proof. compute_done. Qed. Lemma quarter_quarter : 1 / 4 + 1 / 4 = 1 / 2. Proof. compute_done. Qed. Lemma quarter_three_quarter : 1 / 4 + 3 / 4 = 1. Proof. compute_done. Qed. Lemma three_quarter_quarter : 3 / 4 + 1 / 4 = 1. Proof. compute_done. Qed. Global Instance div_inj_r p : Inj (=) (=) (div p). Proof. unfold div; apply _. Qed. Global Instance div_inj_l p : Inj (=) (=) (λ q, q / p)%Qp. Proof. unfold div; apply _. Qed. Global Instance le_po : PartialOrder (≤). Proof. split; [split|]. - intros p. by apply to_Qc_inj_le. - intros p q r. rewrite !to_Qc_inj_le. by etrans. - intros p q. rewrite !to_Qc_inj_le, <-to_Qc_inj_iff. apply Qcle_antisym. Qed. Global Instance lt_strict : StrictOrder (<). Proof. split. - intros p ?%to_Qc_inj_lt. by apply (irreflexivity (<)%Qc (Qp_to_Qc p)). - intros p q r. rewrite !to_Qc_inj_lt. by etrans. Qed. Global Instance le_total: Total (≤). Proof. intros p q. rewrite !to_Qc_inj_le. apply (total Qcle). Qed. Lemma lt_le_incl p q : p < q → p ≤ q. Proof. rewrite to_Qc_inj_lt, to_Qc_inj_le. apply Qclt_le_weak. Qed. Lemma le_lteq p q : p ≤ q ↔ p < q ∨ p = q. Proof. rewrite to_Qc_inj_lt, to_Qc_inj_le, <-Qp.to_Qc_inj_iff. split. - intros [?| ->]%Qcle_lt_or_eq; auto. - intros [?| ->]; auto using Qclt_le_weak. Qed. Lemma lt_ge_cases p q : {p < q} + {q ≤ p}. Proof. refine (cast_if (Qclt_le_dec (Qp_to_Qc p) (Qp_to_Qc q)%Qc)); [by apply to_Qc_inj_lt|by apply to_Qc_inj_le]. Defined. Lemma le_lt_trans p q r : p ≤ q → q < r → p < r. Proof. rewrite !to_Qc_inj_lt, to_Qc_inj_le. apply Qcle_lt_trans. Qed. Lemma lt_le_trans p q r : p < q → q ≤ r → p < r. Proof. rewrite !to_Qc_inj_lt, to_Qc_inj_le. apply Qclt_le_trans. Qed. Lemma le_ngt p q : p ≤ q ↔ ¬q < p. Proof. rewrite !to_Qc_inj_lt, to_Qc_inj_le. split; auto using Qcle_not_lt, Qcnot_lt_le. Qed. Lemma lt_nge p q : p < q ↔ ¬q ≤ p. Proof. rewrite !to_Qc_inj_lt, to_Qc_inj_le. split; auto using Qclt_not_le, Qcnot_le_lt. Qed. Lemma add_le_mono_l p q r : p ≤ q ↔ r + p ≤ r + q. Proof. rewrite !to_Qc_inj_le. destruct p, q, r; apply Qcplus_le_mono_l. Qed. Lemma add_le_mono_r p q r : p ≤ q ↔ p + r ≤ q + r. Proof. rewrite !(comm_L add _ r). apply add_le_mono_l. Qed. Lemma add_le_mono q p n m : q ≤ n → p ≤ m → q + p ≤ n + m. Proof. intros. etrans; [by apply add_le_mono_l|by apply add_le_mono_r]. Qed. Lemma add_lt_mono_l p q r : p < q ↔ r + p < r + q. Proof. by rewrite !lt_nge, <-add_le_mono_l. Qed. Lemma add_lt_mono_r p q r : p < q ↔ p + r < q + r. Proof. by rewrite !lt_nge, <-add_le_mono_r. Qed. Lemma add_lt_mono q p n m : q < n → p < m → q + p < n + m. Proof. intros. etrans; [by apply add_lt_mono_l|by apply add_lt_mono_r]. Qed. Lemma mul_le_mono_l p q r : p ≤ q ↔ r * p ≤ r * q. Proof. rewrite !to_Qc_inj_le. destruct p, q, r; by apply Qcmult_le_mono_pos_l. Qed. Lemma mul_le_mono_r p q r : p ≤ q ↔ p * r ≤ q * r. Proof. rewrite !(comm_L mul _ r). apply mul_le_mono_l. Qed. Lemma mul_le_mono q p n m : q ≤ n → p ≤ m → q * p ≤ n * m. Proof. intros. etrans; [by apply mul_le_mono_l|by apply mul_le_mono_r]. Qed. Lemma mul_lt_mono_l p q r : p < q ↔ r * p < r * q. Proof. rewrite !to_Qc_inj_lt. destruct p, q, r; by apply Qcmult_lt_mono_pos_l. Qed. Lemma mul_lt_mono_r p q r : p < q ↔ p * r < q * r. Proof. rewrite !(comm_L mul _ r). apply mul_lt_mono_l. Qed. Lemma mul_lt_mono q p n m : q < n → p < m → q * p < n * m. Proof. intros. etrans; [by apply mul_lt_mono_l|by apply mul_lt_mono_r]. Qed. Lemma lt_add_l p q : p < p + q. Proof. destruct p as [p ?], q as [q ?]. apply to_Qc_inj_lt; simpl. rewrite <- (Qcplus_0_r p) at 1. by rewrite <-Qcplus_lt_mono_l. Qed. Lemma lt_add_r p q : q < p + q. Proof. rewrite (comm_L add). apply lt_add_l. Qed. Lemma not_add_le_l p q : ¬(p + q ≤ p). Proof. apply lt_nge, lt_add_l. Qed. Lemma not_add_le_r p q : ¬(p + q ≤ q). Proof. apply lt_nge, lt_add_r. Qed. Lemma add_id_free q p : q + p ≠ q. Proof. intro Heq. apply (not_add_le_l q p). by rewrite Heq. Qed. Lemma le_add_l p q : p ≤ p + q. Proof. apply lt_le_incl, lt_add_l. Qed. Lemma le_add_r p q : q ≤ p + q. Proof. apply lt_le_incl, lt_add_r. Qed. Lemma sub_Some p q r : p - q = Some r ↔ p = q + r. Proof. destruct p as [p Hp], q as [q Hq], r as [r Hr]. unfold sub, add; simpl; rewrite <-Qp.to_Qc_inj_iff; simpl. split. - intros; simplify_option_eq. unfold Qcminus. by rewrite (Qcplus_comm p), Qcplus_assoc, Qcplus_opp_r, Qcplus_0_l. - intros ->. unfold Qcminus. rewrite <-Qcplus_assoc, (Qcplus_comm r), Qcplus_assoc. rewrite Qcplus_opp_r, Qcplus_0_l. simplify_option_eq; [|done]. f_equal. by apply Qp.to_Qc_inj_iff. Qed. Lemma lt_sum p q : p < q ↔ ∃ r, q = p + r. Proof. destruct p as [p Hp], q as [q Hq]. rewrite to_Qc_inj_lt; simpl. split. - intros Hlt%Qclt_minus_iff. exists (mk_Qp (q - p) Hlt). apply Qp.to_Qc_inj_iff; simpl. unfold Qcminus. by rewrite (Qcplus_comm q), Qcplus_assoc, Qcplus_opp_r, Qcplus_0_l. - intros [[r ?] ?%Qp.to_Qc_inj_iff]; simplify_eq/=. rewrite <-(Qcplus_0_r p) at 1. by apply Qcplus_lt_mono_l. Qed. Lemma sub_None p q : p - q = None ↔ p ≤ q. Proof. rewrite le_ngt, lt_sum, eq_None_not_Some. by setoid_rewrite <-sub_Some. Qed. Lemma sub_diag p : p - p = None. Proof. by apply sub_None. Qed. Lemma add_sub p q : (p + q) - q = Some p. Proof. apply sub_Some. by rewrite (comm_L add). Qed. Lemma inv_lt_mono p q : p < q ↔ /q < /p. Proof. revert p q. cut (∀ p q, p < q → / q < / p). { intros help p q. split; [apply help|]. intros. rewrite <-(inv_involutive p), <-(inv_involutive q). by apply help. } intros p q Hpq. apply (mul_lt_mono_l _ _ q). rewrite mul_inv_r. apply (mul_lt_mono_r _ _ p). rewrite <-(assoc_L _), mul_inv_l. by rewrite mul_1_l, mul_1_r. Qed. Lemma inv_le_mono p q : p ≤ q ↔ /q ≤ /p. Proof. by rewrite !le_ngt, inv_lt_mono. Qed. Lemma div_le_mono_l p q r : q ≤ p ↔ r / p ≤ r / q. Proof. unfold div. by rewrite <-mul_le_mono_l, inv_le_mono. Qed. Lemma div_le_mono_r p q r : p ≤ q ↔ p / r ≤ q / r. Proof. apply mul_le_mono_r. Qed. Lemma div_lt_mono_l p q r : q < p ↔ r / p < r / q. Proof. unfold div. by rewrite <-mul_lt_mono_l, inv_lt_mono. Qed. Lemma div_lt_mono_r p q r : p < q ↔ p / r < q / r. Proof. apply mul_lt_mono_r. Qed. Lemma div_lt p q : 1 < q → p / q < p. Proof. by rewrite (div_lt_mono_l _ _ p), div_1. Qed. Lemma div_le p q : 1 ≤ q → p / q ≤ p. Proof. by rewrite (div_le_mono_l _ _ p), div_1. Qed. Lemma lower_bound q1 q2 : ∃ q q1' q2', q1 = q + q1' ∧ q2 = q + q2'. Proof. revert q1 q2. cut (∀ q1 q2 : Qp, q1 ≤ q2 → ∃ q q1' q2', q1 = q + q1' ∧ q2 = q + q2'). { intros help q1 q2. destruct (lt_ge_cases q2 q1) as [Hlt|Hle]; eauto. destruct (help q2 q1) as (q&q1'&q2'&?&?); eauto using lt_le_incl. } intros q1 q2 Hq. exists (q1 / 2)%Qp, (q1 / 2)%Qp. assert (q1 / 2 < q2) as [q2' ->]%lt_sum. { eapply lt_le_trans, Hq. by apply div_lt. } eexists; split; [|done]. by rewrite div_2. Qed. Lemma lower_bound_lt q1 q2 : ∃ q : Qp, q < q1 ∧ q < q2. Proof. destruct (lower_bound q1 q2) as (qmin & q1' & q2' & [-> ->]). exists qmin. split; eapply lt_sum; eauto. Qed. Lemma cross_split a b c d : a + b = c + d → ∃ ac ad bc bd, ac + ad = a ∧ bc + bd = b ∧ ac + bc = c ∧ ad + bd = d. Proof. intros H. revert a b c d H. cut (∀ a b c d : Qp, a < c → a + b = c + d → ∃ ac ad bc bd, ac + ad = a ∧ bc + bd = b ∧ ac + bc = c ∧ ad + bd = d)%Qp. { intros help a b c d Habcd. destruct (lt_ge_cases a c) as [?|[?| ->]%le_lteq]. - auto. - destruct (help c d a b); [done..|]. naive_solver. - apply (inj (add a)) in Habcd as ->. destruct (lower_bound a d) as (q&a'&d'&->&->). exists a', q, q, d'. repeat split; done || by rewrite (comm_L add). } intros a b c d [e ->]%lt_sum. rewrite <-(assoc_L _). intros ->%(inj (add a)). destruct (lower_bound a d) as (q&a'&d'&->&->). eexists a', q, (q + e)%Qp, d'; split_and?; [by rewrite (comm_L add)|..|done]. - by rewrite (assoc_L _), (comm_L add e). - by rewrite (assoc_L _), (comm_L add a'). Qed. Lemma bounded_split p r : ∃ q1 q2 : Qp, q1 ≤ r ∧ p = q1 + q2. Proof. destruct (lt_ge_cases r p) as [[q ->]%lt_sum|?]. { by exists r, q. } exists (p / 2)%Qp, (p / 2)%Qp; split. + trans p; [|done]. by apply div_le. + by rewrite div_2. Qed. Lemma max_spec q p : (q < p ∧ q `max` p = p) ∨ (p ≤ q ∧ q `max` p = q). Proof. unfold max. destruct (decide (q ≤ p)) as [[?| ->]%le_lteq|?]; [by auto..|]. right. split; [|done]. by apply lt_le_incl, lt_nge. Qed. Lemma max_spec_le q p : (q ≤ p ∧ q `max` p = p) ∨ (p ≤ q ∧ q `max` p = q). Proof. destruct (max_spec q p) as [[?%lt_le_incl?]|]; [left|right]; done. Qed. Global Instance max_assoc : Assoc (=) max. Proof. intros q p o. unfold max. destruct (decide (q ≤ p)), (decide (p ≤ o)); try by rewrite ?decide_True by (by etrans). rewrite decide_False by done. by rewrite decide_False by (apply lt_nge; etrans; by apply lt_nge). Qed. Global Instance max_comm : Comm (=) max. Proof. intros q p. destruct (max_spec_le q p) as [[?->]|[?->]], (max_spec_le p q) as [[?->]|[?->]]; done || by apply (anti_symm (≤)). Qed. Lemma max_id q : q `max` q = q. Proof. by destruct (max_spec q q) as [[_->]|[_->]]. Qed. Lemma le_max_l q p : q ≤ q `max` p. Proof. unfold max. by destruct (decide (q ≤ p)). Qed. Lemma le_max_r q p : p ≤ q `max` p. Proof. rewrite (comm_L max q). apply le_max_l. Qed. Lemma max_add q p : q `max` p ≤ q + p. Proof. unfold max. destruct (decide (q ≤ p)); [apply le_add_r|apply le_add_l]. Qed. Lemma max_lub_l q p o : q `max` p ≤ o → q ≤ o. Proof. unfold max. destruct (decide (q ≤ p)); [by etrans|done]. Qed. Lemma max_lub_r q p o : q `max` p ≤ o → p ≤ o. Proof. rewrite (comm _ q). apply max_lub_l. Qed. Lemma min_spec q p : (q < p ∧ q `min` p = q) ∨ (p ≤ q ∧ q `min` p = p). Proof. unfold min. destruct (decide (q ≤ p)) as [[?| ->]%le_lteq|?]; [by auto..|]. right. split; [|done]. by apply lt_le_incl, lt_nge. Qed. Lemma min_spec_le q p : (q ≤ p ∧ q `min` p = q) ∨ (p ≤ q ∧ q `min` p = p). Proof. destruct (min_spec q p) as [[?%lt_le_incl ?]|]; [left|right]; done. Qed. Global Instance min_assoc : Assoc (=) min. Proof. intros q p o. unfold min. destruct (decide (q ≤ p)), (decide (p ≤ o)); eauto using decide_False. - by rewrite !decide_True by (by etrans). - by rewrite decide_False by (apply lt_nge; etrans; by apply lt_nge). Qed. Global Instance min_comm : Comm (=) min. Proof. intros q p. destruct (min_spec_le q p) as [[?->]|[?->]], (min_spec_le p q) as [[? ->]|[? ->]]; done || by apply (anti_symm (≤)). Qed. Lemma min_id q : q `min` q = q. Proof. by destruct (min_spec q q) as [[_->]|[_->]]. Qed. Lemma le_min_r q p : q `min` p ≤ p. Proof. by destruct (min_spec_le q p) as [[?->]|[?->]]. Qed. Lemma le_min_l p q : p `min` q ≤ p. Proof. rewrite (comm_L min p). apply le_min_r. Qed. Lemma min_l_iff q p : q `min` p = q ↔ q ≤ p. Proof. destruct (min_spec_le q p) as [[?->]|[?->]]; [done|]. split; [by intros ->|]. intros. by apply (anti_symm (≤)). Qed. Lemma min_r_iff q p : q `min` p = p ↔ p ≤ q. Proof. rewrite (comm_L min q). apply min_l_iff. Qed. End Qp. Export Qp.notations. Lemma pos_to_Qp_1 : pos_to_Qp 1 = 1. Proof. compute_done. Qed. Lemma pos_to_Qp_inj n m : pos_to_Qp n = pos_to_Qp m → n = m. Proof. by injection 1. Qed. Lemma pos_to_Qp_inj_iff n m : pos_to_Qp n = pos_to_Qp m ↔ n = m. Proof. split; [apply pos_to_Qp_inj|by intros ->]. Qed. Lemma pos_to_Qp_inj_le n m : (n ≤ m)%positive ↔ pos_to_Qp n ≤ pos_to_Qp m. Proof. rewrite Qp.to_Qc_inj_le; simpl. by rewrite <-Z2Qc_inj_le. Qed. Lemma pos_to_Qp_inj_lt n m : (n < m)%positive ↔ pos_to_Qp n < pos_to_Qp m. Proof. by rewrite Pos.lt_nle, Qp.lt_nge, <-pos_to_Qp_inj_le. Qed. Lemma pos_to_Qp_add x y : pos_to_Qp x + pos_to_Qp y = pos_to_Qp (x + y). Proof. apply Qp.to_Qc_inj_iff; simpl. by rewrite Pos2Z.inj_add, Z2Qc_inj_add. Qed. Lemma pos_to_Qp_mul x y : pos_to_Qp x * pos_to_Qp y = pos_to_Qp (x * y). Proof. apply Qp.to_Qc_inj_iff; simpl. by rewrite Pos2Z.inj_mul, Z2Qc_inj_mul. Qed. Local Close Scope Qp_scope. (** * Helper for working with accessing lists with wrap-around See also [rotate] and [rotate_take] in [list.v] *) (** [rotate_nat_add base offset len] computes [(base + offset) `mod` len]. This is useful in combination with the [rotate] function on lists, since the index [i] of [rotate n l] corresponds to the index [rotate_nat_add n i (length i)] of the original list. The definition uses [Z] for consistency with [rotate_nat_sub]. **) Definition rotate_nat_add (base offset len : nat) : nat := Z.to_nat ((Z.of_nat base + Z.of_nat offset) `mod` Z.of_nat len)%Z. (** [rotate_nat_sub base offset len] is the inverse of [rotate_nat_add base offset len]. The definition needs to use modulo on [Z] instead of on nat since otherwise we need the sidecondition [base < len] on [rotate_nat_sub_add]. **) Definition rotate_nat_sub (base offset len : nat) : nat := Z.to_nat ((Z.of_nat len + Z.of_nat offset - Z.of_nat base) `mod` Z.of_nat len)%Z. Lemma rotate_nat_add_add_mod base offset len: rotate_nat_add base offset len = rotate_nat_add (base `mod` len) offset len. Proof. unfold rotate_nat_add. by rewrite Nat2Z.inj_mod, Zplus_mod_idemp_l. Qed. Lemma rotate_nat_add_alt base offset len: base < len → offset < len → rotate_nat_add base offset len = if decide (base + offset < len) then base + offset else base + offset - len. Proof. unfold rotate_nat_add. intros ??. case_decide. - rewrite Z.mod_small by lia. by rewrite <-Nat2Z.inj_add, Nat2Z.id. - rewrite (Z.mod_in_range 1) by lia. by rewrite Z.mul_1_l, <-Nat2Z.inj_add, <-Nat2Z.inj_sub,Nat2Z.id by lia. Qed. Lemma rotate_nat_sub_alt base offset len: base < len → offset < len → rotate_nat_sub base offset len = if decide (offset < base) then len + offset - base else offset - base. Proof. unfold rotate_nat_sub. intros ??. case_decide. - rewrite Z.mod_small by lia. by rewrite <-Nat2Z.inj_add, <-Nat2Z.inj_sub, Nat2Z.id by lia. - rewrite (Z.mod_in_range 1) by lia. rewrite Z.mul_1_l, <-Nat2Z.inj_add, <-!Nat2Z.inj_sub,Nat2Z.id; lia. Qed. Lemma rotate_nat_add_0 base len : base < len → rotate_nat_add base 0 len = base. Proof. intros ?. unfold rotate_nat_add. rewrite Z.mod_small by lia. by rewrite Z.add_0_r, Nat2Z.id. Qed. Lemma rotate_nat_sub_0 base len : base < len → rotate_nat_sub base base len = 0. Proof. intros ?. rewrite rotate_nat_sub_alt by done. case_decide; lia. Qed. Lemma rotate_nat_add_lt base offset len : 0 < len → rotate_nat_add base offset len < len. Proof. unfold rotate_nat_add. intros ?. pose proof (Nat.mod_upper_bound (base + offset) len). rewrite Z2Nat.inj_mod, Z2Nat.inj_add, !Nat2Z.id; lia. Qed. Lemma rotate_nat_sub_lt base offset len : 0 < len → rotate_nat_sub base offset len < len. Proof. unfold rotate_nat_sub. intros ?. pose proof (Z_mod_lt (Z.of_nat len + Z.of_nat offset - Z.of_nat base) (Z.of_nat len)). apply Nat2Z.inj_lt. rewrite Z2Nat.id; lia. Qed. Lemma rotate_nat_add_sub base len offset: offset < len → rotate_nat_add base (rotate_nat_sub base offset len) len = offset. Proof. intros ?. unfold rotate_nat_add, rotate_nat_sub. rewrite Z2Nat.id by (apply Z.mod_pos; lia). rewrite Zplus_mod_idemp_r. replace (Z.of_nat base + (Z.of_nat len + Z.of_nat offset - Z.of_nat base))%Z with (Z.of_nat len + Z.of_nat offset)%Z by lia. rewrite (Z.mod_in_range 1) by lia. rewrite Z.mul_1_l, <-Nat2Z.inj_add, <-!Nat2Z.inj_sub,Nat2Z.id; lia. Qed. Lemma rotate_nat_sub_add base len offset: offset < len → rotate_nat_sub base (rotate_nat_add base offset len) len = offset. Proof. intros ?. unfold rotate_nat_add, rotate_nat_sub. rewrite Z2Nat.id by (apply Z.mod_pos; lia). assert (∀ n, (Z.of_nat len + n - Z.of_nat base) = ((Z.of_nat len - Z.of_nat base) + n))%Z as -> by naive_solver lia. rewrite Zplus_mod_idemp_r. replace (Z.of_nat len - Z.of_nat base + (Z.of_nat base + Z.of_nat offset))%Z with (Z.of_nat len + Z.of_nat offset)%Z by lia. rewrite (Z.mod_in_range 1) by lia. rewrite Z.mul_1_l, <-Nat2Z.inj_add, <-!Nat2Z.inj_sub,Nat2Z.id; lia. Qed. Lemma rotate_nat_add_add base offset len n: 0 < len → rotate_nat_add base (offset + n) len = (rotate_nat_add base offset len + n) `mod` len. Proof. intros ?. unfold rotate_nat_add. rewrite !Z2Nat.inj_mod, !Z2Nat.inj_add, !Nat2Z.id by lia. by rewrite Nat.add_assoc, Nat.add_mod_idemp_l by lia. Qed. Lemma rotate_nat_add_S base offset len: 0 < len → rotate_nat_add base (S offset) len = S (rotate_nat_add base offset len) `mod` len. Proof. intros ?. by rewrite <-Nat.add_1_r, rotate_nat_add_add, Nat.add_1_r. Qed. stdpp-coq-stdpp-1.9.0/stdpp/option.v000066400000000000000000000570661451153341500174340ustar00rootroot00000000000000(** This file collects general purpose definitions and theorems on the option data type that are not in the Coq standard library. *) From stdpp Require Export tactics. From stdpp Require Import options. Inductive option_reflect {A} (P : A → Prop) (Q : Prop) : option A → Type := | ReflectSome x : P x → option_reflect P Q (Some x) | ReflectNone : Q → option_reflect P Q None. (** * General definitions and theorems *) (** Basic properties about equality. *) Lemma None_ne_Some {A} (x : A) : None ≠ Some x. Proof. congruence. Qed. Lemma Some_ne_None {A} (x : A) : Some x ≠ None. Proof. congruence. Qed. Lemma eq_None_ne_Some {A} (mx : option A) : (∀ x, mx ≠ Some x) ↔ mx = None. Proof. destruct mx; split; congruence. Qed. Lemma eq_None_ne_Some_1 {A} (mx : option A) x : mx = None → mx ≠ Some x. Proof. intros ?. by apply eq_None_ne_Some. Qed. Lemma eq_None_ne_Some_2 {A} (mx : option A) : (∀ x, mx ≠ Some x) → mx = None. Proof. intros ?. by apply eq_None_ne_Some. Qed. Global Instance Some_inj {A} : Inj (=) (=) (@Some A). Proof. congruence. Qed. (** The [from_option] is the eliminator for option. *) Definition from_option {A B} (f : A → B) (y : B) (mx : option A) : B := match mx with None => y | Some x => f x end. Global Instance: Params (@from_option) 2 := {}. Global Arguments from_option {_ _} _ _ !_ / : assert. (** The eliminator with the identity function. *) Notation default := (from_option id). (** An alternative, but equivalent, definition of equality on the option data type. This theorem is useful to prove that two options are the same. *) Lemma option_eq {A} (mx my: option A): mx = my ↔ ∀ x, mx = Some x ↔ my = Some x. Proof. split; [by intros; by subst |]. destruct mx, my; naive_solver. Qed. Lemma option_eq_1 {A} (mx my: option A) x : mx = my → mx = Some x → my = Some x. Proof. congruence. Qed. Lemma option_eq_1_alt {A} (mx my : option A) x : mx = my → my = Some x → mx = Some x. Proof. congruence. Qed. Definition is_Some {A} (mx : option A) := ∃ x, mx = Some x. Global Instance: Params (@is_Some) 1 := {}. (** We avoid calling [done] recursively as that can lead to an unresolved evar. *) Global Hint Extern 0 (is_Some _) => eexists; fast_done : core. Lemma is_Some_alt {A} (mx : option A) : is_Some mx ↔ match mx with Some _ => True | None => False end. Proof. unfold is_Some. destruct mx; naive_solver. Qed. Lemma mk_is_Some {A} (mx : option A) x : mx = Some x → is_Some mx. Proof. by intros ->. Qed. Global Hint Resolve mk_is_Some : core. Lemma is_Some_None {A} : ¬is_Some (@None A). Proof. by destruct 1. Qed. Global Hint Resolve is_Some_None : core. Lemma eq_None_not_Some {A} (mx : option A) : mx = None ↔ ¬is_Some mx. Proof. rewrite is_Some_alt; destruct mx; naive_solver. Qed. Lemma not_eq_None_Some {A} (mx : option A) : mx ≠ None ↔ is_Some mx. Proof. rewrite is_Some_alt; destruct mx; naive_solver. Qed. Global Instance is_Some_pi {A} (mx : option A) : ProofIrrel (is_Some mx). Proof. set (P (mx : option A) := match mx with Some _ => True | _ => False end). set (f mx := match mx return P mx → is_Some mx with Some _ => λ _, ex_intro _ _ eq_refl | None => False_rect _ end). set (g mx (H : is_Some mx) := match H return P mx with ex_intro _ _ p => eq_rect _ _ I _ (eq_sym p) end). assert (∀ mx H, f mx (g mx H) = H) as f_g by (by intros ? [??]; subst). intros p1 p2. rewrite <-(f_g _ p1), <-(f_g _ p2). by destruct mx, p1. Qed. Global Instance is_Some_dec {A} (mx : option A) : Decision (is_Some mx) := match mx with | Some x => left (ex_intro _ x eq_refl) | None => right is_Some_None end. Definition is_Some_proj {A} {mx : option A} : is_Some mx → A := match mx with Some x => λ _, x | None => False_rect _ ∘ is_Some_None end. Definition Some_dec {A} (mx : option A) : { x | mx = Some x } + { mx = None } := match mx return { x | mx = Some x } + { mx = None } with | Some x => inleft (x ↾ eq_refl _) | None => inright eq_refl end. (** Lifting a relation point-wise to option *) Inductive option_Forall2 {A B} (R: A → B → Prop) : option A → option B → Prop := | Some_Forall2 x y : R x y → option_Forall2 R (Some x) (Some y) | None_Forall2 : option_Forall2 R None None. Definition option_relation {A B} (R: A → B → Prop) (P: A → Prop) (Q: B → Prop) (mx : option A) (my : option B) : Prop := match mx, my with | Some x, Some y => R x y | Some x, None => P x | None, Some y => Q y | None, None => True end. Section Forall2. Context {A} (R : relation A). Global Instance option_Forall2_refl : Reflexive R → Reflexive (option_Forall2 R). Proof. intros ? [?|]; by constructor. Qed. Global Instance option_Forall2_sym : Symmetric R → Symmetric (option_Forall2 R). Proof. destruct 2; by constructor. Qed. Global Instance option_Forall2_trans : Transitive R → Transitive (option_Forall2 R). Proof. destruct 2; inversion_clear 1; constructor; etrans; eauto. Qed. Global Instance option_Forall2_equiv : Equivalence R → Equivalence (option_Forall2 R). Proof. destruct 1; split; apply _. Qed. Lemma option_eq_Forall2 (mx my : option A) : mx = my ↔ option_Forall2 eq mx my. Proof. split. - intros ->. destruct my; constructor; done. - intros [|]; naive_solver. Qed. End Forall2. (** Setoids *) Global Instance option_equiv `{Equiv A} : Equiv (option A) := option_Forall2 (≡). Section setoids. Context `{Equiv A}. Implicit Types mx my : option A. Lemma option_equiv_Forall2 mx my : mx ≡ my ↔ option_Forall2 (≡) mx my. Proof. done. Qed. Global Instance option_equivalence : Equivalence (≡@{A}) → Equivalence (≡@{option A}). Proof. apply _. Qed. Global Instance option_leibniz `{!LeibnizEquiv A} : LeibnizEquiv (option A). Proof. intros x y; destruct 1; f_equal; by apply leibniz_equiv. Qed. Global Instance Some_proper : Proper ((≡) ==> (≡@{option A})) Some. Proof. by constructor. Qed. Global Instance Some_equiv_inj : Inj (≡) (≡@{option A}) Some. Proof. by inversion_clear 1. Qed. Lemma None_equiv_eq mx : mx ≡ None ↔ mx = None. Proof. split; [by inversion_clear 1|intros ->; constructor]. Qed. Lemma Some_equiv_eq mx y : mx ≡ Some y ↔ ∃ y', mx = Some y' ∧ y' ≡ y. Proof. split; [inversion 1; naive_solver|naive_solver (by constructor)]. Qed. Global Instance is_Some_proper : Proper ((≡@{option A}) ==> iff) is_Some. Proof. by inversion_clear 1. Qed. Global Instance from_option_proper {B} (R : relation B) : Proper (((≡@{A}) ==> R) ==> R ==> (≡) ==> R) from_option. Proof. destruct 3; simpl; auto. Qed. End setoids. Global Typeclasses Opaque option_equiv. (** Equality on [option] is decidable. *) Global Instance option_eq_None_dec {A} (mx : option A) : Decision (mx = None) := match mx with Some _ => right (Some_ne_None _) | None => left eq_refl end. Global Instance option_None_eq_dec {A} (mx : option A) : Decision (None = mx) := match mx with Some _ => right (None_ne_Some _) | None => left eq_refl end. Global Instance option_eq_dec `{dec : EqDecision A} : EqDecision (option A). Proof. refine (λ mx my, match mx, my with | Some x, Some y => cast_if (decide (x = y)) | None, None => left _ | _, _ => right _ end); clear dec; abstract congruence. Defined. (** * Monadic operations *) Global Instance option_ret: MRet option := @Some. Global Instance option_bind: MBind option := λ A B f mx, match mx with Some x => f x | None => None end. Global Instance option_join: MJoin option := λ A mmx, match mmx with Some mx => mx | None => None end. Global Instance option_fmap: FMap option := @option_map. Global Instance option_guard: MGuard option := λ P dec A f, match dec with left H => f H | _ => None end. Lemma option_fmap_inj {A B} (R1 : A → A → Prop) (R2 : B → B → Prop) (f : A → B) : Inj R1 R2 f → Inj (option_Forall2 R1) (option_Forall2 R2) (fmap f). Proof. intros ? [?|] [?|]; inversion 1; constructor; auto. Qed. Global Instance option_fmap_eq_inj {A B} (f : A → B) : Inj (=) (=) f → Inj (=@{option A}) (=@{option B}) (fmap f). Proof. intros ?%option_fmap_inj ?? ?%option_eq_Forall2%(inj _). by apply option_eq_Forall2. Qed. Global Instance option_fmap_equiv_inj `{Equiv A, Equiv B} (f : A → B) : Inj (≡) (≡) f → Inj (≡@{option A}) (≡@{option B}) (fmap f). Proof. apply option_fmap_inj. Qed. Lemma fmap_is_Some {A B} (f : A → B) mx : is_Some (f <$> mx) ↔ is_Some mx. Proof. unfold is_Some; destruct mx; naive_solver. Qed. Lemma fmap_Some {A B} (f : A → B) mx y : f <$> mx = Some y ↔ ∃ x, mx = Some x ∧ y = f x. Proof. destruct mx; naive_solver. Qed. Lemma fmap_Some_1 {A B} (f : A → B) mx y : f <$> mx = Some y → ∃ x, mx = Some x ∧ y = f x. Proof. apply fmap_Some. Qed. Lemma fmap_Some_2 {A B} (f : A → B) mx x : mx = Some x → f <$> mx = Some (f x). Proof. intros. apply fmap_Some; eauto. Qed. Lemma fmap_Some_equiv {A B} `{Equiv B} `{!Equivalence (≡@{B})} (f : A → B) mx y : f <$> mx ≡ Some y ↔ ∃ x, mx = Some x ∧ y ≡ f x. Proof. destruct mx; simpl; split. - intros ?%(inj Some). eauto. - intros (? & ->%(inj Some) & ?). constructor. done. - intros [=]%symmetry%None_equiv_eq. - intros (? & [=] & ?). Qed. Lemma fmap_Some_equiv_1 {A B} `{Equiv B} `{!Equivalence (≡@{B})} (f : A → B) mx y : f <$> mx ≡ Some y → ∃ x, mx = Some x ∧ y ≡ f x. Proof. by rewrite fmap_Some_equiv. Qed. Lemma fmap_None {A B} (f : A → B) mx : f <$> mx = None ↔ mx = None. Proof. by destruct mx. Qed. Lemma option_fmap_id {A} (mx : option A) : id <$> mx = mx. Proof. by destruct mx. Qed. Lemma option_fmap_compose {A B} (f : A → B) {C} (g : B → C) (mx : option A) : g ∘ f <$> mx = g <$> (f <$> mx). Proof. by destruct mx. Qed. Lemma option_fmap_ext {A B} (f g : A → B) (mx : option A) : (∀ x, f x = g x) → f <$> mx = g <$> mx. Proof. intros; destruct mx; f_equal/=; auto. Qed. Lemma option_fmap_equiv_ext {A} `{Equiv B} (f g : A → B) (mx : option A) : (∀ x, f x ≡ g x) → f <$> mx ≡ g <$> mx. Proof. destruct mx; constructor; auto. Qed. Lemma option_fmap_bind {A B C} (f : A → B) (g : B → option C) mx : (f <$> mx) ≫= g = mx ≫= g ∘ f. Proof. by destruct mx. Qed. Lemma option_bind_assoc {A B C} (f : A → option B) (g : B → option C) (mx : option A) : (mx ≫= f) ≫= g = mx ≫= (mbind g ∘ f). Proof. by destruct mx; simpl. Qed. Lemma option_bind_ext {A B} (f g : A → option B) mx my : (∀ x, f x = g x) → mx = my → mx ≫= f = my ≫= g. Proof. destruct mx, my; naive_solver. Qed. Lemma option_bind_ext_fun {A B} (f g : A → option B) mx : (∀ x, f x = g x) → mx ≫= f = mx ≫= g. Proof. intros. by apply option_bind_ext. Qed. Lemma bind_Some {A B} (f : A → option B) (mx : option A) y : mx ≫= f = Some y ↔ ∃ x, mx = Some x ∧ f x = Some y. Proof. destruct mx; naive_solver. Qed. Lemma bind_Some_equiv {A} `{Equiv B} (f : A → option B) (mx : option A) y : mx ≫= f ≡ Some y ↔ ∃ x, mx = Some x ∧ f x ≡ Some y. Proof. destruct mx; (split; [inversion 1|]); naive_solver. Qed. Lemma bind_None {A B} (f : A → option B) (mx : option A) : mx ≫= f = None ↔ mx = None ∨ ∃ x, mx = Some x ∧ f x = None. Proof. destruct mx; naive_solver. Qed. Lemma bind_with_Some {A} (mx : option A) : mx ≫= Some = mx. Proof. by destruct mx. Qed. Global Instance option_fmap_proper `{Equiv A, Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{option A}) ==> (≡@{option B})) fmap. Proof. destruct 2; constructor; auto. Qed. Global Instance option_bind_proper `{Equiv A, Equiv B} : Proper (((≡) ==> (≡)) ==> (≡@{option A}) ==> (≡@{option B})) mbind. Proof. destruct 2; simpl; try constructor; auto. Qed. Global Instance option_join_proper `{Equiv A} : Proper ((≡) ==> (≡@{option (option A)})) mjoin. Proof. destruct 1 as [?? []|]; simpl; by constructor. Qed. (** ** Inverses of constructors *) (** We can do this in a fancy way using dependent types, but rewrite does not particularly like type level reductions. *) Class Maybe {A B : Type} (c : A → B) := maybe : B → option A. Global Arguments maybe {_ _} _ {_} !_ / : assert. Class Maybe2 {A1 A2 B : Type} (c : A1 → A2 → B) := maybe2 : B → option (A1 * A2). Global Arguments maybe2 {_ _ _} _ {_} !_ / : assert. Class Maybe3 {A1 A2 A3 B : Type} (c : A1 → A2 → A3 → B) := maybe3 : B → option (A1 * A2 * A3). Global Arguments maybe3 {_ _ _ _} _ {_} !_ / : assert. Class Maybe4 {A1 A2 A3 A4 B : Type} (c : A1 → A2 → A3 → A4 → B) := maybe4 : B → option (A1 * A2 * A3 * A4). Global Arguments maybe4 {_ _ _ _ _} _ {_} !_ / : assert. Global Instance maybe_comp `{Maybe B C c1, Maybe A B c2} : Maybe (c1 ∘ c2) := λ x, maybe c1 x ≫= maybe c2. Global Arguments maybe_comp _ _ _ _ _ _ _ !_ / : assert. Global Instance maybe_inl {A B} : Maybe (@inl A B) := λ xy, match xy with inl x => Some x | _ => None end. Global Instance maybe_inr {A B} : Maybe (@inr A B) := λ xy, match xy with inr y => Some y | _ => None end. Global Instance maybe_Some {A} : Maybe (@Some A) := id. Global Arguments maybe_Some _ !_ / : assert. (** * Union, intersection and difference *) Global Instance option_union_with {A} : UnionWith A (option A) := λ f mx my, match mx, my with | Some x, Some y => f x y | Some x, None => Some x | None, Some y => Some y | None, None => None end. Global Instance option_intersection_with {A} : IntersectionWith A (option A) := λ f mx my, match mx, my with Some x, Some y => f x y | _, _ => None end. Global Instance option_difference_with {A} : DifferenceWith A (option A) := λ f mx my, match mx, my with | Some x, Some y => f x y | Some x, None => Some x | None, _ => None end. Global Instance option_union {A} : Union (option A) := union_with (λ x _, Some x). Lemma union_Some {A} (mx my : option A) z : mx ∪ my = Some z ↔ mx = Some z ∨ (mx = None ∧ my = Some z). Proof. destruct mx, my; naive_solver. Qed. Lemma union_Some_l {A} x (my : option A) : Some x ∪ my = Some x. Proof. destruct my; done. Qed. Lemma union_Some_r {A} (mx : option A) y : mx ∪ Some y = Some (default y mx). Proof. destruct mx; done. Qed. Lemma union_None {A} (mx my : option A) : mx ∪ my = None ↔ mx = None ∧ my = None. Proof. destruct mx, my; naive_solver. Qed. Lemma union_is_Some {A} (mx my : option A) : is_Some (mx ∪ my) ↔ is_Some mx ∨ is_Some my. Proof. destruct mx, my; naive_solver. Qed. Global Instance option_union_left_id {A} : LeftId (=@{option A}) None union. Proof. by intros [?|]. Qed. Global Instance option_union_right_id {A} : RightId (=@{option A}) None union. Proof. by intros [?|]. Qed. Global Instance option_intersection {A} : Intersection (option A) := intersection_with (λ x _, Some x). Lemma intersection_Some {A} (mx my : option A) x : mx ∩ my = Some x ↔ mx = Some x ∧ is_Some my. Proof. destruct mx, my; unfold is_Some; naive_solver. Qed. Lemma intersection_is_Some {A} (mx my : option A) : is_Some (mx ∩ my) ↔ is_Some mx ∧ is_Some my. Proof. destruct mx, my; unfold is_Some; naive_solver. Qed. Lemma intersection_Some_r {A} (mx : option A) (y : A) : mx ∩ Some y = mx. Proof. by destruct mx. Qed. Lemma intersection_None {A} (mx my : option A) : mx ∩ my = None ↔ mx = None ∨ my = None. Proof. destruct mx, my; naive_solver. Qed. Lemma intersection_None_l {A} (my : option A) : None ∩ my = None. Proof. destruct my; done. Qed. Lemma intersection_None_r {A} (mx : option A) : mx ∩ None = None. Proof. destruct mx; done. Qed. Global Instance option_intersection_right_absorb {A} : RightAbsorb (=@{option A}) None intersection. Proof. by intros [?|]. Qed. Global Instance option_intersection_left_absorb {A} : LeftAbsorb (=@{option A}) None intersection. Proof. by intros [?|]. Qed. Section union_intersection_difference. Context {A} (f : A → A → option A). Global Instance union_with_left_id : LeftId (=) None (union_with f). Proof. by intros [?|]. Qed. Global Instance union_with_right_id : RightId (=) None (union_with f). Proof. by intros [?|]. Qed. Global Instance union_with_comm : Comm (=) f → Comm (=@{option A}) (union_with f). Proof. by intros ? [?|] [?|]; compute; rewrite 1?(comm f). Qed. (** These are duplicates of the above [LeftId]/[RightId] instances, but easier to find with [SearchAbout]. *) Lemma union_with_None_l my : union_with f None my = my. Proof. destruct my; done. Qed. Lemma union_with_None_r mx : union_with f mx None = mx. Proof. destruct mx; done. Qed. Global Instance intersection_with_left_ab : LeftAbsorb (=) None (intersection_with f). Proof. by intros [?|]. Qed. Global Instance intersection_with_right_ab : RightAbsorb (=) None (intersection_with f). Proof. by intros [?|]. Qed. Global Instance intersection_with_comm : Comm (=) f → Comm (=@{option A}) (intersection_with f). Proof. by intros ? [?|] [?|]; compute; rewrite 1?(comm f). Qed. (** These are duplicates of the above [LeftAbsorb]/[RightAbsorb] instances, but easier to find with [SearchAbout]. *) Lemma intersection_with_None_l my : intersection_with f None my = None. Proof. destruct my; done. Qed. Lemma intersection_with_None_r mx : intersection_with f mx None = None. Proof. destruct mx; done. Qed. Global Instance difference_with_comm : Comm (=) f → Comm (=@{option A}) (intersection_with f). Proof. by intros ? [?|] [?|]; compute; rewrite 1?(comm f). Qed. Global Instance difference_with_right_id : RightId (=) None (difference_with f). Proof. by intros [?|]. Qed. Global Instance union_with_proper `{Equiv A} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{option A}) ==> (≡) ==> (≡)) union_with. Proof. intros ?? Hf; do 2 destruct 1; try constructor; by try apply Hf. Qed. Global Instance intersection_with_proper `{Equiv A} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{option A}) ==> (≡) ==> (≡)) intersection_with. Proof. intros ?? Hf; do 2 destruct 1; try constructor; by try apply Hf. Qed. Global Instance difference_with_proper `{Equiv A} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{option A}) ==> (≡) ==> (≡)) difference_with. Proof. intros ?? Hf; do 2 destruct 1; try constructor; by try apply Hf. Qed. Global Instance union_proper `{Equiv A} : Proper ((≡@{option A}) ==> (≡) ==> (≡)) union. Proof. apply union_with_proper. by constructor. Qed. End union_intersection_difference. (** * Tactics *) Tactic Notation "case_option_guard" "as" ident(Hx) := match goal with | H : context C [@mguard option _ ?P ?dec] |- _ => change (@mguard option _ P dec) with (λ A (f : P → option A), match @decide P dec with left H' => f H' | _ => None end) in *; destruct_decide (@decide P dec) as Hx | |- context C [@mguard option _ ?P ?dec] => change (@mguard option _ P dec) with (λ A (f : P → option A), match @decide P dec with left H' => f H' | _ => None end) in *; destruct_decide (@decide P dec) as Hx end. Tactic Notation "case_option_guard" := let H := fresh in case_option_guard as H. Lemma option_guard_True {A} P `{Decision P} (mx : option A) : P → mguard P (λ _, mx) = mx. Proof. intros. by case_option_guard. Qed. Lemma option_guard_True_pi {A} P `{Decision P, ProofIrrel P} (f : P → option A) (HP : P) : mguard P f = f HP. Proof. intros. case_option_guard; [|done]. f_equal; apply proof_irrel. Qed. Lemma option_guard_False {A} P `{Decision P} (f : P → option A) : ¬P → mguard P f = None. Proof. intros. by case_option_guard. Qed. Lemma option_guard_iff {A} P Q `{Decision P, Decision Q} (mx : option A) : (P ↔ Q) → (guard P; mx) = guard Q; mx. Proof. intros [??]. repeat case_option_guard; intuition. Qed. Lemma option_guard_decide {A} P `{Decision P} (mx : option A) : (guard P; mx) = if decide P then mx else None. Proof. done. Qed. Lemma option_guard_bool_decide {A} P `{Decision P} (mx : option A) : (guard P; mx) = if bool_decide P then mx else None. Proof. by rewrite option_guard_decide, decide_bool_decide. Qed. Tactic Notation "simpl_option" "by" tactic3(tac) := let assert_Some_None A mx H := first [ let x := mk_evar A in assert (mx = Some x) as H by tac | assert (mx = None) as H by tac ] in repeat match goal with | H : context [@mret _ _ ?A] |- _ => change (@mret _ _ A) with (@Some A) in H | |- context [@mret _ _ ?A] => change (@mret _ _ A) with (@Some A) | H : context [mbind (M:=option) (A:=?A) ?f ?mx] |- _ => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx | H : context [fmap (M:=option) (A:=?A) ?f ?mx] |- _ => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx | H : context [from_option (A:=?A) _ _ ?mx] |- _ => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx | H : context [ match ?mx with _ => _ end ] |- _ => match type of mx with | option ?A => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx in H; clear Hx end | |- context [mbind (M:=option) (A:=?A) ?f ?mx] => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx | |- context [fmap (M:=option) (A:=?A) ?f ?mx] => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx | |- context [from_option (A:=?A) _ _ ?mx] => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx | |- context [ match ?mx with _ => _ end ] => match type of mx with | option ?A => let Hx := fresh in assert_Some_None A mx Hx; rewrite Hx; clear Hx end | H : context [decide _] |- _ => rewrite decide_True in H by tac | H : context [decide _] |- _ => rewrite decide_False in H by tac | H : context [mguard _ _] |- _ => rewrite option_guard_False in H by tac | H : context [mguard _ _] |- _ => rewrite option_guard_True in H by tac | _ => rewrite decide_True by tac | _ => rewrite decide_False by tac | _ => rewrite option_guard_True by tac | _ => rewrite option_guard_False by tac | H : context [None ∪ _] |- _ => rewrite (left_id_L None (∪)) in H | H : context [_ ∪ None] |- _ => rewrite (right_id_L None (∪)) in H | |- context [None ∪ _] => rewrite (left_id_L None (∪)) | |- context [_ ∪ None] => rewrite (right_id_L None (∪)) end. Tactic Notation "simplify_option_eq" "by" tactic3(tac) := repeat match goal with | _ => progress simplify_eq/= | _ => progress simpl_option by tac | _ : maybe _ ?x = Some _ |- _ => is_var x; destruct x | _ : maybe2 _ ?x = Some _ |- _ => is_var x; destruct x | _ : maybe3 _ ?x = Some _ |- _ => is_var x; destruct x | _ : maybe4 _ ?x = Some _ |- _ => is_var x; destruct x | H : _ ∪ _ = Some _ |- _ => apply union_Some in H; destruct H | H : mbind (M:=option) ?f ?mx = ?my |- _ => match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end; match my with Some _ => idtac | None => idtac | _ => fail 1 end; let x := fresh in destruct mx as [x|] eqn:?; [change (f x = my) in H|change (None = my) in H] | H : ?my = mbind (M:=option) ?f ?mx |- _ => match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end; match my with Some _ => idtac | None => idtac | _ => fail 1 end; let x := fresh in destruct mx as [x|] eqn:?; [change (my = f x) in H|change (my = None) in H] | H : fmap (M:=option) ?f ?mx = ?my |- _ => match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end; match my with Some _ => idtac | None => idtac | _ => fail 1 end; let x := fresh in destruct mx as [x|] eqn:?; [change (Some (f x) = my) in H|change (None = my) in H] | H : ?my = fmap (M:=option) ?f ?mx |- _ => match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end; match my with Some _ => idtac | None => idtac | _ => fail 1 end; let x := fresh in destruct mx as [x|] eqn:?; [change (my = Some (f x)) in H|change (my = None) in H] | _ => progress case_decide | _ => progress case_option_guard end. Tactic Notation "simplify_option_eq" := simplify_option_eq by eauto. stdpp-coq-stdpp-1.9.0/stdpp/options.v000066400000000000000000000022121451153341500175760ustar00rootroot00000000000000(** Coq configuration for std++ (not meant to leak to clients). If you are a user of std++, note that importing this file means you are implicitly opting-in to every new option we will add here in the future. We are *not* guaranteeing any kind of stability here. Instead our advice is for you to have your own options file; then you can re-export the std++ file there but if we ever add an option you disagree with you can easily overwrite it in one central location. *) (* Everything here should be [Export Set], which means when this file is *imported*, the option will only apply on the import site but not transitively. *) (** Allow async proof-checking of sections. *) #[export] Set Default Proof Using "Type". (* FIXME: cannot enable this yet as some files disable 'Default Proof Using'. #[export] Set Suggest Proof Using. *) (** Enforces that every tactic is executed with a single focused goal, meaning that bullets and curly braces must be used to structure the proof. *) #[export] Set Default Goal Selector "!". (* "Fake" import to whitelist this file for the check that ensures we import this file everywhere. From stdpp Require Import options. *) stdpp-coq-stdpp-1.9.0/stdpp/orders.v000066400000000000000000000072161451153341500174120ustar00rootroot00000000000000(** Properties about arbitrary pre-, partial, and total orders. We do not use the relation [⊆] because we often have multiple orders on the same structure *) From stdpp Require Export tactics. From stdpp Require Import options. Section orders. Context {A} {R : relation A}. Implicit Types X Y : A. Infix "⊆" := R. Notation "X ⊈ Y" := (¬X ⊆ Y). Infix "⊂" := (strict R). Lemma reflexive_eq `{!Reflexive R} X Y : X = Y → X ⊆ Y. Proof. by intros <-. Qed. Lemma anti_symm_iff `{!PartialOrder R} X Y : X = Y ↔ R X Y ∧ R Y X. Proof. split; [by intros ->|]. by intros [??]; apply (anti_symm R). Qed. Lemma strict_spec X Y : X ⊂ Y ↔ X ⊆ Y ∧ Y ⊈ X. Proof. done. Qed. Lemma strict_include X Y : X ⊂ Y → X ⊆ Y. Proof. by intros [? _]. Qed. Lemma strict_ne X Y : X ⊂ Y → X ≠ Y. Proof. by intros [??] <-. Qed. Lemma strict_ne_sym X Y : X ⊂ Y → Y ≠ X. Proof. by intros [??] <-. Qed. Lemma strict_transitive_l `{!Transitive R} X Y Z : X ⊂ Y → Y ⊆ Z → X ⊂ Z. Proof. intros [? HXY] ?. split; [by trans Y|]. contradict HXY. by trans Z. Qed. Lemma strict_transitive_r `{!Transitive R} X Y Z : X ⊆ Y → Y ⊂ Z → X ⊂ Z. Proof. intros ? [? HYZ]. split; [by trans Y|]. contradict HYZ. by trans X. Qed. Global Instance: Irreflexive (strict R). Proof. firstorder. Qed. Global Instance: Transitive R → StrictOrder (strict R). Proof. split; try apply _. eauto using strict_transitive_r, strict_include. Qed. Global Instance preorder_subset_dec_slow `{!RelDecision R} : RelDecision (strict R) | 100. Proof. solve_decision. Defined. Lemma strict_spec_alt `{!AntiSymm (=) R} X Y : X ⊂ Y ↔ X ⊆ Y ∧ X ≠ Y. Proof. split. - intros [? HYX]. split; [ done | by intros <- ]. - intros [? HXY]. split; [ done | by contradict HXY; apply (anti_symm R) ]. Qed. Lemma po_eq_dec `{!PartialOrder R, !RelDecision R} : EqDecision A. Proof. refine (λ X Y, cast_if_and (decide (X ⊆ Y)) (decide (Y ⊆ X))); abstract (rewrite anti_symm_iff; tauto). Defined. Lemma total_not `{!Total R} X Y : X ⊈ Y → Y ⊆ X. Proof. intros. destruct (total R X Y); tauto. Qed. Lemma total_not_strict `{!Total R} X Y : X ⊈ Y → Y ⊂ X. Proof. red; auto using total_not. Qed. Global Instance trichotomy_total `{!Trichotomy (strict R), !Reflexive R} : Total R. Proof. intros X Y. destruct (trichotomy (strict R) X Y) as [[??]|[<-|[??]]]; intuition. Qed. End orders. Section strict_orders. Context {A} {R : relation A}. Implicit Types X Y : A. Infix "⊂" := R. Lemma irreflexive_eq `{!Irreflexive R} X Y : X = Y → ¬X ⊂ Y. Proof. intros ->. apply (irreflexivity R). Qed. Lemma strict_anti_symm `{!StrictOrder R} X Y : X ⊂ Y → Y ⊂ X → False. Proof. intros. apply (irreflexivity R X). by trans Y. Qed. Global Instance trichotomyT_dec `{!TrichotomyT R, !StrictOrder R} : RelDecision R := λ X Y, match trichotomyT R X Y with | inleft (left H) => left H | inleft (right H) => right (irreflexive_eq _ _ H) | inright H => right (strict_anti_symm _ _ H) end. Global Instance trichotomyT_trichotomy `{!TrichotomyT R} : Trichotomy R. Proof. intros X Y. destruct (trichotomyT R X Y) as [[|]|]; tauto. Qed. End strict_orders. Ltac simplify_order := repeat match goal with | _ => progress simplify_eq/= | H : ?R ?x ?x |- _ => by destruct (irreflexivity _ _ H) | H1 : ?R ?x ?y |- _ => match goal with | H2 : R y x |- _ => assert (x = y) by (by apply (anti_symm R)); clear H1 H2 | H2 : R y ?z |- _ => unless (R x z) by done; assert (R x z) by (by trans y) end end. stdpp-coq-stdpp-1.9.0/stdpp/pmap.v000066400000000000000000000401301451153341500170410ustar00rootroot00000000000000(** This files implements an efficient implementation of finite maps whose keys range over Coq's data type of positive binary naturals [positive]. The data structure is based on the "canonical" binary tries representation by Appel and Leroy, https://hal.inria.fr/hal-03372247. It has various good properties: - It guarantees logarithmic-time [lookup] and [partial_alter], and linear-time [merge]. It has a low constant factor for computation in Coq compared to other versions (see the Appel and Leroy paper for benchmarks). - It satisfies extensional equality, i.e., [(∀ i, m1 !! i = m2 !! i) → m1 = m2]. - It can be used in nested recursive definitions, e.g., [Inductive test := Test : Pmap test → test]. This is possible because we do _not_ use a Sigma type to ensure canonical representations (a Sigma type would break Coq's strict positivity check). *) From stdpp Require Export countable fin_maps fin_map_dom. From stdpp Require Import mapset. From stdpp Require Import options. Local Open Scope positive_scope. (** * The trie data structure *) (** To obtain canonical representations, we need to make sure that the "empty" trie is represented uniquely. That is, each node should either have a value, a non-empty left subtrie, or a non-empty right subtrie. The [Pmap_ne] type enumerates all ways of constructing non-empty canonical trie. *) Inductive Pmap_ne (A : Type) := | PNode001 : Pmap_ne A → Pmap_ne A | PNode010 : A → Pmap_ne A | PNode011 : A → Pmap_ne A → Pmap_ne A | PNode100 : Pmap_ne A → Pmap_ne A | PNode101 : Pmap_ne A → Pmap_ne A → Pmap_ne A | PNode110 : Pmap_ne A → A → Pmap_ne A | PNode111 : Pmap_ne A → A → Pmap_ne A → Pmap_ne A. Global Arguments PNode001 {A} _ : assert. Global Arguments PNode010 {A} _ : assert. Global Arguments PNode011 {A} _ _ : assert. Global Arguments PNode100 {A} _ : assert. Global Arguments PNode101 {A} _ _ : assert. Global Arguments PNode110 {A} _ _ : assert. Global Arguments PNode111 {A} _ _ _ : assert. (** Using [Variant] we supress the generation of the induction scheme. We use the induction scheme [Pmap_ind] in terms of the smart constructors to reduce the number of cases, similar to Appel and Leroy. *) Variant Pmap (A : Type) := PEmpty : Pmap A | PNodes : Pmap_ne A → Pmap A. Global Arguments PEmpty {A}. Global Arguments PNodes {A} _. Global Instance Pmap_ne_eq_dec `{EqDecision A} : EqDecision (Pmap_ne A). Proof. solve_decision. Defined. Global Instance Pmap_eq_dec `{EqDecision A} : EqDecision (Pmap A). Proof. solve_decision. Defined. (** The smart constructor [PNode] and eliminator [Pmap_ne_case] are used to reduce the number of cases, similar to Appel and Leroy. *) Local Definition PNode {A} (ml : Pmap A) (mx : option A) (mr : Pmap A) : Pmap A := match ml, mx, mr with | PEmpty, None, PEmpty => PEmpty | PEmpty, None, PNodes r => PNodes (PNode001 r) | PEmpty, Some x, PEmpty => PNodes (PNode010 x) | PEmpty, Some x, PNodes r => PNodes (PNode011 x r) | PNodes l, None, PEmpty => PNodes (PNode100 l) | PNodes l, None, PNodes r => PNodes (PNode101 l r) | PNodes l, Some x, PEmpty => PNodes (PNode110 l x) | PNodes l, Some x, PNodes r => PNodes (PNode111 l x r) end. Local Definition Pmap_ne_case {A B} (t : Pmap_ne A) (f : Pmap A → option A → Pmap A → B) : B := match t with | PNode001 r => f PEmpty None (PNodes r) | PNode010 x => f PEmpty (Some x) PEmpty | PNode011 x r => f PEmpty (Some x) (PNodes r) | PNode100 l => f (PNodes l) None PEmpty | PNode101 l r => f (PNodes l) None (PNodes r) | PNode110 l x => f (PNodes l) (Some x) PEmpty | PNode111 l x r => f (PNodes l) (Some x) (PNodes r) end. (** Operations *) Global Instance Pmap_ne_lookup {A} : Lookup positive A (Pmap_ne A) := fix go i t {struct t} := let _ : Lookup _ _ _ := @go in match t, i with | (PNode010 x | PNode011 x _ | PNode110 _ x | PNode111 _ x _), 1 => Some x | (PNode100 l | PNode110 l _ | PNode101 l _ | PNode111 l _ _), i~0 => l !! i | (PNode001 r | PNode011 _ r | PNode101 _ r | PNode111 _ _ r), i~1 => r !! i | _, _ => None end. Global Instance Pmap_lookup {A} : Lookup positive A (Pmap A) := λ i mt, match mt with PEmpty => None | PNodes t => t !! i end. Local Arguments lookup _ _ _ _ _ !_ / : simpl nomatch, assert. Global Instance Pmap_empty {A} : Empty (Pmap A) := PEmpty. (** Block reduction, even on concrete [Pmap]s. Marking [Pmap_empty] as [simpl never] would not be enough, because of https://github.com/coq/coq/issues/2972 and https://github.com/coq/coq/issues/2986. And marking [Pmap] consumers as [simpl never] does not work either, see: https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/171#note_53216 *) Global Opaque Pmap_empty. Local Fixpoint Pmap_ne_singleton {A} (i : positive) (x : A) : Pmap_ne A := match i with | 1 => PNode010 x | i~0 => PNode100 (Pmap_ne_singleton i x) | i~1 => PNode001 (Pmap_ne_singleton i x) end. Local Definition Pmap_partial_alter_aux {A} (go : positive → Pmap_ne A → Pmap A) (f : option A → option A) (i : positive) (mt : Pmap A) : Pmap A := match mt with | PEmpty => match f None with | None => PEmpty | Some x => PNodes (Pmap_ne_singleton i x) end | PNodes t => go i t end. Local Definition Pmap_ne_partial_alter {A} (f : option A → option A) : positive → Pmap_ne A → Pmap A := fix go i t {struct t} := Pmap_ne_case t $ λ ml mx mr, match i with | 1 => PNode ml (f mx) mr | i~0 => PNode (Pmap_partial_alter_aux go f i ml) mx mr | i~1 => PNode ml mx (Pmap_partial_alter_aux go f i mr) end. Global Instance Pmap_partial_alter {A} : PartialAlter positive A (Pmap A) := λ f, Pmap_partial_alter_aux (Pmap_ne_partial_alter f) f. Local Definition Pmap_ne_fmap {A B} (f : A → B) : Pmap_ne A → Pmap_ne B := fix go t := match t with | PNode001 r => PNode001 (go r) | PNode010 x => PNode010 (f x) | PNode011 x r => PNode011 (f x) (go r) | PNode100 l => PNode100 (go l) | PNode101 l r => PNode101 (go l) (go r) | PNode110 l x => PNode110 (go l) (f x) | PNode111 l x r => PNode111 (go l) (f x) (go r) end. Global Instance Pmap_fmap : FMap Pmap := λ {A B} f mt, match mt with PEmpty => PEmpty | PNodes t => PNodes (Pmap_ne_fmap f t) end. Local Definition Pmap_omap_aux {A B} (go : Pmap_ne A → Pmap B) (tm : Pmap A) : Pmap B := match tm with PEmpty => PEmpty | PNodes t' => go t' end. Local Definition Pmap_ne_omap {A B} (f : A → option B) : Pmap_ne A → Pmap B := fix go t := Pmap_ne_case t $ λ ml mx mr, PNode (Pmap_omap_aux go ml) (mx ≫= f) (Pmap_omap_aux go mr). Global Instance Pmap_omap : OMap Pmap := λ {A B} f, Pmap_omap_aux (Pmap_ne_omap f). Local Definition Pmap_merge_aux {A B C} (go : Pmap_ne A → Pmap_ne B → Pmap C) (f : option A → option B → option C) (mt1 : Pmap A) (mt2 : Pmap B) : Pmap C := match mt1, mt2 with | PEmpty, PEmpty => PEmpty | PNodes t1', PEmpty => Pmap_ne_omap (λ x, f (Some x) None) t1' | PEmpty, PNodes t2' => Pmap_ne_omap (λ x, f None (Some x)) t2' | PNodes t1', PNodes t2' => go t1' t2' end. Local Definition Pmap_ne_merge {A B C} (f : option A → option B → option C) : Pmap_ne A → Pmap_ne B → Pmap C := fix go t1 t2 {struct t1} := Pmap_ne_case t1 $ λ ml1 mx1 mr1, Pmap_ne_case t2 $ λ ml2 mx2 mr2, PNode (Pmap_merge_aux go f ml1 ml2) (diag_None f mx1 mx2) (Pmap_merge_aux go f mr1 mr2). Global Instance Pmap_merge : Merge Pmap := λ {A B C} f, Pmap_merge_aux (Pmap_ne_merge f) f. Local Definition Pmap_fold_aux {A B} (go : positive → B → Pmap_ne A → B) (i : positive) (y : B) (mt : Pmap A) : B := match mt with PEmpty => y | PNodes t => go i y t end. Local Definition Pmap_ne_fold {A B} (f : positive → A → B → B) : positive → B → Pmap_ne A → B := fix go i y t := Pmap_ne_case t $ λ ml mx mr, Pmap_fold_aux go i~1 (Pmap_fold_aux go i~0 match mx with None => y | Some x => f (Pos.reverse i) x y end ml) mr. Global Instance Pmap_fold {A} : MapFold positive A (Pmap A) := λ {B} f, Pmap_fold_aux (Pmap_ne_fold f) 1. (** Proofs *) Local Definition PNode_valid {A} (ml : Pmap A) (mx : option A) (mr : Pmap A) := match ml, mx, mr with PEmpty, None, PEmpty => False | _, _, _ => True end. Local Lemma Pmap_ind {A} (P : Pmap A → Prop) : P PEmpty → (∀ ml mx mr, PNode_valid ml mx mr → P ml → P mr → P (PNode ml mx mr)) → ∀ mt, P mt. Proof. intros Hemp Hnode [|t]; [done|]. induction t. - by apply (Hnode PEmpty None (PNodes _)). - by apply (Hnode PEmpty (Some _) PEmpty). - by apply (Hnode PEmpty (Some _) (PNodes _)). - by apply (Hnode (PNodes _) None PEmpty). - by apply (Hnode (PNodes _) None (PNodes _)). - by apply (Hnode (PNodes _) (Some _) PEmpty). - by apply (Hnode (PNodes _) (Some _) (PNodes _)). Qed. Local Lemma Pmap_lookup_PNode {A} (ml mr : Pmap A) mx i : PNode ml mx mr !! i = match i with 1 => mx | i~0 => ml !! i | i~1 => mr !! i end. Proof. by destruct ml, mx, mr, i. Qed. Local Lemma Pmap_ne_lookup_not_None {A} (t : Pmap_ne A) : ∃ i, t !! i ≠ None. Proof. induction t; repeat select (∃ _, _) (fun H => destruct H); try first [by eexists 1|by eexists _~0|by eexists _~1]. Qed. Local Lemma Pmap_eq_empty {A} (mt : Pmap A) : (∀ i, mt !! i = None) → mt = ∅. Proof. intros Hlookup. destruct mt as [|t]; [done|]. destruct (Pmap_ne_lookup_not_None t); naive_solver. Qed. Local Lemma Pmap_eq {A} (mt1 mt2 : Pmap A) : (∀ i, mt1 !! i = mt2 !! i) → mt1 = mt2. Proof. revert mt2. induction mt1 as [|ml1 mx1 mr1 _ IHl IHr] using Pmap_ind; intros mt2 Hlookup; destruct mt2 as [|ml2 mx2 mr2 _ _ _] using Pmap_ind. - done. - symmetry. apply Pmap_eq_empty. naive_solver. - apply Pmap_eq_empty. naive_solver. - f_equal. + apply IHl. intros i. generalize (Hlookup (i~0)). by rewrite !Pmap_lookup_PNode. + generalize (Hlookup 1). by rewrite !Pmap_lookup_PNode. + apply IHr. intros i. generalize (Hlookup (i~1)). by rewrite !Pmap_lookup_PNode. Qed. Local Lemma Pmap_ne_lookup_singleton {A} i (x : A) : Pmap_ne_singleton i x !! i = Some x. Proof. by induction i. Qed. Local Lemma Pmap_ne_lookup_singleton_ne {A} i j (x : A) : i ≠ j → Pmap_ne_singleton i x !! j = None. Proof. revert j. induction i; intros [?|?|]; naive_solver. Qed. Local Lemma Pmap_partial_alter_PNode {A} (f : option A → option A) i ml mx mr : PNode_valid ml mx mr → partial_alter f i (PNode ml mx mr) = match i with | 1 => PNode ml (f mx) mr | i~0 => PNode (partial_alter f i ml) mx mr | i~1 => PNode ml mx (partial_alter f i mr) end. Proof. by destruct ml, mx, mr. Qed. Local Lemma Pmap_lookup_partial_alter {A} (f : option A → option A) (mt : Pmap A) i : partial_alter f i mt !! i = f (mt !! i). Proof. revert i. induction mt using Pmap_ind. { intros i. unfold partial_alter; simpl. destruct (f None); simpl; [|done]. by rewrite Pmap_ne_lookup_singleton. } intros []; by rewrite Pmap_partial_alter_PNode, !Pmap_lookup_PNode by done. Qed. Local Lemma Pmap_lookup_partial_alter_ne {A} (f : option A → option A) (mt : Pmap A) i j : i ≠ j → partial_alter f i mt !! j = mt !! j. Proof. revert i j; induction mt using Pmap_ind. { intros i j ?; unfold partial_alter; simpl. destruct (f None); simpl; [|done]. by rewrite Pmap_ne_lookup_singleton_ne. } intros [] [] ?; rewrite Pmap_partial_alter_PNode, !Pmap_lookup_PNode by done; auto with lia. Qed. Local Lemma Pmap_lookup_fmap {A B} (f : A → B) (mt : Pmap A) i : (f <$> mt) !! i = f <$> mt !! i. Proof. destruct mt as [|t]; simpl; [done|]. revert i. induction t; intros []; by simpl. Qed. Local Lemma Pmap_omap_PNode {A B} (f : A → option B) ml mx mr : PNode_valid ml mx mr → omap f (PNode ml mx mr) = PNode (omap f ml) (mx ≫= f) (omap f mr). Proof. by destruct ml, mx, mr. Qed. Local Lemma Pmap_lookup_omap {A B} (f : A → option B) (mt : Pmap A) i : omap f mt !! i = mt !! i ≫= f. Proof. revert i. induction mt using Pmap_ind; [done|]. intros []; by rewrite Pmap_omap_PNode, !Pmap_lookup_PNode by done. Qed. Section Pmap_merge. Context {A B C} (f : option A → option B → option C). Local Lemma Pmap_merge_PNode_PEmpty ml mx mr : PNode_valid ml mx mr → merge f (PNode ml mx mr) ∅ = PNode (omap (λ x, f (Some x) None) ml) (diag_None f mx None) (omap (λ x, f (Some x) None) mr). Proof. by destruct ml, mx, mr. Qed. Local Lemma Pmap_merge_PEmpty_PNode ml mx mr : PNode_valid ml mx mr → merge f ∅ (PNode ml mx mr) = PNode (omap (λ x, f None (Some x)) ml) (diag_None f None mx) (omap (λ x, f None (Some x)) mr). Proof. by destruct ml, mx, mr. Qed. Local Lemma Pmap_merge_PNode_PNode ml1 ml2 mx1 mx2 mr1 mr2 : PNode_valid ml1 mx1 mr1 → PNode_valid ml2 mx2 mr2 → merge f (PNode ml1 mx1 mr1) (PNode ml2 mx2 mr2) = PNode (merge f ml1 ml2) (diag_None f mx1 mx2) (merge f mr1 mr2). Proof. by destruct ml1, mx1, mr1, ml2, mx2, mr2. Qed. Local Lemma Pmap_lookup_merge (mt1 : Pmap A) (mt2 : Pmap B) i : merge f mt1 mt2 !! i = diag_None f (mt1 !! i) (mt2 !! i). Proof. revert mt2 i; induction mt1 using Pmap_ind; intros mt2 i. { induction mt2 using Pmap_ind; [done|]. rewrite Pmap_merge_PEmpty_PNode, Pmap_lookup_PNode by done. destruct i; rewrite ?Pmap_lookup_omap, Pmap_lookup_PNode; simpl; by repeat destruct (_ !! _). } destruct mt2 using Pmap_ind. { rewrite Pmap_merge_PNode_PEmpty, Pmap_lookup_PNode by done. destruct i; rewrite ?Pmap_lookup_omap, Pmap_lookup_PNode; simpl; by repeat destruct (_ !! _). } rewrite Pmap_merge_PNode_PNode by done. destruct i; by rewrite ?Pmap_lookup_PNode. Qed. End Pmap_merge. Section Pmap_fold. Context {A B} (f : positive → A → B → B). Local Notation Pmap_fold f := (Pmap_fold_aux (Pmap_ne_fold f)). Local Lemma Pmap_fold_PNode i y ml mx mr : PNode_valid ml mx mr → Pmap_fold f i y (PNode ml mx mr) = Pmap_fold f i~1 (Pmap_fold f i~0 match mx with None => y | Some x => f (Pos.reverse i) x y end ml) mr. Proof. by destruct ml, mx, mr. Qed. Local Lemma Pmap_fold_ind (P : B → Pmap A → Prop) (b : B) j : P b PEmpty → (∀ i x mt r, mt !! i = None → P r mt → P (f (Pos.reverse_go i j) x r) (<[i:=x]> mt)) → ∀ mt, P (Pmap_fold f j b mt) mt. Proof. intros Hemp Hinsert mt. revert P b j Hemp Hinsert. induction mt as [|ml mx mr ? IHl IHr] using Pmap_ind; intros P b j Hemp Hinsert; [done|]. rewrite Pmap_fold_PNode by done. apply (IHr (λ y mt, P y (PNode ml mx mt))). { apply (IHl (λ y mt, P y (PNode mt mx PEmpty))). { destruct mx as [x|]; [|done]. replace (PNode PEmpty (Some x) PEmpty) with (<[1:=x]> PEmpty : Pmap A) by done. by apply Hinsert. } intros i x mt r ??. replace (PNode (<[i:=x]> mt) mx PEmpty) with (<[i~0:=x]> (PNode mt mx PEmpty)) by (by destruct mt, mx). apply Hinsert; by rewrite ?Pmap_lookup_PNode. } intros i x mt r ??. replace (PNode ml mx (<[i:=x]> mt)) with (<[i~1:=x]> (PNode ml mx mt)) by (by destruct ml, mx, mt). apply Hinsert; by rewrite ?Pmap_lookup_PNode. Qed. End Pmap_fold. (** Instance of the finite map type class *) Global Instance Pmap_finmap : FinMap positive Pmap. Proof. split. - intros. by apply Pmap_eq. - done. - intros. apply Pmap_lookup_partial_alter. - intros. by apply Pmap_lookup_partial_alter_ne. - intros. apply Pmap_lookup_fmap. - intros. apply Pmap_lookup_omap. - intros. apply Pmap_lookup_merge. - intros A B P f b Hemp Hinsert. by apply (Pmap_fold_ind f P). Qed. (** Type annotation [list (positive * A)] seems needed in Coq 8.14, not in more recent versions. *) Global Program Instance Pmap_countable `{Countable A} : Countable (Pmap A) := { encode m := encode (map_to_list m : list (positive * A)); decode p := list_to_map <$> decode p }. Next Obligation. intros A ?? m; simpl. rewrite decode_encode; simpl. by rewrite list_to_map_to_list. Qed. (** * Finite sets *) (** We construct sets of [positives]s satisfying extensional equality. *) Notation Pset := (mapset Pmap). Global Instance Pmap_dom {A} : Dom (Pmap A) Pset := mapset_dom. Global Instance Pmap_dom_spec : FinMapDom positive Pmap Pset := mapset_dom_spec. stdpp-coq-stdpp-1.9.0/stdpp/prelude.v000066400000000000000000000002731451153341500175500ustar00rootroot00000000000000From stdpp Require Export base tactics orders option vector numbers relations sets fin_sets listset list list_numbers lexico. From stdpp Require Import options. stdpp-coq-stdpp-1.9.0/stdpp/pretty.v000066400000000000000000000122251451153341500174370ustar00rootroot00000000000000From stdpp Require Export strings. From stdpp Require Import relations numbers. From Coq Require Import Ascii. From stdpp Require Import options. Class Pretty A := pretty : A → string. Global Hint Mode Pretty ! : typeclass_instances. Definition pretty_N_char (x : N) : ascii := match x with | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4" | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9" end%char%N. Lemma pretty_N_char_inj x y : (x < 10)%N → (y < 10)%N → pretty_N_char x = pretty_N_char y → x = y. Proof. compute; intros. by repeat (discriminate || case_match). Qed. Fixpoint pretty_N_go_help (x : N) (acc : Acc (<)%N x) (s : string) : string := match decide (0 < x)%N with | left H => pretty_N_go_help (x `div` 10)%N (Acc_inv acc (N.div_lt x 10 H eq_refl)) (String (pretty_N_char (x `mod` 10)) s) | right _ => s end. (** The argument [S (N.size_nat x)] of [wf_guard] makes sure that computation works if [x] is a closed term, but that it blocks if [x] is an open term. The latter prevents unexpected stack overflows, see [tests/pretty.v]. *) Definition pretty_N_go (x : N) : string → string := pretty_N_go_help x (wf_guard (S (N.size_nat x)) N.lt_wf_0 x). Global Instance pretty_N : Pretty N := λ x, if decide (x = 0)%N then "0" else pretty_N_go x "". Lemma pretty_N_go_0 s : pretty_N_go 0 s = s. Proof. done. Qed. Lemma pretty_N_go_help_irrel x acc1 acc2 s : pretty_N_go_help x acc1 s = pretty_N_go_help x acc2 s. Proof. revert x acc1 acc2 s; fix FIX 2; intros x [acc1] [acc2] s; simpl. destruct (decide (0 < x)%N); auto. Qed. Lemma pretty_N_go_step x s : (0 < x)%N → pretty_N_go x s = pretty_N_go (x `div` 10) (String (pretty_N_char (x `mod` 10)) s). Proof. unfold pretty_N_go; intros; destruct (wf_guard 32 N.lt_wf_0 x). destruct (wf_guard _ _). (* this makes coqchk happy. *) unfold pretty_N_go_help at 1; fold pretty_N_go_help. by destruct (decide (0 < x)%N); auto using pretty_N_go_help_irrel. Qed. (** Helper lemma to prove [pretty_N_inj] and [pretty_Z_inj]. *) Lemma pretty_N_go_ne_0 x s : s ≠ "0" → pretty_N_go x s ≠ "0". Proof. revert s. induction (N.lt_wf_0 x) as [x _ IH]; intros s ?. assert (x = 0 ∨ 0 < x < 10 ∨ 10 ≤ x)%N as [->|[[??]|?]] by lia. - by rewrite pretty_N_go_0. - rewrite pretty_N_go_step by done. apply IH. { by apply N.div_lt. } assert (x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4 ∨ x = 5 ∨ x = 6 ∨ x = 7 ∨ x = 8 ∨ x = 9)%N by lia; naive_solver. - rewrite 2!pretty_N_go_step by (try apply N.div_str_pos_iff; lia). apply IH; [|done]. trans (x `div` 10)%N; apply N.div_lt; auto using N.div_str_pos with lia. Qed. (** Helper lemma to prove [pretty_Z_inj]. *) Lemma pretty_N_go_ne_dash x s s' : s ≠ "-" +:+ s' → pretty_N_go x s ≠ "-" +:+ s'. Proof. revert s. induction (N.lt_wf_0 x) as [x _ IH]; intros s ?. assert (x = 0 ∨ 0 < x)%N as [->|?] by lia. - by rewrite pretty_N_go_0. - rewrite pretty_N_go_step by done. apply IH. { by apply N.div_lt. } unfold pretty_N_char. by repeat case_match. Qed. Global Instance pretty_N_inj : Inj (=@{N}) (=) pretty. Proof. cut (∀ x y s s', pretty_N_go x s = pretty_N_go y s' → String.length s = String.length s' → x = y ∧ s = s'). { intros help x y. unfold pretty, pretty_N. intros. repeat case_decide; simplify_eq/=; [done|..]. - by destruct (pretty_N_go_ne_0 y ""). - by destruct (pretty_N_go_ne_0 x ""). - by apply (help x y "" ""). } assert (∀ x s, ¬String.length (pretty_N_go x s) < String.length s) as help. { setoid_rewrite <-Nat.le_ngt. intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros s. assert (x = 0 ∨ 0 < x)%N as [->|?] by lia; [by rewrite pretty_N_go_0|]. rewrite pretty_N_go_step by done. etrans; [|by eapply IH, N.div_lt]; simpl; lia. } intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros y s s'. assert ((x = 0 ∨ 0 < x) ∧ (y = 0 ∨ 0 < y))%N as [[->|?] [->|?]] by lia; rewrite ?pretty_N_go_0, ?pretty_N_go_step, ?(pretty_N_go_step y) by done. { done. } { intros -> Hlen. edestruct help; rewrite Hlen; simpl; lia. } { intros <- Hlen. edestruct help; rewrite <-Hlen; simpl; lia. } intros Hs Hlen. apply IH in Hs as [? [= Hchar]]; [|auto using N.div_lt_upper_bound with lia|simpl; lia]. split; [|done]. apply pretty_N_char_inj in Hchar; [|by auto using N.mod_lt..]. rewrite (N.div_mod x 10), (N.div_mod y 10) by done. lia. Qed. Global Instance pretty_nat : Pretty nat := λ x, pretty (N.of_nat x). Global Instance pretty_nat_inj : Inj (=@{nat}) (=) pretty. Proof. apply _. Qed. Global Instance pretty_positive : Pretty positive := λ x, pretty (Npos x). Global Instance pretty_positive_inj : Inj (=@{positive}) (=) pretty. Proof. apply _. Qed. Global Instance pretty_Z : Pretty Z := λ x, match x with | Z0 => "0" | Zpos x => pretty x | Zneg x => "-" +:+ pretty x end%string. Global Instance pretty_Z_inj : Inj (=@{Z}) (=) pretty. Proof. unfold pretty, pretty_Z. intros [|x|x] [|y|y] Hpretty; simplify_eq/=; try done. - by destruct (pretty_N_go_ne_0 (N.pos y) ""). - by destruct (pretty_N_go_ne_0 (N.pos x) ""). - by edestruct (pretty_N_go_ne_dash (N.pos x) ""). - by edestruct (pretty_N_go_ne_dash (N.pos y) ""). Qed. stdpp-coq-stdpp-1.9.0/stdpp/proof_irrel.v000066400000000000000000000035341451153341500204350ustar00rootroot00000000000000(** This file collects facts on proof irrelevant types/propositions. *) From stdpp Require Export base. From stdpp Require Import options. Global Hint Extern 200 (ProofIrrel _) => progress (lazy beta) : typeclass_instances. Global Instance True_pi: ProofIrrel True. Proof. intros [] []; reflexivity. Qed. Global Instance False_pi: ProofIrrel False. Proof. intros []. Qed. Global Instance unit_pi: ProofIrrel (). Proof. intros [] []; reflexivity. Qed. Global Instance and_pi (A B : Prop) : ProofIrrel A → ProofIrrel B → ProofIrrel (A ∧ B). Proof. intros ?? [??] [??]. f_equal; trivial. Qed. Global Instance prod_pi (A B : Type) : ProofIrrel A → ProofIrrel B → ProofIrrel (A * B). Proof. intros ?? [??] [??]. f_equal; trivial. Qed. Global Instance eq_pi {A} (x : A) `{∀ z, Decision (x = z)} (y : A) : ProofIrrel (x = y). Proof. set (f z (H : x = z) := match decide (x = z) return x = z with | left H => H | right H' => False_rect _ (H' H) end). assert (∀ z (H : x = z), eq_trans (eq_sym (f x (eq_refl x))) (f z H) = H) as help. { intros ? []. destruct (f x eq_refl); tauto. } intros p q. rewrite <-(help _ p), <-(help _ q). unfold f at 2 4. destruct (decide _); [reflexivity|]. exfalso; tauto. Qed. Global Instance Is_true_pi (b : bool) : ProofIrrel (Is_true b). Proof. destruct b; simpl; apply _. Qed. Lemma sig_eq_pi `(P : A → Prop) `{∀ x, ProofIrrel (P x)} (x y : sig P) : x = y ↔ `x = `y. Proof. split; [intros <-; reflexivity|]. destruct x as [x Hx], y as [y Hy]; simpl; intros; subst. f_equal. apply proof_irrel. Qed. Global Instance proj1_sig_inj `(P : A → Prop) `{∀ x, ProofIrrel (P x)} : Inj (=) (=) (proj1_sig (P:=P)). Proof. intros ??. apply (sig_eq_pi P). Qed. Lemma exists_proj1_pi `(P : A → Prop) `{∀ x, ProofIrrel (P x)} (x : sig P) p : `x ↾ p = x. Proof. apply (sig_eq_pi _); reflexivity. Qed. stdpp-coq-stdpp-1.9.0/stdpp/propset.v000066400000000000000000000047371451153341500176150ustar00rootroot00000000000000(** This file implements sets as functions into Prop. *) From stdpp Require Export sets. From stdpp Require Import options. Record propset (A : Type) : Type := PropSet { propset_car : A → Prop }. Add Printing Constructor propset. Global Arguments PropSet {_} _ : assert. Global Arguments propset_car {_} _ _ : assert. Notation "{[ x | P ]}" := (PropSet (λ x, P)) (at level 1, format "{[ x | P ]}") : stdpp_scope. Global Instance propset_elem_of {A} : ElemOf A (propset A) := λ x X, propset_car X x. Global Instance propset_top {A} : Top (propset A) := {[ _ | True ]}. Global Instance propset_empty {A} : Empty (propset A) := {[ _ | False ]}. Global Instance propset_singleton {A} : Singleton A (propset A) := λ y, {[ x | y = x ]}. Global Instance propset_union {A} : Union (propset A) := λ X1 X2, {[ x | x ∈ X1 ∨ x ∈ X2 ]}. Global Instance propset_intersection {A} : Intersection (propset A) := λ X1 X2, {[ x | x ∈ X1 ∧ x ∈ X2 ]}. Global Instance propset_difference {A} : Difference (propset A) := λ X1 X2, {[ x | x ∈ X1 ∧ x ∉ X2 ]}. Global Instance propset_top_set {A} : TopSet A (propset A). Proof. split; [split; [split| |]|]; by repeat intro. Qed. Lemma elem_of_PropSet {A} (P : A → Prop) x : x ∈ {[ x | P x ]} ↔ P x. Proof. done. Qed. Lemma not_elem_of_PropSet {A} (P : A → Prop) x : x ∉ {[ x | P x ]} ↔ ¬P x. Proof. done. Qed. Definition set_to_propset `{ElemOf A C} (X : C) : propset A := {[ x | x ∈ X ]}. Lemma elem_of_set_to_propset `{SemiSet A C} x (X : C) : x ∈ set_to_propset X ↔ x ∈ X. Proof. done. Qed. Global Instance propset_ret : MRet propset := λ A (x : A), {[ x ]}. Global Instance propset_bind : MBind propset := λ A B (f : A → propset B) (X : propset A), PropSet (λ b, ∃ a, b ∈ f a ∧ a ∈ X). Global Instance propset_fmap : FMap propset := λ A B (f : A → B) (X : propset A), {[ b | ∃ a, b = f a ∧ a ∈ X ]}. Global Instance propset_join : MJoin propset := λ A (XX : propset (propset A)), {[ a | ∃ X : propset A, a ∈ X ∧ X ∈ XX ]}. Global Instance propset_monad_set : MonadSet propset. Proof. by split; try apply _. Qed. Global Instance set_unfold_PropSet {A} (P : A → Prop) x Q : SetUnfoldSimpl (P x) Q → SetUnfoldElemOf x (PropSet P) Q. Proof. intros HPQ. constructor. apply HPQ. Qed. Global Opaque propset_elem_of propset_top propset_empty propset_singleton. Global Opaque propset_union propset_intersection propset_difference. Global Opaque propset_ret propset_bind propset_fmap propset_join. stdpp-coq-stdpp-1.9.0/stdpp/relations.v000066400000000000000000000477351451153341500201260ustar00rootroot00000000000000(** This file collects definitions and theorems on abstract rewriting systems. These are particularly useful as we define the operational semantics as a small step semantics. *) From stdpp Require Export sets well_founded. From stdpp Require Import options. (** * Definitions *) Section definitions. Context `(R : relation A). (** An element is reducible if a step is possible. *) Definition red (x : A) := ∃ y, R x y. (** An element is in normal form if no further steps are possible. *) Definition nf (x : A) := ¬red x. (** The symmetric closure. *) Definition sc : relation A := λ x y, R x y ∨ R y x. (** The reflexive transitive closure. *) Inductive rtc : relation A := | rtc_refl x : rtc x x | rtc_l x y z : R x y → rtc y z → rtc x z. (** The reflexive transitive closure for setoids. *) Inductive rtcS `{Equiv A} : relation A := | rtcS_refl x y : x ≡ y → rtcS x y | rtcS_l x y z : R x y → rtcS y z → rtcS x z. (** Reductions of exactly [n] steps. *) Inductive nsteps : nat → relation A := | nsteps_O x : nsteps 0 x x | nsteps_l n x y z : R x y → nsteps n y z → nsteps (S n) x z. (** Reductions of at most [n] steps. *) Inductive bsteps : nat → relation A := | bsteps_refl n x : bsteps n x x | bsteps_l n x y z : R x y → bsteps n y z → bsteps (S n) x z. (** The transitive closure. *) Inductive tc : relation A := | tc_once x y : R x y → tc x y | tc_l x y z : R x y → tc y z → tc x z. (** An element [x] is universally looping if all paths starting at [x] are infinite. *) CoInductive all_loop : A → Prop := | all_loop_do_step x : red x → (∀ y, R x y → all_loop y) → all_loop x. (** An element [x] is existentally looping if some path starting at [x] is infinite. *) CoInductive ex_loop : A → Prop := | ex_loop_do_step x y : R x y → ex_loop y → ex_loop x. End definitions. (** The reflexive transitive symmetric closure. *) Definition rtsc {A} (R : relation A) := rtc (sc R). (** Weakly and strongly normalizing elements. *) Definition wn {A} (R : relation A) (x : A) := ∃ y, rtc R x y ∧ nf R y. Notation sn R := (Acc (flip R)). (** The various kinds of "confluence" properties. Any relation that has the diamond property is confluent, and any confluent relation is locally confluent. The naming convention are taken from "Term Rewriting and All That" by Baader and Nipkow. *) Definition diamond {A} (R : relation A) := ∀ x y1 y2, R x y1 → R x y2 → ∃ z, R y1 z ∧ R y2 z. Definition confluent {A} (R : relation A) := diamond (rtc R). Definition locally_confluent {A} (R : relation A) := ∀ x y1 y2, R x y1 → R x y2 → ∃ z, rtc R y1 z ∧ rtc R y2 z. Global Hint Unfold nf red : core. (** * General theorems *) Section general. Context `{R : relation A}. Local Hint Constructors rtc nsteps bsteps tc : core. (** ** Results about the reflexive-transitive closure [rtc] *) Lemma rtc_transitive x y z : rtc R x y → rtc R y z → rtc R x z. Proof. induction 1; eauto. Qed. (* We give this instance a lower-than-usual priority because [setoid_rewrite] queries for [@Reflexive Prop ?r] in the hope of [iff_reflexive] getting picked as the instance. [rtc_reflexive] overlaps with that, leading to backtracking. We cannot set [Hint Mode] because that query must not fail, but we can at least avoid picking [rtc_reflexive]. See Coq bug https://github.com/coq/coq/issues/7916 and the test [tests.typeclasses.test_setoid_rewrite]. *) Global Instance rtc_po : PreOrder (rtc R) | 10. Proof. split; [exact (@rtc_refl A R) | exact rtc_transitive]. Qed. (* Not an instance, related to the issue described above, this sometimes makes [setoid_rewrite] queries loop. *) Lemma rtc_equivalence : Symmetric R → Equivalence (rtc R). Proof. split; try apply _. intros x y. induction 1 as [|x1 x2 x3]; [done|trans x2; eauto]. Qed. Lemma rtc_once x y : R x y → rtc R x y. Proof. eauto. Qed. Lemma rtc_r x y z : rtc R x y → R y z → rtc R x z. Proof. intros. etrans; eauto. Qed. Lemma rtc_inv x z : rtc R x z → x = z ∨ ∃ y, R x y ∧ rtc R y z. Proof. inversion_clear 1; eauto. Qed. Lemma rtc_ind_l (P : A → Prop) (z : A) (Prefl : P z) (Pstep : ∀ x y, R x y → rtc R y z → P y → P x) : ∀ x, rtc R x z → P x. Proof. induction 1; eauto. Qed. Lemma rtc_ind_r_weak (P : A → A → Prop) (Prefl : ∀ x, P x x) (Pstep : ∀ x y z, rtc R x y → R y z → P x y → P x z) : ∀ x z, rtc R x z → P x z. Proof. cut (∀ y z, rtc R y z → ∀ x, rtc R x y → P x y → P x z). { eauto using rtc_refl. } induction 1; eauto using rtc_r. Qed. Lemma rtc_ind_r (P : A → Prop) (x : A) (Prefl : P x) (Pstep : ∀ y z, rtc R x y → R y z → P y → P z) : ∀ z, rtc R x z → P z. Proof. intros z p. revert x z p Prefl Pstep. refine (rtc_ind_r_weak _ _ _); eauto. Qed. Lemma rtc_inv_r x z : rtc R x z → x = z ∨ ∃ y, rtc R x y ∧ R y z. Proof. revert z. apply rtc_ind_r; eauto. Qed. Lemma rtc_nf x y : rtc R x y → nf R x → x = y. Proof. destruct 1 as [x|x y1 y2]; [done|]. intros []; eauto. Qed. Lemma rtc_congruence {B} (f : A → B) (R' : relation B) x y : (∀ x y, R x y → R' (f x) (f y)) → rtc R x y → rtc R' (f x) (f y). Proof. induction 2; econstructor; eauto. Qed. (** ** Results about [nsteps] *) Lemma nsteps_once x y : R x y → nsteps R 1 x y. Proof. eauto. Qed. Lemma nsteps_once_inv x y : nsteps R 1 x y → R x y. Proof. inversion 1 as [|???? Hhead Htail]; inversion Htail; by subst. Qed. Lemma nsteps_trans n m x y z : nsteps R n x y → nsteps R m y z → nsteps R (n + m) x z. Proof. induction 1; simpl; eauto. Qed. Lemma nsteps_r n x y z : nsteps R n x y → R y z → nsteps R (S n) x z. Proof. induction 1; eauto. Qed. Lemma nsteps_add_inv n m x z : nsteps R (n + m) x z → ∃ y, nsteps R n x y ∧ nsteps R m y z. Proof. revert x. induction n as [|n IH]; intros x Hx; simpl; [by eauto|]. inversion Hx; naive_solver. Qed. Lemma nsteps_inv_r n x z : nsteps R (S n) x z → ∃ y, nsteps R n x y ∧ R y z. Proof. rewrite <- PeanoNat.Nat.add_1_r. intros (?&?&?%nsteps_once_inv)%nsteps_add_inv; eauto. Qed. Lemma nsteps_congruence {B} (f : A → B) (R' : relation B) n x y : (∀ x y, R x y → R' (f x) (f y)) → nsteps R n x y → nsteps R' n (f x) (f y). Proof. induction 2; econstructor; eauto. Qed. (** ** Results about [bsteps] *) Lemma bsteps_once n x y : R x y → bsteps R (S n) x y. Proof. eauto. Qed. Lemma bsteps_add_r n m x y : bsteps R n x y → bsteps R (n + m) x y. Proof. induction 1; simpl; eauto. Qed. Lemma bsteps_weaken n m x y : n ≤ m → bsteps R n x y → bsteps R m x y. Proof. intros. rewrite (Nat.le_add_sub n m); auto using bsteps_add_r. Qed. Lemma bsteps_add_l n m x y : bsteps R n x y → bsteps R (m + n) x y. Proof. apply bsteps_weaken. auto with arith. Qed. Lemma bsteps_S n x y : bsteps R n x y → bsteps R (S n) x y. Proof. apply bsteps_weaken. lia. Qed. Lemma bsteps_trans n m x y z : bsteps R n x y → bsteps R m y z → bsteps R (n + m) x z. Proof. induction 1; simpl; eauto using bsteps_add_l. Qed. Lemma bsteps_r n x y z : bsteps R n x y → R y z → bsteps R (S n) x z. Proof. induction 1; eauto. Qed. Lemma bsteps_ind_r (P : nat → A → Prop) (x : A) (Prefl : ∀ n, P n x) (Pstep : ∀ n y z, bsteps R n x y → R y z → P n y → P (S n) z) : ∀ n z, bsteps R n x z → P n z. Proof. cut (∀ m y z, bsteps R m y z → ∀ n, bsteps R n x y → (∀ m', n ≤ m' ∧ m' ≤ n + m → P m' y) → P (n + m) z). { intros help n. change n with (0 + n). eauto. } induction 1 as [|m x' y z p2 p3 IH]; [by eauto with arith|]. intros n p1 H. rewrite <-plus_n_Sm. apply (IH (S n)); [by eauto using bsteps_r |]. intros [|m'] [??]; [lia |]. apply Pstep with x'. - apply bsteps_weaken with n; intuition lia. - done. - apply H; intuition lia. Qed. Lemma bsteps_congruence {B} (f : A → B) (R' : relation B) n x y : (∀ x y, R x y → R' (f x) (f y)) → bsteps R n x y → bsteps R' n (f x) (f y). Proof. induction 2; econstructor; eauto. Qed. (** ** Results about the transitive closure [tc] *) Lemma tc_transitive x y z : tc R x y → tc R y z → tc R x z. Proof. induction 1; eauto. Qed. Global Instance tc_transitive' : Transitive (tc R). Proof. exact tc_transitive. Qed. Lemma tc_r x y z : tc R x y → R y z → tc R x z. Proof. intros. etrans; eauto. Qed. Lemma tc_rtc_l x y z : rtc R x y → tc R y z → tc R x z. Proof. induction 1; eauto. Qed. Lemma tc_rtc_r x y z : tc R x y → rtc R y z → tc R x z. Proof. intros Hxy Hyz. revert x Hxy. induction Hyz; eauto using tc_r. Qed. Lemma tc_rtc x y : tc R x y → rtc R x y. Proof. induction 1; eauto. Qed. Lemma red_tc x : red (tc R) x ↔ red R x. Proof. split. - intros [y []]; eexists; eauto. - intros [y HR]. exists y. by apply tc_once. Qed. Lemma tc_congruence {B} (f : A → B) (R' : relation B) x y : (∀ x y, R x y → R' (f x) (f y)) → tc R x y → tc R' (f x) (f y). Proof. induction 2; econstructor; by eauto. Qed. (** ** Results about the symmetric closure [sc] *) Global Instance sc_symmetric : Symmetric (sc R). Proof. unfold Symmetric, sc. naive_solver. Qed. Lemma sc_lr x y : R x y → sc R x y. Proof. by left. Qed. Lemma sc_rl x y : R y x → sc R x y. Proof. by right. Qed. Lemma sc_congruence {B} (f : A → B) (R' : relation B) x y : (∀ x y, R x y → R' (f x) (f y)) → sc R x y → sc R' (f x) (f y). Proof. induction 2; econstructor; by eauto. Qed. (** ** Equivalences between closure operators *) Lemma bsteps_nsteps n x y : bsteps R n x y ↔ ∃ n', n' ≤ n ∧ nsteps R n' x y. Proof. split. - induction 1 as [|n x1 x2 y ?? (n'&?&?)]. + exists 0; naive_solver eauto with lia. + exists (S n'); naive_solver eauto with lia. - intros (n'&Hn'&Hsteps). apply bsteps_weaken with n'; [done|]. clear Hn'. induction Hsteps; eauto. Qed. Lemma tc_nsteps x y : tc R x y ↔ ∃ n, 0 < n ∧ nsteps R n x y. Proof. split. - induction 1 as [|x1 x2 y ?? (n&?&?)]. { exists 1. eauto using nsteps_once with lia. } exists (S n); eauto using nsteps_l. - intros (n & ? & Hstep). induction Hstep as [|n x1 x2 y ? Hstep]; [lia|]. destruct Hstep; eauto with lia. Qed. Lemma rtc_tc x y : rtc R x y ↔ x = y ∨ tc R x y. Proof. split; [|naive_solver eauto using tc_rtc]. induction 1; naive_solver. Qed. Lemma rtc_nsteps x y : rtc R x y ↔ ∃ n, nsteps R n x y. Proof. split. - induction 1; naive_solver. - intros [n Hsteps]. induction Hsteps; naive_solver. Qed. Lemma rtc_nsteps_1 x y : rtc R x y → ∃ n, nsteps R n x y. Proof. rewrite rtc_nsteps. naive_solver. Qed. Lemma rtc_nsteps_2 n x y : nsteps R n x y → rtc R x y. Proof. rewrite rtc_nsteps. naive_solver. Qed. Lemma rtc_bsteps x y : rtc R x y ↔ ∃ n, bsteps R n x y. Proof. rewrite rtc_nsteps. setoid_rewrite bsteps_nsteps. naive_solver. Qed. Lemma rtc_bsteps_1 x y : rtc R x y → ∃ n, bsteps R n x y. Proof. rewrite rtc_bsteps. naive_solver. Qed. Lemma rtc_bsteps_2 n x y : bsteps R n x y → rtc R x y. Proof. rewrite rtc_bsteps. naive_solver. Qed. Lemma nsteps_list n x y : nsteps R n x y ↔ ∃ l, length l = S n ∧ head l = Some x ∧ last l = Some y ∧ ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b. Proof. setoid_rewrite head_lookup. split. - induction 1 as [x|n' x x' y ?? IH]. { exists [x]; naive_solver. } destruct IH as (l & Hlen & Hfirst & Hlast & Hcons). exists (x :: l). simpl. rewrite Hlen, last_cons, Hlast. split_and!; [done..|]. intros [|i]; naive_solver. - intros ([|x' l]&?&Hfirst&Hlast&Hcons); simplify_eq/=. revert x Hlast Hcons. induction l as [|x1 l IH]; intros x2 Hlast Hcons; simplify_eq/=; [constructor|]. econstructor; [by apply (Hcons 0)|]. apply IH; [done|]. intros i. apply (Hcons (S i)). Qed. Lemma bsteps_list n x y : bsteps R n x y ↔ ∃ l, length l ≤ S n ∧ head l = Some x ∧ last l = Some y ∧ ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b. Proof. rewrite bsteps_nsteps. split. - intros (n'&?&(l&?&?&?&?)%nsteps_list). exists l; eauto with lia. - intros (l&?&?&?&?). exists (pred (length l)). split; [lia|]. apply nsteps_list. exists l. split; [|by eauto]. by destruct l. Qed. Lemma rtc_list x y : rtc R x y ↔ ∃ l, head l = Some x ∧ last l = Some y ∧ ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b. Proof. rewrite rtc_bsteps. split. - intros (n'&(l&?&?&?&?)%bsteps_list). exists l; eauto with lia. - intros (l&?&?&?). exists (pred (length l)). apply bsteps_list. exists l. eauto with lia. Qed. Lemma tc_list x y : tc R x y ↔ ∃ l, 1 < length l ∧ head l = Some x ∧ last l = Some y ∧ ∀ i a b, l !! i = Some a → l !! S i = Some b → R a b. Proof. rewrite tc_nsteps. split. - intros (n'&?&(l&?&?&?&?)%nsteps_list). exists l; eauto with lia. - intros (l&?&?&?&?). exists (pred (length l)). split; [lia|]. apply nsteps_list. exists l. eauto with lia. Qed. Lemma ex_loop_inv x : ex_loop R x → ∃ x', R x x' ∧ ex_loop R x'. Proof. inversion 1; eauto. Qed. End general. Section more_general. Context `{R : relation A}. (** ** Results about the reflexive-transitive-symmetric closure [rtsc] *) Global Instance rtsc_equivalence : Equivalence (rtsc R) | 10. Proof. apply rtc_equivalence, _. Qed. Lemma rtsc_lr x y : R x y → rtsc R x y. Proof. unfold rtsc. eauto using sc_lr, rtc_once. Qed. Lemma rtsc_rl x y : R y x → rtsc R x y. Proof. unfold rtsc. eauto using sc_rl, rtc_once. Qed. Lemma rtc_rtsc_rl x y : rtc R x y → rtsc R x y. Proof. induction 1; econstructor; eauto using sc_lr. Qed. Lemma rtc_rtsc_lr x y : rtc R y x → rtsc R x y. Proof. intros. symmetry. eauto using rtc_rtsc_rl. Qed. Lemma rtsc_congruence {B} (f : A → B) (R' : relation B) x y : (∀ x y, R x y → R' (f x) (f y)) → rtsc R x y → rtsc R' (f x) (f y). Proof. unfold rtsc; eauto using rtc_congruence, sc_congruence. Qed. Lemma ex_loop_tc x : ex_loop (tc R) x ↔ ex_loop R x. Proof. split. - revert x; cofix IH. intros x (y & Hstep & Hloop')%ex_loop_inv. destruct Hstep as [x y Hstep|x y z Hstep Hsteps]. + econstructor; eauto. + econstructor; [by eauto|]. eapply IH. econstructor; eauto. - revert x; cofix IH. intros x (y & Hstep & Hloop')%ex_loop_inv. econstructor; eauto using tc_once. Qed. End more_general. Section properties. Context `{R : relation A}. Local Hint Constructors rtc nsteps bsteps tc : core. Lemma nf_wn x : nf R x → wn R x. Proof. intros. exists x; eauto. Qed. Lemma wn_step x y : wn R y → R x y → wn R x. Proof. intros (z & ? & ?) ?. exists z; eauto. Qed. Lemma wn_step_rtc x y : wn R y → rtc R x y → wn R x. Proof. induction 2; eauto using wn_step. Qed. Lemma nf_sn x : nf R x → sn R x. Proof. intros Hnf. constructor; intros y Hxy. destruct Hnf; eauto. Qed. Lemma sn_step x y : sn R x → R x y → sn R y. Proof. induction 1; eauto. Qed. Lemma sn_step_rtc x y : sn R x → rtc R x y → sn R y. Proof. induction 2; eauto using sn_step. Qed. (** An acyclic relation that can only take finitely many steps (sometimes called "globally finite") is strongly normalizing *) Lemma tc_finite_sn x : Irreflexive (tc R) → pred_finite (tc R x) → sn R x. Proof. intros Hirr [xs Hfin]. remember (length xs) as n eqn:Hn. revert x xs Hn Hfin. induction (lt_wf n) as [n _ IH]; intros x xs -> Hfin. constructor; simpl; intros x' Hxx'. assert (x' ∈ xs) as (xs1&xs2&->)%elem_of_list_split by eauto using tc_once. refine (IH (length xs1 + length xs2) _ _ (xs1 ++ xs2) _ _); [rewrite app_length; simpl; lia..|]. intros x'' Hx'x''. opose proof* (Hfin x'') as Hx''; [by econstructor|]. cut (x' ≠ x''); [set_solver|]. intros ->. by apply (Hirr x''). Qed. (** The following theorem requires that [red R] is decidable. The intuition for this requirement is that [wn R] is a very "positive" statement as it points out a particular trace. In contrast, [sn R] just says "this also holds for all successors", there is no "data"/"trace" there. *) Lemma sn_wn `{!∀ y, Decision (red R y)} x : sn R x → wn R x. Proof. induction 1 as [x _ IH]. destruct (decide (red R x)) as [[x' ?]|?]. - destruct (IH x') as (y&?&?); eauto using wn_step. - by apply nf_wn. Qed. Lemma all_loop_red x : all_loop R x → red R x. Proof. destruct 1; auto. Qed. Lemma all_loop_step x y : all_loop R x → R x y → all_loop R y. Proof. destruct 1; auto. Qed. Lemma all_loop_rtc x y : all_loop R x → rtc R x y → all_loop R y. Proof. induction 2; eauto using all_loop_step. Qed. Lemma all_loop_alt x : all_loop R x ↔ ∀ y, rtc R x y → red R y. Proof. split; [eauto using all_loop_red, all_loop_rtc|]. intros H. cut (∀ z, rtc R x z → all_loop R z); [eauto|]. cofix FIX. constructor; eauto using rtc_r. Qed. Lemma wn_not_all_loop x : wn R x → ¬all_loop R x. Proof. intros (z&?&?). rewrite all_loop_alt. eauto. Qed. Lemma sn_not_ex_loop x : sn R x → ¬ex_loop R x. Proof. unfold not. induction 1; destruct 1; eauto. Qed. (** An alternative definition of confluence; also known as the Church-Rosser property. *) Lemma confluent_alt : confluent R ↔ (∀ x y, rtsc R x y → ∃ z, rtc R x z ∧ rtc R y z). Proof. split. - intros Hcr. induction 1 as [x|x y1 y1' [Hy1|Hy1] Hy1' (z&IH1&IH2)]; eauto. destruct (Hcr y1 x z) as (z'&?&?); eauto using rtc_transitive. - intros Hcr x y1 y2 Hy1 Hy2. apply Hcr; trans x; eauto using rtc_rtsc_rl, rtc_rtsc_lr. Qed. Lemma confluent_nf_r x y : confluent R → rtsc R x y → nf R y → rtc R x y. Proof. rewrite confluent_alt. intros Hcr ??. destruct (Hcr x y) as (z&Hx&Hy); auto. by apply rtc_nf in Hy as ->. Qed. Lemma confluent_nf_l x y : confluent R → rtsc R x y → nf R x → rtc R y x. Proof. intros. by apply (confluent_nf_r y x). Qed. Lemma diamond_confluent : diamond R → confluent R. Proof. intros Hdiam. assert (∀ x y1 y2, rtc R x y1 → R x y2 → ∃ z, rtc R y1 z ∧ rtc R y2 z) as Hstrip. { intros x y1 y2 Hy1; revert y2. induction Hy1 as [x|x y1 y1' Hy1 Hy1' IH]; [by eauto|]; intros y2 Hy2. destruct (Hdiam x y1 y2) as (z&Hy1z&Hy2z); auto. destruct (IH z) as (z'&?&?); eauto. } intros x y1 y2 Hy1; revert y2. induction Hy1 as [x|x y1 y1' Hy1 Hy1' IH]; [by eauto|]; intros y2 Hy2. destruct (Hstrip x y2 y1) as (z&?&?); eauto. destruct (IH z) as (z'&?&?); eauto using rtc_transitive. Qed. Lemma confluent_locally_confluent : confluent R → locally_confluent R. Proof. unfold confluent, locally_confluent; eauto. Qed. (** The following is also known as Newman's lemma *) Lemma locally_confluent_confluent : (∀ x, sn R x) → locally_confluent R → confluent R. Proof. intros Hsn Hcr x. induction (Hsn x) as [x _ IH]. intros y1 y2 Hy1 Hy2. destruct Hy1 as [x|x y1 y1' Hy1 Hy1']; [by eauto|]. destruct Hy2 as [x|x y2 y2' Hy2 Hy2']; [by eauto|]. destruct (Hcr x y1 y2) as (z&Hy1z&Hy2z); auto. destruct (IH _ Hy1 y1' z) as (z1&?&?); auto. destruct (IH _ Hy2 y2' z1) as (z2&?&?); eauto using rtc_transitive. Qed. End properties. (** * Theorems on sub relations *) Section subrel. Context {A} (R1 R2 : relation A). Notation subrel := (∀ x y, R1 x y → R2 x y). Lemma red_subrel x : subrel → red R1 x → red R2 x. Proof. intros ? [y ?]; eauto. Qed. Lemma nf_subrel x : subrel → nf R2 x → nf R1 x. Proof. intros ? H1 H2; destruct H1; by apply red_subrel. Qed. Lemma rtc_subrel x y : subrel → rtc R1 x y → rtc R2 x y. Proof. induction 2; [by apply rtc_refl|]. eapply rtc_l; eauto. Qed. End subrel. stdpp-coq-stdpp-1.9.0/stdpp/sets.v000066400000000000000000001622701451153341500170740ustar00rootroot00000000000000(** This file collects definitions and theorems on sets. Most importantly, it implements some tactics to automatically solve goals involving sets. *) From stdpp Require Export orders list list_numbers. From stdpp Require Import finite. From stdpp Require Import options. (* FIXME: This file needs a 'Proof Using' hint, but they need to be set locally (or things moved out of sections) as no default works well enough. *) Unset Default Proof Using. (* Higher precedence to make sure these instances are not used for other types with an [ElemOf] instance, such as lists. *) Global Instance set_equiv_instance `{ElemOf A C} : Equiv C | 20 := λ X Y, ∀ x, x ∈ X ↔ x ∈ Y. Global Instance set_subseteq_instance `{ElemOf A C} : SubsetEq C | 20 := λ X Y, ∀ x, x ∈ X → x ∈ Y. Global Instance set_disjoint_instance `{ElemOf A C} : Disjoint C | 20 := λ X Y, ∀ x, x ∈ X → x ∈ Y → False. Global Typeclasses Opaque set_equiv_instance set_subseteq_instance set_disjoint_instance. (** * Setoids *) Section setoids_simple. Context `{SemiSet A C}. Global Instance set_equiv_equivalence : Equivalence (≡@{C}). Proof. split. - done. - intros X Y ? x. by symmetry. - intros X Y Z ?? x; by trans (x ∈ Y). Qed. Global Instance singleton_proper : Proper ((=) ==> (≡@{C})) singleton. Proof. apply _. Qed. Global Instance elem_of_proper : Proper ((=) ==> (≡) ==> iff) (∈@{C}) | 5. Proof. by intros x ? <- X Y. Qed. Global Instance disjoint_proper: Proper ((≡) ==> (≡) ==> iff) (##@{C}). Proof. intros X1 X2 HX Y1 Y2 HY; apply forall_proper; intros x. by rewrite HX, HY. Qed. Global Instance union_proper : Proper ((≡) ==> (≡) ==> (≡@{C})) union. Proof. intros X1 X2 HX Y1 Y2 HY x. rewrite !elem_of_union. f_equiv; auto. Qed. Global Instance union_list_proper: Proper ((≡) ==> (≡@{C})) union_list. Proof. by induction 1; simpl; try apply union_proper. Qed. Global Instance subseteq_proper : Proper ((≡@{C}) ==> (≡@{C}) ==> iff) (⊆). Proof. intros X1 X2 HX Y1 Y2 HY. apply forall_proper; intros x. by rewrite HX, HY. Qed. Global Instance subset_proper : Proper ((≡@{C}) ==> (≡@{C}) ==> iff) (⊂). Proof. solve_proper. Qed. End setoids_simple. Section setoids. Context `{Set_ A C}. (** * Setoids *) Global Instance intersection_proper : Proper ((≡) ==> (≡) ==> (≡@{C})) intersection. Proof. intros X1 X2 HX Y1 Y2 HY x. by rewrite !elem_of_intersection, HX, HY. Qed. Global Instance difference_proper : Proper ((≡) ==> (≡) ==> (≡@{C})) difference. Proof. intros X1 X2 HX Y1 Y2 HY x. by rewrite !elem_of_difference, HX, HY. Qed. End setoids. Section setoids_monad. Context `{MonadSet M}. Global Instance set_fmap_proper {A B} : Proper (pointwise_relation _ (=) ==> (≡) ==> (≡)) (@fmap M _ A B). Proof. intros f1 f2 Hf X1 X2 HX x. rewrite !elem_of_fmap. f_equiv; intros z. by rewrite HX, Hf. Qed. Global Instance set_bind_proper {A B} : Proper (pointwise_relation _ (≡) ==> (≡) ==> (≡)) (@mbind M _ A B). Proof. intros f1 f2 Hf X1 X2 HX x. rewrite !elem_of_bind. f_equiv; intros z. by rewrite HX, (Hf z). Qed. Global Instance set_join_proper {A} : Proper ((≡) ==> (≡)) (@mjoin M _ A). Proof. intros X1 X2 HX x. rewrite !elem_of_join. f_equiv; intros z. by rewrite HX. Qed. End setoids_monad. (** * Tactics *) (** The tactic [set_unfold] transforms all occurrences of [(∪)], [(∩)], [(∖)], [(<$>)], [∅], [{[_]}], [(≡)], and [(⊆)] into logically equivalent propositions involving just [∈]. For example, [A → x ∈ X ∪ ∅] becomes [A → x ∈ X ∨ False]. This transformation is implemented using type classes instead of setoid rewriting to ensure that we traverse each term at most once and to be able to deal with occurences of the set operations under binders. *) Class SetUnfold (P Q : Prop) := { set_unfold : P ↔ Q }. Global Arguments set_unfold _ _ {_} : assert. Global Hint Mode SetUnfold + - : typeclass_instances. (** The class [SetUnfoldElemOf] is a more specialized version of [SetUnfold] for propositions of the shape [x ∈ X] to improve performance. *) Class SetUnfoldElemOf `{ElemOf A C} (x : A) (X : C) (Q : Prop) := { set_unfold_elem_of : x ∈ X ↔ Q }. Global Arguments set_unfold_elem_of {_ _ _} _ _ _ {_} : assert. Global Hint Mode SetUnfoldElemOf + + + - + - : typeclass_instances. Global Instance set_unfold_elem_of_default `{ElemOf A C} (x : A) (X : C) : SetUnfoldElemOf x X (x ∈ X) | 1000. Proof. done. Qed. Global Instance set_unfold_elem_of_set_unfold `{ElemOf A C} (x : A) (X : C) Q : SetUnfoldElemOf x X Q → SetUnfold (x ∈ X) Q. Proof. by destruct 1; constructor. Qed. Class SetUnfoldSimpl (P Q : Prop) := { set_unfold_simpl : SetUnfold P Q }. Global Hint Extern 0 (SetUnfoldSimpl _ _) => csimpl; constructor : typeclass_instances. Global Instance set_unfold_default P : SetUnfold P P | 1000. done. Qed. Definition set_unfold_1 `{SetUnfold P Q} : P → Q := proj1 (set_unfold P Q). Definition set_unfold_2 `{SetUnfold P Q} : Q → P := proj2 (set_unfold P Q). Lemma set_unfold_impl P Q P' Q' : SetUnfold P P' → SetUnfold Q Q' → SetUnfold (P → Q) (P' → Q'). Proof. constructor. by rewrite (set_unfold P P'), (set_unfold Q Q'). Qed. Lemma set_unfold_and P Q P' Q' : SetUnfold P P' → SetUnfold Q Q' → SetUnfold (P ∧ Q) (P' ∧ Q'). Proof. constructor. by rewrite (set_unfold P P'), (set_unfold Q Q'). Qed. Lemma set_unfold_or P Q P' Q' : SetUnfold P P' → SetUnfold Q Q' → SetUnfold (P ∨ Q) (P' ∨ Q'). Proof. constructor. by rewrite (set_unfold P P'), (set_unfold Q Q'). Qed. Lemma set_unfold_iff P Q P' Q' : SetUnfold P P' → SetUnfold Q Q' → SetUnfold (P ↔ Q) (P' ↔ Q'). Proof. constructor. by rewrite (set_unfold P P'), (set_unfold Q Q'). Qed. Lemma set_unfold_not P P' : SetUnfold P P' → SetUnfold (¬P) (¬P'). Proof. constructor. by rewrite (set_unfold P P'). Qed. Lemma set_unfold_forall {A} (P P' : A → Prop) : (∀ x, SetUnfold (P x) (P' x)) → SetUnfold (∀ x, P x) (∀ x, P' x). Proof. constructor. naive_solver. Qed. Lemma set_unfold_exist {A} (P P' : A → Prop) : (∀ x, SetUnfold (P x) (P' x)) → SetUnfold (∃ x, P x) (∃ x, P' x). Proof. constructor. naive_solver. Qed. (* Avoid too eager application of the above instances (and thus too eager unfolding of type class transparent definitions). *) Global Hint Extern 0 (SetUnfold (_ → _) _) => class_apply set_unfold_impl : typeclass_instances. Global Hint Extern 0 (SetUnfold (_ ∧ _) _) => class_apply set_unfold_and : typeclass_instances. Global Hint Extern 0 (SetUnfold (_ ∨ _) _) => class_apply set_unfold_or : typeclass_instances. Global Hint Extern 0 (SetUnfold (_ ↔ _) _) => class_apply set_unfold_iff : typeclass_instances. Global Hint Extern 0 (SetUnfold (¬ _) _) => class_apply set_unfold_not : typeclass_instances. Global Hint Extern 1 (SetUnfold (∀ _, _) _) => class_apply set_unfold_forall : typeclass_instances. Global Hint Extern 0 (SetUnfold (∃ _, _) _) => class_apply set_unfold_exist : typeclass_instances. Section set_unfold_simple. Context `{SemiSet A C}. Implicit Types x y : A. Implicit Types X Y : C. Global Instance set_unfold_empty x : SetUnfoldElemOf x (∅ : C) False. Proof. constructor. split; [|done]. apply not_elem_of_empty. Qed. Global Instance set_unfold_singleton x y : SetUnfoldElemOf x ({[ y ]} : C) (x = y). Proof. constructor; apply elem_of_singleton. Qed. Global Instance set_unfold_union x X Y P Q : SetUnfoldElemOf x X P → SetUnfoldElemOf x Y Q → SetUnfoldElemOf x (X ∪ Y) (P ∨ Q). Proof. intros ??; constructor. by rewrite elem_of_union, (set_unfold_elem_of x X P), (set_unfold_elem_of x Y Q). Qed. Global Instance set_unfold_equiv_same X : SetUnfold (X ≡ X) True | 1. Proof. done. Qed. Global Instance set_unfold_equiv_empty_l X (P : A → Prop) : (∀ x, SetUnfoldElemOf x X (P x)) → SetUnfold (∅ ≡ X) (∀ x, ¬P x) | 5. Proof. intros ?; constructor. unfold equiv, set_equiv_instance. pose proof (not_elem_of_empty (C:=C)); naive_solver. Qed. Global Instance set_unfold_equiv_empty_r (P : A → Prop) X : (∀ x, SetUnfoldElemOf x X (P x)) → SetUnfold (X ≡ ∅) (∀ x, ¬P x) | 5. Proof. intros ?; constructor. unfold equiv, set_equiv_instance. pose proof (not_elem_of_empty (C:=C)); naive_solver. Qed. Global Instance set_unfold_equiv (P Q : A → Prop) X Y : (∀ x, SetUnfoldElemOf x X (P x)) → (∀ x, SetUnfoldElemOf x Y (Q x)) → SetUnfold (X ≡ Y) (∀ x, P x ↔ Q x) | 10. Proof. constructor. apply forall_proper; naive_solver. Qed. Global Instance set_unfold_subseteq (P Q : A → Prop) X Y : (∀ x, SetUnfoldElemOf x X (P x)) → (∀ x, SetUnfoldElemOf x Y (Q x)) → SetUnfold (X ⊆ Y) (∀ x, P x → Q x). Proof. constructor. apply forall_proper; naive_solver. Qed. Global Instance set_unfold_subset (P Q : A → Prop) X Y : (∀ x, SetUnfoldElemOf x X (P x)) → (∀ x, SetUnfoldElemOf x Y (Q x)) → SetUnfold (X ⊂ Y) ((∀ x, P x → Q x) ∧ ¬∀ x, Q x → P x). Proof. constructor. unfold strict. repeat f_equiv; apply forall_proper; naive_solver. Qed. Global Instance set_unfold_disjoint (P Q : A → Prop) X Y : (∀ x, SetUnfoldElemOf x X (P x)) → (∀ x, SetUnfoldElemOf x Y (Q x)) → SetUnfold (X ## Y) (∀ x, P x → Q x → False). Proof. constructor. unfold disjoint, set_disjoint_instance. naive_solver. Qed. Context `{!LeibnizEquiv C}. Global Instance set_unfold_equiv_same_L X : SetUnfold (X = X) True | 1. Proof. done. Qed. Global Instance set_unfold_equiv_empty_l_L X (P : A → Prop) : (∀ x, SetUnfoldElemOf x X (P x)) → SetUnfold (∅ = X) (∀ x, ¬P x) | 5. Proof. constructor. unfold_leibniz. by apply set_unfold_equiv_empty_l. Qed. Global Instance set_unfold_equiv_empty_r_L (P : A → Prop) X : (∀ x, SetUnfoldElemOf x X (P x)) → SetUnfold (X = ∅) (∀ x, ¬P x) | 5. Proof. constructor. unfold_leibniz. by apply set_unfold_equiv_empty_r. Qed. Global Instance set_unfold_equiv_L (P Q : A → Prop) X Y : (∀ x, SetUnfoldElemOf x X (P x)) → (∀ x, SetUnfoldElemOf x Y (Q x)) → SetUnfold (X = Y) (∀ x, P x ↔ Q x) | 10. Proof. constructor. unfold_leibniz. by apply set_unfold_equiv. Qed. End set_unfold_simple. Section set_unfold. Context `{Set_ A C}. Implicit Types x y : A. Implicit Types X Y : C. Global Instance set_unfold_intersection x X Y P Q : SetUnfoldElemOf x X P → SetUnfoldElemOf x Y Q → SetUnfoldElemOf x (X ∩ Y) (P ∧ Q). Proof. intros ??; constructor. rewrite elem_of_intersection. by rewrite (set_unfold_elem_of x X P), (set_unfold_elem_of x Y Q). Qed. Global Instance set_unfold_difference x X Y P Q : SetUnfoldElemOf x X P → SetUnfoldElemOf x Y Q → SetUnfoldElemOf x (X ∖ Y) (P ∧ ¬Q). Proof. intros ??; constructor. rewrite elem_of_difference. by rewrite (set_unfold_elem_of x X P), (set_unfold_elem_of x Y Q). Qed. End set_unfold. Global Instance set_unfold_top `{TopSet A C} (x : A) : SetUnfoldElemOf x (⊤ : C) True. Proof. constructor. split; [done|intros; apply elem_of_top']. Qed. Section set_unfold_monad. Context `{MonadSet M}. Global Instance set_unfold_ret {A} (x y : A) : SetUnfoldElemOf x (mret (M:=M) y) (x = y). Proof. constructor; apply elem_of_ret. Qed. Global Instance set_unfold_bind {A B} (f : A → M B) X (P Q : A → Prop) x : (∀ y, SetUnfoldElemOf y X (P y)) → (∀ y, SetUnfoldElemOf x (f y) (Q y)) → SetUnfoldElemOf x (X ≫= f) (∃ y, Q y ∧ P y). Proof. constructor. rewrite elem_of_bind; naive_solver. Qed. Global Instance set_unfold_fmap {A B} (f : A → B) (X : M A) (P : A → Prop) x : (∀ y, SetUnfoldElemOf y X (P y)) → SetUnfoldElemOf x (f <$> X) (∃ y, x = f y ∧ P y). Proof. constructor. rewrite elem_of_fmap; naive_solver. Qed. Global Instance set_unfold_join {A} (X : M (M A)) (P : M A → Prop) x : (∀ Y, SetUnfoldElemOf Y X (P Y)) → SetUnfoldElemOf x (mjoin X) (∃ Y, x ∈ Y ∧ P Y). Proof. constructor. rewrite elem_of_join; naive_solver. Qed. End set_unfold_monad. Section set_unfold_list. Context {A : Type}. Implicit Types x : A. Implicit Types l : list A. Global Instance set_unfold_nil x : SetUnfoldElemOf x [] False. Proof. constructor; apply elem_of_nil. Qed. Global Instance set_unfold_cons x y l P : SetUnfoldElemOf x l P → SetUnfoldElemOf x (y :: l) (x = y ∨ P). Proof. constructor. by rewrite elem_of_cons, (set_unfold_elem_of x l P). Qed. Global Instance set_unfold_app x l k P Q : SetUnfoldElemOf x l P → SetUnfoldElemOf x k Q → SetUnfoldElemOf x (l ++ k) (P ∨ Q). Proof. intros ??; constructor. by rewrite elem_of_app, (set_unfold_elem_of x l P), (set_unfold_elem_of x k Q). Qed. Global Instance set_unfold_included l k (P Q : A → Prop) : (∀ x, SetUnfoldElemOf x l (P x)) → (∀ x, SetUnfoldElemOf x k (Q x)) → SetUnfold (l ⊆ k) (∀ x, P x → Q x). Proof. constructor; unfold subseteq, list_subseteq. apply forall_proper; naive_solver. Qed. Global Instance set_unfold_reverse x l P : SetUnfoldElemOf x l P → SetUnfoldElemOf x (reverse l) P. Proof. constructor. by rewrite elem_of_reverse, (set_unfold_elem_of x l P). Qed. Global Instance set_unfold_list_fmap {B} (f : A → B) l P y : (∀ x, SetUnfoldElemOf x l (P x)) → SetUnfoldElemOf y (f <$> l) (∃ x, y = f x ∧ P x). Proof. constructor. rewrite elem_of_list_fmap. f_equiv; intros x. by rewrite (set_unfold_elem_of x l (P x)). Qed. Global Instance set_unfold_rotate x l P n: SetUnfoldElemOf x l P → SetUnfoldElemOf x (rotate n l) P. Proof. constructor. by rewrite elem_of_rotate, (set_unfold_elem_of x l P). Qed. Global Instance set_unfold_list_bind {B} (f : A → list B) l P Q y : (∀ x, SetUnfoldElemOf x l (P x)) → (∀ x, SetUnfoldElemOf y (f x) (Q x)) → SetUnfoldElemOf y (l ≫= f) (∃ x, Q x ∧ P x). Proof. constructor. rewrite elem_of_list_bind. naive_solver. Qed. End set_unfold_list. Tactic Notation "set_unfold" := let rec unfold_hyps := try match goal with | H : ?P |- _ => lazymatch type of P with | Prop => apply set_unfold_1 in H; revert H; first [unfold_hyps; intros H | intros H; fail 1] | _ => fail end end in apply set_unfold_2; unfold_hyps; csimpl in *. Tactic Notation "set_unfold" "in" ident(H) := let P := type of H in lazymatch type of P with | Prop => apply set_unfold_1 in H | _ => fail "hypothesis" H "is not a proposition" end. (** Since [firstorder] already fails or loops on very small goals generated by [set_solver], we use the [naive_solver] tactic as a substitute. *) Tactic Notation "set_solver" "by" tactic3(tac) := try fast_done; intros; setoid_subst; set_unfold; intros; setoid_subst; try match goal with |- _ ∈ _ => apply dec_stable end; naive_solver tac. Tactic Notation "set_solver" "-" hyp_list(Hs) "by" tactic3(tac) := clear Hs; set_solver by tac. Tactic Notation "set_solver" "+" hyp_list(Hs) "by" tactic3(tac) := clear -Hs; set_solver by tac. Tactic Notation "set_solver" := set_solver by eauto. Tactic Notation "set_solver" "-" hyp_list(Hs) := clear Hs; set_solver. Tactic Notation "set_solver" "+" hyp_list(Hs) := clear -Hs; set_solver. Global Hint Extern 1000 (_ ∉ _) => set_solver : set_solver. Global Hint Extern 1000 (_ ∈ _) => set_solver : set_solver. Global Hint Extern 1000 (_ ⊆ _) => set_solver : set_solver. (** * Sets with [∪], [∅] and [{[_]}] *) Section semi_set. Context `{SemiSet A C}. Implicit Types x y : A. Implicit Types X Y : C. Implicit Types Xs Ys : list C. (** Equality *) Lemma set_equiv X Y : X ≡ Y ↔ ∀ x, x ∈ X ↔ x ∈ Y. Proof. set_solver. Qed. Lemma set_equiv_subseteq X Y : X ≡ Y ↔ X ⊆ Y ∧ Y ⊆ X. Proof. set_solver. Qed. Global Instance singleton_equiv_inj : Inj (=) (≡@{C}) singleton. Proof. unfold Inj. set_solver. Qed. Global Instance singleton_inj `{!LeibnizEquiv C} : Inj (=) (=@{C}) singleton. Proof. unfold Inj. set_solver. Qed. (** Subset relation *) Global Instance set_subseteq_antisymm: AntiSymm (≡) (⊆@{C}). Proof. intros ??. set_solver. Qed. Global Instance set_subseteq_preorder: PreOrder (⊆@{C}). Proof. split; [by intros ??|]. intros ???; set_solver. Qed. Lemma subseteq_union X Y : X ⊆ Y ↔ X ∪ Y ≡ Y. Proof. set_solver. Qed. Lemma subseteq_union_1 X Y : X ⊆ Y → X ∪ Y ≡ Y. Proof. by rewrite subseteq_union. Qed. Lemma subseteq_union_2 X Y : X ∪ Y ≡ Y → X ⊆ Y. Proof. by rewrite subseteq_union. Qed. Lemma union_subseteq_l X Y : X ⊆ X ∪ Y. Proof. set_solver. Qed. Lemma union_subseteq_l' X X' Y : X ⊆ X' → X ⊆ X' ∪ Y. Proof. set_solver. Qed. Lemma union_subseteq_r X Y : Y ⊆ X ∪ Y. Proof. set_solver. Qed. Lemma union_subseteq_r' X Y Y' : Y ⊆ Y' → Y ⊆ X ∪ Y'. Proof. set_solver. Qed. Lemma union_least X Y Z : X ⊆ Z → Y ⊆ Z → X ∪ Y ⊆ Z. Proof. set_solver. Qed. Lemma elem_of_subseteq X Y : X ⊆ Y ↔ ∀ x, x ∈ X → x ∈ Y. Proof. done. Qed. Lemma elem_of_subset X Y : X ⊂ Y ↔ (∀ x, x ∈ X → x ∈ Y) ∧ ¬(∀ x, x ∈ Y → x ∈ X). Proof. set_solver. Qed. Lemma elem_of_weaken x X Y : x ∈ X → X ⊆ Y → x ∈ Y. Proof. set_solver. Qed. Lemma not_elem_of_weaken x X Y : x ∉ Y → X ⊆ Y → x ∉ X. Proof. set_solver. Qed. (** Union *) Lemma union_subseteq X Y Z : X ∪ Y ⊆ Z ↔ X ⊆ Z ∧ Y ⊆ Z. Proof. set_solver. Qed. Lemma not_elem_of_union x X Y : x ∉ X ∪ Y ↔ x ∉ X ∧ x ∉ Y. Proof. set_solver. Qed. Lemma elem_of_union_l x X Y : x ∈ X → x ∈ X ∪ Y. Proof. set_solver. Qed. Lemma elem_of_union_r x X Y : x ∈ Y → x ∈ X ∪ Y. Proof. set_solver. Qed. Lemma union_mono_l X Y1 Y2 : Y1 ⊆ Y2 → X ∪ Y1 ⊆ X ∪ Y2. Proof. set_solver. Qed. Lemma union_mono_r X1 X2 Y : X1 ⊆ X2 → X1 ∪ Y ⊆ X2 ∪ Y. Proof. set_solver. Qed. Lemma union_mono X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∪ Y1 ⊆ X2 ∪ Y2. Proof. set_solver. Qed. Global Instance union_idemp : IdemP (≡@{C}) (∪). Proof. intros X. set_solver. Qed. Global Instance union_empty_l : LeftId (≡@{C}) ∅ (∪). Proof. intros X. set_solver. Qed. Global Instance union_empty_r : RightId (≡@{C}) ∅ (∪). Proof. intros X. set_solver. Qed. Global Instance union_comm : Comm (≡@{C}) (∪). Proof. intros X Y. set_solver. Qed. Global Instance union_assoc : Assoc (≡@{C}) (∪). Proof. intros X Y Z. set_solver. Qed. Lemma empty_union X Y : X ∪ Y ≡ ∅ ↔ X ≡ ∅ ∧ Y ≡ ∅. Proof. set_solver. Qed. Lemma union_cancel_l X Y Z : Z ## X → Z ## Y → Z ∪ X ≡ Z ∪ Y → X ≡ Y. Proof. set_solver. Qed. Lemma union_cancel_r X Y Z : X ## Z → Y ## Z → X ∪ Z ≡ Y ∪ Z → X ≡ Y. Proof. set_solver. Qed. (** Empty *) Lemma empty_subseteq X : ∅ ⊆ X. Proof. set_solver. Qed. Lemma elem_of_equiv_empty X : X ≡ ∅ ↔ ∀ x, x ∉ X. Proof. set_solver. Qed. Lemma elem_of_empty x : x ∈@{C} ∅ ↔ False. Proof. set_solver. Qed. Lemma equiv_empty X : X ⊆ ∅ → X ≡ ∅. Proof. set_solver. Qed. Lemma union_positive_l X Y : X ∪ Y ≡ ∅ → X ≡ ∅. Proof. set_solver. Qed. Lemma union_positive_l_alt X Y : X ≢ ∅ → X ∪ Y ≢ ∅. Proof. set_solver. Qed. Lemma non_empty_inhabited x X : x ∈ X → X ≢ ∅. Proof. set_solver. Qed. (** Singleton *) Lemma elem_of_singleton_1 x y : x ∈@{C} {[y]} → x = y. Proof. by rewrite elem_of_singleton. Qed. Lemma elem_of_singleton_2 x y : x = y → x ∈@{C} {[y]}. Proof. by rewrite elem_of_singleton. Qed. Lemma elem_of_subseteq_singleton x X : x ∈ X ↔ {[ x ]} ⊆ X. Proof. set_solver. Qed. Lemma non_empty_singleton x : {[ x ]} ≢@{C} ∅. Proof. set_solver. Qed. Lemma not_elem_of_singleton x y : x ∉@{C} {[ y ]} ↔ x ≠ y. Proof. by rewrite elem_of_singleton. Qed. Lemma not_elem_of_singleton_1 x y : x ∉@{C} {[ y ]} → x ≠ y. Proof. apply not_elem_of_singleton. Qed. Lemma not_elem_of_singleton_2 x y : x ≠ y → x ∉@{C} {[ y ]}. Proof. apply not_elem_of_singleton. Qed. Lemma singleton_subseteq_l x X : {[ x ]} ⊆ X ↔ x ∈ X. Proof. set_solver. Qed. Lemma singleton_subseteq x y : {[ x ]} ⊆@{C} {[ y ]} ↔ x = y. Proof. set_solver. Qed. (** Disjointness *) Lemma elem_of_disjoint X Y : X ## Y ↔ ∀ x, x ∈ X → x ∈ Y → False. Proof. done. Qed. Global Instance disjoint_sym : Symmetric (##@{C}). Proof. intros X Y. set_solver. Qed. Lemma disjoint_empty_l Y : ∅ ## Y. Proof. set_solver. Qed. Lemma disjoint_empty_r X : X ## ∅. Proof. set_solver. Qed. Lemma disjoint_singleton_l x Y : {[ x ]} ## Y ↔ x ∉ Y. Proof. set_solver. Qed. Lemma disjoint_singleton_r y X : X ## {[ y ]} ↔ y ∉ X. Proof. set_solver. Qed. Lemma disjoint_union_l X1 X2 Y : X1 ∪ X2 ## Y ↔ X1 ## Y ∧ X2 ## Y. Proof. set_solver. Qed. Lemma disjoint_union_r X Y1 Y2 : X ## Y1 ∪ Y2 ↔ X ## Y1 ∧ X ## Y2. Proof. set_solver. Qed. (** Big unions *) Lemma elem_of_union_list Xs x : x ∈ ⋃ Xs ↔ ∃ X, X ∈ Xs ∧ x ∈ X. Proof. split. - induction Xs; simpl; intros HXs; [by apply elem_of_empty in HXs|]. setoid_rewrite elem_of_cons. apply elem_of_union in HXs. naive_solver. - intros [X [Hx]]. induction Hx; simpl; [by apply elem_of_union_l |]. intros. apply elem_of_union_r; auto. Qed. Lemma union_list_nil : ⋃ @nil C = ∅. Proof. done. Qed. Lemma union_list_cons X Xs : ⋃ (X :: Xs) = X ∪ ⋃ Xs. Proof. done. Qed. Lemma union_list_singleton X : ⋃ [X] ≡ X. Proof. simpl. by rewrite (right_id ∅ _). Qed. Lemma union_list_app Xs1 Xs2 : ⋃ (Xs1 ++ Xs2) ≡ ⋃ Xs1 ∪ ⋃ Xs2. Proof. induction Xs1 as [|X Xs1 IH]; simpl; [by rewrite (left_id ∅ _)|]. by rewrite IH, (assoc _). Qed. Lemma union_list_reverse Xs : ⋃ (reverse Xs) ≡ ⋃ Xs. Proof. induction Xs as [|X Xs IH]; simpl; [done |]. by rewrite reverse_cons, union_list_app, union_list_singleton, (comm _), IH. Qed. Lemma union_list_mono Xs Ys : Xs ⊆* Ys → ⋃ Xs ⊆ ⋃ Ys. Proof. induction 1; simpl; auto using union_mono. Qed. Lemma empty_union_list Xs : ⋃ Xs ≡ ∅ ↔ Forall (.≡ ∅) Xs. Proof. split. - induction Xs; simpl; rewrite ?empty_union; intuition. - induction 1 as [|?? E1 ? E2]; simpl; [done|]. by apply empty_union. Qed. Section leibniz. Context `{!LeibnizEquiv C}. Lemma set_eq X Y : X = Y ↔ ∀ x, x ∈ X ↔ x ∈ Y. Proof. unfold_leibniz. apply set_equiv. Qed. Lemma set_eq_subseteq X Y : X = Y ↔ X ⊆ Y ∧ Y ⊆ X. Proof. unfold_leibniz. apply set_equiv_subseteq. Qed. (** Subset relation *) Global Instance set_subseteq_partialorder : PartialOrder (⊆@{C}). Proof. split; [apply _|]. intros ??. unfold_leibniz. apply (anti_symm _). Qed. Lemma subseteq_union_L X Y : X ⊆ Y ↔ X ∪ Y = Y. Proof. unfold_leibniz. apply subseteq_union. Qed. Lemma subseteq_union_1_L X Y : X ⊆ Y → X ∪ Y = Y. Proof. unfold_leibniz. apply subseteq_union_1. Qed. Lemma subseteq_union_2_L X Y : X ∪ Y = Y → X ⊆ Y. Proof. unfold_leibniz. apply subseteq_union_2. Qed. (** Union *) Global Instance union_idemp_L : IdemP (=@{C}) (∪). Proof. intros ?. unfold_leibniz. apply (idemp _). Qed. Global Instance union_empty_l_L : LeftId (=@{C}) ∅ (∪). Proof. intros ?. unfold_leibniz. apply (left_id _ _). Qed. Global Instance union_empty_r_L : RightId (=@{C}) ∅ (∪). Proof. intros ?. unfold_leibniz. apply (right_id _ _). Qed. Global Instance union_comm_L : Comm (=@{C}) (∪). Proof. intros ??. unfold_leibniz. apply (comm _). Qed. Global Instance union_assoc_L : Assoc (=@{C}) (∪). Proof. intros ???. unfold_leibniz. apply (assoc _). Qed. Lemma empty_union_L X Y : X ∪ Y = ∅ ↔ X = ∅ ∧ Y = ∅. Proof. unfold_leibniz. apply empty_union. Qed. Lemma union_cancel_l_L X Y Z : Z ## X → Z ## Y → Z ∪ X = Z ∪ Y → X = Y. Proof. unfold_leibniz. apply union_cancel_l. Qed. Lemma union_cancel_r_L X Y Z : X ## Z → Y ## Z → X ∪ Z = Y ∪ Z → X = Y. Proof. unfold_leibniz. apply union_cancel_r. Qed. (** Empty *) Lemma elem_of_equiv_empty_L X : X = ∅ ↔ ∀ x, x ∉ X. Proof. unfold_leibniz. apply elem_of_equiv_empty. Qed. Lemma equiv_empty_L X : X ⊆ ∅ → X = ∅. Proof. unfold_leibniz. apply equiv_empty. Qed. Lemma union_positive_l_L X Y : X ∪ Y = ∅ → X = ∅. Proof. unfold_leibniz. apply union_positive_l. Qed. Lemma union_positive_l_alt_L X Y : X ≠ ∅ → X ∪ Y ≠ ∅. Proof. unfold_leibniz. apply union_positive_l_alt. Qed. Lemma non_empty_inhabited_L x X : x ∈ X → X ≠ ∅. Proof. unfold_leibniz. apply non_empty_inhabited. Qed. (** Singleton *) Lemma non_empty_singleton_L x : {[ x ]} ≠@{C} ∅. Proof. unfold_leibniz. apply non_empty_singleton. Qed. (** Big unions *) Lemma union_list_singleton_L X : ⋃ [X] = X. Proof. unfold_leibniz. apply union_list_singleton. Qed. Lemma union_list_app_L Xs1 Xs2 : ⋃ (Xs1 ++ Xs2) = ⋃ Xs1 ∪ ⋃ Xs2. Proof. unfold_leibniz. apply union_list_app. Qed. Lemma union_list_reverse_L Xs : ⋃ (reverse Xs) = ⋃ Xs. Proof. unfold_leibniz. apply union_list_reverse. Qed. Lemma empty_union_list_L Xs : ⋃ Xs = ∅ ↔ Forall (.= ∅) Xs. Proof. unfold_leibniz. apply empty_union_list. Qed. End leibniz. Lemma not_elem_of_iff `{!RelDecision (∈@{C})} X Y x : (x ∈ X ↔ x ∈ Y) ↔ (x ∉ X ↔ x ∉ Y). Proof. destruct (decide (x ∈ X)), (decide (x ∈ Y)); tauto. Qed. Section dec. Context `{!RelDecision (≡@{C})}. Lemma set_subseteq_inv X Y : X ⊆ Y → X ⊂ Y ∨ X ≡ Y. Proof. destruct (decide (X ≡ Y)); [by right|left;set_solver]. Qed. Lemma set_not_subset_inv X Y : X ⊄ Y → X ⊈ Y ∨ X ≡ Y. Proof. destruct (decide (X ≡ Y)); [by right|left;set_solver]. Qed. Lemma non_empty_union X Y : X ∪ Y ≢ ∅ ↔ X ≢ ∅ ∨ Y ≢ ∅. Proof. destruct (decide (X ≡ ∅)); set_solver. Qed. Lemma non_empty_union_list Xs : ⋃ Xs ≢ ∅ → Exists (.≢ ∅) Xs. Proof. rewrite empty_union_list. apply (not_Forall_Exists _). Qed. End dec. Section dec_leibniz. Context `{!RelDecision (≡@{C}), !LeibnizEquiv C}. Lemma set_subseteq_inv_L X Y : X ⊆ Y → X ⊂ Y ∨ X = Y. Proof. unfold_leibniz. apply set_subseteq_inv. Qed. Lemma set_not_subset_inv_L X Y : X ⊄ Y → X ⊈ Y ∨ X = Y. Proof. unfold_leibniz. apply set_not_subset_inv. Qed. Lemma non_empty_union_L X Y : X ∪ Y ≠ ∅ ↔ X ≠ ∅ ∨ Y ≠ ∅. Proof. unfold_leibniz. apply non_empty_union. Qed. Lemma non_empty_union_list_L Xs : ⋃ Xs ≠ ∅ → Exists (.≠ ∅) Xs. Proof. unfold_leibniz. apply non_empty_union_list. Qed. End dec_leibniz. End semi_set. (** * Sets with [∪], [∩], [∖], [∅] and [{[_]}] *) Section set. Context `{Set_ A C}. Implicit Types x y : A. Implicit Types X Y : C. (** Intersection *) Lemma subseteq_intersection X Y : X ⊆ Y ↔ X ∩ Y ≡ X. Proof. set_solver. Qed. Lemma subseteq_intersection_1 X Y : X ⊆ Y → X ∩ Y ≡ X. Proof. apply subseteq_intersection. Qed. Lemma subseteq_intersection_2 X Y : X ∩ Y ≡ X → X ⊆ Y. Proof. apply subseteq_intersection. Qed. Lemma intersection_subseteq_l X Y : X ∩ Y ⊆ X. Proof. set_solver. Qed. Lemma intersection_subseteq_r X Y : X ∩ Y ⊆ Y. Proof. set_solver. Qed. Lemma intersection_greatest X Y Z : Z ⊆ X → Z ⊆ Y → Z ⊆ X ∩ Y. Proof. set_solver. Qed. Lemma intersection_mono_l X Y1 Y2 : Y1 ⊆ Y2 → X ∩ Y1 ⊆ X ∩ Y2. Proof. set_solver. Qed. Lemma intersection_mono_r X1 X2 Y : X1 ⊆ X2 → X1 ∩ Y ⊆ X2 ∩ Y. Proof. set_solver. Qed. Lemma intersection_mono X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∩ Y1 ⊆ X2 ∩ Y2. Proof. set_solver. Qed. Global Instance intersection_idemp : IdemP (≡@{C}) (∩). Proof. intros X; set_solver. Qed. Global Instance intersection_comm : Comm (≡@{C}) (∩). Proof. intros X Y; set_solver. Qed. Global Instance intersection_assoc : Assoc (≡@{C}) (∩). Proof. intros X Y Z; set_solver. Qed. Global Instance intersection_empty_l : LeftAbsorb (≡@{C}) ∅ (∩). Proof. intros X; set_solver. Qed. Global Instance intersection_empty_r: RightAbsorb (≡@{C}) ∅ (∩). Proof. intros X; set_solver. Qed. Lemma intersection_singletons x : {[x]} ∩ {[x]} ≡@{C} {[x]}. Proof. set_solver. Qed. Lemma union_intersection_l X Y Z : X ∪ (Y ∩ Z) ≡ (X ∪ Y) ∩ (X ∪ Z). Proof. set_solver. Qed. Lemma union_intersection_r X Y Z : (X ∩ Y) ∪ Z ≡ (X ∪ Z) ∩ (Y ∪ Z). Proof. set_solver. Qed. Lemma intersection_union_l X Y Z : X ∩ (Y ∪ Z) ≡ (X ∩ Y) ∪ (X ∩ Z). Proof. set_solver. Qed. Lemma intersection_union_r X Y Z : (X ∪ Y) ∩ Z ≡ (X ∩ Z) ∪ (Y ∩ Z). Proof. set_solver. Qed. (** Difference *) Lemma difference_twice X Y : (X ∖ Y) ∖ Y ≡ X ∖ Y. Proof. set_solver. Qed. Lemma subseteq_empty_difference X Y : X ⊆ Y → X ∖ Y ≡ ∅. Proof. set_solver. Qed. Lemma difference_diag X : X ∖ X ≡ ∅. Proof. set_solver. Qed. Lemma difference_empty X : X ∖ ∅ ≡ X. Proof. set_solver. Qed. Lemma difference_union_distr_l X Y Z : (X ∪ Y) ∖ Z ≡ X ∖ Z ∪ Y ∖ Z. Proof. set_solver. Qed. Lemma difference_union_distr_r X Y Z : Z ∖ (X ∪ Y) ≡ (Z ∖ X) ∩ (Z ∖ Y). Proof. set_solver. Qed. Lemma difference_intersection_distr_l X Y Z : (X ∩ Y) ∖ Z ≡ X ∖ Z ∩ Y ∖ Z. Proof. set_solver. Qed. Lemma difference_disjoint X Y : X ## Y → X ∖ Y ≡ X. Proof. set_solver. Qed. Lemma subset_difference_elem_of x X : x ∈ X → X ∖ {[ x ]} ⊂ X. Proof. set_solver. Qed. Lemma difference_difference_l X Y Z : (X ∖ Y) ∖ Z ≡ X ∖ (Y ∪ Z). Proof. set_solver. Qed. Lemma difference_mono X1 X2 Y1 Y2 : X1 ⊆ X2 → Y2 ⊆ Y1 → X1 ∖ Y1 ⊆ X2 ∖ Y2. Proof. set_solver. Qed. Lemma difference_mono_l X Y1 Y2 : Y2 ⊆ Y1 → X ∖ Y1 ⊆ X ∖ Y2. Proof. set_solver. Qed. Lemma difference_mono_r X1 X2 Y : X1 ⊆ X2 → X1 ∖ Y ⊆ X2 ∖ Y. Proof. set_solver. Qed. Lemma subseteq_difference_r X Y1 Y2 : X ## Y2 → X ⊆ Y1 → X ⊆ Y1 ∖ Y2. Proof. set_solver. Qed. Lemma subseteq_difference_l X1 X2 Y : X1 ⊆ Y → X1 ∖ X2 ⊆ Y. Proof. set_solver. Qed. (** Disjointness *) Lemma disjoint_intersection X Y : X ## Y ↔ X ∩ Y ≡ ∅. Proof. set_solver. Qed. Lemma disjoint_difference_l1 X1 X2 Y : Y ⊆ X2 → X1 ∖ X2 ## Y. Proof. set_solver. Qed. Lemma disjoint_difference_l2 X1 X2 Y : X1 ## Y → X1 ∖ X2 ## Y. Proof. set_solver. Qed. Lemma disjoint_difference_r1 X Y1 Y2 : X ⊆ Y2 → X ## Y1 ∖ Y2. Proof. set_solver. Qed. Lemma disjoint_difference_r2 X Y1 Y2 : X ## Y1 → X ## Y1 ∖ Y2. Proof. set_solver. Qed. Section leibniz. Context `{!LeibnizEquiv C}. (** Intersection *) Lemma subseteq_intersection_L X Y : X ⊆ Y ↔ X ∩ Y = X. Proof. unfold_leibniz. apply subseteq_intersection. Qed. Lemma subseteq_intersection_1_L X Y : X ⊆ Y → X ∩ Y = X. Proof. unfold_leibniz. apply subseteq_intersection_1. Qed. Lemma subseteq_intersection_2_L X Y : X ∩ Y = X → X ⊆ Y. Proof. unfold_leibniz. apply subseteq_intersection_2. Qed. Global Instance intersection_idemp_L : IdemP (=@{C}) (∩). Proof. intros ?. unfold_leibniz. apply (idemp _). Qed. Global Instance intersection_comm_L : Comm (=@{C}) (∩). Proof. intros ??. unfold_leibniz. apply (comm _). Qed. Global Instance intersection_assoc_L : Assoc (=@{C}) (∩). Proof. intros ???. unfold_leibniz. apply (assoc _). Qed. Global Instance intersection_empty_l_L: LeftAbsorb (=@{C}) ∅ (∩). Proof. intros ?. unfold_leibniz. apply (left_absorb _ _). Qed. Global Instance intersection_empty_r_L: RightAbsorb (=@{C}) ∅ (∩). Proof. intros ?. unfold_leibniz. apply (right_absorb _ _). Qed. Lemma intersection_singletons_L x : {[x]} ∩ {[x]} =@{C} {[x]}. Proof. unfold_leibniz. apply intersection_singletons. Qed. Lemma union_intersection_l_L X Y Z : X ∪ (Y ∩ Z) = (X ∪ Y) ∩ (X ∪ Z). Proof. unfold_leibniz; apply union_intersection_l. Qed. Lemma union_intersection_r_L X Y Z : (X ∩ Y) ∪ Z = (X ∪ Z) ∩ (Y ∪ Z). Proof. unfold_leibniz; apply union_intersection_r. Qed. Lemma intersection_union_l_L X Y Z : X ∩ (Y ∪ Z) = (X ∩ Y) ∪ (X ∩ Z). Proof. unfold_leibniz; apply intersection_union_l. Qed. Lemma intersection_union_r_L X Y Z : (X ∪ Y) ∩ Z = (X ∩ Z) ∪ (Y ∩ Z). Proof. unfold_leibniz; apply intersection_union_r. Qed. (** Difference *) Lemma difference_twice_L X Y : (X ∖ Y) ∖ Y = X ∖ Y. Proof. unfold_leibniz. apply difference_twice. Qed. Lemma subseteq_empty_difference_L X Y : X ⊆ Y → X ∖ Y = ∅. Proof. unfold_leibniz. apply subseteq_empty_difference. Qed. Lemma difference_diag_L X : X ∖ X = ∅. Proof. unfold_leibniz. apply difference_diag. Qed. Lemma difference_empty_L X : X ∖ ∅ = X. Proof. unfold_leibniz. apply difference_empty. Qed. Lemma difference_union_distr_l_L X Y Z : (X ∪ Y) ∖ Z = X ∖ Z ∪ Y ∖ Z. Proof. unfold_leibniz. apply difference_union_distr_l. Qed. Lemma difference_union_distr_r_L X Y Z : Z ∖ (X ∪ Y) = (Z ∖ X) ∩ (Z ∖ Y). Proof. unfold_leibniz. apply difference_union_distr_r. Qed. Lemma difference_intersection_distr_l_L X Y Z : (X ∩ Y) ∖ Z = X ∖ Z ∩ Y ∖ Z. Proof. unfold_leibniz. apply difference_intersection_distr_l. Qed. Lemma difference_disjoint_L X Y : X ## Y → X ∖ Y = X. Proof. unfold_leibniz. apply difference_disjoint. Qed. Lemma difference_difference_l_L X Y Z : (X ∖ Y) ∖ Z = X ∖ (Y ∪ Z). Proof. unfold_leibniz. apply difference_difference_l. Qed. (** Disjointness *) Lemma disjoint_intersection_L X Y : X ## Y ↔ X ∩ Y = ∅. Proof. unfold_leibniz. apply disjoint_intersection. Qed. End leibniz. Section dec. Context `{!RelDecision (∈@{C})}. Lemma not_elem_of_intersection x X Y : x ∉ X ∩ Y ↔ x ∉ X ∨ x ∉ Y. Proof. rewrite elem_of_intersection. destruct (decide (x ∈ X)); tauto. Qed. Lemma not_elem_of_difference x X Y : x ∉ X ∖ Y ↔ x ∉ X ∨ x ∈ Y. Proof. rewrite elem_of_difference. destruct (decide (x ∈ Y)); tauto. Qed. Lemma union_difference X Y : X ⊆ Y → Y ≡ X ∪ Y ∖ X. Proof. intros ? x; split; rewrite !elem_of_union, elem_of_difference; [|intuition]. destruct (decide (x ∈ X)); intuition. Qed. Lemma union_difference_singleton x Y : x ∈ Y → Y ≡ {[x]} ∪ Y ∖ {[x]}. Proof. intros ?. apply union_difference. set_solver. Qed. Lemma difference_union X Y : X ∖ Y ∪ Y ≡ X ∪ Y. Proof. intros x. rewrite !elem_of_union; rewrite elem_of_difference. split; [ | destruct (decide (x ∈ Y)) ]; intuition. Qed. Lemma difference_difference_r X Y Z : X ∖ (Y ∖ Z) ≡ (X ∖ Y) ∪ (X ∩ Z). Proof. intros x. destruct (decide (x ∈ Z)); set_solver. Qed. Lemma subseteq_disjoint_union X Y : X ⊆ Y ↔ ∃ Z, Y ≡ X ∪ Z ∧ X ## Z. Proof. split; [|set_solver]. exists (Y ∖ X); split; [auto using union_difference|set_solver]. Qed. Lemma non_empty_difference X Y : X ⊂ Y → Y ∖ X ≢ ∅. Proof. intros [HXY1 HXY2] Hdiff. destruct HXY2. set_solver. Qed. Lemma empty_difference_subseteq X Y : X ∖ Y ≡ ∅ → X ⊆ Y. Proof. set_solver. Qed. Lemma singleton_union_difference X Y x : {[x]} ∪ (X ∖ Y) ≡ ({[x]} ∪ X) ∖ (Y ∖ {[x]}). Proof. intro y; destruct (decide (y ∈@{C} {[x]})); set_solver. Qed. End dec. Section dec_leibniz. Context `{!RelDecision (∈@{C}), !LeibnizEquiv C}. Lemma union_difference_L X Y : X ⊆ Y → Y = X ∪ Y ∖ X. Proof. unfold_leibniz. apply union_difference. Qed. Lemma union_difference_singleton_L x Y : x ∈ Y → Y = {[x]} ∪ Y ∖ {[x]}. Proof. unfold_leibniz. apply union_difference_singleton. Qed. Lemma difference_union_L X Y : X ∖ Y ∪ Y = X ∪ Y. Proof. unfold_leibniz. apply difference_union. Qed. Lemma non_empty_difference_L X Y : X ⊂ Y → Y ∖ X ≠ ∅. Proof. unfold_leibniz. apply non_empty_difference. Qed. Lemma empty_difference_subseteq_L X Y : X ∖ Y = ∅ → X ⊆ Y. Proof. unfold_leibniz. apply empty_difference_subseteq. Qed. Lemma subseteq_disjoint_union_L X Y : X ⊆ Y ↔ ∃ Z, Y = X ∪ Z ∧ X ## Z. Proof. unfold_leibniz. apply subseteq_disjoint_union. Qed. Lemma singleton_union_difference_L X Y x : {[x]} ∪ (X ∖ Y) = ({[x]} ∪ X) ∖ (Y ∖ {[x]}). Proof. unfold_leibniz. apply singleton_union_difference. Qed. Lemma difference_difference_r_L X Y Z : X ∖ (Y ∖ Z) = (X ∖ Y) ∪ (X ∩ Z). Proof. unfold_leibniz. apply difference_difference_r. Qed. End dec_leibniz. End set. (** * Sets with [∪], [∩], [∖], [∅], [{[_]}], and [⊤] *) Section top_set. Context `{TopSet A C}. Implicit Types x y : A. Implicit Types X Y : C. Lemma elem_of_top x : x ∈@{C} ⊤ ↔ True. Proof. split; [done|intros; apply elem_of_top']. Qed. Lemma top_subseteq X : X ⊆ ⊤. Proof. intros x. by rewrite elem_of_top. Qed. End top_set. (** * Conversion of option and list *) Section option_and_list_to_set. Context `{SemiSet A C}. Implicit Types l : list A. Lemma elem_of_option_to_set (x : A) mx: x ∈ option_to_set (C:=C) mx ↔ mx = Some x. Proof. destruct mx; set_solver. Qed. Lemma not_elem_of_option_to_set (x : A) mx: x ∉ option_to_set (C:=C) mx ↔ mx ≠ Some x. Proof. by rewrite elem_of_option_to_set. Qed. Lemma elem_of_list_to_set (x : A) l : x ∈ list_to_set (C:=C) l ↔ x ∈ l. Proof. split. - induction l; simpl; [by rewrite elem_of_empty|]. rewrite elem_of_union,elem_of_singleton; intros [->|?]; constructor; auto. - induction 1; simpl; rewrite elem_of_union, elem_of_singleton; auto. Qed. Lemma not_elem_of_list_to_set (x : A) l : x ∉ list_to_set (C:=C) l ↔ x ∉ l. Proof. by rewrite elem_of_list_to_set. Qed. Global Instance set_unfold_option_to_set (mx : option A) x : SetUnfoldElemOf x (option_to_set (C:=C) mx) (mx = Some x). Proof. constructor; apply elem_of_option_to_set. Qed. Global Instance set_unfold_list_to_set (l : list A) x P : SetUnfoldElemOf x l P → SetUnfoldElemOf x (list_to_set (C:=C) l) P. Proof. constructor. by rewrite elem_of_list_to_set, (set_unfold (x ∈ l) P). Qed. Lemma list_to_set_nil : list_to_set [] =@{C} ∅. Proof. done. Qed. Lemma list_to_set_cons x l : list_to_set (x :: l) =@{C} {[ x ]} ∪ list_to_set l. Proof. done. Qed. Lemma list_to_set_app l1 l2 : list_to_set (l1 ++ l2) ≡@{C} list_to_set l1 ∪ list_to_set l2. Proof. set_solver. Qed. Lemma list_to_set_singleton x : list_to_set [x] ≡@{C} {[ x ]}. Proof. set_solver. Qed. Lemma list_to_set_snoc l x : list_to_set (l ++ [x]) ≡@{C} list_to_set l ∪ {[ x ]}. Proof. set_solver. Qed. Global Instance list_to_set_perm : Proper ((≡ₚ) ==> (≡)) (list_to_set (C:=C)). Proof. induction 1; set_solver. Qed. Section leibniz. Context `{!LeibnizEquiv C}. Lemma list_to_set_app_L l1 l2 : list_to_set (l1 ++ l2) =@{C} list_to_set l1 ∪ list_to_set l2. Proof. set_solver. Qed. Global Instance list_to_set_perm_L : Proper ((≡ₚ) ==> (=)) (list_to_set (C:=C)). Proof. induction 1; set_solver. Qed. End leibniz. End option_and_list_to_set. (** * Finite types to sets. *) Definition fin_to_set (A : Type) `{Singleton A C, Empty C, Union C, Finite A} : C := list_to_set (enum A). Section fin_to_set. Context `{SemiSet A C, Finite A}. Implicit Types a : A. Lemma elem_of_fin_to_set a : a ∈@{C} fin_to_set A. Proof. apply elem_of_list_to_set, elem_of_enum. Qed. Global Instance set_unfold_fin_to_set a : SetUnfoldElemOf (C:=C) a (fin_to_set A) True. Proof. constructor. split; auto using elem_of_fin_to_set. Qed. End fin_to_set. (** * Guard *) Global Instance set_guard `{MonadSet M} : MGuard M := λ P dec A x, match dec with left H => x H | _ => ∅ end. Section set_monad_base. Context `{MonadSet M}. Lemma elem_of_guard `{Decision P} {A} (x : A) (X : M A) : (x ∈ guard P; X) ↔ P ∧ x ∈ X. Proof. unfold mguard, set_guard; simpl; case_match; rewrite ?elem_of_empty; naive_solver. Qed. Lemma elem_of_guard_2 `{Decision P} {A} (x : A) (X : M A) : P → x ∈ X → x ∈ guard P; X. Proof. by rewrite elem_of_guard. Qed. Lemma guard_empty `{Decision P} {A} (X : M A) : (guard P; X) ≡ ∅ ↔ ¬P ∨ X ≡ ∅. Proof. rewrite !elem_of_equiv_empty; setoid_rewrite elem_of_guard. destruct (decide P); naive_solver. Qed. Global Instance set_unfold_guard `{Decision P} {A} (x : A) (X : M A) Q : SetUnfoldElemOf x X Q → SetUnfoldElemOf x (guard P; X) (P ∧ Q). Proof. constructor. by rewrite elem_of_guard, (set_unfold (x ∈ X) Q). Qed. Lemma bind_empty {A B} (f : A → M B) X : X ≫= f ≡ ∅ ↔ X ≡ ∅ ∨ ∀ x, x ∈ X → f x ≡ ∅. Proof. set_solver. Qed. End set_monad_base. (** * Quantifiers *) Definition set_Forall `{ElemOf A C} (P : A → Prop) (X : C) := ∀ x, x ∈ X → P x. Definition set_Exists `{ElemOf A C} (P : A → Prop) (X : C) := ∃ x, x ∈ X ∧ P x. Section quantifiers. Context `{SemiSet A C} (P : A → Prop). Implicit Types X Y : C. Global Instance set_unfold_set_Forall X (QX QP : A → Prop) : (∀ x, SetUnfoldElemOf x X (QX x)) → (∀ x, SetUnfold (P x) (QP x)) → SetUnfold (set_Forall P X) (∀ x, QX x → QP x). Proof. intros HX HP; constructor. unfold set_Forall. apply forall_proper; intros x. by rewrite (set_unfold (x ∈ X) _), (set_unfold (P x) _). Qed. Global Instance set_unfold_set_Exists X (QX QP : A → Prop) : (∀ x, SetUnfoldElemOf x X (QX x)) → (∀ x, SetUnfold (P x) (QP x)) → SetUnfold (set_Exists P X) (∃ x, QX x ∧ QP x). Proof. intros HX HP; constructor. unfold set_Exists. f_equiv; intros x. by rewrite (set_unfold (x ∈ X) _), (set_unfold (P x) _). Qed. Lemma set_Forall_empty : set_Forall P (∅ : C). Proof. set_solver. Qed. Lemma set_Forall_singleton x : set_Forall P ({[ x ]} : C) ↔ P x. Proof. set_solver. Qed. Lemma set_Forall_union X Y : set_Forall P X → set_Forall P Y → set_Forall P (X ∪ Y). Proof. set_solver. Qed. Lemma set_Forall_union_inv_1 X Y : set_Forall P (X ∪ Y) → set_Forall P X. Proof. set_solver. Qed. Lemma set_Forall_union_inv_2 X Y : set_Forall P (X ∪ Y) → set_Forall P Y. Proof. set_solver. Qed. Lemma set_Forall_list_to_set l : set_Forall P (list_to_set (C:=C) l) ↔ Forall P l. Proof. rewrite Forall_forall. set_solver. Qed. Lemma set_Exists_empty : ¬set_Exists P (∅ : C). Proof. set_solver. Qed. Lemma set_Exists_singleton x : set_Exists P ({[ x ]} : C) ↔ P x. Proof. set_solver. Qed. Lemma set_Exists_union_1 X Y : set_Exists P X → set_Exists P (X ∪ Y). Proof. set_solver. Qed. Lemma set_Exists_union_2 X Y : set_Exists P Y → set_Exists P (X ∪ Y). Proof. set_solver. Qed. Lemma set_Exists_union_inv X Y : set_Exists P (X ∪ Y) → set_Exists P X ∨ set_Exists P Y. Proof. set_solver. Qed. Lemma set_Exists_list_to_set l : set_Exists P (list_to_set (C:=C) l) ↔ Exists P l. Proof. rewrite Exists_exists. set_solver. Qed. End quantifiers. Section more_quantifiers. Context `{SemiSet A C}. Implicit Types X : C. Lemma set_Forall_impl (P Q : A → Prop) X : set_Forall P X → (∀ x, P x → Q x) → set_Forall Q X. Proof. set_solver. Qed. Lemma set_Exists_impl (P Q : A → Prop) X : set_Exists P X → (∀ x, P x → Q x) → set_Exists Q X. Proof. set_solver. Qed. End more_quantifiers. (** * Properties of implementations of sets that form a monad *) Section set_monad. Context `{MonadSet M}. Global Instance set_fmap_mono {A B} : Proper (pointwise_relation _ (=) ==> (⊆) ==> (⊆)) (@fmap M _ A B). Proof. intros f g ? X Y ?; set_solver by eauto. Qed. Global Instance set_bind_mono {A B} : Proper (pointwise_relation _ (⊆) ==> (⊆) ==> (⊆)) (@mbind M _ A B). Proof. unfold respectful, pointwise_relation; intros f g Hfg X Y ?. set_solver. Qed. Global Instance set_join_mono {A} : Proper ((⊆) ==> (⊆)) (@mjoin M _ A). Proof. intros X Y ?; set_solver. Qed. Lemma set_bind_singleton {A B} (f : A → M B) x : {[ x ]} ≫= f ≡ f x. Proof. set_solver. Qed. Lemma set_guard_True {A} `{Decision P} (X : M A) : P → (guard P; X) ≡ X. Proof. set_solver. Qed. Lemma set_fmap_compose {A B C} (f : A → B) (g : B → C) (X : M A) : g ∘ f <$> X ≡ g <$> (f <$> X). Proof. set_solver. Qed. Lemma elem_of_fmap_1 {A B} (f : A → B) (X : M A) (y : B) : y ∈ f <$> X → ∃ x, y = f x ∧ x ∈ X. Proof. set_solver. Qed. Lemma elem_of_fmap_2 {A B} (f : A → B) (X : M A) (x : A) : x ∈ X → f x ∈ f <$> X. Proof. set_solver. Qed. Lemma elem_of_fmap_2_alt {A B} (f : A → B) (X : M A) (x : A) (y : B) : x ∈ X → y = f x → y ∈ f <$> X. Proof. set_solver. Qed. Lemma elem_of_mapM {A B} (f : A → M B) l k : l ∈ mapM f k ↔ Forall2 (λ x y, x ∈ f y) l k. Proof. split. - revert l. induction k; set_solver by eauto. - induction 1; set_solver. Qed. Lemma set_mapM_length {A B} (f : A → M B) l k : l ∈ mapM f k → length l = length k. Proof. revert l; induction k; set_solver by eauto. Qed. Lemma elem_of_mapM_fmap {A B} (f : A → B) (g : B → M A) l k : Forall (λ x, ∀ y, y ∈ g x → f y = x) l → k ∈ mapM g l → fmap f k = l. Proof. intros Hl. revert k. induction Hl; set_solver. Qed. Lemma elem_of_mapM_Forall {A B} (f : A → M B) (P : B → Prop) l k : l ∈ mapM f k → Forall (λ x, ∀ y, y ∈ f x → P y) k → Forall P l. Proof. rewrite elem_of_mapM. apply Forall2_Forall_l. Qed. Lemma elem_of_mapM_Forall2_l {A B C} (f : A → M B) (P: B → C → Prop) l1 l2 k : l1 ∈ mapM f k → Forall2 (λ x y, ∀ z, z ∈ f x → P z y) k l2 → Forall2 P l1 l2. Proof. rewrite elem_of_mapM. intros Hl1. revert l2. induction Hl1; inversion_clear 1; constructor; auto. Qed. End set_monad. (** Finite sets *) Definition pred_finite {A} (P : A → Prop) := ∃ xs : list A, ∀ x, P x → x ∈ xs. Definition set_finite `{ElemOf A B} (X : B) := pred_finite (.∈ X). Definition pred_infinite {A} (P : A → Prop) := ∀ xs : list A, ∃ x, P x ∧ x ∉ xs. Definition set_infinite `{ElemOf A C} (X : C) := pred_infinite (.∈ X). Section pred_finite_infinite. Lemma pred_finite_impl {A} (P Q : A → Prop) : pred_finite P → (∀ x, Q x → P x) → pred_finite Q. Proof. unfold pred_finite. set_solver. Qed. Lemma pred_infinite_impl {A} (P Q : A → Prop) : pred_infinite P → (∀ x, P x → Q x) → pred_infinite Q. Proof. unfold pred_infinite. set_solver. Qed. (** If [f] is surjective onto [P], then pre-composing with [f] preserves infinity. *) Lemma pred_infinite_surj {A B} (P : B → Prop) (f : A → B) : (∀ x, P x → ∃ y, f y = x) → pred_infinite P → pred_infinite (P ∘ f). Proof. intros Hf HP xs. destruct (HP (f <$> xs)) as [x [HPx Hx]]. destruct (Hf _ HPx) as [y Hf']. exists y. split. - simpl. rewrite Hf'. done. - intros Hy. apply Hx. apply elem_of_list_fmap. eauto. Qed. Lemma pred_not_infinite_finite {A} (P : A → Prop) : pred_infinite P → pred_finite P → False. Proof. intros Hinf [xs ?]. destruct (Hinf xs). set_solver. Qed. Lemma pred_infinite_True `{Infinite A} : pred_infinite (λ _: A, True). Proof. intros xs. exists (fresh xs). split; [done|]. apply infinite_is_fresh. Qed. Lemma pred_finite_lt n : pred_finite (flip lt n). Proof. exists (seq 0 n); intros i Hi. apply (elem_of_list_lookup_2 _ i). by rewrite lookup_seq. Qed. Lemma pred_infinite_lt n : pred_infinite (lt n). Proof. intros l. exists (S (n `max` max_list l)). split; [lia| ]. intros H%max_list_elem_of_le; lia. Qed. Lemma pred_finite_le n : pred_finite (flip le n). Proof. eapply pred_finite_impl; [apply (pred_finite_lt (S n))|]; naive_solver lia. Qed. Lemma pred_infinite_le n : pred_infinite (le n). Proof. eapply pred_infinite_impl; [apply (pred_infinite_lt (S n))|]; naive_solver lia. Qed. End pred_finite_infinite. Section set_finite_infinite. Context `{SemiSet A C}. Implicit Types X Y : C. Lemma set_not_infinite_finite X : set_infinite X → set_finite X → False. Proof. apply pred_not_infinite_finite. Qed. Global Instance set_finite_subseteq : Proper (flip (⊆) ==> impl) (@set_finite A C _). Proof. intros X Y HX ?. eapply pred_finite_impl; set_solver. Qed. Global Instance set_finite_proper : Proper ((≡) ==> iff) (@set_finite A C _). Proof. intros X Y HX; apply exist_proper. by setoid_rewrite HX. Qed. Lemma empty_finite : set_finite (∅ : C). Proof. by exists []; intros ?; rewrite elem_of_empty. Qed. Lemma singleton_finite (x : A) : set_finite ({[ x ]} : C). Proof. exists [x]; intros y ->%elem_of_singleton; left. Qed. Lemma union_finite X Y : set_finite X → set_finite Y → set_finite (X ∪ Y). Proof. intros [lX ?] [lY ?]; exists (lX ++ lY); intros x. rewrite elem_of_union, elem_of_app; naive_solver. Qed. Lemma union_finite_inv_l X Y : set_finite (X ∪ Y) → set_finite X. Proof. intros [l ?]; exists l; set_solver. Qed. Lemma union_finite_inv_r X Y : set_finite (X ∪ Y) → set_finite Y. Proof. intros [l ?]; exists l; set_solver. Qed. Lemma list_to_set_finite l : set_finite (list_to_set (C:=C) l). Proof. exists l. intros x. by rewrite elem_of_list_to_set. Qed. Global Instance set_infinite_subseteq : Proper ((⊆) ==> impl) (@set_infinite A C _). Proof. intros X Y HX ?. eapply pred_infinite_impl; set_solver. Qed. Global Instance set_infinite_proper : Proper ((≡) ==> iff) (@set_infinite A C _). Proof. intros X Y HX; apply forall_proper. by setoid_rewrite HX. Qed. Lemma union_infinite_l X Y : set_infinite X → set_infinite (X ∪ Y). Proof. intros Hinf xs. destruct (Hinf xs). set_solver. Qed. Lemma union_infinite_r X Y : set_infinite Y → set_infinite (X ∪ Y). Proof. intros Hinf xs. destruct (Hinf xs). set_solver. Qed. End set_finite_infinite. Section more_finite. Context `{Set_ A C}. Implicit Types X Y : C. Lemma intersection_finite_l X Y : set_finite X → set_finite (X ∩ Y). Proof. intros [l ?]; exists l; intros x [??]%elem_of_intersection; auto. Qed. Lemma intersection_finite_r X Y : set_finite Y → set_finite (X ∩ Y). Proof. intros [l ?]; exists l; intros x [??]%elem_of_intersection; auto. Qed. Lemma difference_finite X Y : set_finite X → set_finite (X ∖ Y). Proof. intros [l ?]; exists l; intros x [??]%elem_of_difference; auto. Qed. Lemma difference_finite_inv X Y `{∀ x, Decision (x ∈ Y)} : set_finite Y → set_finite (X ∖ Y) → set_finite X. Proof. intros [l ?] [k ?]; exists (l ++ k). intros x ?; destruct (decide (x ∈ Y)); rewrite elem_of_app; set_solver. Qed. Lemma difference_infinite X Y : set_infinite X → set_finite Y → set_infinite (X ∖ Y). Proof. intros Hinf [xs ?] xs'. destruct (Hinf (xs ++ xs')). set_solver. Qed. End more_finite. Lemma top_infinite `{TopSet A C, Infinite A} : set_infinite (⊤ : C). Proof. intros xs. exists (fresh xs). split; [set_solver|]. apply infinite_is_fresh. Qed. (** This formulation of finiteness is stronger than [pred_finite]: when equality is decidable, it is equivalent to the predicate being finite AND decidable. *) Lemma dec_pred_finite_alt {A} (P : A → Prop) `{!∀ x, Decision (P x)} : pred_finite P ↔ ∃ xs : list A, ∀ x, P x ↔ x ∈ xs. Proof. split; intros [xs ?]. - exists (filter P xs). intros x. rewrite elem_of_list_filter. naive_solver. - exists xs. naive_solver. Qed. Lemma finite_sig_pred_finite {A} (P : A → Prop) `{Finite (sig P)} : pred_finite P. Proof. exists (proj1_sig <$> enum _). intros x px. apply elem_of_list_fmap_1_alt with (x ↾ px); [apply elem_of_enum|]; done. Qed. Lemma pred_finite_arg2 {A B} (P : A → B → Prop) x : pred_finite (uncurry P) → pred_finite (P x). Proof. intros [xys ?]. exists (xys.*2). intros y ?. apply elem_of_list_fmap_1_alt with (x, y); by auto. Qed. Lemma pred_finite_arg1 {A B} (P : A → B → Prop) y : pred_finite (uncurry P) → pred_finite (flip P y). Proof. intros [xys ?]. exists (xys.*1). intros x ?. apply elem_of_list_fmap_1_alt with (x, y); by auto. Qed. (** Sets of sequences of natural numbers *) (* The set [seq_seq start len] of natural numbers contains the sequence [start, start + 1, ..., start + (len-1)]. *) Fixpoint set_seq `{Singleton nat C, Union C, Empty C} (start len : nat) : C := match len with | O => ∅ | S len' => {[ start ]} ∪ set_seq (S start) len' end. Section set_seq. Context `{SemiSet nat C}. Implicit Types start len x : nat. Lemma elem_of_set_seq start len x : x ∈ set_seq (C:=C) start len ↔ start ≤ x < start + len. Proof. revert start. induction len as [|len IH]; intros start; simpl. - rewrite elem_of_empty. lia. - rewrite elem_of_union, elem_of_singleton, IH. lia. Qed. Global Instance set_unfold_seq start len x : SetUnfoldElemOf x (set_seq (C:=C) start len) (start ≤ x < start + len). Proof. constructor; apply elem_of_set_seq. Qed. Lemma set_seq_len_pos n start len : n ∈ set_seq (C:=C) start len → 0 < len. Proof. rewrite elem_of_set_seq. lia. Qed. Lemma set_seq_subseteq start1 len1 start2 len2 : 0 < len1 → set_seq (C:=C) start1 len1 ⊆ set_seq (C:=C) start2 len2 ↔ start2 ≤ start1 ∧ start1 + len1 ≤ start2 + len2. Proof. intros Hlen. set_unfold. split. - intros Hx. pose proof (Hx start1). pose proof (Hx (start1 + len1 - 1)). lia. - intros Heq x. lia. Qed. Lemma set_seq_subseteq_len_gt start1 len1 start2 len2 : set_seq (C:=C) start1 len1 ⊆ set_seq (C:=C) start2 len2 → len1 ≤ len2. Proof. destruct len1 as [|len1]. - set_unfold. lia. - rewrite set_seq_subseteq; lia. Qed. Lemma set_seq_add_disjoint start len1 len2 : set_seq (C:=C) start len1 ## set_seq (start + len1) len2. Proof. set_solver by lia. Qed. Lemma set_seq_add start len1 len2 : set_seq (C:=C) start (len1 + len2) ≡ set_seq start len1 ∪ set_seq (start + len1) len2. Proof. set_solver by lia. Qed. Lemma set_seq_add_L `{!LeibnizEquiv C} start len1 len2 : set_seq (C:=C) start (len1 + len2) = set_seq start len1 ∪ set_seq (start + len1) len2. Proof. unfold_leibniz. apply set_seq_add. Qed. Lemma set_seq_S_start_disjoint start len : {[ start ]} ## set_seq (C:=C) (S start) len. Proof. set_solver by lia. Qed. Lemma set_seq_S_start start len : set_seq (C:=C) start (S len) ≡ {[ start ]} ∪ set_seq (S start) len. Proof. set_solver by lia. Qed. Lemma set_seq_S_end_disjoint start len : {[ start + len ]} ## set_seq (C:=C) start len. Proof. set_solver by lia. Qed. Lemma set_seq_S_end_union start len : set_seq start (S len) ≡@{C} {[ start + len ]} ∪ set_seq start len. Proof. set_solver by lia. Qed. Lemma set_seq_S_end_union_L `{!LeibnizEquiv C} start len : set_seq start (S len) =@{C} {[ start + len ]} ∪ set_seq start len. Proof. unfold_leibniz. apply set_seq_S_end_union. Qed. Lemma list_to_set_seq start len : list_to_set (seq start len) =@{C} set_seq start len. Proof. revert start; induction len; intros; f_equal/=; auto. Qed. Lemma set_seq_finite start len : set_finite (set_seq (C:=C) start len). Proof. exists (seq start len); intros x. rewrite <-list_to_set_seq. set_solver. Qed. End set_seq. (** Mimimal elements *) Definition minimal `{ElemOf A C} (R : relation A) (x : A) (X : C) : Prop := ∀ y, y ∈ X → R y x → R x y. Global Instance: Params (@minimal) 5 := {}. Global Typeclasses Opaque minimal. Section minimal. Context `{SemiSet A C} {R : relation A}. Implicit Types X Y : C. Global Instance minimal_proper x : Proper ((≡@{C}) ==> iff) (minimal R x). Proof. intros X X' y; unfold minimal; set_solver. Qed. Lemma minimal_anti_symm_1 `{!AntiSymm (=) R} X x y : minimal R x X → y ∈ X → R y x → x = y. Proof. intros Hmin ??. apply (anti_symm _); auto. Qed. Lemma minimal_anti_symm `{!AntiSymm (=) R} X x : minimal R x X ↔ ∀ y, y ∈ X → R y x → x = y. Proof. unfold minimal; naive_solver eauto using minimal_anti_symm_1. Qed. Lemma minimal_strict_1 `{!StrictOrder R} X x y : minimal R x X → y ∈ X → ¬R y x. Proof. intros Hmin ??. destruct (irreflexivity R x); trans y; auto. Qed. Lemma minimal_strict `{!StrictOrder R} X x : minimal R x X ↔ ∀ y, y ∈ X → ¬R y x. Proof. unfold minimal; split; [eauto using minimal_strict_1|naive_solver]. Qed. Lemma empty_minimal x : minimal R x (∅ : C). Proof. unfold minimal; set_solver. Qed. Lemma singleton_minimal x : minimal R x ({[ x ]} : C). Proof. unfold minimal; set_solver. Qed. Lemma singleton_minimal_not_above y x : ¬R y x → minimal R x ({[ y ]} : C). Proof. unfold minimal; set_solver. Qed. Lemma union_minimal X Y x : minimal R x X → minimal R x Y → minimal R x (X ∪ Y). Proof. unfold minimal; set_solver. Qed. Lemma minimal_subseteq X Y x : minimal R x X → Y ⊆ X → minimal R x Y. Proof. unfold minimal; set_solver. Qed. Lemma minimal_weaken `{!Transitive R} X x x' : minimal R x X → R x' x → minimal R x' X. Proof. intros Hmin ? y ??. trans x; [done|]. by eapply (Hmin y), transitivity. Qed. End minimal. stdpp-coq-stdpp-1.9.0/stdpp/sorting.v000066400000000000000000000232641451153341500176020ustar00rootroot00000000000000(** Merge sort. Adapted from the implementation of Hugo Herbelin in the Coq standard library, but without using the module system. *) From Coq Require Export Sorted. From stdpp Require Export orders list. From stdpp Require Import options. Section merge_sort. Context {A} (R : relation A) `{∀ x y, Decision (R x y)}. Fixpoint list_merge (l1 : list A) : list A → list A := fix list_merge_aux l2 := match l1, l2 with | [], _ => l2 | _, [] => l1 | x1 :: l1, x2 :: l2 => if decide (R x1 x2) then x1 :: list_merge l1 (x2 :: l2) else x2 :: list_merge_aux l2 end. Global Arguments list_merge !_ !_ / : assert. Local Notation stack := (list (option (list A))). Fixpoint merge_list_to_stack (st : stack) (l : list A) : stack := match st with | [] => [Some l] | None :: st => Some l :: st | Some l' :: st => None :: merge_list_to_stack st (list_merge l' l) end. Fixpoint merge_stack (st : stack) : list A := match st with | [] => [] | None :: st => merge_stack st | Some l :: st => list_merge l (merge_stack st) end. Fixpoint merge_sort_aux (st : stack) (l : list A) : list A := match l with | [] => merge_stack st | x :: l => merge_sort_aux (merge_list_to_stack st [x]) l end. Definition merge_sort : list A → list A := merge_sort_aux []. End merge_sort. (** Helper definition for [Sorted_reverse] below *) Inductive TlRel {A} (R : relation A) (a : A) : list A → Prop := | TlRel_nil : TlRel R a [] | TlRel_cons b l : R b a → TlRel R a (l ++ [b]). (** ** Properties of the [Sorted] and [StronglySorted] predicate *) Section sorted. Context {A} (R : relation A). Lemma elem_of_StronglySorted_app l1 l2 x1 x2 : StronglySorted R (l1 ++ l2) → x1 ∈ l1 → x2 ∈ l2 → R x1 x2. Proof. induction l1 as [|x1' l1 IH]; simpl; [by rewrite elem_of_nil|]. intros [? Hall]%StronglySorted_inv [->|?]%elem_of_cons ?; [|by auto]. rewrite Forall_app, !Forall_forall in Hall. naive_solver. Qed. Lemma StronglySorted_app_inv_l l1 l2 : StronglySorted R (l1 ++ l2) → StronglySorted R l1. Proof. induction l1 as [|x1' l1 IH]; simpl; [|inversion_clear 1]; decompose_Forall; constructor; auto. Qed. Lemma StronglySorted_app_inv_r l1 l2 : StronglySorted R (l1 ++ l2) → StronglySorted R l2. Proof. induction l1 as [|x1' l1 IH]; simpl; [|inversion_clear 1]; decompose_Forall; auto. Qed. Lemma Sorted_StronglySorted `{!Transitive R} l : Sorted R l → StronglySorted R l. Proof. by apply Sorted.Sorted_StronglySorted. Qed. Lemma StronglySorted_unique `{!AntiSymm (=) R} l1 l2 : StronglySorted R l1 → StronglySorted R l2 → l1 ≡ₚ l2 → l1 = l2. Proof. intros Hl1; revert l2. induction Hl1 as [|x1 l1 ? IH Hx1]; intros l2 Hl2 E. { symmetry. by apply Permutation_nil. } destruct Hl2 as [|x2 l2 ? Hx2]. { by apply Permutation_nil_r in E. } assert (x1 = x2); subst. { rewrite Forall_forall in Hx1, Hx2. assert (x2 ∈ x1 :: l1) as Hx2' by (by rewrite E; left). assert (x1 ∈ x2 :: l2) as Hx1' by (by rewrite <-E; left). inversion Hx1'; inversion Hx2'; simplify_eq; auto. } f_equal. by apply IH, (inj (x2 ::.)). Qed. Lemma Sorted_unique `{!Transitive R, !AntiSymm (=) R} l1 l2 : Sorted R l1 → Sorted R l2 → l1 ≡ₚ l2 → l1 = l2. Proof. auto using StronglySorted_unique, Sorted_StronglySorted. Qed. Global Instance HdRel_dec x `{∀ y, Decision (R x y)} l : Decision (HdRel R x l). Proof. refine match l with | [] => left _ | y :: l => cast_if (decide (R x y)) end; abstract first [by constructor | by inversion 1]. Defined. Global Instance Sorted_dec `{∀ x y, Decision (R x y)} : ∀ l, Decision (Sorted R l). Proof. refine (fix go l := match l return Decision (Sorted R l) with | [] => left _ | x :: l => cast_if_and (decide (HdRel R x l)) (go l) end); clear go; abstract first [by constructor | by inversion 1]. Defined. Global Instance StronglySorted_dec `{∀ x y, Decision (R x y)} : ∀ l, Decision (StronglySorted R l). Proof. refine (fix go l := match l return Decision (StronglySorted R l) with | [] => left _ | x :: l => cast_if_and (decide (Forall (R x) l)) (go l) end); clear go; abstract first [by constructor | by inversion 1]. Defined. Section fmap. Context {B} (f : A → B). Lemma HdRel_fmap (R1 : relation A) (R2 : relation B) x l : (∀ y, R1 x y → R2 (f x) (f y)) → HdRel R1 x l → HdRel R2 (f x) (f <$> l). Proof. destruct 2; constructor; auto. Qed. Lemma Sorted_fmap (R1 : relation A) (R2 : relation B) l : (∀ x y, R1 x y → R2 (f x) (f y)) → Sorted R1 l → Sorted R2 (f <$> l). Proof. induction 2; simpl; constructor; eauto using HdRel_fmap. Qed. Lemma StronglySorted_fmap (R1 : relation A) (R2 : relation B) l : (∀ x y, R1 x y → R2 (f x) (f y)) → StronglySorted R1 l → StronglySorted R2 (f <$> l). Proof. induction 2; csimpl; constructor; rewrite ?Forall_fmap; eauto using Forall_impl. Qed. End fmap. Lemma HdRel_reverse l x : HdRel R x l → TlRel (flip R) x (reverse l). Proof. destruct 1; rewrite ?reverse_cons; by constructor. Qed. Lemma Sorted_snoc l x : Sorted R l → TlRel R x l → Sorted R (l ++ [x]). Proof. induction 1 as [|y l Hsort IH Hhd]; intros Htl; simpl. { repeat constructor. } constructor. - apply IH. inversion Htl as [|? [|??]]; simplify_list_eq; by constructor. - destruct Hhd; constructor; [|done]. inversion Htl as [|? [|??]]; by try discriminate_list. Qed. End sorted. Lemma Sorted_reverse {A} (R : relation A) l : Sorted R l → Sorted (flip R) (reverse l). Proof. induction 1; rewrite ?reverse_nil, ?reverse_cons; auto using Sorted_snoc, HdRel_reverse. Qed. (** ** Correctness of merge sort *) Section merge_sort_correct. Context {A} (R : relation A) `{∀ x y, Decision (R x y)}. Lemma list_merge_nil_l l2 : list_merge R [] l2 = l2. Proof. by destruct l2. Qed. Lemma list_merge_nil_r l1 : list_merge R l1 [] = l1. Proof. by destruct l1. Qed. Lemma list_merge_cons x1 x2 l1 l2 : list_merge R (x1 :: l1) (x2 :: l2) = if decide (R x1 x2) then x1 :: list_merge R l1 (x2 :: l2) else x2 :: list_merge R (x1 :: l1) l2. Proof. done. Qed. Lemma HdRel_list_merge x l1 l2 : HdRel R x l1 → HdRel R x l2 → HdRel R x (list_merge R l1 l2). Proof. destruct 1 as [|x1 l1 IH1], 1 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl; repeat case_decide; auto. Qed. Lemma Sorted_list_merge `{!Total R} l1 l2 : Sorted R l1 → Sorted R l2 → Sorted R (list_merge R l1 l2). Proof. intros Hl1. revert l2. induction Hl1 as [|x1 l1 IH1]; induction 1 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl; repeat case_decide; repeat match goal with H : ¬R _ _ |- _ => apply total_not in H end; constructor; eauto using HdRel_list_merge, HdRel_cons. Qed. Lemma merge_Permutation l1 l2 : list_merge R l1 l2 ≡ₚ l1 ++ l2. Proof. revert l2. induction l1 as [|x1 l1 IH1]; intros l2; induction l2 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl; repeat case_decide; auto. - by rewrite (right_id_L [] (++)). - by rewrite IH2, Permutation_middle. Qed. Local Notation stack := (list (option (list A))). Inductive merge_stack_Sorted : stack → Prop := | merge_stack_Sorted_nil : merge_stack_Sorted [] | merge_stack_Sorted_cons_None st : merge_stack_Sorted st → merge_stack_Sorted (None :: st) | merge_stack_Sorted_cons_Some l st : Sorted R l → merge_stack_Sorted st → merge_stack_Sorted (Some l :: st). Fixpoint merge_stack_flatten (st : stack) : list A := match st with | [] => [] | None :: st => merge_stack_flatten st | Some l :: st => l ++ merge_stack_flatten st end. Lemma Sorted_merge_list_to_stack `{!Total R} st l : merge_stack_Sorted st → Sorted R l → merge_stack_Sorted (merge_list_to_stack R st l). Proof. intros Hst. revert l. induction Hst; repeat constructor; naive_solver auto using Sorted_list_merge. Qed. Lemma merge_list_to_stack_Permutation st l : merge_stack_flatten (merge_list_to_stack R st l) ≡ₚ l ++ merge_stack_flatten st. Proof. revert l. induction st as [|[l'|] st IH]; intros l; simpl; auto. by rewrite IH, merge_Permutation, (assoc_L _), (comm (++) l). Qed. Lemma Sorted_merge_stack `{!Total R} st : merge_stack_Sorted st → Sorted R (merge_stack R st). Proof. induction 1; simpl; auto using Sorted_list_merge. Qed. Lemma merge_stack_Permutation st : merge_stack R st ≡ₚ merge_stack_flatten st. Proof. induction st as [|[] ? IH]; intros; simpl; auto. by rewrite merge_Permutation, IH. Qed. Lemma Sorted_merge_sort_aux `{!Total R} st l : merge_stack_Sorted st → Sorted R (merge_sort_aux R st l). Proof. revert st. induction l; simpl; auto using Sorted_merge_stack, Sorted_merge_list_to_stack. Qed. Lemma merge_sort_aux_Permutation st l : merge_sort_aux R st l ≡ₚ merge_stack_flatten st ++ l. Proof. revert st. induction l as [|?? IH]; simpl; intros. - by rewrite (right_id_L [] (++)), merge_stack_Permutation. - rewrite IH, merge_list_to_stack_Permutation; simpl. by rewrite Permutation_middle. Qed. Lemma Sorted_merge_sort `{!Total R} l : Sorted R (merge_sort R l). Proof. apply Sorted_merge_sort_aux. by constructor. Qed. Lemma merge_sort_Permutation l : merge_sort R l ≡ₚ l. Proof. unfold merge_sort. by rewrite merge_sort_aux_Permutation. Qed. Lemma StronglySorted_merge_sort `{!Transitive R, !Total R} l : StronglySorted R (merge_sort R l). Proof. auto using Sorted_StronglySorted, Sorted_merge_sort. Qed. End merge_sort_correct. stdpp-coq-stdpp-1.9.0/stdpp/ssreflect.v000066400000000000000000000007521451153341500201040ustar00rootroot00000000000000(** This file provides support for using std++ in combination with the ssreflect tactics. It patches up some global options of ssreflect. *) From Coq.ssr Require Export ssreflect. From stdpp Require Export prelude. From stdpp Require Import options. (** Restore Coq's normal "if" scope, ssr redefines it. *) Global Open Scope general_if_scope. (** See Coq issue #5706 *) Global Set SsrOldRewriteGoalsOrder. (** Overwrite ssr's [done] tactic with ours *) Ltac done := stdpp.tactics.done. stdpp-coq-stdpp-1.9.0/stdpp/streams.v000066400000000000000000000042171451153341500175700ustar00rootroot00000000000000From stdpp Require Export tactics. From stdpp Require Import options. Declare Scope stream_scope. Delimit Scope stream_scope with stream. Global Open Scope stream_scope. CoInductive stream (A : Type) : Type := scons : A → stream A → stream A. Global Arguments scons {_} _ _ : assert. Infix ":.:" := scons (at level 60, right associativity) : stream_scope. Bind Scope stream_scope with stream. Definition shead {A} (s : stream A) : A := match s with x :.: _ => x end. Definition stail {A} (s : stream A) : stream A := match s with _ :.: s => s end. CoInductive stream_equiv' {A} (s1 s2 : stream A) : Prop := scons_equiv' : shead s1 = shead s2 → stream_equiv' (stail s1) (stail s2) → stream_equiv' s1 s2. Global Instance stream_equiv {A} : Equiv (stream A) := stream_equiv'. Reserved Infix "!.!" (at level 20). Fixpoint slookup {A} (i : nat) (s : stream A) : A := match i with O => shead s | S i => stail s !.! i end where "s !.! i" := (slookup i s). Global Instance stream_fmap : FMap stream := λ A B f, cofix go s := f (shead s) :.: go (stail s). Fixpoint stake {A} (n : nat) (s : stream A) := match n with 0 => [] | S n => shead s :: stake n (stail s) end. CoFixpoint srepeat {A} (x : A) : stream A := x :.: srepeat x. Section stream_properties. Context {A : Type}. Implicit Types x y : A. Implicit Types s t : stream A. Lemma scons_equiv s1 s2 : shead s1 = shead s2 → stail s1 ≡ stail s2 → s1 ≡ s2. Proof. by constructor. Qed. Global Instance equal_equivalence : Equivalence (≡@{stream A}). Proof. split. - now cofix FIX; intros ?; constructor. - now cofix FIX; intros ?? [??]; constructor. - cofix FIX; intros ??? [??] [??]; constructor; etrans; eauto. Qed. Global Instance scons_proper x : Proper ((≡) ==> (≡)) (scons x). Proof. by constructor. Qed. Global Instance shead_proper : Proper ((≡) ==> (=@{A})) shead. Proof. by intros ?? [??]. Qed. Global Instance stail_proper : Proper ((≡) ==> (≡@{stream A})) stail. Proof. by intros ?? [??]. Qed. Global Instance slookup_proper i : Proper ((≡@{stream A}) ==> (=)) (slookup i). Proof. by induction i as [|i IH]; intros s1 s2 Hs; simpl; rewrite Hs. Qed. End stream_properties. stdpp-coq-stdpp-1.9.0/stdpp/stringmap.v000066400000000000000000000051171451153341500201160ustar00rootroot00000000000000(** This files implements an efficient implementation of finite maps whose keys range over Coq's data type of strings [string]. The implementation uses radix-2 search trees (uncompressed Patricia trees) as implemented in the file [pmap] and guarantees logarithmic-time operations. *) From stdpp Require Export fin_maps pretty. From stdpp Require Import gmap. From stdpp Require Import options. Notation stringmap := (gmap string). Notation stringset := (gset string). (** * Generating fresh strings *) Section stringmap. Local Open Scope N_scope. Let R {A} (s : string) (m : stringmap A) (n1 n2 : N) := n2 < n1 ∧ is_Some (m !! (s +:+ pretty (n1 - 1))). Lemma fresh_string_step {A} s (m : stringmap A) n x : m !! (s +:+ pretty n) = Some x → R s m (1 + n) n. Proof. split; [lia|]. replace (1 + n - 1) with n by lia; eauto. Qed. Lemma fresh_string_R_wf {A} s (m : stringmap A) : wf (R s m). Proof. induction (map_wf m) as [m _ IH]. intros n1; constructor; intros n2 [Hn Hs]. specialize (IH _ (delete_subset m (s +:+ pretty (n2 - 1)) Hs) n2). cut (n2 - 1 < n2); [|lia]. clear n1 Hn Hs; revert IH; generalize (n2 - 1). intros n1. induction 1 as [n2 _ IH]; constructor; intros n3 [??]. apply IH; [|lia]; split; [lia|]. by rewrite lookup_delete_ne by (intros ?; simplify_eq/=; lia). Qed. Definition fresh_string_go {A} (s : string) (m : stringmap A) (n : N) (go : ∀ n', R s m n' n → string) : string := let s' := s +:+ pretty n in match Some_dec (m !! s') with | inleft (_↾Hs') => go (1 + n)%N (fresh_string_step s m n _ Hs') | inright _ => s' end. Definition fresh_string {A} (s : string) (m : stringmap A) : string := match m !! s with | None => s | Some _ => Fix_F _ (fresh_string_go s m) (wf_guard 32 (fresh_string_R_wf s m) 0) end. Lemma fresh_string_fresh {A} (m : stringmap A) s : m !! fresh_string s m = None. Proof. unfold fresh_string. destruct (m !! s) as [a|] eqn:Hs; [clear a Hs|done]. generalize 0 (wf_guard 32 (fresh_string_R_wf s m) 0); revert m. fix FIX 3; intros m n [?]; simpl; unfold fresh_string_go at 1; simpl. destruct (Some_dec (m !! _)) as [[??]|?]; auto. Qed. Definition fresh_string_of_set (s : string) (X : stringset) : string := fresh_string s (mapset.mapset_car X). Lemma fresh_string_of_set_fresh (X : stringset) s : fresh_string_of_set s X ∉ X. Proof. apply eq_None_ne_Some, fresh_string_fresh. Qed. Fixpoint fresh_strings_of_set (s : string) (n : nat) (X : stringset) : list string := match n with | 0 => [] | S n => let x := fresh_string_of_set s X in x :: fresh_strings_of_set s n ({[ x ]} ∪ X) end%nat. End stringmap. stdpp-coq-stdpp-1.9.0/stdpp/strings.v000066400000000000000000000121121451153341500175740ustar00rootroot00000000000000From Coq Require Import Ascii. From Coq Require Export String. From stdpp Require Export list. From stdpp Require Import countable. From stdpp Require Import options. (* To avoid randomly ending up with String.length because this module is imported hereditarily somewhere. *) Notation length := List.length. (** * Fix scopes *) Global Open Scope string_scope. (* Make sure [list_scope] has priority over [string_scope], so that the "++" notation designates list concatenation. *) Global Open Scope list_scope. Infix "+:+" := String.append (at level 60, right associativity) : stdpp_scope. Global Arguments String.append : simpl never. (** * Decision of equality *) Global Instance ascii_eq_dec : EqDecision ascii := ascii_dec. Global Instance string_eq_dec : EqDecision string. Proof. solve_decision. Defined. Global Instance string_app_inj s1 : Inj (=) (=) (String.append s1). Proof. intros ???. induction s1; simplify_eq/=; f_equal/=; auto. Qed. Global Instance string_inhabited : Inhabited string := populate "". (* Reverse *) Fixpoint string_rev_app (s1 s2 : string) : string := match s1 with | "" => s2 | String a s1 => string_rev_app s1 (String a s2) end. Definition string_rev (s : string) : string := string_rev_app s "". Definition is_nat (x : ascii) : option nat := match x with | "0" => Some 0 | "1" => Some 1 | "2" => Some 2 | "3" => Some 3 | "4" => Some 4 | "5" => Some 5 | "6" => Some 6 | "7" => Some 7 | "8" => Some 8 | "9" => Some 9 | _ => None end%char. (* Break a string up into lists of words, delimited by white space *) Definition is_space (x : Ascii.ascii) : bool := match x with | "009" | "010" | "011" | "012" | "013" | " " => true | _ => false end%char. Fixpoint words_go (cur : option string) (s : string) : list string := match s with | "" => option_list (string_rev <$> cur) | String a s => if is_space a then option_list (string_rev <$> cur) ++ words_go None s else words_go (Some (from_option (String a) (String a "") cur)) s end. Definition words : string → list string := words_go None. Ltac words s := match type of s with | list string => s | string => eval vm_compute in (words s) end. (** * Encoding and decoding *) (** The [Countable] instance of [string] is particularly useful to allow strings to be used as keys in [gmap]. The encoding of [string] to [positive] is taken from https://github.com/xavierleroy/canonical-binary-tries/blob/v2/lib/String2pos.v. It avoids creating auxilary data structures such as [list bool], thereby improving efficiency. *) Local Definition bool_cons_pos (b : bool) (p : positive) : positive := if b then p~1 else p~0. Local Definition ascii_cons_pos (c : ascii) (p : positive) : positive := match c with | Ascii b0 b1 b2 b3 b4 b5 b6 b7 => bool_cons_pos b0 $ bool_cons_pos b1 $ bool_cons_pos b2 $ bool_cons_pos b3 $ bool_cons_pos b4 $ bool_cons_pos b5 $ bool_cons_pos b6 $ bool_cons_pos b7 p end. Local Fixpoint string_to_pos (s : string) : positive := match s with | EmptyString => 1 | String c s => ascii_cons_pos c (string_to_pos s) end. (* The decoder that turns [positive] into string results in 256 cases (we need to peel off 8 times a [~0]/[~1] constructor) and a number of fall through cases. We avoid writing these cases explicitly by generating the definition using Ltac. The lemma [string_of_to_pos] ensures the generated definition is correct. Alternatively, we could implement it in two steps. Convert the [positive] to [list bool], and convert the list to [string]. This definition will be slower since auxilary data structures are created. *) Local Fixpoint pos_to_string (p : positive) : string. Proof. (** The argument [p] is the [positive] that we are peeling off. The argument [a] is the constructor [Ascii] partially applied to some number of Booleans (so its Coq type changes during the iteration). The argument [n] says how many more Booleans are needed to make this fully applied so that the [constr] has type ascii. *) let rec gen p a n := lazymatch n with (* This character is done. Stop the ltac recursion; recursively invoke [pos_to_string] on the Gallina level for the remaining bits. *) | 0 => exact (String a (pos_to_string p)) (* There are more bits to consume for this character, generate an appropriate [match] with ltac. *) | S ?n => exact (match p with | 1 => EmptyString | p~0 => ltac:(gen p (a false) n) | p~1 => ltac:(gen p (a true) n) end%positive) end in gen p Ascii 8. Defined. Local Lemma pos_to_string_string_to_pos s : pos_to_string (string_to_pos s) = s. Proof. induction s as [|[[][][][][][][][]]]; by f_equal/=. Qed. Global Program Instance string_countable : Countable string := {| encode := string_to_pos; decode p := Some (pos_to_string p) |}. Solve Obligations with naive_solver eauto using pos_to_string_string_to_pos with f_equal. Global Instance ascii_countable : Countable ascii := inj_countable (λ a, String a EmptyString) (λ s, match s with String a _ => Some a | _ => None end) (λ a, eq_refl). stdpp-coq-stdpp-1.9.0/stdpp/tactics.v000066400000000000000000001056011451153341500175430ustar00rootroot00000000000000(** This file collects general purpose tactics that are used throughout the development. *) From Coq Require Export Lia. From stdpp Require Export decidable. From stdpp Require Import options. Lemma f_equal_dep {A B} (f g : ∀ x : A, B x) x : f = g → f x = g x. Proof. intros ->; reflexivity. Qed. Lemma f_equal_help {A B} (f g : A → B) x y : f = g → x = y → f x = g y. Proof. intros -> ->; reflexivity. Qed. Ltac f_equal := let rec go := match goal with | _ => reflexivity | _ => apply f_equal_help; [go|try reflexivity] | |- ?f ?x = ?g ?x => apply (f_equal_dep f g); go end in try go. (** We declare hint databases [f_equal], [congruence] and [lia] and containing solely the tactic corresponding to its name. These hint database are useful in to be combined in combination with other hint database. *) Global Hint Extern 998 (_ = _) => f_equal : f_equal. Global Hint Extern 999 => congruence : congruence. Global Hint Extern 1000 => lia : lia. Global Hint Extern 1001 => progress subst : subst. (** backtracking on this one will be very bad, so use with care! *) (** The tactic [intuition] expands to [intuition auto with *] by default. This is rather inefficient when having big hint databases, or expensive [Hint Extern] declarations as the ones above. *) Ltac intuition_solver ::= auto. (** The [fast_reflexivity] tactic only works on syntactically equal terms. It can be used to avoid expensive failing unification. *) Ltac fast_reflexivity := match goal with | |- _ ?x ?x => solve [simple apply reflexivity] end. (** [done] can get slow as it calls "trivial". [fast_done] can solve way less goals, but it will also always finish quickly. We do 'reflexivity' last because for goals of the form ?x = y, if we have x = y in the context, we will typically want to use the assumption and not reflexivity *) Ltac fast_done := solve [ eassumption | symmetry; eassumption | apply not_symmetry; eassumption | reflexivity ]. Tactic Notation "fast_by" tactic(tac) := tac; fast_done. Class TCFastDone (P : Prop) : Prop := tc_fast_done : P. Global Hint Extern 1 (TCFastDone ?P) => (change P; fast_done) : typeclass_instances. (** A slightly modified version of Ssreflect's finishing tactic [done]. It also performs [reflexivity] and uses symmetry of negated equalities. Compared to Ssreflect's [done], it does not compute the goal's [hnf] so as to avoid unfolding setoid equalities. Note that this tactic performs much better than Coq's [easy] tactic as it does not perform [inversion]. *) Ltac done := solve [ repeat first [ fast_done | solve [trivial] (* All the tactics below will introduce themselves anyway, or make no sense for goals of product type. So this is a good place for us to do it. *) | progress intros | solve [symmetry; trivial] | solve [apply not_symmetry; trivial] | discriminate | contradiction | split | match goal with H : ¬_ |- _ => case H; clear H; fast_done end ] ]. Tactic Notation "by" tactic(tac) := tac; done. Ltac done_if b := match b with | true => done | false => idtac end. (** Aliases for transitivity and etransitivity that are easier to type *) Tactic Notation "trans" constr(A) := transitivity A. Tactic Notation "etrans" := etransitivity. (** Tactics for splitting conjunctions: - [split_and] : split the goal if is syntactically of the shape [_ ∧ _] - [split_and?] : split the goal repeatedly (perhaps zero times) while it is of the shape [_ ∧ _]. - [split_and!] : works similarly, but at least one split should succeed. In order to do so, it will head normalize the goal first to possibly expose a conjunction. Note that [split_and] differs from [split] by only splitting conjunctions. The [split] tactic splits any inductive with one constructor. - [destruct_and? H] : destruct assumption [H] repeatedly (perhaps zero times) while it is of the shape [_ ∧ _]. - [destruct_and! H] : works similarly, but at least one destruct should succeed. In order to do so, it will head normalize the goal first to possibly expose a conjunction. - [destruct_and?] iterates [destruct_or? H] on every matching assumption [H]. - [destruct_and!] works similarly, but at least one destruct should succeed. *) Tactic Notation "split_and" := match goal with | |- _ ∧ _ => split | |- Is_true (_ && _) => apply andb_True; split end. Tactic Notation "split_and" "?" := repeat split_and. Tactic Notation "split_and" "!" := hnf; split_and; split_and?. Ltac destruct_and_go H := try lazymatch type of H with | True => clear H | _ ∧ _ => let H1 := fresh in let H2 := fresh in destruct H as [ H1 H2 ]; destruct_and_go H1; destruct_and_go H2 | Is_true (bool_decide _) => apply (bool_decide_unpack _) in H; destruct_and_go H | Is_true (_ && _) => apply andb_True in H; destruct_and_go H end. Tactic Notation "destruct_and" "?" ident(H) := destruct_and_go H. Tactic Notation "destruct_and" "!" ident(H) := hnf in H; progress (destruct_and? H). Tactic Notation "destruct_and" "?" := repeat match goal with H : _ |- _ => progress (destruct_and? H) end. Tactic Notation "destruct_and" "!" := progress destruct_and?. (** Tactics for splitting disjunctions in an assumption: - [destruct_or? H] : destruct the assumption [H] repeatedly (perhaps zero times) while it is of the shape [_ ∨ _]. - [destruct_or! H] : works similarly, but at least one destruct should succeed. In order to do so, it will head normalize the goal first to possibly expose a disjunction. - [destruct_or?] iterates [destruct_or? H] on every matching assumption [H]. - [destruct_or!] works similarly, but at least one destruct should succeed. *) Tactic Notation "destruct_or" "?" ident(H) := repeat match type of H with | False => destruct H | _ ∨ _ => destruct H as [H|H] | Is_true (bool_decide _) => apply (bool_decide_unpack _) in H | Is_true (_ || _) => apply orb_True in H; destruct H as [H|H] end. Tactic Notation "destruct_or" "!" ident(H) := hnf in H; progress (destruct_or? H). Tactic Notation "destruct_or" "?" := repeat match goal with H : _ |- _ => progress (destruct_or? H) end. Tactic Notation "destruct_or" "!" := progress destruct_or?. (** The tactic [case_match] destructs an arbitrary match in the conclusion or assumptions, and generates a corresponding equality. This tactic is best used together with the [repeat] tactical. *) Tactic Notation "case_match" "eqn" ":" ident(Hd) := match goal with | H : context [ match ?x with _ => _ end ] |- _ => destruct x eqn:Hd | |- context [ match ?x with _ => _ end ] => destruct x eqn:Hd end. Ltac case_match := let H := fresh in case_match eqn:H. (** The tactic [unless T by tac_fail] succeeds if [T] is not provable by the tactic [tac_fail]. *) Tactic Notation "unless" constr(T) "by" tactic3(tac_fail) := first [assert T by tac_fail; fail 1 | idtac]. (** The tactic [repeat_on_hyps tac] repeatedly applies [tac] in unspecified order on all hypotheses until it cannot be applied to any hypothesis anymore. *) Tactic Notation "repeat_on_hyps" tactic3(tac) := repeat match goal with H : _ |- _ => progress tac H end. (** The tactic [clear dependent H1 ... Hn] clears the hypotheses [Hi] and their dependencies. *) Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) := clear dependent H1; clear dependent H2. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) := clear dependent H1 H2; clear dependent H3. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) := clear dependent H1 H2 H3; clear dependent H4. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) := clear dependent H1 H2 H3 H4; clear dependent H5. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) hyp (H6) := clear dependent H1 H2 H3 H4 H5; clear dependent H6. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) hyp (H6) hyp(H7) := clear dependent H1 H2 H3 H4 H5 H6; clear dependent H7. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) hyp (H6) hyp(H7) hyp(H8) := clear dependent H1 H2 H3 H4 H5 H6 H7; clear dependent H8. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) hyp (H6) hyp(H7) hyp(H8) hyp(H9) := clear dependent H1 H2 H3 H4 H5 H6 H7 H8; clear dependent H9. Tactic Notation "clear" "dependent" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) hyp (H6) hyp(H7) hyp(H8) hyp(H9) hyp(H10) := clear dependent H1 H2 H3 H4 H5 H6 H7 H8 H9; clear dependent H10. (** The tactic [is_non_dependent H] determines whether the goal's conclusion or hypotheses depend on [H]. *) Tactic Notation "is_non_dependent" constr(H) := match goal with | _ : context [ H ] |- _ => fail 1 | |- context [ H ] => fail 1 | _ => idtac end. (** The tactic [var_eq x y] fails if [x] and [y] are unequal, and [var_neq] does the converse. *) Ltac var_eq x1 x2 := match x1 with x2 => idtac | _ => fail 1 end. Ltac var_neq x1 x2 := match x1 with x2 => fail 1 | _ => idtac end. (** The tactic [mk_evar T] returns a new evar of type [T], without affecting the current context. This is usually a more useful behavior than Coq's [evar], which is a side-effecting tactic (not returning anything) that introduces a local definition into the context that holds the evar. Note that the obvious alternative [open_constr (_:T)] has subtly different behavior, see std++ issue 115. Usually, Ltacs cannot return a value and have a side-effect, but we use the trick described at to work around that: wrap the side-effect in a [match goal]. *) Ltac mk_evar T := let T := constr:(T : Type) in let e := fresh in let _ := match goal with _ => evar (e:T) end in let e' := eval unfold e in e in let _ := match goal with _ => clear e end in e'. (** The tactic [get_head t] returns the head function [f] when [t] is of the shape [f a1 ... aN]. This is purely syntactic, no unification is performed. *) Ltac get_head e := lazymatch e with | ?h _ => get_head h | _ => e end. (** The tactic [eunify x y] succeeds if [x] and [y] can be unified, and fails otherwise. If it succeeds, it will instantiate necessary evars in [x] and [y]. Contrary to Coq's standard [unify] tactic, which uses [constr] for the arguments [x] and [y], [eunify] uses [open_constr] so that one can use holes (i.e., [_]s). For example, it allows one to write [eunify x (S _)], which will test if [x] unifies a successor. *) Tactic Notation "eunify" open_constr(x) open_constr(y) := unify x y. (** Operational type class projections in recursive calls are not folded back appropriately by [simpl]. The tactic [csimpl] uses the [fold_classes] tactics to refold recursive calls of [fmap], [mbind], [omap] and [alter]. A self-contained example explaining the problem can be found in the following Coq-club message: https://sympa.inria.fr/sympa/arc/coq-club/2012-10/msg00147.html *) Ltac fold_classes := repeat match goal with | |- context [ ?F ] => progress match type of F with | FMap _ => change F with (@fmap _ F); repeat change (@fmap _ (@fmap _ F)) with (@fmap _ F) | MBind _ => change F with (@mbind _ F); repeat change (@mbind _ (@mbind _ F)) with (@mbind _ F) | OMap _ => change F with (@omap _ F); repeat change (@omap _ (@omap _ F)) with (@omap _ F) | Alter _ _ _ => change F with (@alter _ _ _ F); repeat change (@alter _ _ _ (@alter _ _ _ F)) with (@alter _ _ _ F) end end. Ltac fold_classes_hyps H := repeat match type of H with | context [ ?F ] => progress match type of F with | FMap _ => change F with (@fmap _ F) in H; repeat change (@fmap _ (@fmap _ F)) with (@fmap _ F) in H | MBind _ => change F with (@mbind _ F) in H; repeat change (@mbind _ (@mbind _ F)) with (@mbind _ F) in H | OMap _ => change F with (@omap _ F) in H; repeat change (@omap _ (@omap _ F)) with (@omap _ F) in H | Alter _ _ _ => change F with (@alter _ _ _ F) in H; repeat change (@alter _ _ _ (@alter _ _ _ F)) with (@alter _ _ _ F) in H end end. Tactic Notation "csimpl" "in" hyp(H) := try (progress simpl in H; fold_classes_hyps H). Tactic Notation "csimpl" := try (progress simpl; fold_classes). Tactic Notation "csimpl" "in" "*" := repeat_on_hyps (fun H => csimpl in H); csimpl. (** The tactic [simplify_eq] repeatedly substitutes, discriminates, and injects equalities, and tries to contradict impossible inequalities. *) Tactic Notation "simplify_eq" := repeat match goal with | H : _ ≠ _ |- _ => by case H; try clear H | H : _ = _ → False |- _ => by case H; try clear H | H : ?x = _ |- _ => subst x | H : _ = ?x |- _ => subst x | H : _ = _ |- _ => discriminate H | H : _ ≡ _ |- _ => apply leibniz_equiv in H | H : ?f _ = ?f _ |- _ => apply (inj f) in H | H : ?f _ _ = ?f _ _ |- _ => apply (inj2 f) in H; destruct H (* before [injection] to circumvent bug #2939 in some situations *) | H : ?f _ = ?f _ |- _ => progress injection H as H (* first hyp will be named [H], subsequent hyps will be given fresh names *) | H : ?f _ _ = ?f _ _ |- _ => progress injection H as H | H : ?f _ _ _ = ?f _ _ _ |- _ => progress injection H as H | H : ?f _ _ _ _ = ?f _ _ _ _ |- _ => progress injection H as H | H : ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _ => progress injection H as H | H : ?f _ _ _ _ _ _ = ?f _ _ _ _ _ _ |- _ => progress injection H as H | H : ?x = ?x |- _ => clear H (* unclear how to generalize the below *) | H1 : ?o = Some ?x, H2 : ?o = Some ?y |- _ => assert (y = x) by congruence; clear H2 | H1 : ?o = Some ?x, H2 : ?o = None |- _ => congruence | H : @existT ?A _ _ _ = existT _ _ |- _ => apply (Eqdep_dec.inj_pair2_eq_dec _ (decide_rel (=@{A}))) in H end. Tactic Notation "simplify_eq" "/=" := repeat (progress csimpl in * || simplify_eq). Tactic Notation "f_equal" "/=" := csimpl in *; f_equal. Ltac setoid_subst_aux R x := match goal with | H : R x ?y |- _ => is_var x; try match y with x _ => fail 2 end; repeat match goal with | |- context [ x ] => setoid_rewrite H | H' : context [ x ] |- _ => try match H' with H => fail 2 end; setoid_rewrite H in H' end; clear x H end. Ltac setoid_subst := repeat match goal with | _ => progress simplify_eq/= | H : @equiv ?A ?e ?x _ |- _ => setoid_subst_aux (@equiv A e) x | H : @equiv ?A ?e _ ?x |- _ => symmetry in H; setoid_subst_aux (@equiv A e) x end. (** f_equiv works on goals of the form [f _ = f _], for any relation and any number of arguments. It looks for an appropriate [Proper] instance, and applies it. The tactic is somewhat limited, since it cannot be used to backtrack on the Proper instances that has been found. To that end, we try to avoid the trivial instance in which the resulting goals have an [eq]. More generally, we try to "maintain" the relation of the current goal. For example, when having [Proper (equiv ==> dist) f] and [Proper (dist ==> dist) f], it will favor the second because the relation (dist) stays the same. *) Ltac f_equiv := match goal with | |- pointwise_relation _ _ _ _ => intros ? (* We support matches on both sides, *if* they concern the same variable, or variables in some relation. *) | |- ?R (match ?x with _ => _ end) (match ?x with _ => _ end) => destruct x | H : ?R ?x ?y |- ?R2 (match ?x with _ => _ end) (match ?y with _ => _ end) => destruct H (* First assume that the arguments need the same relation as the result. We check the most restrictive pattern first: [(?f _) (?f _)] requires all but the last argument to be syntactically equal. *) | |- ?R (?f _) (?f _) => simple apply (_ : Proper (R ==> R) f) | |- ?R (?f _ _) (?f _ _) => simple apply (_ : Proper (R ==> R ==> R) f) | |- ?R (?f _ _ _) (?f _ _ _) => simple apply (_ : Proper (R ==> R ==> R ==> R) f) | |- ?R (?f _ _ _ _) (?f _ _ _ _) => simple apply (_ : Proper (R ==> R ==> R ==> R ==> R) f) | |- ?R (?f _ _ _ _ _) (?f _ _ _ _ _) => simple apply (_ : Proper (R ==> R ==> R ==> R ==> R ==> R) f) (* For the case in which R is polymorphic, or an operational type class, like equiv. *) | |- (?R _) (?f _) (?f _) => simple apply (_ : Proper (R _ ==> R _) f) | |- (?R _ _) (?f _) (?f _) => simple apply (_ : Proper (R _ _ ==> R _ _) f) | |- (?R _ _ _) (?f _) (?f _) => simple apply (_ : Proper (R _ _ _ ==> R _ _ _) f) | |- (?R _) (?f _ _) (?f _ _) => simple apply (_ : Proper (R _ ==> R _ ==> R _) f) | |- (?R _ _) (?f _ _) (?f _ _) => simple apply (_ : Proper (R _ _ ==> R _ _ ==> R _ _) f) | |- (?R _ _ _) (?f _ _) (?f _ _) => simple apply (_ : Proper (R _ _ _ ==> R _ _ _ ==> R _ _ _) f) | |- (?R _) (?f _ _ _) (?f _ _ _) => simple apply (_ : Proper (R _ ==> R _ ==> R _ ==> R _) f) | |- (?R _ _) (?f _ _ _) (?f _ _ _) => simple apply (_ : Proper (R _ _ ==> R _ _ ==> R _ _ ==> R _ _) f) | |- (?R _ _ _) (?f _ _ _) (?f _ _ _) => simple apply (_ : Proper (R _ _ _ ==> R _ _ _ ==> R _ _ _ ==> R _ _ _) f) | |- (?R _) (?f _ _ _ _) (?f _ _ _ _) => simple apply (_ : Proper (R _ ==> R _ ==> R _ ==> R _ ==> R _) f) | |- (?R _ _) (?f _ _ _ _) (?f _ _ _ _) => simple apply (_ : Proper (R _ _ ==> R _ _ ==> R _ _ ==> R _ _ ==> R _ _) f) | |- (?R _ _ _) (?f _ _ _ _) (?f _ _ _ _) => simple apply (_ : Proper (R _ _ _ ==> R _ _ _ ==> R _ _ _ ==> R _ _ _ ==> R _ _ _) f) | |- (?R _) (?f _ _ _ _ _) (?f _ _ _ _ _) => simple apply (_ : Proper (R _ ==> R _ ==> R _ ==> R _ ==> R _ ==> R _) f) | |- (?R _ _) (?f _ _ _ _ _) (?f _ _ _ _ _) => simple apply (_ : Proper (R _ _ ==> R _ _ ==> R _ _ ==> R _ _ ==> R _ _ ==> R _ _) f) | |- (?R _ _ _) (?f _ _ _ _ _) (?f _ _ _ _ _) => simple apply (_ : Proper (R _ _ _ ==> R _ _ _ ==> R _ _ _ ==> R _ _ _ ==> R _ _ _ ==> R _ _ _) f) (* In case the function symbol differs, but the arguments are the same, maybe we have a relation about those functions in our context that we can simply apply. (The case where the arguments differ is a lot more complicated; with the way we typically define the relations on function spaces it further requires [Proper]ness of [f] or [g]). *) | H : _ ?f ?g |- ?R (?f ?x) (?g ?x) => solve [simple apply H] | H : _ ?f ?g |- ?R (?f ?x ?y) (?g ?x ?y) => solve [simple apply H] (* Fallback case: try to infer the relation, and allow the function to not be syntactically the same on both sides. Unfortunately, very often, it will turn the goal into a Leibniz equality so we get stuck. Furthermore, looking for instances in this order will mean that Coq will try to unify the remaining arguments that we have not explicitly generalized, which can be very slow -- but if we go for the opposite order, we will hit the Leibniz equality fallback instance even more often. *) (* TODO: Can we exclude that Leibniz equality instance? *) | |- ?R (?f _) _ => simple apply (_ : Proper (_ ==> R) f) | |- ?R (?f _ _) _ => simple apply (_ : Proper (_ ==> _ ==> R) f) | |- ?R (?f _ _ _) _ => simple apply (_ : Proper (_ ==> _ ==> _ ==> R) f) | |- ?R (?f _ _ _ _) _ => simple apply (_ : Proper (_ ==> _ ==> _ ==> _ ==> R) f) | |- ?R (?f _ _ _ _ _) _ => simple apply (_ : Proper (_ ==> _ ==> _ ==> _ ==> _ ==> R) f) (* Similar to [f_equal] also handle the reflexivity case. *) | |- _ ?x ?x => fast_reflexivity end; (* Similar to [f_equal] immediately solve trivial goals *) try fast_reflexivity. Tactic Notation "f_equiv" "/=" := csimpl in *; f_equiv. (** The tactic [solve_proper_unfold] unfolds the first head symbol, so that we proceed by repeatedly using [f_equiv]. *) Ltac solve_proper_unfold := (* Try unfolding the head symbol, which is the one we are proving a new property about *) try lazymatch goal with | |- ?R ?t1 ?t2 => let h1 := get_head t1 in let h2 := get_head t2 in unify h1 h2; unfold h1 end. (** [solve_proper_prepare] does some preparation work before the main [solve_proper] loop. Having this as a separate tactic is useful for debugging [solve_proper] failure. *) Ltac solve_proper_prepare := (* Introduce everything *) intros; repeat lazymatch goal with | |- Proper _ _ => intros ??? | |- (_ ==> _)%signature _ _ => intros ??? | |- pointwise_relation _ _ _ _ => intros ? | |- ?R ?f _ => (* Deal with other cases where we have an equivalence relation on functions (e.g. a [pointwise_relation] that is hidden in some form in [R]). We do this by checking if the arguments of the relation are actually functions, and then forcefully introduce one ∀ and introduce the remaining ∀s that show up in the goal. To check that we actually have an equivalence relation on functions, we try to eta expand [f], which will only succeed if [f] is actually a function. *) let f' := constr:(λ x, f x) in (* Now forcefully introduce the first ∀ and other ∀s that show up in the goal afterwards. *) intros ?; intros end; simplify_eq; (* We try with and without unfolding. We have to backtrack on that because unfolding may succeed, but then the proof may fail. *) (solve_proper_unfold + idtac); simpl. (** The tactic [solve_proper_core tac] solves goals of the form "Proper (R1 ==> R2)", for any number of relations. The actual work is done by repeatedly applying [tac]. *) Ltac solve_proper_core tac := solve_proper_prepare; (* Now do the job. *) solve [repeat first [eassumption | tac ()] ]. (** Finally, [solve_proper] tries to apply [f_equiv] in a loop. *) Ltac solve_proper := solve_proper_core ltac:(fun _ => f_equiv). (** The tactic [intros_revert tac] introduces all foralls/arrows, performs tac, and then reverts them. *) Ltac intros_revert tac := lazymatch goal with | |- ∀ _, _ => let H := fresh in intro H; intros_revert tac; revert H | |- _ => tac end. (** The tactic [iter tac l] runs [tac x] for each element [x ∈ l] until [tac x] succeeds. If it does not suceed for any element of the generated list, the whole tactic wil fail. *) Tactic Notation "iter" tactic(tac) tactic(l) := let rec go l := match l with ?x :: ?l => tac x || go l end in go l. (** * The "o" family of tactics equips [pose proof], [destruct], [inversion], [generalize] and [specialize] with support for "o"pen terms. You can leave underscores that become evars or subgoals, similar to [refine]. You can suffix the tactic with [*] (e.g., [opose proof*]) to eliminate all remaining ∀ and → (i.e., add underscores for the remaining arguments). For [odestruct] and [oinversion], eliminating all remaining ∀ and → is the default (hence there is no [*] version). *) (** The helper [opose_core p tac] takes a uconstr [p] and turns it into a constr that is passed to [tac]. All underscores inside [p] become evars, and the ones that are unifiable (i.e, appear in the type of other evars) are shelved. This is similar to creating a [open_constr], except that we have control over what does and does not get shelved. Creating a [open_constr] would shelve every created evar, which is not what we want, and it is hard to avoid since it happens very early (before we can easily wrap things in [unshelve]). *) Ltac opose_core p tac := (* The "opose_internal" here is useful for debugging but not helpful for name collisions since it gets ignored with name mangling. The [clear] below is what ensures we don't get name collisions. *) let i := fresh "opose_internal" in unshelve (epose _ as i); [shelve (*type of [p]*) |refine p (* will create the subgoals, and shelve some of them *) |(* Now we have [i := t] in the context, let's get the [t] and remove [i]. *) let t := eval unfold i in i in (* We want to leave the context exactly as we found it, to avoid any issues with fresh name generation. So clear [i] before calling the user-visible tactic. *) clear i; tac t]; (* [tac] might have added more subgoals, making some existing ones unifiable, so we need to shelve again. *) shelve_unifiable. (** Turn all leading ∀ and → of [p] into evars (∀-evars will be shelved), and call [tac] with the term applied with those evars. This fill unfold definitions to find leading ∀/→. [_name_guard] is an unused argument where you can pass anything you want. If the argument is an intro pattern, those will be taken into account by the [fresh] that is inside this tactic, avoiding name collisions that can otherwise arise. This is a work-around for https://github.com/coq/coq/issues/18109. *) Ltac ospecialize_foralls p _name_guard tac := let T := type of p in lazymatch eval hnf in T with | ?T1 → ?T2 => (* This is the [fresh] where the presence of [_name_guard] matters. Note that the "opose_internal" is nice but not sufficient because it gets ignored when name mangling is enabled. *) let pT1 := fresh "opose_internal" in assert T1 as pT1; [| ospecialize_foralls (p pT1) _name_guard tac; clear pT1] | ∀ x : ?T1, _ => let e := mk_evar T1 in ospecialize_foralls (p e) _name_guard tac | ?T1 => tac p end. Ltac opose_specialize_foralls_core p _name_guard tac := opose_core p ltac:(fun p => ospecialize_foralls p _name_guard tac). Tactic Notation "opose" "proof" uconstr(p) "as" simple_intropattern(pat) := opose_core p ltac:(fun p => pose proof p as pat). Tactic Notation "opose" "proof" "*" uconstr(p) "as" simple_intropattern(pat) := opose_specialize_foralls_core p pat ltac:(fun p => pose proof p as pat). Tactic Notation "opose" "proof" uconstr(p) := opose proof p as ?. Tactic Notation "opose" "proof" "*" uconstr(p) := opose proof* p as ?. Tactic Notation "ogeneralize" uconstr(p) := opose_core p ltac:(fun p => generalize p). Tactic Notation "ogeneralize" "*" uconstr(p) := opose_specialize_foralls_core p () ltac:(fun p => generalize p). (** Similar to [edestruct], [odestruct] will never clear the destructed variable. *) (** No [*] versions for [odestruct] and [oinversion]: we always specialize all foralls and implications; otherwise it does not make sense to destruct/invert. We also do not support [eqn:EQ]; this would not make sense for most users of this tactic since the term being destructed is [some_lemma ?evar ?proofterm]. *) Tactic Notation "odestruct" uconstr(p) := opose_specialize_foralls_core p () ltac:(fun p => destruct p). Tactic Notation "odestruct" uconstr(p) "as" simple_intropattern(pat) := opose_specialize_foralls_core p pat ltac:(fun p => destruct p as pat). Tactic Notation "oinversion" uconstr(p) "as" simple_intropattern(pat) := opose_specialize_foralls_core p pat ltac:(fun p => let Hp := fresh in pose proof p as Hp; inversion Hp as pat; clear Hp). Tactic Notation "oinversion" uconstr(p) := opose_specialize_foralls_core p () ltac:(fun p => let Hp := fresh in pose proof p as Hp; inversion Hp; clear Hp). (** Helper for [ospecialize]: call [tac] with the name of the head term *if* that term is a variable. Written in CPS to get around weird thunking limitations. *) Ltac ospecialize_ident_head_of t tac := let h := get_head t in tryif is_var h then tac h else fail "ospecialize can only specialize a local hypothesis;" "use opose proof instead". Tactic Notation "ospecialize" uconstr(p) := (* Unfortunately there does not seem to be a way to reuse [specialize] here, so we need to re-implement the logic for reusing the name. *) opose_core p ltac:(fun p => ospecialize_ident_head_of p ltac:(fun H => (* The term of [p] (but not its type) can refer to [H], so we need to use a temporary [H'] here to hold the type of [p] before we can clear [H]. *) let H' := fresh in pose proof p as H'; clear H; rename H' into H )). Tactic Notation "ospecialize" "*" uconstr(p) := opose_specialize_foralls_core p () ltac:(fun p => ospecialize_ident_head_of p ltac:(fun H => (* The term of [p] (but not its type) can refer to [H], so we need to use a temporary [H'] here to hold the type of [p] before we can clear [H]. *) let H' := fresh in pose proof p as H'; clear H; rename H' into H )). (** The block definitions are taken from [Coq.Program.Equality] and can be used by tactics to separate their goal from hypotheses they generalize over. *) Definition block {A : Type} (a : A) := a. Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. Ltac unblock_goal := unfold block in *. (** [learn_hyp p as H] and [learn_hyp p], where [p] is a proof of [P], add [P] to the context and fail if [P] already exists in the context. This is a simple form of the learning pattern. These tactics are inspired by [Program.Tactics.add_hypothesis]. *) Tactic Notation "learn_hyp" constr(p) "as" ident(H') := let P := type of p in match goal with | H : P |- _ => fail 1 | _ => pose proof p as H' end. Tactic Notation "learn_hyp" constr(p) := let H := fresh in learn_hyp p as H. (** The tactic [select pat tac] finds the last (i.e., bottommost) hypothesis matching [pat] and passes it to the continuation [tac]. Its main advantage over using [match goal with ] directly is that it is shorter. If [pat] matches multiple hypotheses and [tac] fails, then [select tac] will not backtrack on subsequent matching hypotheses. The tactic [select] is written in CPS and does not return the name of the hypothesis due to limitations in the Ltac1 tactic runtime (see https://gitter.im/coq/coq?at=5e96c82f85b01628f04bbb89). *) Tactic Notation "select" open_constr(pat) tactic3(tac) := lazymatch goal with (** Before running [tac] on the hypothesis [H] we must first unify the pattern [pat] with the term it matched against. This forces every evar coming from [pat] (and in particular from the holes [_] it contains and from the implicit arguments it uses) to be instantiated. If we do not do so then shelved goals are produced for every such evar. *) | H : pat |- _ => let T := (type of H) in unify T pat; tac H end. (** [select_revert] reverts the first hypothesis matching [pat]. *) Tactic Notation "revert" "select" open_constr(pat) := select pat (fun H => revert H). Tactic Notation "rename" "select" open_constr(pat) "into" ident(name) := select pat (fun H => rename H into name). Tactic Notation "destruct" "select" open_constr(pat) := select pat (fun H => destruct H). Tactic Notation "destruct" "select" open_constr(pat) "as" simple_intropattern(ipat) := select pat (fun H => destruct H as ipat). (** The tactic [is_closed_term t] succeeds if [t] is a closed term and fails otherwise. By closed we mean that [t] does not depend on any variable bound in the context. axioms are considered closed terms by this tactic (but Section variables are not). A function application is considered closed if the function and the argument are closed, without considering the body of the function (or whether it is opaque or not). This tactic is useful for example to decide whether to call [vm_compute] on [t]. This trick was originally suggested by Jason Gross: https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/Check.20that.20a.20term.20is.20closed.20in.20Ltac/near/240885618 *) Ltac is_closed_term t := first [ (** We use the [assert_succeeds] sandbox to be able to freely change the context. *) assert_succeeds ( (** Make sure that the goal only contains [t]. (We use [const False t] instead of [let x := t in False] as the let-binding in the latter would be unfolded by the [unfold] later.) *) exfalso; change_no_check (const False t); (** Clear all hypotheses. *) repeat match goal with H : _ |- _ => try unfold H in *; clear H end; (** If there are still hypotheses left, [t] is not closed. *) lazymatch goal with H : _ |- _ => fail | _ => idtac end ) | fail 1 "The term" t "is not closed" ]. (** Coq's [firstorder] tactic fails or loops on rather small goals already. In particular, on those generated by the tactic [unfold_elem_ofs] which is used to solve propositions on sets. The [naive_solver] tactic implements an ad-hoc and incomplete [firstorder]-like solver using Ltac's backtracking mechanism. The tactic suffers from the following limitations: - It might leave unresolved evars as Ltac provides no way to detect that. - To avoid the tactic becoming too slow, we allow a universally quantified hypothesis to be instantiated only once during each search path. - It does not perform backtracking on instantiation of universally quantified assumptions. We use a counter to make the search breath first. Breath first search ensures that a minimal number of hypotheses is instantiated, and thus reduced the posibility that an evar remains unresolved. Despite these limitations, it works much better than Coq's [firstorder] tactic for the purposes of this development. This tactic either fails or proves the goal. *) Lemma forall_and_distr (A : Type) (P Q : A → Prop) : (∀ x, P x ∧ Q x) ↔ (∀ x, P x) ∧ (∀ x, Q x). Proof. firstorder. Qed. (** The tactic [no_new_unsolved_evars tac] executes [tac] and fails if it creates any new evars. *) Ltac no_new_unsolved_evars tac := solve [unshelve tac]. Tactic Notation "naive_solver" tactic(tac) := unfold iff, not in *; repeat match goal with | H : context [∀ _, _ ∧ _ ] |- _ => repeat setoid_rewrite forall_and_distr in H; revert H end; let rec go n := repeat match goal with (**i solve the goal *) | |- _ => fast_done (**i intros *) | |- ∀ _, _ => intro (**i simplification of assumptions *) | H : False |- _ => destruct H | H : _ ∧ _ |- _ => (* Work around bug https://coq.inria.fr/bugs/show_bug.cgi?id=2901 *) let H1 := fresh in let H2 := fresh in destruct H as [H1 H2]; try clear H | H : ∃ _, _ |- _ => let x := fresh in let Hx := fresh in destruct H as [x Hx]; try clear H | H : ?P → ?Q, H2 : ?P |- _ => specialize (H H2) | H : Is_true (bool_decide _) |- _ => apply (bool_decide_unpack _) in H | H : Is_true (_ && _) |- _ => apply andb_True in H; destruct H (**i simplify and solve equalities *) | |- _ => progress simplify_eq/= (**i operations that generate more subgoals *) | |- _ ∧ _ => split | |- Is_true (bool_decide _) => apply (bool_decide_pack _) | |- Is_true (_ && _) => apply andb_True; split | H : _ ∨ _ |- _ => let H1 := fresh in destruct H as [H1|H1]; try clear H | H : Is_true (_ || _) |- _ => apply orb_True in H; let H1 := fresh in destruct H as [H1|H1]; try clear H (**i solve the goal using the user supplied tactic *) | |- _ => no_new_unsolved_evars (tac) end; (**i use recursion to enable backtracking on the following clauses. *) match goal with (**i instantiation of the conclusion *) | |- ∃ x, _ => no_new_unsolved_evars ltac:(eexists; go n) | |- _ ∨ _ => first [left; go n | right; go n] | |- Is_true (_ || _) => apply orb_True; first [left; go n | right; go n] | _ => (**i instantiations of assumptions. *) lazymatch n with | S ?n' => (**i we give priority to assumptions that fit on the conclusion. *) match goal with | H : _ → _ |- _ => is_non_dependent H; no_new_unsolved_evars ltac:(first [eapply H | opose proof* H]; clear H; go n') end end end in iter (fun n' => go n') (eval compute in (seq 1 6)). Tactic Notation "naive_solver" := naive_solver eauto. stdpp-coq-stdpp-1.9.0/stdpp/telescopes.v000066400000000000000000000212711451153341500202570ustar00rootroot00000000000000From stdpp Require Import base tactics. From stdpp Require Import options. Local Set Universe Polymorphism. Local Set Polymorphic Inductive Cumulativity. (** Without this flag, Coq minimizes some universes to [Set] when they should not be, e.g. in [texist_exist]. See the [texist_exist_universes] test. *) Local Unset Universe Minimization ToSet. (** Telescopes *) Inductive tele : Type := | TeleO : tele | TeleS {X} (binder : X → tele) : tele. Global Arguments TeleS {_} _. (** The telescope version of Coq's function type *) Fixpoint tele_fun (TT : tele) (T : Type) : Type := match TT with | TeleO => T | TeleS b => ∀ x, tele_fun (b x) T end. Notation "TT -t> A" := (tele_fun TT A) (at level 99, A at level 200, right associativity). (** An eliminator for elements of [tele_fun]. We use a [fix] because, for some reason, that makes stuff print nicer in the proofs in iris:bi/lib/telescopes.v *) Definition tele_fold {X Y} {TT : tele} (step : ∀ {A : Type}, (A → Y) → Y) (base : X → Y) : (TT -t> X) → Y := (fix rec {TT} : (TT -t> X) → Y := match TT as TT return (TT -t> X) → Y with | TeleO => λ x : X, base x | TeleS b => λ f, step (λ x, rec (f x)) end) TT. Global Arguments tele_fold {_ _ !_} _ _ _ /. (** A duplication of the type [sigT] to avoid any connection to other universes *) Record tele_arg_cons {X : Type} (f : X → Type) : Type := TeleArgCons { tele_arg_head : X; tele_arg_tail : f tele_arg_head }. Global Arguments TeleArgCons {_ _} _ _. (** A sigma-like type for an "element" of a telescope, i.e. the data it takes to get a [T] from a [TT -t> T]. *) Fixpoint tele_arg@{u} (t : tele@{u}) : Type@{u} := match t with | TeleO => unit | TeleS f => tele_arg_cons (λ x, tele_arg (f x)) end. Global Arguments tele_arg _ : simpl never. (* Coq has no idea that [unit] and [tele_arg_cons] have anything to do with telescopes. This only becomes a problem when concrete telescope arguments (of concrete telescopes) need to be typechecked. To work around this, we annotate the notations below with extra information to guide unification. *) (* The cast in the notation below is necessary to make Coq understand that [TargO] can be unified with [tele_arg TeleO]. *) Notation TargO := (tt : tele_arg TeleO) (only parsing). (* The casts and annotations are necessary for Coq to typecheck nested [TargS] as well as the final [TargO] in a chain of [TargS]. *) Notation TargS a b := ((@TeleArgCons _ (λ x, tele_arg (_ x)) a b) : (tele_arg (TeleS _))) (only parsing). Coercion tele_arg : tele >-> Sortclass. Lemma tele_arg_ind (P : ∀ TT, tele_arg TT → Prop) : P TeleO TargO → (∀ T (b : T → tele) x xs, P (b x) xs → P (TeleS b) (TargS x xs)) → ∀ TT (xs : tele_arg TT), P TT xs. Proof. intros H0 HS TT. induction TT as [|T b IH]; simpl. - by intros []. - intros [x xs]. by apply HS. Qed. Fixpoint tele_app {TT : tele} {U} : (TT -t> U) -> TT → U := match TT as TT return (TT -t> U) -> TT → U with | TeleO => λ F _, F | TeleS r => λ (F : TeleS r -t> U) '(TeleArgCons x b), tele_app (F x) b end. (* The bidirectionality hint [&] simplifies defining tele_app-based notation such as the atomic updates and atomic triples in Iris. *) Global Arguments tele_app {!_ _} & _ !_ /. (* This is a local coercion because otherwise, the "λ.." notation stops working. *) Local Coercion tele_app : tele_fun >-> Funclass. (** Inversion lemma for [tele_arg] *) Lemma tele_arg_inv {TT : tele} (a : tele_arg TT) : match TT as TT return tele_arg TT → Prop with | TeleO => λ a, a = TargO | TeleS f => λ a, ∃ x a', a = TargS x a' end a. Proof. destruct TT; destruct a; eauto. Qed. Lemma tele_arg_O_inv (a : TeleO) : a = TargO. Proof. exact (tele_arg_inv a). Qed. Lemma tele_arg_S_inv {X} {f : X → tele} (a : TeleS f) : ∃ x a', a = TargS x a'. Proof. exact (tele_arg_inv a). Qed. (** Map below a tele_fun *) Fixpoint tele_map {T U} {TT : tele} : (T → U) → (TT -t> T) → TT -t> U := match TT as TT return (T → U) → (TT -t> T) → TT -t> U with | TeleO => λ F : T → U, F | @TeleS X b => λ (F : T → U) (f : TeleS b -t> T) (x : X), tele_map F (f x) end. Global Arguments tele_map {_ _ !_} _ _ /. Lemma tele_map_app {T U} {TT : tele} (F : T → U) (t : TT -t> T) (x : TT) : (tele_map F t) x = F (t x). Proof. induction TT as [|X f IH]; simpl in *. - rewrite (tele_arg_O_inv x). done. - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl. rewrite <-IH. done. Qed. Global Instance tele_fmap {TT : tele} : FMap (tele_fun TT) := λ T U, tele_map. Lemma tele_fmap_app {T U} {TT : tele} (F : T → U) (t : TT -t> T) (x : TT) : (F <$> t) x = F (t x). Proof. apply tele_map_app. Qed. (** Operate below [tele_fun]s with argument telescope [TT]. *) Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U := match TT as TT return (TT → U) → TT -t> U with | TeleO => λ F, F tt | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *) tele_bind (λ a, F (TargS x a)) end. Global Arguments tele_bind {_ !_} _ /. (* Show that tele_app ∘ tele_bind is the identity. *) Lemma tele_app_bind {U} {TT : tele} (f : TT → U) x : (tele_bind f) x = f x. Proof. induction TT as [|X b IH]; simpl in *. - rewrite (tele_arg_O_inv x). done. - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl. rewrite IH. done. Qed. (** We can define the identity function and composition of the [-t>] function space. *) Definition tele_fun_id {TT : tele} : TT -t> TT := tele_bind id. Lemma tele_fun_id_eq {TT : tele} (x : TT) : tele_fun_id x = x. Proof. unfold tele_fun_id. rewrite tele_app_bind. done. Qed. Definition tele_fun_compose {TT1 TT2 TT3 : tele} : (TT2 -t> TT3) → (TT1 -t> TT2) → (TT1 -t> TT3) := λ t1 t2, tele_bind (compose (tele_app t1) (tele_app t2)). Lemma tele_fun_compose_eq {TT1 TT2 TT3 : tele} (f : TT2 -t> TT3) (g : TT1 -t> TT2) x : tele_fun_compose f g $ x = (f ∘ g) x. Proof. unfold tele_fun_compose. rewrite tele_app_bind. done. Qed. (** Notation *) Notation "'[tele' x .. z ]" := (TeleS (fun x => .. (TeleS (fun z => TeleO)) ..)) (x binder, z binder, format "[tele '[hv' x .. z ']' ]"). Notation "'[tele' ]" := (TeleO) (format "[tele ]"). Notation "'[tele_arg' x ; .. ; z ]" := (TargS x ( .. (TargS z TargO) ..)) (format "[tele_arg '[hv' x ; .. ; z ']' ]"). Notation "'[tele_arg' ]" := (TargO) (format "[tele_arg ]"). (** Notation-compatible telescope mapping *) (* This adds (tele_app ∘ tele_bind), which is an identity function, around every binder so that, after simplifying, this matches the way we typically write notations involving telescopes. *) Notation "'λ..' x .. y , e" := (tele_app (tele_bind (λ x, .. (tele_app (tele_bind (λ y, e))) .. ))) (at level 200, x binder, y binder, right associativity, format "'[ ' 'λ..' x .. y ']' , e") : stdpp_scope. (** Telescopic quantifiers *) Definition tforall {TT : tele} (Ψ : TT → Prop) : Prop := tele_fold (λ (T : Type) (b : T → Prop), ∀ x : T, b x) (λ x, x) (tele_bind Ψ). Global Arguments tforall {!_} _ /. Definition texist {TT : tele} (Ψ : TT → Prop) : Prop := tele_fold ex (λ x, x) (tele_bind Ψ). Global Arguments texist {!_} _ /. Notation "'∀..' x .. y , P" := (tforall (λ x, .. (tforall (λ y, P)) .. )) (at level 200, x binder, y binder, right associativity, format "∀.. x .. y , P") : stdpp_scope. Notation "'∃..' x .. y , P" := (texist (λ x, .. (texist (λ y, P)) .. )) (at level 200, x binder, y binder, right associativity, format "∃.. x .. y , P") : stdpp_scope. Lemma tforall_forall {TT : tele} (Ψ : TT → Prop) : tforall Ψ ↔ (∀ x, Ψ x). Proof. symmetry. unfold tforall. induction TT as [|X ft IH]. - simpl. split. + done. + intros ? p. rewrite (tele_arg_O_inv p). done. - simpl. split; intros Hx a. + rewrite <-IH. done. + destruct (tele_arg_S_inv a) as [x [pf ->]]. revert pf. setoid_rewrite IH. done. Qed. Lemma texist_exist {TT : tele} (Ψ : TT → Prop) : texist Ψ ↔ ex Ψ. Proof. symmetry. induction TT as [|X ft IH]. - simpl. split. + intros [p Hp]. rewrite (tele_arg_O_inv p) in Hp. done. + intros. by exists TargO. - simpl. split; intros [p Hp]; revert Hp. + destruct (tele_arg_S_inv p) as [x [pf ->]]. intros ?. exists x. rewrite <-(IH x (λ a, Ψ (TargS x a))). eauto. + rewrite <-(IH p (λ a, Ψ (TargS p a))). intros [??]. eauto. Qed. (* Teach typeclass resolution how to make progress on these binders *) Global Typeclasses Opaque tforall texist. Global Hint Extern 1 (tforall _) => progress cbn [tforall tele_fold tele_bind tele_app] : typeclass_instances. Global Hint Extern 1 (texist _) => progress cbn [texist tele_fold tele_bind tele_app] : typeclass_instances. stdpp-coq-stdpp-1.9.0/stdpp/vector.v000066400000000000000000000332031451153341500174110ustar00rootroot00000000000000(** This file collects general purpose definitions and theorems on vectors (lists of fixed length). It uses the definitions from the standard library, but renames or changes their notations, so that it becomes more consistent with the naming conventions in this development. *) From stdpp Require Import countable. From stdpp Require Export fin list. From stdpp Require Import options. Global Open Scope vector_scope. (** The type [vec n] represents lists of consisting of exactly [n] elements. Whereas the standard library declares exactly the same notations for vectors as used for lists, we use slightly different notations so it becomes easier to use lists and vectors together. *) Notation vec := Vector.t. Notation vnil := Vector.nil. Global Arguments vnil {_}. Notation vcons := Vector.cons. Notation vapp := Vector.append. Global Arguments vcons {_} _ {_} _. Infix ":::" := vcons (at level 60, right associativity) : vector_scope. Notation "(:::)" := vcons (only parsing) : vector_scope. Notation "( x :::.)" := (vcons x) (only parsing) : vector_scope. Notation "(.::: v )" := (λ x, vcons x v) (only parsing) : vector_scope. Notation "[# ] " := vnil : vector_scope. Notation "[# x ] " := (vcons x vnil) : vector_scope. Notation "[# x ; .. ; y ] " := (vcons x .. (vcons y vnil) ..) : vector_scope. Infix "+++" := vapp (at level 60, right associativity) : vector_scope. Notation "(+++)" := vapp (only parsing) : vector_scope. Notation "( v +++.)" := (vapp v) (only parsing) : vector_scope. Notation "(.+++ w )" := (λ v, vapp v w) (only parsing) : vector_scope. (** Similar to [fin], we provide an inversion principle that keeps the length fixed. We define a tactic [inv_vec v] to perform case analysis on [v], using this inversion principle. *) Notation vec_0_inv := Vector.case0. Definition vec_S_inv {A n} (P : vec A (S n) → Type) (Hcons : ∀ x v, P (x ::: v)) v : P v. Proof. revert P Hcons. refine match v with [#] => tt | x ::: v => λ P Hcons, Hcons x v end. Defined. Global Instance vector_lookup_total A : ∀ m, LookupTotal (fin m) A (vec A m) := fix go m i {struct i} := let _ : ∀ m, LookupTotal _ _ _ := @go in match i in fin m return vec A m → A with | 0%fin => vec_S_inv (λ _, A) (λ x _, x) | FS j => vec_S_inv (λ _, A) (λ _ v, v !!! j) end. (** The tactic [vec_double_ind v1 v2] performs double induction on [v1] and [v2] provided that they have the same length. *) Notation vec_rect2 := Vector.rect2. Ltac vec_double_ind v1 v2 := match type of v1 with | vec _ ?n => repeat match goal with | H' : context [ n ] |- _ => var_neq v1 H'; var_neq v2 H'; revert H' end; revert n v1 v2; match goal with |- ∀ n v1 v2, @?P n v1 v2 => apply (vec_rect2 P) end end. Notation vcons_inj := VectorSpec.cons_inj. Lemma vcons_inj_1 {A n} x y (v w : vec A n) : x ::: v = y ::: w → x = y. Proof. apply vcons_inj. Qed. Lemma vcons_inj_2 {A n} x y (v w : vec A n) : x ::: v = y ::: w → v = w. Proof. apply vcons_inj. Qed. Lemma vec_eq {A n} (v w : vec A n) : (∀ i, v !!! i = w !!! i) → v = w. Proof. vec_double_ind v w; [done|]. intros n v w IH x y Hi. f_equal. - apply (Hi 0%fin). - apply IH. intros i. apply (Hi (FS i)). Qed. Global Instance vec_dec {A} {dec : EqDecision A} {n} : EqDecision (vec A n). Proof. refine (vec_rect2 (λ n (v w : vec A n), { v = w } + { v ≠ w }) (left _) (λ _ _ _ H x y, cast_if_and (dec x y) H)); f_equal; eauto using vcons_inj_1, vcons_inj_2. Defined. Ltac inv_vec v := let T := type of v in match eval hnf in T with | vec _ ?n => match eval hnf in n with | 0 => generalize dependent v; match goal with |- ∀ v, @?P v => apply (vec_0_inv P) end | S ?n => generalize dependent v; match goal with |- ∀ v, @?P v => apply (vec_S_inv P) end; (* Try going on recursively. *) try (let x := fresh "x" in intros x v; inv_vec v; revert x) end end. (** The following tactic performs case analysis on all hypotheses of the shape [fin 0], [fin (S n)], [vec A 0] and [vec A (S n)] until no further case analyses are possible. *) Ltac inv_all_vec_fin := block_goal; repeat match goal with | v : vec _ _ |- _ => inv_vec v; intros | i : fin _ |- _ => inv_fin i; intros end; unblock_goal. (** We define a coercion from [vec] to [list] and show that it preserves the operations on vectors. We also define a function to go in the other way, but do not define it as a coercion, as it would otherwise introduce ambiguity. *) Fixpoint vec_to_list {A n} (v : vec A n) : list A := match v with [#] => [] | x ::: v => x :: vec_to_list v end. Coercion vec_to_list : vec >-> list. Notation list_to_vec := Vector.of_list. Lemma vec_to_list_cons {A n} x (v : vec A n) : vec_to_list (x ::: v) = x :: vec_to_list v. Proof. done. Qed. Lemma vec_to_list_app {A n m} (v : vec A n) (w : vec A m) : vec_to_list (v +++ w) = vec_to_list v ++ vec_to_list w. Proof. by induction v; f_equal/=. Qed. Lemma vec_to_list_to_vec {A} (l : list A): vec_to_list (list_to_vec l) = l. Proof. by induction l; f_equal/=. Qed. Lemma vec_to_list_length {A n} (v : vec A n) : length (vec_to_list v) = n. Proof. induction v; simpl; by f_equal. Qed. Lemma vec_to_list_same_length {A B n} (v : vec A n) (w : vec B n) : length v = length w. Proof. by rewrite !vec_to_list_length. Qed. Lemma vec_to_list_inj1 {A n m} (v : vec A n) (w : vec A m) : vec_to_list v = vec_to_list w → n = m. Proof. revert m w. induction v; intros ? [|???] ?; simplify_eq/=; f_equal; eauto. Qed. Lemma vec_to_list_inj2 {A n} (v : vec A n) (w : vec A n) : vec_to_list v = vec_to_list w → v = w. Proof. revert w. induction v; intros w; inv_vec w; intros; simplify_eq/=; f_equal; eauto. Qed. Lemma list_to_vec_to_list {A n} (v : vec A n) : list_to_vec (vec_to_list v) = eq_rect _ _ v _ (eq_sym (vec_to_list_length v)). Proof. apply vec_to_list_inj2. rewrite vec_to_list_to_vec. by destruct (eq_sym (vec_to_list_length v)). Qed. Lemma vlookup_middle {A n m} (v : vec A n) (w : vec A m) x : ∃ i : fin (n + S m), x = (v +++ x ::: w) !!! i. Proof. induction v as [|??? IHv]; simpl; [by eexists 0%fin|]. destruct IHv as [i ?]. by exists (FS i). Qed. Lemma vec_to_list_lookup_middle {A n} (v : vec A n) (l k : list A) x : vec_to_list v = l ++ x :: k → ∃ i : fin n, l = take i v ∧ x = v !!! i ∧ k = drop (S i) v. Proof. intros H. rewrite <-(vec_to_list_to_vec l), <-(vec_to_list_to_vec k) in H. rewrite <-vec_to_list_cons, <-vec_to_list_app in H. pose proof (vec_to_list_inj1 _ _ H); subst. apply vec_to_list_inj2 in H; subst. induction l as [|?? IHl]; simpl. - eexists 0%fin. simpl. by rewrite vec_to_list_to_vec. - destruct IHl as [i ?]. exists (FS i). simpl. intuition congruence. Qed. Lemma vec_to_list_drop_lookup {A n} (v : vec A n) (i : fin n) : drop i v = v !!! i :: drop (S i) v. Proof. induction i as [|?? IHi]; inv_vec v; simpl; intros; [done | by rewrite IHi]. Qed. Lemma vec_to_list_take_drop_lookup {A n} (v : vec A n) (i : fin n) : vec_to_list v = take i v ++ v !!! i :: drop (S i) v. Proof. rewrite <-(take_drop i v) at 1. by rewrite vec_to_list_drop_lookup. Qed. Lemma vlookup_lookup {A n} (v : vec A n) (i : fin n) x : v !!! i = x ↔ (v : list A) !! (i : nat) = Some x. Proof. induction v as [|? ? v IH]; inv_fin i. - simpl; split; congruence. - done. Qed. Lemma vlookup_lookup' {A n} (v : vec A n) (i : nat) x : (∃ H : i < n, v !!! nat_to_fin H = x) ↔ (v : list A) !! i = Some x. Proof. split. - intros [Hlt ?]. rewrite <-(fin_to_nat_to_fin i n Hlt). by apply vlookup_lookup. - intros Hvix. assert (Hlt:=lookup_lt_Some _ _ _ Hvix). rewrite vec_to_list_length in Hlt. exists Hlt. apply vlookup_lookup. by rewrite fin_to_nat_to_fin. Qed. Lemma elem_of_vlookup {A n} (v : vec A n) x : x ∈ vec_to_list v ↔ ∃ i, v !!! i = x. Proof. rewrite elem_of_list_lookup. setoid_rewrite <-vlookup_lookup'. split; [by intros (?&?&?); eauto|]. intros [i Hx]. exists i, (fin_to_nat_lt _). by rewrite nat_to_fin_to_nat. Qed. Lemma Forall_vlookup {A} (P : A → Prop) {n} (v : vec A n) : Forall P (vec_to_list v) ↔ ∀ i, P (v !!! i). Proof. rewrite Forall_forall. setoid_rewrite elem_of_vlookup. naive_solver. Qed. Lemma Forall_vlookup_1 {A} (P : A → Prop) {n} (v : vec A n) i : Forall P (vec_to_list v) → P (v !!! i). Proof. by rewrite Forall_vlookup. Qed. Lemma Forall_vlookup_2 {A} (P : A → Prop) {n} (v : vec A n) : (∀ i, P (v !!! i)) → Forall P (vec_to_list v). Proof. by rewrite Forall_vlookup. Qed. Lemma Exists_vlookup {A} (P : A → Prop) {n} (v : vec A n) : Exists P (vec_to_list v) ↔ ∃ i, P (v !!! i). Proof. rewrite Exists_exists. setoid_rewrite elem_of_vlookup. naive_solver. Qed. Lemma Forall2_vlookup {A B} (P : A → B → Prop) {n} (v1 : vec A n) (v2 : vec B n) : Forall2 P (vec_to_list v1) (vec_to_list v2) ↔ ∀ i, P (v1 !!! i) (v2 !!! i). Proof. split. - vec_double_ind v1 v2; [intros _ i; inv_fin i |]. intros n v1 v2 IH a b; simpl. inversion_clear 1. intros i. inv_fin i; simpl; auto. - vec_double_ind v1 v2; [constructor|]. intros ??? IH ?? H. constructor. + apply (H 0%fin). + apply IH, (λ i, H (FS i)). Qed. (** Given a function [fin n → A], we can construct a vector. *) Fixpoint fun_to_vec {A n} {struct n} : (fin n → A) → vec A n := match n with | 0 => λ f, [#] | S n => λ f, f 0%fin ::: fun_to_vec (f ∘ FS) end. Lemma lookup_fun_to_vec {A n} (f : fin n → A) i : fun_to_vec f !!! i = f i. Proof. revert f. induction i as [|n i IH]; intros f; simpl; [done|]. by rewrite IH. Qed. (** The function [vmap f v] applies a function [f] element wise to [v]. *) Notation vmap := Vector.map. Lemma vlookup_map `(f : A → B) {n} (v : vec A n) i : vmap f v !!! i = f (v !!! i). Proof. by induction v; inv_fin i; eauto. Qed. Lemma vec_to_list_map `(f : A → B) {n} (v : vec A n) : vec_to_list (vmap f v) = f <$> vec_to_list v. Proof. induction v as [|??? IHv]; simpl; [done|]. by rewrite IHv. Qed. (** The function [vzip_with f v w] combines the vectors [v] and [w] element wise using the function [f]. *) Notation vzip_with := Vector.map2. Lemma vlookup_zip_with `(f : A → B → C) {n} (v1 : vec A n) (v2 : vec B n) i : vzip_with f v1 v2 !!! i = f (v1 !!! i) (v2 !!! i). Proof. vec_double_ind v1 v2. - intros i; inv_fin i. - intros n v1 v2 IH a b i. inv_fin i; eauto. Qed. Lemma vec_to_list_zip_with `(f : A → B → C) {n} (v1 : vec A n) (v2 : vec B n) : vec_to_list (vzip_with f v1 v2) = zip_with f (vec_to_list v1) (vec_to_list v2). Proof. revert v2. induction v1 as [|??? IHv1]; intros v2; inv_vec v2; intros; simpl; [done|]. by rewrite IHv1. Qed. (** Similar to vlookup, we cannot define [vinsert] as an instance of the [Insert] type class, as it has a dependent type. *) Fixpoint vinsert {A n} (i : fin n) (x : A) : vec A n → vec A n := match i with | 0%fin => vec_S_inv _ (λ _ v, x ::: v) | FS i => vec_S_inv _ (λ y v, y ::: vinsert i x v) end. Lemma vec_to_list_insert {A n} i x (v : vec A n) : vec_to_list (vinsert i x v) = insert (fin_to_nat i) x (vec_to_list v). Proof. induction v as [|??? IHv]; inv_fin i; [done|]. simpl. intros. by rewrite IHv. Qed. Lemma vlookup_insert {A n} i x (v : vec A n) : vinsert i x v !!! i = x. Proof. by induction i; inv_vec v. Qed. Lemma vlookup_insert_ne {A n} i j x (v : vec A n) : i ≠ j → vinsert i x v !!! j = v !!! j. Proof. induction i as [|?? IHi]; inv_fin j; inv_vec v; simpl; try done. intros. apply IHi. congruence. Qed. Lemma vlookup_insert_self {A n} i (v : vec A n) : vinsert i (v !!! i) v = v. Proof. by induction v; inv_fin i; intros; f_equal/=. Qed. Lemma vmap_insert {A B} (f : A → B) (n : nat) i x (v : vec A n) : vmap f (vinsert i x v) = vinsert i (f x) (vmap f v). Proof. induction v; inv_fin i; intros; f_equal/=; auto. Qed. (** The functions [vtake i v] and [vdrop i v] take the first [i] elements of a vector [v], respectively remove the first [i] elements of a vector [v]. *) Fixpoint vtake {A n} (i : fin n) : vec A n → vec A i := match i in fin n return vec A n → vec A i with | 0%fin => λ _, [#] | FS i => vec_S_inv _ (λ x v, x ::: vtake i v) end. Fixpoint vdrop {A n} (i : fin n) : vec A n → vec A (n - i) := match i in fin n return vec A n → vec A (n - i) with | 0%fin => id | FS i => vec_S_inv _ (λ _, vdrop i) end. Lemma vec_to_list_take {A n} i (v : vec A n) : vec_to_list (vtake i v) = take (fin_to_nat i) (vec_to_list v). Proof. induction i; inv_vec v; intros; f_equal/=; auto. Qed. Lemma vec_to_list_drop {A n} i (v : vec A n) : vec_to_list (vdrop i v) = drop (fin_to_nat i) (vec_to_list v). Proof. induction i; inv_vec v; intros; f_equal/=; auto. Qed. (** The function [vreplicate n x] generates a vector with length [n] of elements with value [x]. *) Fixpoint vreplicate {A} (n : nat) (x : A) : vec A n := match n with 0 => [#] | S n => x ::: vreplicate n x end. Lemma vec_to_list_replicate {A} n (x : A) : vec_to_list (vreplicate n x) = replicate n x. Proof. induction n; by f_equal/=. Qed. Lemma vlookup_replicate {A} n (x : A) i : vreplicate n x !!! i = x. Proof. induction i; f_equal/=; auto. Qed. Lemma vmap_replicate {A B} (f : A → B) n (x : A) : vmap f (vreplicate n x) = vreplicate n (f x). Proof. induction n; f_equal/=; auto. Qed. (** Vectors are inhabited and countable *) Global Instance vec_0_inhabited T : Inhabited (vec T 0) := populate [#]. Global Instance vec_inhabited `{Inhabited T} n : Inhabited (vec T n) := populate (vreplicate n inhabitant). Global Instance vec_countable `{Countable A} n : Countable (vec A n). Proof. apply (inj_countable vec_to_list (λ l, guard (n = length l) as H; Some (eq_rect _ _ (list_to_vec l) _ (eq_sym H)))). intros v. case_option_guard as Hn. - rewrite list_to_vec_to_list. rewrite (proof_irrel (eq_sym _) Hn). by destruct Hn. - by rewrite vec_to_list_length in Hn. Qed. stdpp-coq-stdpp-1.9.0/stdpp/well_founded.v000066400000000000000000000053121451153341500205560ustar00rootroot00000000000000(** * Theorems on well founded relations *) From stdpp Require Import base. From stdpp Require Import options. Lemma Acc_impl {A} (R1 R2 : relation A) x : Acc R1 x → (∀ y1 y2, R2 y1 y2 → R1 y1 y2) → Acc R2 x. Proof. induction 1; constructor; auto. Qed. Notation wf := well_founded. (** The function [wf_guard n wfR] adds [2 ^ n - 1] times an [Acc_intro] constructor ahead of the [wfR] proof. This definition can be used to make opaque [wf] proofs "compute". For big enough [n], say [32], computation will reach implementation limits before running into the opaque [wf] proof. This trick is originally due to Georges Gonthier, see https://sympa.inria.fr/sympa/arc/coq-club/2007-07/msg00013.html *) Definition wf_guard `{R : relation A} (n : nat) (wfR : wf R) : wf R := Acc_intro_generator n wfR. (* Generally we do not want [wf_guard] to be expanded (neither by tactics, nor by conversion tests in the kernel), but in some cases we do need it for computation (that is, we cannot make it opaque). We use the [Strategy] command to make its expanding behavior less eager. *) Strategy 100 [wf_guard]. Lemma wf_projected `{R1 : relation A} `(R2 : relation B) (f : A → B) : (∀ x y, R1 x y → R2 (f x) (f y)) → wf R2 → wf R1. Proof. intros Hf Hwf. cut (∀ y, Acc R2 y → ∀ x, y = f x → Acc R1 x). { intros aux x. apply (aux (f x)); auto. } induction 1 as [y _ IH]. intros x ?. subst. constructor. intros y ?. apply (IH (f y)); auto. Qed. Lemma Fix_F_proper `{R : relation A} (B : A → Type) (E : ∀ x, relation (B x)) (F : ∀ x, (∀ y, R y x → B y) → B x) (HF : ∀ (x : A) (f g : ∀ y, R y x → B y), (∀ y Hy Hy', E _ (f y Hy) (g y Hy')) → E _ (F x f) (F x g)) (x : A) (acc1 acc2 : Acc R x) : E _ (Fix_F B F acc1) (Fix_F B F acc2). Proof. revert x acc1 acc2. fix FIX 2. intros x [acc1] [acc2]; simpl; auto. Qed. Lemma Fix_unfold_rel `{R : relation A} (wfR : wf R) (B : A → Type) (E : ∀ x, relation (B x)) (F: ∀ x, (∀ y, R y x → B y) → B x) (HF: ∀ (x: A) (f g: ∀ y, R y x → B y), (∀ y Hy Hy', E _ (f y Hy) (g y Hy')) → E _ (F x f) (F x g)) (x: A) : E _ (Fix wfR B F x) (F x (λ y _, Fix wfR B F y)). Proof. unfold Fix. destruct (wfR x); simpl. apply HF; intros. apply Fix_F_proper; auto. Qed. (** Generate an induction principle for [Acc] for reasoning about recursion on [Acc], such as [countable.choose_proper]. We need an induction principle to prove predicates of [Acc] values, with conclusion [∀ (x : A) (a : Acc R x), P x a]. Instead, [Acc_ind] has conclusion [∀ x : A, Acc R x → P x], as if it were generated by [Scheme Acc_rect := Minimality for Acc Sort Prop.] *) Scheme Acc_dep_ind := Induction for Acc Sort Prop. stdpp-coq-stdpp-1.9.0/stdpp/zmap.v000066400000000000000000000063761451153341500170710ustar00rootroot00000000000000(** This files extends the implementation of finite over [positive] to finite maps whose keys range over Coq's data type of binary naturals [Z]. *) From stdpp Require Import pmap mapset. From stdpp Require Export prelude fin_maps. From stdpp Require Import options. Local Open Scope Z_scope. Record Zmap (A : Type) : Type := ZMap { Zmap_0 : option A; Zmap_pos : Pmap A; Zmap_neg : Pmap A }. Global Arguments Zmap_0 {_} _ : assert. Global Arguments Zmap_pos {_} _ : assert. Global Arguments Zmap_neg {_} _ : assert. Global Arguments ZMap {_} _ _ _ : assert. Global Instance Zmap_eq_dec `{EqDecision A} : EqDecision (Zmap A). Proof. refine (λ t1 t2, match t1, t2 with | ZMap x t1 t1', ZMap y t2 t2' => cast_if_and3 (decide (x = y)) (decide (t1 = t2)) (decide (t1' = t2')) end); abstract congruence. Defined. Global Instance Zmap_empty {A} : Empty (Zmap A) := ZMap None ∅ ∅. Global Instance Zmap_lookup {A} : Lookup Z A (Zmap A) := λ i t, match i with | Z0 => Zmap_0 t | Zpos p => Zmap_pos t !! p | Zneg p => Zmap_neg t !! p end. Global Instance Zmap_partial_alter {A} : PartialAlter Z A (Zmap A) := λ f i t, match i, t with | Z0, ZMap o t t' => ZMap (f o) t t' | Z.pos p, ZMap o t t' => ZMap o (partial_alter f p t) t' | Z.neg p, ZMap o t t' => ZMap o t (partial_alter f p t') end. Global Instance Zmap_fmap: FMap Zmap := λ A B f t, match t with ZMap o t t' => ZMap (f <$> o) (f <$> t) (f <$> t') end. Global Instance Zmap_omap: OMap Zmap := λ A B f t, match t with ZMap o t t' => ZMap (o ≫= f) (omap f t) (omap f t') end. Global Instance Zmap_merge: Merge Zmap := λ A B C f t1 t2, match t1, t2 with | ZMap o1 t1 t1', ZMap o2 t2 t2' => ZMap (diag_None f o1 o2) (merge f t1 t2) (merge f t1' t2') end. Global Instance Zmap_fold {A} : MapFold Z A (Zmap A) := λ B f d t, match t with | ZMap mx t t' => map_fold (f ∘ Z.pos) (map_fold (f ∘ Z.neg) match mx with Some x => f 0 x d | None => d end t') t end. Global Instance Zmap_map: FinMap Z Zmap. Proof. split. - intros ? [??] [??] H. f_equal. + apply (H 0). + apply map_eq. intros i. apply (H (Z.pos i)). + apply map_eq. intros i. apply (H (Z.neg i)). - by intros ? []. - intros ? f [] [|?|?]; simpl; [done| |]; apply lookup_partial_alter. - intros ? f [] [|?|?] [|?|?]; simpl; intuition congruence || intros; apply lookup_partial_alter_ne; congruence. - intros ??? [??] []; simpl; [done| |]; apply lookup_fmap. - intros ?? f [??] [|?|?]; simpl; [done| |]; apply (lookup_omap f). - intros ??? f [??] [??] [|?|?]; simpl; [done| |]; apply (lookup_merge f). - intros A B P f b Hemp Hinsert [mx t t']. apply (map_fold_ind (λ r t, P r (ZMap mx t t'))); clear t. { apply (map_fold_ind (λ r t', P r (ZMap mx ∅ t'))); clear t'. { destruct mx as [x|]; [|done]. replace (ZMap (Some x) ∅ ∅) with (<[0:=x]> ∅ : Zmap _) by done. by apply Hinsert. } intros i x t' r ??. by apply (Hinsert (Z.neg i) x (ZMap mx ∅ t')). } intros i x t r ??. by apply (Hinsert (Z.pos i) x (ZMap mx t t')). Qed. (** * Finite sets *) (** We construct sets of [Z]s satisfying extensional equality. *) Notation Zset := (mapset Zmap). Global Instance Zmap_dom {A} : Dom (Zmap A) Zset := mapset_dom. Global Instance: FinMapDom Z Zmap Zset := mapset_dom_spec. stdpp-coq-stdpp-1.9.0/stdpp_unstable/000077500000000000000000000000001451153341500176145ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/stdpp_unstable/bitblast.v000066400000000000000000000531331451153341500216140ustar00rootroot00000000000000(* This file is still experimental. See its tracking issue https://gitlab.mpi-sws.org/iris/stdpp/-/issues/141 for details on remaining issues before stabilization. This file is maintained by Michael Sammler. *) From Coq Require Import ssreflect. From Coq.btauto Require Export Btauto. From stdpp Require Export tactics numbers list. From stdpp Require Import options. (** * [bitblast] tactic: Solve integer goals by bitwise reasoning *) (** This file provides the [bitblast] tactic for bitwise reasoning about [Z] via [Z.testbit]. Concretely, [bitblast] first turns an equality [a = b] into [∀ n, Z.testbit a n = Z.testbit b n], then simplifies the [Z.testbit] expressions using lemmas like [Z.testbit (Z.land a b) n = Z.testbit a n && Z.testbit b n], or [Z.testbit (Z.ones z) n = bool_decide (0 ≤ n < z) || bool_decide (z < 0 ∧ 0 ≤ n)] and finally simplifies the resulting boolean expression by performing case distinction on all [bool_decide] in the goal and pruning impossible cases. This library provides the following variants of the [bitblast] tactic: - [bitblast]: applies the bitblasting technique described above to the goal. If the goal already contains a [Z.testbit], the first step (which introduces [Z.testbit] to prove equalities between [Z]) is skipped. - [bitblast as n] behaves the same as [bitblast], but it allows naming the [n] introduced in the first step. Fails if the goal is not an equality between [Z]. - [bitblast H] applies the simplification of [Z.testbit] in the hypothesis [H] (but does not perform case distinction). - [bitblast H with n as H'] deduces from the equality [H] of the form [z1 = z2] that the [n]-th bit of [z1] and [z2] are equal, simplifies the resulting equation, and adds it as the hypothesis [H']. - [bitblast H with n] is the same as [bitblast H with n as H'], but using a fresh name for [H']. See also https://github.com/mit-plv/coqutil/blob/master/src/coqutil/Z/bitblast.v for another implementation of the same idea. *) (** * Settings *) Local Set SsrOldRewriteGoalsOrder. (* See Coq issue #5706 *) Local Open Scope Z_scope. (** * Helper lemmas to upstream *) Lemma Nat_eqb_eq n1 n2 : (n1 =? n2)%nat = bool_decide (n1 = n2). Proof. case_bool_decide; [by apply Nat.eqb_eq | by apply Nat.eqb_neq]. Qed. Lemma Z_eqb_eq n1 n2 : (n1 =? n2)%Z = bool_decide (n1 = n2). Proof. case_bool_decide; [by apply Z.eqb_eq | by apply Z.eqb_neq]. Qed. Lemma Z_testbit_pos_testbit p n : (0 ≤ n)%Z → Z.testbit (Z.pos p) n = Pos.testbit p (Z.to_N n). Proof. by destruct n, p. Qed. Lemma negb_forallb {A} (ls : list A) f : negb (forallb f ls) = existsb (negb ∘ f) ls. Proof. induction ls; [done|]; simpl. rewrite negb_andb. congruence. Qed. Lemma Z_bits_inj'' a b : a = b → (∀ n : Z, 0 ≤ n → Z.testbit a n = Z.testbit b n). Proof. apply Z.bits_inj_iff'. Qed. Lemma tac_tactic_in_hyp (P1 P2 : Prop) : P1 → (P1 → P2) → P2. Proof. eauto. Qed. (** TODO: replace this with [do [ tac ] in H] from ssreflect? *) Tactic Notation "tactic" tactic3(tac) "in" ident(H) := let H' := fresh in unshelve epose proof (tac_tactic_in_hyp _ _ H _) as H'; [shelve| tac; let H := fresh H in intros H; exact H |]; clear H; rename H' into H. (** ** bitranges *) Fixpoint pos_to_bit_ranges_aux (p : positive) : (nat * nat) * list (nat * nat) := match p with | xH => ((0, 1)%nat, []) | xO p' => let x := pos_to_bit_ranges_aux p' in ((S x.1.1, x.1.2), prod_map S id <$> x.2) | xI p' => let x := pos_to_bit_ranges_aux p' in if (x.1.1 =? 0)%nat then ((0%nat, S x.1.2), prod_map S id <$> x.2) else ((0%nat, 1%nat), prod_map S id <$> (x.1 :: x.2)) end. (** [pos_to_bit_ranges p] computes the list of (start, length) pairs describing which bits of [p] are [1]. The following examples show the behavior of [pos_to_bit_ranges]: *) (* Compute (pos_to_bit_ranges 1%positive). (** 0b 1 [(0, 1)] *) *) (* Compute (pos_to_bit_ranges 2%positive). (** 0b 10 [(1, 1)] *) *) (* Compute (pos_to_bit_ranges 3%positive). (** 0b 11 [(0, 2)] *) *) (* Compute (pos_to_bit_ranges 4%positive). (** 0b100 [(2, 1)] *) *) (* Compute (pos_to_bit_ranges 5%positive). (** 0b101 [(0, 1); (2, 1)] *) *) (* Compute (pos_to_bit_ranges 6%positive). (** 0b110 [(1, 2)] *) *) (* Compute (pos_to_bit_ranges 7%positive). (** 0b111 [(0, 3)] *) *) (* Compute (pos_to_bit_ranges 21%positive). (** 0b10101 [(0, 1); (2, 1); (4, 1)] *) *) Definition pos_to_bit_ranges (p : positive) : list (nat * nat) := let x := pos_to_bit_ranges_aux p in x.1::x.2. Lemma pos_to_bit_ranges_spec p rs : pos_to_bit_ranges p = rs → (∀ n, Pos.testbit p n ↔ ∃ r, r ∈ rs ∧ (N.of_nat r.1 ≤ n ∧ n < N.of_nat r.1 + N.of_nat r.2)%N). Proof. unfold pos_to_bit_ranges => <-. elim: p => //; csimpl. - move => p IH n. rewrite Nat_eqb_eq. case_match; subst. + split; [|done] => _. case_match. all: eexists _; split; [by apply elem_of_list_here|] => /=; lia. + rewrite {}IH. split; move => [r[/elem_of_cons[Heq|Hin] ?]]; simplify_eq/=. * (* r = (pos_to_bit_ranges_aux p).1 *) case_bool_decide as Heq; simplify_eq/=. -- eexists _. split; [by apply elem_of_list_here|] => /=. lia. -- eexists _. split. { apply elem_of_list_further. apply elem_of_list_here. } simplify_eq/=. lia. * (* r ∈ (pos_to_bit_ranges_aux p).2 *) case_bool_decide as Heq; simplify_eq/=. -- eexists _. split. { apply elem_of_list_further. apply elem_of_list_fmap. by eexists _. } simplify_eq/=. lia. -- eexists _. split. { do 2 apply elem_of_list_further. apply elem_of_list_fmap. by eexists _. } simplify_eq/=. lia. * eexists _. split; [by apply elem_of_list_here|]. case_bool_decide as Heq; simplify_eq/=; lia. * case_bool_decide as Heq; simplify_eq/=. -- move: Hin => /= /elem_of_list_fmap[?[??]]; subst. eexists _. split; [by apply elem_of_list_further |]. simplify_eq/=. lia. -- rewrite -fmap_cons in Hin. move: Hin => /elem_of_list_fmap[?[??]]; subst. naive_solver lia. - move => p IH n. case_match; subst. + split; [done|] => -[[l h][/elem_of_cons[?|/(elem_of_list_fmap_2 _ _ _)[[??][??]]]?]]; simplify_eq/=; lia. + rewrite IH. split; move => [r[/elem_of_cons[Heq|Hin] ?]]; simplify_eq/=. * eexists _. split; [by apply elem_of_list_here|] => /=; lia. * eexists _. split. { apply elem_of_list_further. apply elem_of_list_fmap. by eexists _. } destruct r; simplify_eq/=. lia. * eexists _. split; [by apply elem_of_list_here|] => /=; lia. * move: Hin => /elem_of_list_fmap[r'[??]]; subst. eexists _. split; [by apply elem_of_list_further|]. destruct r'; simplify_eq/=. lia. - move => n. setoid_rewrite elem_of_list_singleton. case_match; split => //; subst; naive_solver lia. Qed. Definition Z_to_bit_ranges (z : Z) : list (nat * nat) := match z with | Z0 => [] | Z.pos p => pos_to_bit_ranges p | Z.neg p => [] end. Lemma Z_to_bit_ranges_spec z n rs : (0 ≤ n)%Z → (0 ≤ z)%Z → Z_to_bit_ranges z = rs → Z.testbit z n ↔ Exists (λ r, Z.of_nat r.1 ≤ n ∧ n < Z.of_nat r.1 + Z.of_nat r.2) rs. Proof. move => /= ??. destruct z => //=. + move => <-. rewrite Z.bits_0 Exists_nil. done. + move => /pos_to_bit_ranges_spec Hbit. rewrite Z_testbit_pos_testbit // Hbit Exists_exists. naive_solver lia. Qed. (** * [simpl_bool] *) Ltac simpl_bool_cbn := cbn [andb orb negb]. Ltac simpl_bool := repeat match goal with | |- context C [true && ?b] => simpl_bool_cbn | |- context C [false && ?b] => simpl_bool_cbn | |- context C [true || ?b] => simpl_bool_cbn | |- context C [false || ?b] => simpl_bool_cbn | |- context C [negb true] => simpl_bool_cbn | |- context C [negb false] => simpl_bool_cbn | |- context C [?b && true] => rewrite (Bool.andb_true_r b) | |- context C [?b && false] => rewrite (Bool.andb_false_r b) | |- context C [?b || true] => rewrite (Bool.orb_true_r b) | |- context C [?b || false] => rewrite (Bool.orb_false_r b) | |- context C [xorb ?b true] => rewrite (Bool.xorb_true_r b) | |- context C [xorb ?b false] => rewrite (Bool.xorb_false_r b) | |- context C [xorb true ?b] => rewrite (Bool.orb_true_l b) | |- context C [xorb false ?b] => rewrite (Bool.orb_false_l b) end. (** * [simplify_bitblast_index] *) Create HintDb simplify_bitblast_index_db discriminated. Global Hint Rewrite Z.sub_add Z.add_simpl_r : simplify_bitblast_index_db. Local Ltac simplify_bitblast_index := autorewrite with simplify_bitblast_index_db. (** * Main typeclasses for bitblast *) Create HintDb bitblast discriminated. Global Hint Constants Opaque : bitblast. Global Hint Variables Opaque : bitblast. (** ** [IsPowerOfTwo] *) Class IsPowerOfTwo (z n : Z) := { is_power_of_two_proof : z = 2 ^ n; }. Global Arguments is_power_of_two_proof _ _ {_}. Global Hint Mode IsPowerOfTwo + - : bitblast. Lemma is_power_of_two_pow2 n : IsPowerOfTwo (2 ^ n) n. Proof. constructor. done. Qed. Global Hint Resolve is_power_of_two_pow2 | 10 : bitblast. Lemma is_power_of_two_const n p : (∀ x, [(n, 1%nat)] = x → prod_map Z.of_nat id <$> Z_to_bit_ranges (Z.pos p) = x) → IsPowerOfTwo (Z.pos p) n. Proof. move => Hn. constructor. have {}Hn := Hn _ ltac:(done). apply Z.bits_inj_iff' => i ?. apply eq_bool_prop_intro. rewrite Z_to_bit_ranges_spec; [|done|lia|done]. move: Hn => /(fmap_cons_inv _ _ _)[[n' ?][?/=[[??][/(@eq_sym _ _ _)/fmap_nil_inv->->]]]]. subst. rewrite Exists_cons Exists_nil /=. rewrite Z.pow2_bits_eqb ?Z_eqb_eq ?bool_decide_spec; lia. Qed. Global Hint Extern 10 (IsPowerOfTwo (Z.pos ?p) _) => lazymatch isPcst p with | true => idtac end; simple notypeclasses refine (is_power_of_two_const _ _ _); let H := fresh in intros ? H; vm_compute; apply H : bitblast. (** ** [BitblastBounded] *) Class BitblastBounded (z n : Z) := { bitblast_bounded_proof : 0 ≤ z < 2 ^ n; }. Global Arguments bitblast_bounded_proof _ _ {_}. Global Hint Mode BitblastBounded + - : bitblast. Global Hint Extern 10 (BitblastBounded _ _) => constructor; first [ split; [lia|done] | done] : bitblast. (** ** [Bitblast] *) Class Bitblast (z n : Z) (b : bool) := { bitblast_proof : Z.testbit z n = b; }. Global Arguments bitblast_proof _ _ _ {_}. Global Hint Mode Bitblast + + - : bitblast. Definition BITBLAST_TESTBIT := Z.testbit. Lemma bitblast_id z n : Bitblast z n (bool_decide (0 ≤ n) && BITBLAST_TESTBIT z n). Proof. constructor. case_bool_decide => //=. rewrite Z.testbit_neg_r //; lia. Qed. Global Hint Resolve bitblast_id | 1000 : bitblast. Lemma bitblast_id_bounded z z' n : BitblastBounded z z' → Bitblast z n (bool_decide (0 ≤ n < z') && BITBLAST_TESTBIT z n). Proof. move => [Hb]. constructor. move: (Hb) => /Z.bounded_iff_bits_nonneg' Hn. case_bool_decide => //=. destruct (decide (0 ≤ n)); [|rewrite Z.testbit_neg_r //; lia]. apply Hn; try lia. destruct (decide (0 ≤ z')) => //. rewrite Z.pow_neg_r in Hb; lia. Qed. Global Hint Resolve bitblast_id_bounded | 990 : bitblast. Lemma bitblast_0 n : Bitblast 0 n false. Proof. constructor. by rewrite Z.bits_0. Qed. Global Hint Resolve bitblast_0 | 10 : bitblast. Lemma bitblast_pos p n rs b : (∀ x, rs = x → (λ p, (Z.of_nat p.1, Z.of_nat p.1 + Z.of_nat p.2)) <$> Z_to_bit_ranges (Z.pos p) = x) → existsb (λ '(r1, r2), bool_decide (r1 ≤ n ∧ n < r2)) rs = b → Bitblast (Z.pos p) n b. Proof. move => Hr <-. constructor. rewrite -(Hr rs) //. destruct (decide (0 ≤ n)). 2: { rewrite Z.testbit_neg_r; [|lia]. elim: (Z_to_bit_ranges (Z.pos p)) => // [??]; csimpl => <-. case_bool_decide => //; lia. } apply eq_bool_prop_intro. rewrite Z_to_bit_ranges_spec; [|done..]. rewrite existb_True Exists_fmap. f_equiv => -[??] /=. by rewrite bool_decide_spec. Qed. Global Hint Extern 10 (Bitblast (Z.pos ?p) _ _) => lazymatch isPcst p with | true => idtac end; simple notypeclasses refine (bitblast_pos _ _ _ _ _ _);[shelve| let H := fresh in intros ? H; vm_compute; apply H | cbv [existsb]; exact eq_refl] : bitblast. Lemma bitblast_neg p n rs b : (∀ x, rs = x → (λ p, (Z.of_nat p.1, Z.of_nat p.1 + Z.of_nat p.2)) <$> Z_to_bit_ranges (Z.pred (Z.pos p)) = x) → forallb (λ '(r1, r2), bool_decide (n < r1 ∨ r2 ≤ n)) rs = b → Bitblast (Z.neg p) n (bool_decide (0 ≤ n) && b). Proof. move => Hr <-. constructor. rewrite -(Hr rs) //. case_bool_decide => /=; [|rewrite Z.testbit_neg_r; [done|lia]]. have -> : Z.neg p = Z.lnot (Z.pred (Z.pos p)). { rewrite -Pos2Z.opp_pos. have := Z.add_lnot_diag (Z.pred (Z.pos p)). lia. } rewrite Z.lnot_spec //. symmetry. apply negb_sym. apply eq_bool_prop_intro. rewrite Z_to_bit_ranges_spec; [|done|lia|done]. rewrite negb_forallb existb_True Exists_fmap. f_equiv => -[??] /=. rewrite negb_True bool_decide_spec. lia. Qed. Global Hint Extern 10 (Bitblast (Z.neg ?p) _ _) => lazymatch isPcst p with | true => idtac end; simple notypeclasses refine (bitblast_neg _ _ _ _ _ _);[shelve|shelve| let H := fresh in intros ? H; vm_compute; apply H | cbv [forallb]; exact eq_refl] : bitblast. Lemma bitblast_land z1 z2 n b1 b2 : Bitblast z1 n b1 → Bitblast z2 n b2 → Bitblast (Z.land z1 z2) n (b1 && b2). Proof. move => [<-] [<-]. constructor. by rewrite Z.land_spec. Qed. Global Hint Resolve bitblast_land | 10 : bitblast. Lemma bitblast_lor z1 z2 n b1 b2 : Bitblast z1 n b1 → Bitblast z2 n b2 → Bitblast (Z.lor z1 z2) n (b1 || b2). Proof. move => [<-] [<-]. constructor. by rewrite Z.lor_spec. Qed. Global Hint Resolve bitblast_lor | 10 : bitblast. Lemma bitblast_lxor z1 z2 n b1 b2 : Bitblast z1 n b1 → Bitblast z2 n b2 → Bitblast (Z.lxor z1 z2) n (xorb b1 b2). Proof. move => [<-] [<-]. constructor. by rewrite Z.lxor_spec. Qed. Global Hint Resolve bitblast_lxor | 10 : bitblast. Lemma bitblast_shiftr z1 z2 n b1 : Bitblast z1 (n + z2) b1 → Bitblast (z1 ≫ z2) n (bool_decide (0 ≤ n) && b1). Proof. move => [<-]. constructor. case_bool_decide => /=; [by rewrite Z.shiftr_spec| rewrite Z.testbit_neg_r //; lia]. Qed. Global Hint Resolve bitblast_shiftr | 10 : bitblast. Lemma bitblast_shiftl z1 z2 n b1 : Bitblast z1 (n - z2) b1 → Bitblast (z1 ≪ z2) n (bool_decide (0 ≤ n) && b1). Proof. move => [<-]. constructor. case_bool_decide => /=; [by rewrite Z.shiftl_spec| rewrite Z.testbit_neg_r //; lia]. Qed. Global Hint Resolve bitblast_shiftl | 10 : bitblast. Lemma bitblast_lnot z1 n b1 : Bitblast z1 n b1 → Bitblast (Z.lnot z1) n (bool_decide (0 ≤ n) && negb b1). Proof. move => [<-]. constructor. case_bool_decide => /=; [by rewrite Z.lnot_spec| rewrite Z.testbit_neg_r //; lia]. Qed. Global Hint Resolve bitblast_lnot | 10 : bitblast. Lemma bitblast_ldiff z1 z2 n b1 b2 : Bitblast z1 n b1 → Bitblast z2 n b2 → Bitblast (Z.ldiff z1 z2) n (b1 && negb b2). Proof. move => [<-] [<-]. constructor. by rewrite Z.ldiff_spec. Qed. Global Hint Resolve bitblast_ldiff | 10 : bitblast. Lemma bitblast_ones z1 n : Bitblast (Z.ones z1) n (bool_decide (0 ≤ n < z1) || bool_decide (z1 < 0 ∧ 0 ≤ n)). Proof. constructor. case_bool_decide; [by apply Z.ones_spec_low|] => /=. case_bool_decide. - rewrite Z.ones_equiv Z.pow_neg_r; [|lia]. apply Z.bits_m1. lia. - destruct (decide (0 ≤ n)); [|rewrite Z.testbit_neg_r //; lia]. apply Z.ones_spec_high; lia. Qed. Global Hint Resolve bitblast_ones | 10 : bitblast. Lemma bitblast_pow2 n n' : Bitblast (2 ^ n') n (bool_decide (n = n' ∧ 0 ≤ n)). Proof. constructor. case_bool_decide; destruct_and?; subst; [by apply Z.pow2_bits_true|]. destruct (decide (0 ≤ n)); [|rewrite Z.testbit_neg_r //; lia]. apply Z.pow2_bits_false. lia. Qed. Global Hint Resolve bitblast_pow2 | 10 : bitblast. Lemma bitblast_setbit z1 n b1 n' : Bitblast (Z.lor z1 (2 ^ n')) n b1 → Bitblast (Z.setbit z1 n') n b1. Proof. by rewrite Z.setbit_spec'. Qed. Global Hint Resolve bitblast_setbit | 10 : bitblast. Lemma bitblast_mod z1 z2 z2' n b1 : IsPowerOfTwo z2 z2' → Bitblast z1 n b1 → (* Coq 8.14 changed the definition of [x `mod` 0] from [0] to [x], so we have to use the following definition to be compatible with both Coq 8.12 and Coq 8.14. The [z2' < 0] case is hopefully not common in practice. *) (* TODO: After dropping support for Coq 8.14, switch to the following definition: *) (* Bitblast (z1 `mod` z2) n ((bool_decide (z2' < 0 ∧ 0 ≤ n) || bool_decide (n < z2')) && b1). *) Bitblast (z1 `mod` z2) n ((bool_decide (z2' < 0 ∧ 0 ≤ n) && Z.testbit (z1 `mod` 0) n) || (bool_decide (n < z2') && b1)). Proof. move => [->] [<-]. constructor. case_bool_decide => /=. { rewrite Z.pow_neg_r ?bool_decide_false /= ?orb_false_r; [done|lia..]. } destruct (decide (0 ≤ n)). 2: { rewrite !Z.testbit_neg_r ?andb_false_r //; lia. } rewrite -Z.land_ones; [|lia]. rewrite Z.land_spec Z.ones_spec; [|lia..]. by rewrite andb_comm. Qed. Global Hint Resolve bitblast_mod | 10 : bitblast. (* TODO: What are good instances for +? Maybe something based on Z_add_nocarry_lor? *) Lemma bitblast_add_0 z1 z2 b1 b2 : Bitblast z1 0 b1 → Bitblast z2 0 b2 → Bitblast (z1 + z2) 0 (xorb b1 b2). Proof. move => [<-] [<-]. constructor. apply Z.add_bit0. Qed. Global Hint Resolve bitblast_add_0 | 5 : bitblast. Lemma bitblast_add_1 z1 z2 b10 b11 b20 b21 : Bitblast z1 0 b10 → Bitblast z2 0 b20 → Bitblast z1 1 b11 → Bitblast z2 1 b21 → Bitblast (z1 + z2) 1 (xorb (xorb b11 b21) (b10 && b20)). Proof. move => [<-] [<-] [<-] [<-]. constructor. apply Z.add_bit1. Qed. Global Hint Resolve bitblast_add_1 | 5 : bitblast. Lemma bitblast_clearbit z n b m : Bitblast z n b → Bitblast (Z.clearbit z m) n (bool_decide (n ≠ m) && b). Proof. move => [<-]. constructor. case_bool_decide; subst => /=. - by apply Z.clearbit_neq. - by apply Z.clearbit_eq. Qed. Global Hint Resolve bitblast_clearbit | 10 : bitblast. (** * Tactics *) (** ** Helper definitions and lemmas for the tactics *) Definition BITBLAST_BOOL_DECIDE := @bool_decide. Global Arguments BITBLAST_BOOL_DECIDE _ {_}. Lemma tac_bitblast_bool_decide_true G (P : Prop) `{!Decision P} : P → G true → G (bool_decide P). Proof. move => ??. by rewrite bool_decide_eq_true_2. Qed. Lemma tac_bitblast_bool_decide_false G (P : Prop) `{!Decision P} : ¬ P → G false → G (bool_decide P). Proof. move => ??. by rewrite bool_decide_eq_false_2. Qed. Lemma tac_bitblast_bool_decide_split G (P : Prop) `{!Decision P} : (P → G true) → (¬ P → G false) → G (bool_decide P). Proof. move => ??. case_bool_decide; eauto. Qed. (** ** Core tactics *) Ltac bitblast_done := solve [ first [ done | lia | btauto ] ]. (** [bitblast_blast_eq] applies to goals of the form [Z.testbit _ _ = ?x] and bitblasts the Z.testbit using the [Bitblast] typeclass. *) Ltac bitblast_blast_eq := lazymatch goal with |- Z.testbit _ _ = _ => idtac end; etrans; [ notypeclasses refine (bitblast_proof _ _ _); typeclasses eauto with bitblast | ]; simplify_bitblast_index; exact eq_refl. (** [bitblast_bool_decide_simplify] get rids of unnecessary bool_decide in the goal. *) Ltac bitblast_bool_decide_simplify := repeat lazymatch goal with | |- context [@bool_decide ?P ?Dec] => pattern (@bool_decide P Dec); lazymatch goal with | |- ?G _ => first [ refine (@tac_bitblast_bool_decide_true G P Dec _ _); [lia|]; simpl_bool_cbn | refine (@tac_bitblast_bool_decide_false G P Dec _ _); [lia|]; simpl_bool_cbn | change_no_check (G (@BITBLAST_BOOL_DECIDE P Dec)) ] end; cbv beta end; (** simpl_bool contains rewriting so it can be quite slow and thus we only do it at the end. *) simpl_bool; lazymatch goal with | |- ?G => let x := eval unfold BITBLAST_BOOL_DECIDE in G in change_no_check x end. (** [bitblast_bool_decide_split] performs a case distinction on a bool_decide in the goal. *) Ltac bitblast_bool_decide_split := lazymatch goal with | |- context [@bool_decide ?P ?Dec] => pattern (@bool_decide P Dec); lazymatch goal with | |- ?G _ => refine (@tac_bitblast_bool_decide_split G P Dec _ _) => ?; cbv beta; simpl_bool end end. (** [bitblast_unfold] bitblasts all [Z.testbit] in the goal. *) Ltac bitblast_unfold := repeat lazymatch goal with | |- context [Z.testbit ?z ?n] => pattern (Z.testbit z n); simple refine (eq_rec_r _ _ _); [shelve| |bitblast_blast_eq]; cbv beta end; lazymatch goal with | |- ?G => let x := eval unfold BITBLAST_TESTBIT in G in change_no_check x end. (** [bitblast_raw] bitblasts all [Z.testbit] in the goal and simplifies the result. *) Ltac bitblast_raw := bitblast_unfold; bitblast_bool_decide_simplify; try bitblast_done; repeat (bitblast_bool_decide_split; bitblast_bool_decide_simplify; try bitblast_done). (** ** Tactic notations *) Tactic Notation "bitblast" "as" ident(i) := apply Z.bits_inj_iff'; intros i => ?; bitblast_raw. Tactic Notation "bitblast" := lazymatch goal with | |- context [Z.testbit _ _] => idtac | _ => apply Z.bits_inj_iff' => ?? end; bitblast_raw. Tactic Notation "bitblast" ident(H) := tactic bitblast_unfold in H; tactic bitblast_bool_decide_simplify in H. Tactic Notation "bitblast" ident(H) "with" constr(i) "as" ident(H') := lazymatch type of H with (* We cannot use [efeed pose proof] since this causes weird failures in combination with [Set Mangle Names]. *) | @eq Z _ _ => opose proof* (Z_bits_inj'' _ _ H i) as H'; [try bitblast_done..|] | ∀ x, _ => opose proof* (H i) as H'; [try bitblast_done..|] end; bitblast H'. Tactic Notation "bitblast" ident(H) "with" constr(i) := let H' := fresh "H" in bitblast H with i as H'. stdpp-coq-stdpp-1.9.0/stdpp_unstable/bitvector.v000066400000000000000000001402171451153341500220110ustar00rootroot00000000000000(** This file is still experimental. See its tracking issue https://gitlab.mpi-sws.org/iris/stdpp/-/issues/145 for details on remaining issues before stabilization. This file is maintained by Michael Sammler. *) From stdpp Require Export numbers. From stdpp Require Import countable finite. From stdpp Require Import options. (** * bitvector library *) (** This file provides the [bv n] type for representing [n]-bit integers with the standard operations. It also provides the [bv_saturate] tactic for learning facts about the range of bit vector variables in context. More extensive automation can be found in [bitvector_auto.v]. Additionally, this file provides the [bvn] type for representing a bitvector of arbitrary size. *) (** * Settings *) Local Open Scope Z_scope. (** * Preliminary definitions *) Definition bv_modulus (n : N) : Z := 2 ^ (Z.of_N n). Definition bv_half_modulus (n : N) : Z := bv_modulus n `div` 2. Definition bv_wrap (n : N) (z : Z) : Z := z `mod` bv_modulus n. Definition bv_swrap (n : N) (z : Z) : Z := bv_wrap n (z + bv_half_modulus n) - bv_half_modulus n. Lemma bv_modulus_pos n : 0 < bv_modulus n. Proof. apply Z.pow_pos_nonneg; lia. Qed. Lemma bv_modulus_gt_1 n : n ≠ 0%N → 1 < bv_modulus n. Proof. intros ?. apply Z.pow_gt_1; lia. Qed. Lemma bv_half_modulus_nonneg n : 0 ≤ bv_half_modulus n. Proof. apply Z.div_pos; [|done]. pose proof bv_modulus_pos n. lia. Qed. Lemma bv_modulus_add n1 n2 : bv_modulus (n1 + n2) = bv_modulus n1 * bv_modulus n2. Proof. unfold bv_modulus. rewrite N2Z.inj_add. eapply Z.pow_add_r; lia. Qed. Lemma bv_half_modulus_twice n: n ≠ 0%N → bv_half_modulus n + bv_half_modulus n = bv_modulus n. Proof. intros. unfold bv_half_modulus, bv_modulus. rewrite Z.add_diag. symmetry. apply Z_div_exact_2; [lia|]. rewrite <-Z.pow_pred_r by lia. rewrite Z.mul_comm. by apply Z.mod_mul. Qed. Lemma bv_half_modulus_lt_modulus n: bv_half_modulus n < bv_modulus n. Proof. pose proof bv_modulus_pos n. apply Z_div_lt; [done| lia]. Qed. Lemma bv_modulus_le_mono n m: (n ≤ m)%N → bv_modulus n ≤ bv_modulus m. Proof. intros. apply Z.pow_le_mono; [done|lia]. Qed. Lemma bv_half_modulus_le_mono n m: (n ≤ m)%N → bv_half_modulus n ≤ bv_half_modulus m. Proof. intros. apply Z.div_le_mono; [done|]. by apply bv_modulus_le_mono. Qed. Lemma bv_modulus_0: bv_modulus 0 = 1. Proof. done. Qed. Lemma bv_half_modulus_0: bv_half_modulus 0 = 0. Proof. done. Qed. Lemma bv_half_modulus_twice_mult n: bv_half_modulus n + bv_half_modulus n = (Z.of_N n `min` 1) * bv_modulus n. Proof. destruct (decide (n = 0%N)); subst; [ rewrite bv_half_modulus_0 | rewrite bv_half_modulus_twice]; lia. Qed. Lemma bv_wrap_in_range n z: 0 ≤ bv_wrap n z < bv_modulus n. Proof. apply Z.mod_pos_bound. apply bv_modulus_pos. Qed. Lemma bv_swrap_in_range n z: n ≠ 0%N → - bv_half_modulus n ≤ bv_swrap n z < bv_half_modulus n. Proof. intros ?. unfold bv_swrap. pose proof bv_half_modulus_twice n. pose proof bv_wrap_in_range n (z + bv_half_modulus n). lia. Qed. Lemma bv_wrap_small n z : 0 ≤ z < bv_modulus n → bv_wrap n z = z. Proof. intros. by apply Z.mod_small. Qed. Lemma bv_swrap_small n z : - bv_half_modulus n ≤ z < bv_half_modulus n → bv_swrap n z = z. Proof. intros Hrange. unfold bv_swrap. destruct (decide (n = 0%N)); subst. { rewrite bv_half_modulus_0 in Hrange. lia. } pose proof bv_half_modulus_twice n. rewrite bv_wrap_small by lia. lia. Qed. Lemma bv_wrap_0 n : bv_wrap n 0 = 0. Proof. done. Qed. Lemma bv_swrap_0 n : bv_swrap n 0 = 0. Proof. pose proof bv_half_modulus_lt_modulus n. pose proof bv_half_modulus_nonneg n. unfold bv_swrap. rewrite bv_wrap_small; lia. Qed. Lemma bv_wrap_idemp n b : bv_wrap n (bv_wrap n b) = bv_wrap n b. Proof. unfold bv_wrap. by rewrite Zmod_mod. Qed. Definition bv_wrap_factor (n : N) (x z : Z) := x = - z `div` bv_modulus n. Lemma bv_wrap_factor_intro n z : ∃ x, bv_wrap_factor n x z ∧ bv_wrap n z = z + x * bv_modulus n. Proof. eexists _. split; [done|]. pose proof (bv_modulus_pos n). unfold bv_wrap. rewrite Z.mod_eq; lia. Qed. Lemma bv_wrap_add_modulus c n z: bv_wrap n (z + c * bv_modulus n) = bv_wrap n z. Proof. apply Z_mod_plus_full. Qed. Lemma bv_wrap_add_modulus_1 n z: bv_wrap n (z + bv_modulus n) = bv_wrap n z. Proof. rewrite <-(bv_wrap_add_modulus 1 n z). f_equal. lia. Qed. Lemma bv_wrap_sub_modulus c n z: bv_wrap n (z - c * bv_modulus n) = bv_wrap n z. Proof. rewrite <-(bv_wrap_add_modulus (-c) n z). f_equal. lia. Qed. Lemma bv_wrap_sub_modulus_1 n z: bv_wrap n (z - bv_modulus n) = bv_wrap n z. Proof. rewrite <-(bv_wrap_add_modulus (-1) n z). done. Qed. Lemma bv_wrap_add_idemp n x y : bv_wrap n (bv_wrap n x + bv_wrap n y) = bv_wrap n (x + y). Proof. symmetry. apply Zplus_mod. Qed. Lemma bv_wrap_add_idemp_l n x y : bv_wrap n (bv_wrap n x + y) = bv_wrap n (x + y). Proof. apply Zplus_mod_idemp_l. Qed. Lemma bv_wrap_add_idemp_r n x y : bv_wrap n (x + bv_wrap n y) = bv_wrap n (x + y). Proof. apply Zplus_mod_idemp_r. Qed. Lemma bv_wrap_opp_idemp n x : bv_wrap n (- bv_wrap n x) = bv_wrap n (- x). Proof. unfold bv_wrap. pose proof (bv_modulus_pos n). destruct (decide (x `mod` bv_modulus n = 0)) as [Hx|Hx]. - rewrite !Z.mod_opp_l_z; [done |lia|done|lia|by rewrite Hx]. - rewrite !Z.mod_opp_l_nz, Z.mod_mod; [done|lia|lia|done|lia|by rewrite Z.mod_mod by lia]. Qed. Lemma bv_wrap_mul_idemp n x y : bv_wrap n (bv_wrap n x * bv_wrap n y) = bv_wrap n (x * y). Proof. etrans; [| apply Zmult_mod_idemp_r]. apply Zmult_mod_idemp_l. Qed. Lemma bv_wrap_mul_idemp_l n x y : bv_wrap n (bv_wrap n x * y) = bv_wrap n (x * y). Proof. apply Zmult_mod_idemp_l. Qed. Lemma bv_wrap_mul_idemp_r n x y : bv_wrap n (x * bv_wrap n y) = bv_wrap n (x * y). Proof. apply Zmult_mod_idemp_r. Qed. Lemma bv_wrap_sub_idemp n x y : bv_wrap n (bv_wrap n x - bv_wrap n y) = bv_wrap n (x - y). Proof. by rewrite <-!Z.add_opp_r, <-bv_wrap_add_idemp_r, bv_wrap_opp_idemp, bv_wrap_add_idemp. Qed. Lemma bv_wrap_sub_idemp_l n x y : bv_wrap n (bv_wrap n x - y) = bv_wrap n (x - y). Proof. by rewrite <-!Z.add_opp_r, bv_wrap_add_idemp_l. Qed. Lemma bv_wrap_sub_idemp_r n x y : bv_wrap n (x - bv_wrap n y) = bv_wrap n (x - y). Proof. by rewrite <-!Z.add_opp_r, <-bv_wrap_add_idemp_r, bv_wrap_opp_idemp, bv_wrap_add_idemp_r. Qed. Lemma bv_wrap_succ_idemp n x : bv_wrap n (Z.succ (bv_wrap n x)) = bv_wrap n (Z.succ x). Proof. by rewrite <-!Z.add_1_r, bv_wrap_add_idemp_l. Qed. Lemma bv_wrap_pred_idemp n x : bv_wrap n (Z.pred (bv_wrap n x)) = bv_wrap n (Z.pred x). Proof. by rewrite <-!Z.sub_1_r, bv_wrap_sub_idemp_l. Qed. Lemma bv_wrap_add_inj n x1 x2 y : bv_wrap n x1 = bv_wrap n x2 ↔ bv_wrap n (x1 + y) = bv_wrap n (x2 + y). Proof. split; intros Heq. - by rewrite <-bv_wrap_add_idemp_l, Heq, bv_wrap_add_idemp_l. - pose proof (bv_wrap_factor_intro n (x1 + y)) as [f1[? Hx1]]. pose proof (bv_wrap_factor_intro n (x2 + y)) as [f2[? Hx2]]. assert (x1 = x2 + f2 * bv_modulus n - f1 * bv_modulus n) as -> by lia. by rewrite bv_wrap_sub_modulus, bv_wrap_add_modulus. Qed. Lemma bv_swrap_wrap n z: bv_swrap n (bv_wrap n z) = bv_swrap n z. Proof. unfold bv_swrap, bv_wrap. by rewrite Zplus_mod_idemp_l. Qed. Lemma bv_wrap_bv_wrap n1 n2 bv : (n1 ≤ n2)%N → bv_wrap n1 (bv_wrap n2 bv) = bv_wrap n1 bv. Proof. intros ?. unfold bv_wrap. rewrite <-Znumtheory.Zmod_div_mod; [done| apply bv_modulus_pos.. |]. unfold bv_modulus. eexists (2 ^ (Z.of_N n2 - Z.of_N n1)). rewrite <-Z.pow_add_r by lia. f_equal. lia. Qed. Lemma bv_wrap_land n z : bv_wrap n z = Z.land z (Z.ones (Z.of_N n)). Proof. by rewrite Z.land_ones by lia. Qed. Lemma bv_wrap_spec n z i: 0 ≤ i → Z.testbit (bv_wrap n z) i = bool_decide (i < Z.of_N n) && Z.testbit z i. Proof. intros ?. rewrite bv_wrap_land, Z.land_spec, Z.ones_spec by lia. case_bool_decide; simpl; by rewrite ?andb_true_r, ?andb_false_r. Qed. Lemma bv_wrap_spec_low n z i: 0 ≤ i < Z.of_N n → Z.testbit (bv_wrap n z) i = Z.testbit z i. Proof. intros ?. rewrite bv_wrap_spec; [|lia]. case_bool_decide; [done|]. lia. Qed. Lemma bv_wrap_spec_high n z i: Z.of_N n ≤ i → Z.testbit (bv_wrap n z) i = false. Proof. intros ?. rewrite bv_wrap_spec; [|lia]. case_bool_decide; [|done]. lia. Qed. (** * [BvWf] *) (** The [BvWf] typeclass checks that the integer [z] can be interpreted as a [n]-bit integer. [BvWf] is a typeclass such that it can be automatically inferred for bitvector constants. *) Class BvWf (n : N) (z : Z) : Prop := bv_wf : (0 <=? z) && (z is_closed_term n; is_closed_term v; try (vm_compute; exact I); fail "Bitvector constant" v "does not fit into" n "bits" end. Global Hint Extern 10 (BvWf _ _) => solve_BvWf : typeclass_instances. Lemma bv_wf_in_range n z: BvWf n z ↔ 0 ≤ z < bv_modulus n. Proof. unfold BvWf. by rewrite andb_True, !Is_true_true, Z.leb_le, Z.ltb_lt. Qed. Lemma bv_wrap_wf n z : BvWf n (bv_wrap n z). Proof. apply bv_wf_in_range. apply bv_wrap_in_range. Qed. Lemma bv_wf_bitwise_op {n} op bop n1 n2 : (∀ k, Z.testbit (op n1 n2) k = bop (Z.testbit n1 k) (Z.testbit n2 k)) → (0 ≤ n1 → 0 ≤ n2 → 0 ≤ op n1 n2) → bop false false = false → BvWf n n1 → BvWf n n2 → BvWf n (op n1 n2). Proof. intros Hbits Hnonneg Hop [? Hok1]%bv_wf_in_range [? Hok2]%bv_wf_in_range. apply bv_wf_in_range. split; [lia|]. apply Z.bounded_iff_bits_nonneg; [lia..|]. intros l ?. eapply Z.bounded_iff_bits_nonneg in Hok1;[|try done; lia..]. eapply Z.bounded_iff_bits_nonneg in Hok2;[|try done; lia..]. by rewrite Hbits, Hok1, Hok2. Qed. (** * Definition of [bv n] *) Record bv (n : N) := BV { bv_unsigned : Z; bv_is_wf : BvWf n bv_unsigned; }. Global Arguments bv_unsigned {_}. Global Arguments bv_is_wf {_}. Global Arguments BV _ _ {_}. Add Printing Constructor bv. Global Arguments bv_unsigned : simpl never. Definition bv_signed {n} (b : bv n) := bv_swrap n (bv_unsigned b). Lemma bv_eq n (b1 b2 : bv n) : b1 = b2 ↔ b1.(bv_unsigned) = b2.(bv_unsigned). Proof. destruct b1, b2. unfold bv_unsigned. split; [ naive_solver|]. intros. subst. f_equal. apply proof_irrel. Qed. Lemma bv_neq n (b1 b2 : bv n) : b1 ≠ b2 ↔ b1.(bv_unsigned) ≠ b2.(bv_unsigned). Proof. unfold not. by rewrite bv_eq. Qed. Global Instance bv_unsigned_inj n : Inj (=) (=) (@bv_unsigned n). Proof. intros ???. by apply bv_eq. Qed. Definition Z_to_bv_checked (n : N) (z : Z) : option (bv n) := guard (BvWf n z) as H; Some (@BV n z H). Program Definition Z_to_bv (n : N) (z : Z) : bv n := @BV n (bv_wrap n z) _. Next Obligation. apply bv_wrap_wf. Qed. Lemma Z_to_bv_unsigned n z: bv_unsigned (Z_to_bv n z) = bv_wrap n z. Proof. done. Qed. Lemma Z_to_bv_signed n z: bv_signed (Z_to_bv n z) = bv_swrap n z. Proof. apply bv_swrap_wrap. Qed. Lemma Z_to_bv_small n z: 0 ≤ z < bv_modulus n → bv_unsigned (Z_to_bv n z) = z. Proof. rewrite Z_to_bv_unsigned. apply bv_wrap_small. Qed. Lemma bv_unsigned_BV n z Hwf: bv_unsigned (@BV n z Hwf) = z. Proof. done. Qed. Lemma bv_signed_BV n z Hwf: bv_signed (@BV n z Hwf) = bv_swrap n z. Proof. done. Qed. Lemma bv_unsigned_in_range n (b : bv n): 0 ≤ bv_unsigned b < bv_modulus n. Proof. apply bv_wf_in_range. apply bv_is_wf. Qed. Lemma bv_wrap_bv_unsigned n (b : bv n): bv_wrap n (bv_unsigned b) = bv_unsigned b. Proof. rewrite bv_wrap_small; [done|apply bv_unsigned_in_range]. Qed. Lemma Z_to_bv_bv_unsigned n (b : bv n): Z_to_bv n (bv_unsigned b) = b. Proof. apply bv_eq. by rewrite Z_to_bv_unsigned, bv_wrap_bv_unsigned. Qed. Lemma bv_eq_wrap n (b1 b2 : bv n) : b1 = b2 ↔ bv_wrap n b1.(bv_unsigned) = bv_wrap n b2.(bv_unsigned). Proof. rewrite !bv_wrap_small; [apply bv_eq | apply bv_unsigned_in_range..]. Qed. Lemma bv_neq_wrap n (b1 b2 : bv n) : b1 ≠ b2 ↔ bv_wrap n b1.(bv_unsigned) ≠ bv_wrap n b2.(bv_unsigned). Proof. unfold not. by rewrite bv_eq_wrap. Qed. Lemma bv_eq_signed n (b1 b2 : bv n) : b1 = b2 ↔ bv_signed b1 = bv_signed b2. Proof. split; [naive_solver |]. unfold bv_signed, bv_swrap. intros ?. assert (bv_wrap n (bv_unsigned b1 + bv_half_modulus n) = bv_wrap n (bv_unsigned b2 + bv_half_modulus n)) as ?%bv_wrap_add_inj by lia. by apply bv_eq_wrap. Qed. Lemma bv_signed_in_range n (b : bv n): n ≠ 0%N → - bv_half_modulus n ≤ bv_signed b < bv_half_modulus n. Proof. apply bv_swrap_in_range. Qed. Lemma bv_unsigned_spec_high i n (b : bv n) : Z.of_N n ≤ i → Z.testbit (bv_unsigned b) i = false. Proof. intros ?. pose proof (bv_unsigned_in_range _ b). unfold bv_modulus in *. eapply Z.bounded_iff_bits_nonneg; [..|done]; lia. Qed. Lemma bv_unsigned_N_0 (b : bv 0): bv_unsigned b = 0. Proof. pose proof bv_unsigned_in_range 0 b as H. rewrite bv_modulus_0 in H. lia. Qed. Lemma bv_signed_N_0 (b : bv 0): bv_signed b = 0. Proof. unfold bv_signed. by rewrite bv_unsigned_N_0, bv_swrap_0. Qed. Lemma bv_swrap_bv_signed n (b : bv n): bv_swrap n (bv_signed b) = bv_signed b. Proof. destruct (decide (n = 0%N)); subst. { by rewrite bv_signed_N_0, bv_swrap_0. } apply bv_swrap_small. by apply bv_signed_in_range. Qed. Lemma Z_to_bv_checked_bv_unsigned n (b : bv n): Z_to_bv_checked n (bv_unsigned b) = Some b. Proof. unfold Z_to_bv_checked. case_option_guard. - f_equal. by apply bv_eq. - by pose proof bv_is_wf b. Qed. Lemma Z_to_bv_checked_Some n a (b : bv n): Z_to_bv_checked n a = Some b ↔ a = bv_unsigned b. Proof. split. - unfold Z_to_bv_checked. case_option_guard; [|done]. intros ?. by simplify_eq. - intros ->. apply Z_to_bv_checked_bv_unsigned. Qed. (** * Typeclass instances for [bv n] *) Global Program Instance bv_eq_dec n : EqDecision (bv n) := λ '(@BV _ v1 p1) '(@BV _ v2 p2), match decide (v1 = v2) with | left eqv => left _ | right eqv => right _ end. Next Obligation. (* TODO: Can we get a better proof term here? *) intros n b1 v1 p1 ? b2 v2 p2 ????. subst. rewrite (proof_irrel p1 p2). exact eq_refl. Defined. Next Obligation. intros. by injection. Qed. Global Instance bv_countable n : Countable (bv n) := inj_countable bv_unsigned (Z_to_bv_checked n) (Z_to_bv_checked_bv_unsigned n). Global Program Instance bv_finite n : Finite (bv n) := {| enum := Z_to_bv n <$> (seqZ 0 (bv_modulus n)) |}. Next Obligation. intros n. apply NoDup_alt. intros i j x. rewrite !list_lookup_fmap. intros [? [[??]%lookup_seqZ ?]]%fmap_Some. intros [? [[??]%lookup_seqZ Hz]]%fmap_Some. subst. apply bv_eq in Hz. rewrite !Z_to_bv_small in Hz; lia. Qed. Next Obligation. intros n x. apply elem_of_list_lookup. eexists (Z.to_nat (bv_unsigned x)). rewrite list_lookup_fmap. apply fmap_Some. eexists _. pose proof (bv_unsigned_in_range _ x). split. - apply lookup_seqZ. split; [done|]. rewrite Z2Nat.id; lia. - apply bv_eq. rewrite Z_to_bv_small; rewrite Z2Nat.id; lia. Qed. Lemma bv_1_ind (P : bv 1 → Prop) : P (@BV 1 1 I) → P (@BV 1 0 I) → ∀ b : bv 1, P b. Proof. intros ??. apply Forall_finite. repeat constructor. - by assert ((@BV 1 0 I) = (Z_to_bv 1 (Z.of_nat 0 + 0))) as <- by by apply bv_eq. - by assert ((@BV 1 1 I) = (Z_to_bv 1 (Z.of_nat 1 + 0))) as <- by by apply bv_eq. Qed. (** * [bv_saturate]: Add range facts about bit vectors to the context *) Ltac bv_saturate := repeat match goal with b : bv _ |- _ => first [ clear b | (* Clear if unused *) learn_hyp (bv_unsigned_in_range _ b) | learn_hyp (bv_signed_in_range _ b) ] end. Ltac bv_saturate_unsigned := repeat match goal with b : bv _ |- _ => first [ clear b | (* Clear if unused *) learn_hyp (bv_unsigned_in_range _ b) ] end. (** * Operations on [bv n] *) Program Definition bv_0 (n : N) := @BV n 0 _. Next Obligation. intros n. apply bv_wf_in_range. split; [done| apply bv_modulus_pos]. Qed. Global Instance bv_inhabited n : Inhabited (bv n) := populate (bv_0 n). Definition bv_succ {n} (x : bv n) : bv n := Z_to_bv n (Z.succ (bv_unsigned x)). Definition bv_pred {n} (x : bv n) : bv n := Z_to_bv n (Z.pred (bv_unsigned x)). Definition bv_add {n} (x y : bv n) : bv n := (* SMT: bvadd *) Z_to_bv n (Z.add (bv_unsigned x) (bv_unsigned y)). Definition bv_sub {n} (x y : bv n) : bv n := (* SMT: bvsub *) Z_to_bv n (Z.sub (bv_unsigned x) (bv_unsigned y)). Definition bv_opp {n} (x : bv n) : bv n := (* SMT: bvneg *) Z_to_bv n (Z.opp (bv_unsigned x)). Definition bv_mul {n} (x y : bv n) : bv n := (* SMT: bvmul *) Z_to_bv n (Z.mul (bv_unsigned x) (bv_unsigned y)). Program Definition bv_divu {n} (x y : bv n) : bv n := (* SMT: bvudiv *) @BV n (Z.div (bv_unsigned x) (bv_unsigned y)) _. Next Obligation. intros n x y. apply bv_wf_in_range. bv_saturate. destruct (decide (bv_unsigned y = 0)) as [->|?]. { rewrite Zdiv_0_r. lia. } split; [ apply Z.div_pos; lia |]. apply (Z.le_lt_trans _ (bv_unsigned x)); [|lia]. apply Z.div_le_upper_bound; [ lia|]. nia. Qed. Program Definition bv_modu {n} (x y : bv n) : bv n := (* SMT: bvurem *) @BV n (Z.modulo (bv_unsigned x) (bv_unsigned y)) _. Next Obligation. intros n x y. apply bv_wf_in_range. bv_saturate. destruct (decide (bv_unsigned y = 0)) as [->|?]. { rewrite Zmod_0_r. lia. } split; [ apply Z.mod_pos; lia |]. apply (Z.le_lt_trans _ (bv_unsigned x)); [|lia]. apply Z.mod_le; lia. Qed. Definition bv_divs {n} (x y : bv n) : bv n := Z_to_bv n (Z.div (bv_signed x) (bv_signed y)). Definition bv_quots {n} (x y : bv n) : bv n := (* SMT: bvsdiv *) Z_to_bv n (Z.quot (bv_signed x) (bv_signed y)). Definition bv_mods {n} (x y : bv n) : bv n := (* SMT: bvsmod *) Z_to_bv n (Z.modulo (bv_signed x) (bv_signed y)). Definition bv_rems {n} (x y : bv n) : bv n := (* SMT: bvsrem *) Z_to_bv n (Z.rem (bv_signed x) (bv_signed y)). Definition bv_shiftl {n} (x y : bv n) : bv n := (* SMT: bvshl *) Z_to_bv n (Z.shiftl (bv_unsigned x) (bv_unsigned y)). Program Definition bv_shiftr {n} (x y : bv n) : bv n := (* SMT: bvlshr *) @BV n (Z.shiftr (bv_unsigned x) (bv_unsigned y)) _. Next Obligation. intros n x y. apply bv_wf_in_range. bv_saturate. split; [ apply Z.shiftr_nonneg; lia|]. rewrite Z.shiftr_div_pow2; [|lia]. apply (Z.le_lt_trans _ (bv_unsigned x)); [|lia]. pose proof (Z.pow_pos_nonneg 2 (bv_unsigned y)). apply Z.div_le_upper_bound; [ lia|]. nia. Qed. Definition bv_ashiftr {n} (x y : bv n) : bv n := (* SMT: bvashr *) Z_to_bv n (Z.shiftr (bv_signed x) (bv_unsigned y)). Program Definition bv_or {n} (x y : bv n) : bv n := (* SMT: bvor *) @BV n (Z.lor (bv_unsigned x) (bv_unsigned y)) _. Next Obligation. intros. eapply bv_wf_bitwise_op; [ apply Z.lor_spec | by intros; eapply Z.lor_nonneg | done | apply bv_is_wf..]. Qed. Program Definition bv_and {n} (x y : bv n) : bv n := (* SMT: bvand *) @BV n (Z.land (bv_unsigned x) (bv_unsigned y)) _. Next Obligation. intros. eapply bv_wf_bitwise_op; [ apply Z.land_spec | intros; eapply Z.land_nonneg; by left | done | apply bv_is_wf..]. Qed. Program Definition bv_xor {n} (x y : bv n) : bv n := (* SMT: bvxor *) @BV n (Z.lxor (bv_unsigned x) (bv_unsigned y)) _. Next Obligation. intros. eapply bv_wf_bitwise_op; [ apply Z.lxor_spec | intros; eapply Z.lxor_nonneg; naive_solver | done | apply bv_is_wf..]. Qed. Program Definition bv_not {n} (x : bv n) : bv n := (* SMT: bvnot *) Z_to_bv n (Z.lnot (bv_unsigned x)). (* [bv_zero_extends z b] extends [b] to [z] bits with 0. If [z] is smaller than [n], [b] is truncated. Note that [z] gives the resulting size instead of the number of bits to add (as SMTLIB does) to avoid a type-level [_ + _] *) Program Definition bv_zero_extend {n} (z : N) (b : bv n) : bv z := (* SMT: zero_extend *) Z_to_bv z (bv_unsigned b). Program Definition bv_sign_extend {n} (z : N) (b : bv n) : bv z := (* SMT: sign_extend *) Z_to_bv z (bv_signed b). (* s is start index and l is length. Note that this is different from extract in SMTLIB which uses [extract (inclusive upper bound) (inclusive lower bound)]. The version here is phrased in a way that makes it impossible to use an upper bound that is lower than the lower bound. *) Definition bv_extract {n} (s l : N) (b : bv n) : bv l := Z_to_bv l (bv_unsigned b ≫ Z.of_N s). (* Note that we should always have n1 + n2 = n, but we use a parameter to avoid a type-level (_ + _) *) Program Definition bv_concat n {n1 n2} (b1 : bv n1) (b2 : bv n2) : bv n := (* SMT: concat *) Z_to_bv n (Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2)). Definition bv_to_little_endian m n (z : Z) : list (bv n) := (λ b, Z_to_bv n b) <$> Z_to_little_endian m (Z.of_N n) z. Definition little_endian_to_bv n (bs : list (bv n)) : Z := little_endian_to_Z (Z.of_N n) (bv_unsigned <$> bs). (** * Operations on [bv n] and Z *) Definition bv_add_Z {n} (x : bv n) (y : Z) : bv n := Z_to_bv n (Z.add (bv_unsigned x) y). Definition bv_sub_Z {n} (x : bv n) (y : Z) : bv n := Z_to_bv n (Z.sub (bv_unsigned x) y). Definition bv_mul_Z {n} (x : bv n) (y : Z) : bv n := Z_to_bv n (Z.mul (bv_unsigned x) y). Definition bv_seq {n} (x : bv n) (len : Z) : list (bv n) := (bv_add_Z x) <$> seqZ 0 len. (** * Operations on [bv n] and bool *) Definition bool_to_bv (n : N) (b : bool) : bv n := Z_to_bv n (bool_to_Z b). Definition bv_to_bits {n} (b : bv n) : list bool := (λ i, Z.testbit (bv_unsigned b) i) <$> seqZ 0 (Z.of_N n). (** * Notation for [bv] operations *) Declare Scope bv_scope. Delimit Scope bv_scope with bv. Bind Scope bv_scope with bv. Infix "+" := bv_add : bv_scope. Infix "-" := bv_sub : bv_scope. Notation "- x" := (bv_opp x) : bv_scope. Infix "*" := bv_mul : bv_scope. Infix "`divu`" := bv_divu (at level 35) : bv_scope. Infix "`modu`" := bv_modu (at level 35) : bv_scope. Infix "`divs`" := bv_divs (at level 35) : bv_scope. Infix "`quots`" := bv_quots (at level 35) : bv_scope. Infix "`mods`" := bv_mods (at level 35) : bv_scope. Infix "`rems`" := bv_rems (at level 35) : bv_scope. Infix "≪" := bv_shiftl : bv_scope. Infix "≫" := bv_shiftr : bv_scope. Infix "`ashiftr`" := bv_ashiftr (at level 35) : bv_scope. Infix "`+Z`" := bv_add_Z (at level 50) : bv_scope. Infix "`-Z`" := bv_sub_Z (at level 50) : bv_scope. Infix "`*Z`" := bv_mul_Z (at level 40) : bv_scope. (** This adds number notations into [bv_scope]. If the number literal is positive or 0, it gets expanded to [BV _ {num} _]. If the number literal is negative, it gets expanded as [Z_to_bv _ {num}]. In the negative case, the notation is parsing only and the [Z_to_bv] call will be printed explicitly. *) Inductive bv_number_notation := BVNumNonNeg (z : Z) | BVNumNeg (z : Z). Definition bv_number_notation_to_Z (n : bv_number_notation) : option Z := match n with | BVNumNonNeg z => Some z (** Don't use the notation for negative numbers for printing. *) | BVNumNeg z => None end. Definition Z_to_bv_number_notation (z : Z) := match z with | Zneg _ => BVNumNeg z | _ => BVNumNonNeg z end. (** We need to temporarily change the implicit arguments of BV and Z_to_bv such that we can pass them to [Number Notation]. *) Local Arguments Z_to_bv {_} _. Local Arguments BV {_} _ {_}. Number Notation bv Z_to_bv_number_notation bv_number_notation_to_Z (via bv_number_notation mapping [[BV] => BVNumNonNeg, [Z_to_bv] => BVNumNeg]) : bv_scope. Local Arguments BV _ _ {_}. Local Arguments Z_to_bv : clear implicits. (** * [bv_wrap_simplify]: typeclass-based automation for simplifying [bv_wrap] *) (** The [bv_wrap_simplify] tactic removes [bv_wrap] where possible by using the fact that [bv_wrap n (bv_warp n z) = bv_wrap n z]. The main use case for this tactic is for proving the lemmas about the operations of [bv n] below. Users should use the more extensive automation provided by [bitvector_auto.v]. *) Create HintDb bv_wrap_simplify_db discriminated. Global Hint Constants Opaque : bv_wrap_simplify_db. Global Hint Variables Opaque : bv_wrap_simplify_db. Class BvWrapSimplify (n : N) (z z' : Z) := { bv_wrap_simplify_proof : bv_wrap n z = bv_wrap n z'; }. Global Arguments bv_wrap_simplify_proof _ _ _ {_}. Global Hint Mode BvWrapSimplify + + - : bv_wrap_simplify_db. (** Default instance to end search. *) Lemma bv_wrap_simplify_id n z : BvWrapSimplify n z z. Proof. by constructor. Qed. Global Hint Resolve bv_wrap_simplify_id | 1000 : bv_wrap_simplify_db. (** [bv_wrap_simplify_bv_wrap] performs the actual simplification. *) Lemma bv_wrap_simplify_bv_wrap n z z' : BvWrapSimplify n z z' → BvWrapSimplify n (bv_wrap n z) z'. Proof. intros [->]. constructor. by rewrite bv_wrap_bv_wrap. Qed. Global Hint Resolve bv_wrap_simplify_bv_wrap | 10 : bv_wrap_simplify_db. (** The rest of the instances propagate [BvWrapSimplify]. *) Lemma bv_wrap_simplify_succ n z z' : BvWrapSimplify n z z' → BvWrapSimplify n (Z.succ z) (Z.succ z'). Proof. intros [Hz]. constructor. by rewrite <-bv_wrap_succ_idemp, Hz, bv_wrap_succ_idemp. Qed. Global Hint Resolve bv_wrap_simplify_succ | 10 : bv_wrap_simplify_db. Lemma bv_wrap_simplify_pred n z z' : BvWrapSimplify n z z' → BvWrapSimplify n (Z.pred z) (Z.pred z'). Proof. intros [Hz]. constructor. by rewrite <-bv_wrap_pred_idemp, Hz, bv_wrap_pred_idemp. Qed. Global Hint Resolve bv_wrap_simplify_pred | 10 : bv_wrap_simplify_db. Lemma bv_wrap_simplify_opp n z z' : BvWrapSimplify n z z' → BvWrapSimplify n (- z) (- z'). Proof. intros [Hz]. constructor. by rewrite <-bv_wrap_opp_idemp, Hz, bv_wrap_opp_idemp. Qed. Global Hint Resolve bv_wrap_simplify_opp | 10 : bv_wrap_simplify_db. Lemma bv_wrap_simplify_add n z1 z1' z2 z2' : BvWrapSimplify n z1 z1' → BvWrapSimplify n z2 z2' → BvWrapSimplify n (z1 + z2) (z1' + z2'). Proof. intros [Hz1] [Hz2]. constructor. by rewrite <-bv_wrap_add_idemp, Hz1, Hz2, bv_wrap_add_idemp. Qed. Global Hint Resolve bv_wrap_simplify_add | 10 : bv_wrap_simplify_db. Lemma bv_wrap_simplify_sub n z1 z1' z2 z2' : BvWrapSimplify n z1 z1' → BvWrapSimplify n z2 z2' → BvWrapSimplify n (z1 - z2) (z1' - z2'). Proof. intros [Hz1] [Hz2]. constructor. by rewrite <-bv_wrap_sub_idemp, Hz1, Hz2, bv_wrap_sub_idemp. Qed. Global Hint Resolve bv_wrap_simplify_sub | 10 : bv_wrap_simplify_db. Lemma bv_wrap_simplify_mul n z1 z1' z2 z2' : BvWrapSimplify n z1 z1' → BvWrapSimplify n z2 z2' → BvWrapSimplify n (z1 * z2) (z1' * z2'). Proof. intros [Hz1] [Hz2]. constructor. by rewrite <-bv_wrap_mul_idemp, Hz1, Hz2, bv_wrap_mul_idemp. Qed. Global Hint Resolve bv_wrap_simplify_mul | 10 : bv_wrap_simplify_db. (** [bv_wrap_simplify_left] applies for goals of the form [bv_wrap n z1 = _] and tries to simplify them by removing any [bv_wrap] inside z1. *) Ltac bv_wrap_simplify_left := lazymatch goal with |- bv_wrap _ _ = _ => idtac end; etrans; [ notypeclasses refine (bv_wrap_simplify_proof _ _ _); typeclasses eauto with bv_wrap_simplify_db | ] . (** [bv_wrap_simplify] applies for goals of the form [bv_wrap n z1 = bv_wrap n z2] and [bv_swrap n z1 = bv_swrap n z2] and tries to simplify them by removing any [bv_wrap] and [bv_swrap] inside z1 and z2. *) Ltac bv_wrap_simplify := unfold bv_signed, bv_swrap; try match goal with | |- _ - _ = _ - _ => f_equal end; bv_wrap_simplify_left; symmetry; bv_wrap_simplify_left; symmetry. Ltac bv_wrap_simplify_solve := bv_wrap_simplify; f_equal; lia. (** * Lemmas about [bv n] operations *) (** ** Unfolding lemmas for the operations. *) Section unfolding. Context {n : N}. Implicit Types (b : bv n). Lemma bv_0_unsigned : bv_unsigned (bv_0 n) = 0. Proof. done. Qed. Lemma bv_0_signed : bv_signed (bv_0 n) = 0. Proof. unfold bv_0. by rewrite bv_signed_BV, bv_swrap_0. Qed. Lemma bv_succ_unsigned b : bv_unsigned (bv_succ b) = bv_wrap n (Z.succ (bv_unsigned b)). Proof. done. Qed. Lemma bv_succ_signed b : bv_signed (bv_succ b) = bv_swrap n (Z.succ (bv_signed b)). Proof. unfold bv_succ. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_pred_unsigned b : bv_unsigned (bv_pred b) = bv_wrap n (Z.pred (bv_unsigned b)). Proof. done. Qed. Lemma bv_pred_signed b : bv_signed (bv_pred b) = bv_swrap n (Z.pred (bv_signed b)). Proof. unfold bv_pred. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_add_unsigned b1 b2 : bv_unsigned (b1 + b2) = bv_wrap n (bv_unsigned b1 + bv_unsigned b2). Proof. done. Qed. Lemma bv_add_signed b1 b2 : bv_signed (b1 + b2) = bv_swrap n (bv_signed b1 + bv_signed b2). Proof. unfold bv_add. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_sub_unsigned b1 b2 : bv_unsigned (b1 - b2) = bv_wrap n (bv_unsigned b1 - bv_unsigned b2). Proof. done. Qed. Lemma bv_sub_signed b1 b2 : bv_signed (b1 - b2) = bv_swrap n (bv_signed b1 - bv_signed b2). Proof. unfold bv_sub. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_opp_unsigned b : bv_unsigned (- b) = bv_wrap n (- bv_unsigned b). Proof. done. Qed. Lemma bv_opp_signed b : bv_signed (- b) = bv_swrap n (- bv_signed b). Proof. unfold bv_opp. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_mul_unsigned b1 b2 : bv_unsigned (b1 * b2) = bv_wrap n (bv_unsigned b1 * bv_unsigned b2). Proof. done. Qed. Lemma bv_mul_signed b1 b2 : bv_signed (b1 * b2) = bv_swrap n (bv_signed b1 * bv_signed b2). Proof. unfold bv_mul. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_divu_unsigned b1 b2 : bv_unsigned (b1 `divu` b2) = bv_unsigned b1 `div` bv_unsigned b2. Proof. done. Qed. Lemma bv_divu_signed b1 b2 : bv_signed (b1 `divu` b2) = bv_swrap n (bv_unsigned b1 `div` bv_unsigned b2). Proof. done. Qed. Lemma bv_modu_unsigned b1 b2 : bv_unsigned (b1 `modu` b2) = bv_unsigned b1 `mod` bv_unsigned b2. Proof. done. Qed. Lemma bv_modu_signed b1 b2 : bv_signed (b1 `modu` b2) = bv_swrap n (bv_unsigned b1 `mod` bv_unsigned b2). Proof. done. Qed. Lemma bv_divs_unsigned b1 b2 : bv_unsigned (b1 `divs` b2) = bv_wrap n (bv_signed b1 `div` bv_signed b2). Proof. done. Qed. Lemma bv_divs_signed b1 b2 : bv_signed (b1 `divs` b2) = bv_swrap n (bv_signed b1 `div` bv_signed b2). Proof. unfold bv_divs. rewrite Z_to_bv_signed. done. Qed. Lemma bv_quots_unsigned b1 b2 : bv_unsigned (b1 `quots` b2) = bv_wrap n (bv_signed b1 `quot` bv_signed b2). Proof. done. Qed. Lemma bv_quots_signed b1 b2 : bv_signed (b1 `quots` b2) = bv_swrap n (bv_signed b1 `quot` bv_signed b2). Proof. unfold bv_quots. rewrite Z_to_bv_signed. done. Qed. Lemma bv_mods_unsigned b1 b2 : bv_unsigned (b1 `mods` b2) = bv_wrap n (bv_signed b1 `mod` bv_signed b2). Proof. done. Qed. Lemma bv_mods_signed b1 b2 : bv_signed (b1 `mods` b2) = bv_swrap n (bv_signed b1 `mod` bv_signed b2). Proof. unfold bv_mods. rewrite Z_to_bv_signed. done. Qed. Lemma bv_rems_unsigned b1 b2 : bv_unsigned (b1 `rems` b2) = bv_wrap n (bv_signed b1 `rem` bv_signed b2). Proof. done. Qed. Lemma bv_rems_signed b1 b2 : bv_signed (b1 `rems` b2) = bv_swrap n (bv_signed b1 `rem` bv_signed b2). Proof. unfold bv_rems. rewrite Z_to_bv_signed. done. Qed. Lemma bv_shiftl_unsigned b1 b2 : bv_unsigned (b1 ≪ b2) = bv_wrap n (bv_unsigned b1 ≪ bv_unsigned b2). Proof. done. Qed. Lemma bv_shiftl_signed b1 b2 : bv_signed (b1 ≪ b2) = bv_swrap n (bv_unsigned b1 ≪ bv_unsigned b2). Proof. unfold bv_shiftl. rewrite Z_to_bv_signed. done. Qed. Lemma bv_shiftr_unsigned b1 b2 : bv_unsigned (b1 ≫ b2) = bv_unsigned b1 ≫ bv_unsigned b2. Proof. done. Qed. Lemma bv_shiftr_signed b1 b2 : bv_signed (b1 ≫ b2) = bv_swrap n (bv_unsigned b1 ≫ bv_unsigned b2). Proof. done. Qed. Lemma bv_ashiftr_unsigned b1 b2 : bv_unsigned (b1 `ashiftr` b2) = bv_wrap n (bv_signed b1 ≫ bv_unsigned b2). Proof. done. Qed. Lemma bv_ashiftr_signed b1 b2 : bv_signed (b1 `ashiftr` b2) = bv_swrap n (bv_signed b1 ≫ bv_unsigned b2). Proof. unfold bv_ashiftr. rewrite Z_to_bv_signed. done. Qed. Lemma bv_or_unsigned b1 b2 : bv_unsigned (bv_or b1 b2) = Z.lor (bv_unsigned b1) (bv_unsigned b2). Proof. done. Qed. Lemma bv_or_signed b1 b2 : bv_signed (bv_or b1 b2) = bv_swrap n (Z.lor (bv_unsigned b1) (bv_unsigned b2)). Proof. done. Qed. Lemma bv_and_unsigned b1 b2 : bv_unsigned (bv_and b1 b2) = Z.land (bv_unsigned b1) (bv_unsigned b2). Proof. done. Qed. Lemma bv_and_signed b1 b2 : bv_signed (bv_and b1 b2) = bv_swrap n (Z.land (bv_unsigned b1) (bv_unsigned b2)). Proof. done. Qed. Lemma bv_xor_unsigned b1 b2 : bv_unsigned (bv_xor b1 b2) = Z.lxor (bv_unsigned b1) (bv_unsigned b2). Proof. done. Qed. Lemma bv_xor_signed b1 b2 : bv_signed (bv_xor b1 b2) = bv_swrap n (Z.lxor (bv_unsigned b1) (bv_unsigned b2)). Proof. done. Qed. Lemma bv_not_unsigned b : bv_unsigned (bv_not b) = bv_wrap n (Z.lnot (bv_unsigned b)). Proof. done. Qed. Lemma bv_not_signed b : bv_signed (bv_not b) = bv_swrap n (Z.lnot (bv_unsigned b)). Proof. unfold bv_not. rewrite Z_to_bv_signed. done. Qed. Lemma bv_zero_extend_unsigned' z b : bv_unsigned (bv_zero_extend z b) = bv_wrap z (bv_unsigned b). Proof. done. Qed. (* [bv_zero_extend_unsigned] is the version that we want, but it only holds with a precondition. *) Lemma bv_zero_extend_unsigned z b : (n ≤ z)%N → bv_unsigned (bv_zero_extend z b) = bv_unsigned b. Proof. intros ?. rewrite bv_zero_extend_unsigned', bv_wrap_small; [done|]. bv_saturate. pose proof (bv_modulus_le_mono n z). lia. Qed. Lemma bv_zero_extend_signed z b : bv_signed (bv_zero_extend z b) = bv_swrap z (bv_unsigned b). Proof. unfold bv_zero_extend. rewrite Z_to_bv_signed. done. Qed. Lemma bv_sign_extend_unsigned z b : bv_unsigned (bv_sign_extend z b) = bv_wrap z (bv_signed b). Proof. done. Qed. Lemma bv_sign_extend_signed' z b : bv_signed (bv_sign_extend z b) = bv_swrap z (bv_signed b). Proof. unfold bv_sign_extend. rewrite Z_to_bv_signed. done. Qed. (* [bv_sign_extend_signed] is the version that we want, but it only holds with a precondition. *) Lemma bv_sign_extend_signed z b : (n ≤ z)%N → bv_signed (bv_sign_extend z b) = bv_signed b. Proof. intros ?. rewrite bv_sign_extend_signed'. destruct (decide (n = 0%N)); subst. { by rewrite bv_signed_N_0, bv_swrap_0. } apply bv_swrap_small. bv_saturate. pose proof bv_half_modulus_le_mono n z. lia. Qed. Lemma bv_extract_unsigned s l b : bv_unsigned (bv_extract s l b) = bv_wrap l (bv_unsigned b ≫ Z.of_N s). Proof. done. Qed. Lemma bv_extract_signed s l b : bv_signed (bv_extract s l b) = bv_swrap l (bv_unsigned b ≫ Z.of_N s). Proof. unfold bv_extract. rewrite Z_to_bv_signed. done. Qed. Lemma bv_concat_unsigned' m n2 b1 (b2 : bv n2) : bv_unsigned (bv_concat m b1 b2) = bv_wrap m (Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2)). Proof. done. Qed. (* [bv_concat_unsigned] is the version that we want, but it only holds with a precondition. *) Lemma bv_concat_unsigned m n2 b1 (b2 : bv n2) : (m = n + n2)%N → bv_unsigned (bv_concat m b1 b2) = Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2). Proof. intros ->. rewrite bv_concat_unsigned', bv_wrap_small; [done|]. apply Z.bounded_iff_bits_nonneg'; [lia | |]. { apply Z.lor_nonneg. bv_saturate. split; [|lia]. apply Z.shiftl_nonneg. lia. } intros k ?. rewrite Z.lor_spec, Z.shiftl_spec; [|lia]. apply orb_false_intro; (eapply Z.bounded_iff_bits_nonneg; [..|done]); bv_saturate; try lia. - apply (Z.lt_le_trans _ (bv_modulus n)); [lia|]. apply Z.pow_le_mono_r; lia. - apply (Z.lt_le_trans _ (bv_modulus n2)); [lia|]. apply Z.pow_le_mono_r; lia. Qed. Lemma bv_concat_signed m n2 b1 (b2 : bv n2) : bv_signed (bv_concat m b1 b2) = bv_swrap m (Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2)). Proof. unfold bv_concat. rewrite Z_to_bv_signed. done. Qed. Lemma bv_add_Z_unsigned b z : bv_unsigned (b `+Z` z) = bv_wrap n (bv_unsigned b + z). Proof. done. Qed. Lemma bv_add_Z_signed b z : bv_signed (b `+Z` z) = bv_swrap n (bv_signed b + z). Proof. unfold bv_add_Z. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_sub_Z_unsigned b z : bv_unsigned (b `-Z` z) = bv_wrap n (bv_unsigned b - z). Proof. done. Qed. Lemma bv_sub_Z_signed b z : bv_signed (b `-Z` z) = bv_swrap n (bv_signed b - z). Proof. unfold bv_sub_Z. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. Lemma bv_mul_Z_unsigned b z: bv_unsigned (b `*Z` z) = bv_wrap n (bv_unsigned b * z). Proof. done. Qed. Lemma bv_mul_Z_signed b z : bv_signed (b `*Z` z) = bv_swrap n (bv_signed b * z). Proof. unfold bv_mul_Z. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed. End unfolding. (** ** Properties of bv operations *) Section properties. Context {n : N}. Implicit Types (b : bv n). Local Open Scope bv_scope. Lemma bv_sub_add_opp b1 b2: b1 - b2 = b1 + - b2. Proof. apply bv_eq. unfold bv_sub, bv_add, bv_opp. rewrite !Z_to_bv_unsigned. bv_wrap_simplify_solve. Qed. Global Instance bv_add_assoc : Assoc (=) (@bv_add n). Proof. intros ???. unfold bv_add. apply bv_eq. rewrite !Z_to_bv_unsigned. bv_wrap_simplify_solve. Qed. Global Instance bv_mul_assoc : Assoc (=) (@bv_mul n). Proof. intros ???. unfold bv_mul. apply bv_eq. rewrite !Z_to_bv_unsigned. bv_wrap_simplify_solve. Qed. Lemma bv_add_0_l b1 b2 : bv_unsigned b1 = 0%Z → b1 + b2 = b2. Proof. intros Hb. apply bv_eq. rewrite bv_add_unsigned, Hb, Z.add_0_l, bv_wrap_small; [done|apply bv_unsigned_in_range]. Qed. Lemma bv_add_0_r b1 b2 : bv_unsigned b2 = 0%Z → b1 + b2 = b1. Proof. intros Hb. apply bv_eq. rewrite bv_add_unsigned, Hb, Z.add_0_r, bv_wrap_small; [done|apply bv_unsigned_in_range]. Qed. Lemma bv_add_Z_0 b : b `+Z` 0 = b. Proof. unfold bv_add_Z. rewrite Z.add_0_r. apply bv_eq. apply Z_to_bv_small. apply bv_unsigned_in_range. Qed. Lemma bv_add_Z_add_r b m o: b `+Z` (m + o) = (b `+Z` o) `+Z` m. Proof. apply bv_eq. unfold bv_add_Z. rewrite !Z_to_bv_unsigned. bv_wrap_simplify_solve. Qed. Lemma bv_add_Z_add_l b m o: b `+Z` (m + o) = (b `+Z` m) `+Z` o. Proof. apply bv_eq. unfold bv_add_Z. rewrite !Z_to_bv_unsigned. bv_wrap_simplify_solve. Qed. Lemma bv_add_Z_succ b m: b `+Z` Z.succ m = (b `+Z` 1) `+Z` m. Proof. apply bv_eq. unfold bv_add_Z. rewrite !Z_to_bv_unsigned. bv_wrap_simplify_solve. Qed. Lemma bv_add_Z_inj_l b i j: 0 ≤ i < bv_modulus n → 0 ≤ j < bv_modulus n → b `+Z` i = b `+Z` j ↔ i = j. Proof. intros ??. split; [|naive_solver]. intros Heq%bv_eq. rewrite !bv_add_Z_unsigned, !(Z.add_comm (bv_unsigned _)) in Heq. by rewrite <-bv_wrap_add_inj, !bv_wrap_small in Heq. Qed. Lemma bv_opp_not b: - b `-Z` 1 = bv_not b. Proof. apply bv_eq. rewrite bv_not_unsigned, bv_sub_Z_unsigned, bv_opp_unsigned, <-Z.opp_lnot. bv_wrap_simplify_solve. Qed. Lemma bv_and_comm b1 b2: bv_and b1 b2 = bv_and b2 b1. Proof. apply bv_eq. by rewrite !bv_and_unsigned, Z.land_comm. Qed. Lemma bv_or_comm b1 b2: bv_or b1 b2 = bv_or b2 b1. Proof. apply bv_eq. by rewrite !bv_or_unsigned, Z.lor_comm. Qed. Lemma bv_or_0_l b1 b2 : bv_unsigned b1 = 0%Z → bv_or b1 b2 = b2. Proof. intros Hb. apply bv_eq. by rewrite bv_or_unsigned, Hb, Z.lor_0_l. Qed. Lemma bv_or_0_r b1 b2 : bv_unsigned b2 = 0%Z → bv_or b1 b2 = b1. Proof. intros Hb. apply bv_eq. by rewrite bv_or_unsigned, Hb, Z.lor_0_r. Qed. Lemma bv_extract_0_unsigned l b: bv_unsigned (bv_extract 0 l b) = bv_wrap l (bv_unsigned b). Proof. rewrite bv_extract_unsigned, Z.shiftr_0_r. done. Qed. Lemma bv_extract_0_bv_add_distr l b1 b2: (l ≤ n)%N → bv_extract 0 l (bv_add b1 b2) = bv_add (bv_extract 0 l b1) (bv_extract 0 l b2). Proof. intros ?. apply bv_eq. rewrite !bv_extract_0_unsigned, !bv_add_unsigned, !bv_extract_0_unsigned. rewrite bv_wrap_bv_wrap by done. bv_wrap_simplify_solve. Qed. Lemma bv_concat_0 m n2 b1 (b2 : bv n2) : bv_unsigned b1 = 0%Z → bv_concat m b1 b2 = bv_zero_extend m b2. Proof. intros Hb1. apply bv_eq. by rewrite bv_zero_extend_unsigned', bv_concat_unsigned', Hb1, Z.shiftl_0_l, Z.lor_0_l. Qed. Lemma bv_zero_extend_idemp b: bv_zero_extend n b = b. Proof. apply bv_eq. by rewrite bv_zero_extend_unsigned. Qed. Lemma bv_sign_extend_idemp b: bv_sign_extend n b = b. Proof. apply bv_eq_signed. by rewrite bv_sign_extend_signed. Qed. End properties. (** ** Lemmas about [bv_to_little] and [bv_of_little] *) Section little. Lemma bv_to_litte_endian_unsigned m n z: 0 ≤ m → bv_unsigned <$> bv_to_little_endian m n z = Z_to_little_endian m (Z.of_N n) z. Proof. intros ?. apply list_eq. intros i. unfold bv_to_little_endian. rewrite list_lookup_fmap, list_lookup_fmap. destruct (Z_to_little_endian m (Z.of_N n) z !! i) eqn: Heq; [simpl |done]. rewrite Z_to_bv_small; [done|]. eapply (Forall_forall (λ z, _ ≤ z < _)); [ |by eapply elem_of_list_lookup_2]. eapply Z_to_little_endian_bound; lia. Qed. Lemma bv_to_little_endian_to_bv m n bs: m = Z.of_nat (length bs) → bv_to_little_endian m n (little_endian_to_bv n bs) = bs. Proof. intros ->. apply (inj (fmap bv_unsigned)). rewrite bv_to_litte_endian_unsigned; [|lia]. apply Z_to_little_endian_to_Z; [by rewrite fmap_length | lia |]. apply Forall_forall. intros ? [?[->?]]%elem_of_list_fmap_2. apply bv_unsigned_in_range. Qed. Lemma little_endian_to_bv_to_little_endian m n z: 0 ≤ m → little_endian_to_bv n (bv_to_little_endian m n z) = z `mod` 2 ^ (m * Z.of_N n). Proof. intros ?. unfold little_endian_to_bv. rewrite bv_to_litte_endian_unsigned; [|lia]. apply little_endian_to_Z_to_little_endian; lia. Qed. Lemma bv_to_little_endian_length m n z : 0 ≤ m → length (bv_to_little_endian m n z) = Z.to_nat m. Proof. intros ?. unfold bv_to_little_endian. rewrite fmap_length. apply Nat2Z.inj. rewrite Z_to_little_endian_length, ?Z2Nat.id; try lia. Qed. Lemma little_endian_to_bv_bound n bs : 0 ≤ little_endian_to_bv n bs < 2 ^ (Z.of_nat (length bs) * Z.of_N n). Proof. unfold little_endian_to_bv. rewrite <-(fmap_length bv_unsigned bs). apply little_endian_to_Z_bound; [lia|]. apply Forall_forall. intros ? [? [-> ?]]%elem_of_list_fmap. apply bv_unsigned_in_range. Qed. Lemma Z_to_bv_little_endian_to_bv_to_little_endian x m n (b : bv x): 0 ≤ m → x = (Z.to_N m * n)%N → Z_to_bv x (little_endian_to_bv n (bv_to_little_endian m n (bv_unsigned b))) = b. Proof. intros ? ->. rewrite little_endian_to_bv_to_little_endian, Z.mod_small; [| |lia]. - apply bv_eq. rewrite Z_to_bv_small; [done|]. apply bv_unsigned_in_range. - pose proof bv_unsigned_in_range _ b as Hr. unfold bv_modulus in Hr. by rewrite N2Z.inj_mul, Z2N.id in Hr. Qed. Lemma bv_to_little_endian_lookup_Some m n z (i : nat) x: 0 ≤ m → bv_to_little_endian m n z !! i = Some x ↔ Z.of_nat i < m ∧ x = Z_to_bv n (z ≫ (Z.of_nat i * Z.of_N n)). Proof. unfold bv_to_little_endian. intros Hm. rewrite list_lookup_fmap, fmap_Some. split. - intros [?[[??]%Z_to_little_endian_lookup_Some ?]]; [|lia..]; subst. split; [done|]. rewrite <-bv_wrap_land. apply bv_eq. by rewrite !Z_to_bv_unsigned, bv_wrap_bv_wrap. - intros [?->]. eexists _. split; [apply Z_to_little_endian_lookup_Some; try done; lia| ]. rewrite <-bv_wrap_land. apply bv_eq. by rewrite !Z_to_bv_unsigned, bv_wrap_bv_wrap. Qed. Lemma little_endian_to_bv_spec n bs i b: 0 ≤ i → n ≠ 0%N → bs !! Z.to_nat (i `div` Z.of_N n) = Some b → Z.testbit (little_endian_to_bv n bs) i = Z.testbit (bv_unsigned b) (i `mod` Z.of_N n). Proof. intros ???. unfold little_endian_to_bv. apply little_endian_to_Z_spec; [lia|lia| |]. { apply Forall_fmap. apply Forall_true. intros ?; simpl. apply bv_unsigned_in_range. } rewrite list_lookup_fmap. apply fmap_Some. naive_solver. Qed. End little. (** ** Lemmas about [bv_seq] *) Section bv_seq. Context {n : N}. Implicit Types (b : bv n). Lemma bv_seq_length b len: length (bv_seq b len) = Z.to_nat len. Proof. unfold bv_seq. by rewrite fmap_length, seqZ_length. Qed. Lemma bv_seq_succ b m: 0 ≤ m → bv_seq b (Z.succ m) = b :: bv_seq (b `+Z` 1) m. Proof. intros. unfold bv_seq. rewrite seqZ_cons by lia. csimpl. rewrite bv_add_Z_0. f_equal. assert (Z.succ 0 = 1 + 0) as -> by lia. rewrite <-fmap_add_seqZ, <-list_fmap_compose, Z.pred_succ. apply list_fmap_ext. intros i x. simpl. by rewrite bv_add_Z_add_l. Qed. Lemma NoDup_bv_seq b z: 0 ≤ z ≤ bv_modulus n → NoDup (bv_seq b z). Proof. intros ?. apply NoDup_alt. intros i j b'. unfold bv_seq. rewrite !list_lookup_fmap. intros [?[[??]%lookup_seqZ ?]]%fmap_Some ; simplify_eq. intros [?[[->?]%lookup_seqZ ?%bv_add_Z_inj_l]]%fmap_Some; lia. Qed. End bv_seq. (** ** Lemmas about [bv] and [bool] *) Section bv_bool. Implicit Types (b : bool). Lemma bool_to_bv_unsigned n b: n ≠ 0%N → bv_unsigned (bool_to_bv n b) = bool_to_Z b. Proof. intros ?. pose proof (bv_modulus_gt_1 n). apply Z_to_bv_small. destruct b; simpl; lia. Qed. Lemma bv_extract_bool_to_bv n n2 b: n ≠ 0%N → n2 ≠ 0%N → bv_extract 0 n (bool_to_bv n2 b) = bool_to_bv n b. Proof. intros ??. apply bv_eq. pose proof (bv_modulus_gt_1 n). rewrite bv_extract_unsigned, !bool_to_bv_unsigned, Z.shiftr_0_r by done. rewrite bv_wrap_small; [done|]. destruct b; simpl; lia. Qed. Lemma bv_not_bool_to_bv b: bv_not (bool_to_bv 1 b) = bool_to_bv 1 (negb b). Proof. apply bv_eq. by destruct b. Qed. Lemma bool_decide_bool_to_bv_0 b: bool_decide (bv_unsigned (bool_to_bv 1 b) = 0) = negb b. Proof. by destruct b. Qed. Lemma bool_decide_bool_to_bv_1 b: bool_decide (bv_unsigned (bool_to_bv 1 b) = 1) = b. Proof. by destruct b. Qed. End bv_bool. Section bv_bits. Context {n : N}. Implicit Types (b : bv n). Lemma bv_to_bits_length b : length (bv_to_bits b) = N.to_nat n. Proof. unfold bv_to_bits. rewrite fmap_length, seqZ_length, <-Z_N_nat, N2Z.id. done. Qed. Lemma bv_to_bits_lookup_Some b i x: bv_to_bits b !! i = Some x ↔ (i < N.to_nat n)%nat ∧ x = Z.testbit (bv_unsigned b) (Z.of_nat i). Proof. unfold bv_to_bits. rewrite list_lookup_fmap, fmap_Some. split. - intros [?[?%lookup_seqZ?]]. naive_solver lia. - intros [??]. eexists _. split; [|done]. apply lookup_seqZ. lia. Qed. Global Instance bv_to_bits_inj : Inj eq eq (@bv_to_bits n). Proof. unfold bv_to_bits. intros x y Hf. apply bv_eq_wrap. apply Z.bits_inj_iff'. intros i Hi. rewrite !bv_wrap_spec; [|lia..]. case_bool_decide; simpl; [|done]. eapply list_fmap_inj_1 in Hf; [done|]. apply elem_of_seqZ. lia. Qed. End bv_bits. (** * [bvn] *) Record bvn := bv_to_bvn { bvn_n : N; bvn_val : bv bvn_n; }. Global Arguments bv_to_bvn {_} _. Add Printing Constructor bvn. Definition bvn_unsigned (b : bvn) := bv_unsigned (b.(bvn_val)). Lemma bvn_eq (b1 b2 : bvn) : b1 = b2 ↔ b1.(bvn_n) = b2.(bvn_n) ∧ bvn_unsigned b1 = bvn_unsigned b2. Proof. split; [ naive_solver|]. destruct b1, b2; simpl; intros [??]. subst. f_equal. by apply bv_eq. Qed. Global Program Instance bvn_eq_dec : EqDecision bvn := λ '(@bv_to_bvn n1 b1) '(@bv_to_bvn n2 b2), cast_if_and (decide (n1 = n2)) (decide (bv_unsigned b1 = bv_unsigned b2)). (* TODO: The following does not compute to eq_refl*) Next Obligation. intros. apply bvn_eq. naive_solver. Qed. Next Obligation. intros. intros ?%bvn_eq. naive_solver. Qed. Next Obligation. intros. intros ?%bvn_eq. naive_solver. Qed. Definition bvn_to_bv (n : N) (b : bvn) : option (bv n) := match decide (b.(bvn_n) = n) with | left eq => Some (eq_rect (bvn_n b) (λ n0 : N, bv n0) (bvn_val b) n eq) | right _ => None end. Global Arguments bvn_to_bv !_ !_ /. Global Coercion bv_to_bvn : bv >-> bvn. (** * Opaqueness *) (** We mark all functions on bitvectors as opaque. *) Global Hint Opaque Z_to_bv bv_0 bv_succ bv_pred bv_add bv_sub bv_opp bv_mul bv_divu bv_modu bv_divs bv_quots bv_mods bv_rems bv_shiftl bv_shiftr bv_ashiftr bv_or bv_and bv_xor bv_not bv_zero_extend bv_sign_extend bv_extract bv_concat bv_add_Z bv_sub_Z bv_mul_Z bool_to_bv bv_to_bits : typeclass_instances. Global Opaque Z_to_bv bv_0 bv_succ bv_pred bv_add bv_sub bv_opp bv_mul bv_divu bv_modu bv_divs bv_quots bv_mods bv_rems bv_shiftl bv_shiftr bv_ashiftr bv_or bv_and bv_xor bv_not bv_zero_extend bv_sign_extend bv_extract bv_concat bv_add_Z bv_sub_Z bv_mul_Z bool_to_bv bv_to_bits. stdpp-coq-stdpp-1.9.0/stdpp_unstable/bitvector_tactics.v000066400000000000000000000550441451153341500235260ustar00rootroot00000000000000(** This file is still experimental. See its tracking issue https://gitlab.mpi-sws.org/iris/stdpp/-/issues/146 for details on remaining issues before stabilization. This file is maintained by Michael Sammler. *) From stdpp.unstable Require Export bitvector. From stdpp.unstable Require Import bitblast. From stdpp Require Import options. (** * bitvector tactics *) (** This file provides tactics for the bitvector library in [bitvector.v]. In particular, it provides integration of bitvectors with the [bitblast] tactic and tactics for simplifying and solving bitvector expressions. The main tactic provided by this library is [bv_simplify] which performs the following steps: 1. Simplify the goal by rewriting with the [bv_simplify] database. 2. If the goal is an (in)equality (= or ≠) between bitvectors, turn it into an (in)equality between their unsigned values. (Using unsigned values here rather than signed is somewhat arbitrary but works well enough in practice.) 3. Unfold [bv_unsigned] and [bv_signed] of operations on [bv n] to operations on [Z]. 4. Simplify the goal by rewriting with the [bv_unfolded_simplify] database. This file provides the following variants of the [bv_simplify] tactic: - [bv_simplify] applies the simplification procedure to the goal. - [bv_simplify H] applies the simplification procedure to the hypothesis [H]. - [bv_simplify select pat] applies the simplification procedure to the hypothesis matching [pat]. - [bv_simplify_arith] applies the simplification procedure to the goal and additionally rewrites with the [bv_unfolded_to_arith] database to turn the goal into a more suitable shape for calling [lia]. - [bv_simplify_arith H] same as [bv_simplify_arith], but in the hypothesis [H]. - [bv_simplify_arith select pat] same as [bv_simplify_arith], but in the hypothesis matching [pat]. - [bv_solve] simplifies the goal using [bv_simplify_arith], learns bounds facts about bitvector variables in the context and tries to solve the goal using [lia]. This automation assumes that [lia] can handle [`mod`] and [`div`] as can be enabled via the one of the following flags: Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations. or Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations. or Ltac Zify.zify_convert_to_euclidean_division_equations_flag ::= constr:(true). See https://coq.github.io/doc/master/refman/addendum/micromega.html#coq:tacn.zify for details. *) (** * Settings *) Local Open Scope Z_scope. (** * General tactics *) Ltac unfold_lets_in_context := repeat match goal with | H := _ |- _ => unfold H in *; clear H end. Tactic Notation "reduce_closed" constr(x) := is_closed_term x; let r := eval vm_compute in x in change_no_check x with r in * . (** * bitblast instances *) Lemma bitblast_bool_to_Z b n: Bitblast (bool_to_Z b) n (bool_decide (n = 0) && b). Proof. constructor. destruct b; simpl_bool; repeat case_bool_decide; subst; try done; rewrite ?Z.bits_0; by destruct n. Qed. Global Hint Resolve bitblast_bool_to_Z | 10 : bitblast. Lemma bitblast_bounded_bv_unsigned n (b : bv n): BitblastBounded (bv_unsigned b) (Z.of_N n). Proof. constructor. apply bv_unsigned_in_range. Qed. Global Hint Resolve bitblast_bounded_bv_unsigned | 15 : bitblast. Lemma bitblast_bv_wrap z1 n n1 b1: Bitblast z1 n b1 → Bitblast (bv_wrap n1 z1) n (bool_decide (n < Z.of_N n1) && b1). Proof. intros [<-]. constructor. destruct (decide (0 ≤ n)); [by rewrite bv_wrap_spec| rewrite !Z.testbit_neg_r; [|lia..]; btauto]. Qed. Global Hint Resolve bitblast_bv_wrap | 10 : bitblast. (* The following two lemmas are proven using [bitblast]. *) Lemma bv_extract_concat_later m n1 n2 s l (b1 : bv n1) (b2 : bv n2): (n2 ≤ s)%N → (m = n1 + n2)%N → bv_extract s l (bv_concat m b1 b2) = bv_extract (s - n2) l b1. Proof. intros ? ->. apply bv_eq. rewrite !bv_extract_unsigned, bv_concat_unsigned, !bv_wrap_land by done. bitblast. f_equal. lia. Qed. Lemma bv_extract_concat_here m n1 n2 s (b1 : bv n1) (b2 : bv n2): s = 0%N → (m = n1 + n2)%N → bv_extract s n2 (bv_concat m b1 b2) = b2. Proof. intros -> ->. apply bv_eq. rewrite !bv_extract_unsigned, bv_concat_unsigned, !bv_wrap_land by done. bitblast. f_equal. lia. Qed. (** * [bv_simplify] rewrite database *) (** The [bv_simplify] database collects rewrite rules that rewrite bitvectors into other bitvectors. *) Create HintDb bv_simplify discriminated. (* Technically not necessary for rewrite db. *) Global Hint Rewrite @bv_concat_0 using done : bv_simplify. Global Hint Rewrite @bv_extract_concat_later @bv_extract_concat_here using lia : bv_simplify. Global Hint Rewrite @bv_extract_bool_to_bv using lia : bv_simplify. Global Hint Rewrite @bv_not_bool_to_bv : bv_simplify. Global Hint Rewrite bool_decide_bool_to_bv_0 bool_decide_bool_to_bv_1 : bv_simplify. (** * [bv_unfold] *) Create HintDb bv_unfold_db discriminated. Global Hint Constants Opaque : bv_unfold_db. Global Hint Variables Opaque : bv_unfold_db. Global Hint Extern 1 (TCFastDone ?P) => (change P; fast_done) : bv_unfold_db. Global Hint Transparent BvWf andb Is_true Z.ltb Z.leb Z.compare Pos.compare Pos.compare_cont bv_modulus Z.pow Z.pow_pos Pos.iter Z.mul Pos.mul Z.of_N : bv_unfold_db. Notation bv_suwrap signed := (if signed then bv_swrap else bv_wrap). Class BvUnfold (n : N) (signed : bool) (wrapped : bool) (b : bv n) (z : Z) := { bv_unfold_proof : ((if signed then bv_signed else bv_unsigned) b) = (if wrapped then bv_suwrap signed n z else z); }. Global Arguments bv_unfold_proof {_ _ _} _ _ {_}. Global Hint Mode BvUnfold + + + + - : bv_unfold_db. (** [BV_UNFOLD_BLOCK] is a marker that this occurence of [bv_signed] or [bv_unsigned] has already been simplified. *) Definition BV_UNFOLD_BLOCK {A} (x : A) : A := x. Lemma bv_unfold_end s w n b : BvUnfold n s w b ((if s then BV_UNFOLD_BLOCK bv_signed else BV_UNFOLD_BLOCK bv_unsigned) b). Proof. constructor. unfold BV_UNFOLD_BLOCK. destruct w, s; by rewrite ?bv_wrap_bv_unsigned, ?bv_swrap_bv_signed. Qed. Global Hint Resolve bv_unfold_end | 1000 : bv_unfold_db. Lemma bv_unfold_BV s w n z Hwf : BvUnfold n s w (@BV _ z Hwf) (if w then z else if s then bv_swrap n z else z). Proof. constructor. unfold bv_unsigned. destruct w, s; simpl; try done; by rewrite bv_wrap_small by by apply bv_wf_in_range. Qed. Global Hint Resolve bv_unfold_BV | 10 : bv_unfold_db. Lemma bv_unfold_bv_0 s w n : BvUnfold n s w (bv_0 n) 0. Proof. constructor. destruct w, s; rewrite ?bv_0_signed, ?bv_0_unsigned, ?bv_swrap_0; done. Qed. Global Hint Resolve bv_unfold_bv_0 | 10 : bv_unfold_db. Lemma bv_unfold_Z_to_bv s w n z : BvUnfold n s w (Z_to_bv _ z) (if w then z else bv_suwrap s n z). Proof. constructor. destruct w, s; rewrite ?Z_to_bv_signed, ?Z_to_bv_unsigned; done. Qed. Global Hint Resolve bv_unfold_Z_to_bv | 10 : bv_unfold_db. Lemma bv_unfold_succ s w n b z : BvUnfold n s true b z → BvUnfold n s w (bv_succ b) (if w then Z.succ z else bv_suwrap s n (Z.succ z)). Proof. intros [Hz]. constructor. destruct w, s; rewrite ?bv_succ_signed, ?bv_succ_unsigned, ?Hz; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_succ | 10 : bv_unfold_db. Lemma bv_unfold_pred s w n b z : BvUnfold n s true b z → BvUnfold n s w (bv_pred b) (if w then Z.pred z else bv_suwrap s n (Z.pred z)). Proof. intros [Hz]. constructor. destruct w, s; rewrite ?bv_pred_signed, ?bv_pred_unsigned, ?Hz; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_pred | 10 : bv_unfold_db. Lemma bv_unfold_add s w n b1 b2 z1 z2 : BvUnfold n s true b1 z1 → BvUnfold n s true b2 z2 → BvUnfold n s w (bv_add b1 b2) (if w then z1 + z2 else bv_suwrap s n (z1 + z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_add_signed, ?bv_add_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_add | 10 : bv_unfold_db. Lemma bv_unfold_sub s w n b1 b2 z1 z2 : BvUnfold n s true b1 z1 → BvUnfold n s true b2 z2 → BvUnfold n s w (bv_sub b1 b2) (if w then z1 - z2 else bv_suwrap s n (z1 - z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_sub_signed, ?bv_sub_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_sub | 10 : bv_unfold_db. Lemma bv_unfold_opp s w n b z : BvUnfold n s true b z → BvUnfold n s w (bv_opp b) (if w then - z else bv_suwrap s n (- z)). Proof. intros [Hz]. constructor. destruct w, s; rewrite ?bv_opp_signed, ?bv_opp_unsigned, ?Hz; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_opp | 10 : bv_unfold_db. Lemma bv_unfold_mul s w n b1 b2 z1 z2 : BvUnfold n s true b1 z1 → BvUnfold n s true b2 z2 → BvUnfold n s w (bv_mul b1 b2) (if w then z1 * z2 else bv_suwrap s n (z1 * z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_mul_signed, ?bv_mul_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_mul | 10 : bv_unfold_db. Lemma bv_unfold_divu s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_divu b1 b2) (if w then z1 `div` z2 else if s then bv_swrap n (z1 `div` z2) else z1 `div` z2). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_divu_signed, ?bv_divu_unsigned, ?Hz1, ?Hz2; try bv_wrap_simplify_solve. - pose proof (bv_unsigned_in_range _ (bv_divu b1 b2)) as Hr. rewrite bv_divu_unsigned in Hr. subst. by rewrite bv_wrap_small. - done. Qed. Global Hint Resolve bv_unfold_divu | 10 : bv_unfold_db. Lemma bv_unfold_modu s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_modu b1 b2) (if w then z1 `mod` z2 else if s then bv_swrap n (z1 `mod` z2) else z1 `mod` z2). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_modu_signed, ?bv_modu_unsigned, ?Hz1, ?Hz2; try bv_wrap_simplify_solve. - pose proof (bv_unsigned_in_range _ (bv_modu b1 b2)) as Hr. rewrite bv_modu_unsigned in Hr. subst. by rewrite bv_wrap_small. - done. Qed. Global Hint Resolve bv_unfold_modu | 10 : bv_unfold_db. Lemma bv_unfold_divs s w n b1 b2 z1 z2 : BvUnfold n true false b1 z1 → BvUnfold n true false b2 z2 → BvUnfold n s w (bv_divs b1 b2) (if w then z1 `div` z2 else bv_suwrap s n (z1 `div` z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_divs_signed, ?bv_divs_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_divs | 10 : bv_unfold_db. Lemma bv_unfold_quots s w n b1 b2 z1 z2 : BvUnfold n true false b1 z1 → BvUnfold n true false b2 z2 → BvUnfold n s w (bv_quots b1 b2) (if w then z1 `quot` z2 else bv_suwrap s n (z1 `quot` z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_quots_signed, ?bv_quots_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_quots | 10 : bv_unfold_db. Lemma bv_unfold_mods s w n b1 b2 z1 z2 : BvUnfold n true false b1 z1 → BvUnfold n true false b2 z2 → BvUnfold n s w (bv_mods b1 b2) (if w then z1 `mod` z2 else bv_suwrap s n (z1 `mod` z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_mods_signed, ?bv_mods_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_mods | 10 : bv_unfold_db. Lemma bv_unfold_rems s w n b1 b2 z1 z2 : BvUnfold n true false b1 z1 → BvUnfold n true false b2 z2 → BvUnfold n s w (bv_rems b1 b2) (if w then z1 `rem` z2 else bv_suwrap s n (z1 `rem` z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_rems_signed, ?bv_rems_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_rems | 10 : bv_unfold_db. Lemma bv_unfold_shiftl s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_shiftl b1 b2) (if w then z1 ≪ z2 else bv_suwrap s n (z1 ≪ z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_shiftl_signed, ?bv_shiftl_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_shiftl | 10 : bv_unfold_db. Lemma bv_unfold_shiftr s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_shiftr b1 b2) (if w then z1 ≫ z2 else if s then bv_swrap n (z1 ≫ z2) else (z1 ≫ z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_shiftr_signed, ?bv_shiftr_unsigned, ?Hz1, ?Hz2; try bv_wrap_simplify_solve. - pose proof (bv_unsigned_in_range _ (bv_shiftr b1 b2)) as Hr. rewrite bv_shiftr_unsigned in Hr. subst. by rewrite bv_wrap_small. - done. Qed. Global Hint Resolve bv_unfold_shiftr | 10 : bv_unfold_db. Lemma bv_unfold_ashiftr s w n b1 b2 z1 z2 : BvUnfold n true false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_ashiftr b1 b2) (if w then z1 ≫ z2 else bv_suwrap s n (z1 ≫ z2)). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_ashiftr_signed, ?bv_ashiftr_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_ashiftr | 10 : bv_unfold_db. Lemma bv_unfold_or s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_or b1 b2) (if w then Z.lor z1 z2 else if s then bv_swrap n (Z.lor z1 z2) else Z.lor z1 z2). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_or_signed, ?bv_or_unsigned, ?Hz1, ?Hz2; try bv_wrap_simplify_solve. - pose proof (bv_unsigned_in_range _ (bv_or b1 b2)) as Hr. rewrite bv_or_unsigned in Hr. subst. by rewrite bv_wrap_small. - done. Qed. Global Hint Resolve bv_unfold_or | 10 : bv_unfold_db. Lemma bv_unfold_and s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_and b1 b2) (if w then Z.land z1 z2 else if s then bv_swrap n (Z.land z1 z2) else Z.land z1 z2). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_and_signed, ?bv_and_unsigned, ?Hz1, ?Hz2; try bv_wrap_simplify_solve. - pose proof (bv_unsigned_in_range _ (bv_and b1 b2)) as Hr. rewrite bv_and_unsigned in Hr. subst. by rewrite bv_wrap_small. - done. Qed. Global Hint Resolve bv_unfold_and | 10 : bv_unfold_db. Lemma bv_unfold_xor s w n b1 b2 z1 z2 : BvUnfold n false false b1 z1 → BvUnfold n false false b2 z2 → BvUnfold n s w (bv_xor b1 b2) (if w then Z.lxor z1 z2 else if s then bv_swrap n (Z.lxor z1 z2) else Z.lxor z1 z2). Proof. intros [Hz1] [Hz2]. constructor. destruct w, s; rewrite ?bv_xor_signed, ?bv_xor_unsigned, ?Hz1, ?Hz2; try bv_wrap_simplify_solve. - pose proof (bv_unsigned_in_range _ (bv_xor b1 b2)) as Hr. rewrite bv_xor_unsigned in Hr. subst. by rewrite bv_wrap_small. - done. Qed. Global Hint Resolve bv_unfold_xor | 10 : bv_unfold_db. Lemma bv_unfold_not s w n b z : BvUnfold n false false b z → BvUnfold n s w (bv_not b) (if w then Z.lnot z else bv_suwrap s n (Z.lnot z)). Proof. intros [Hz]. constructor. destruct w, s; rewrite ?bv_not_signed, ?bv_not_unsigned, ?Hz; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_not | 10 : bv_unfold_db. Lemma bv_unfold_zero_extend s w n n' b z `{!TCFastDone (n' <=? n = true)%N} : BvUnfold n' false false b z → BvUnfold n s w (bv_zero_extend n b) (if w then z else if s then bv_swrap n z else z). Proof. intros [Hz]. constructor. unfold TCFastDone in *. rewrite ->?N.leb_le in *. destruct w, s; rewrite ?bv_zero_extend_signed, ?bv_zero_extend_unsigned, ?Hz by done; try bv_wrap_simplify_solve. - rewrite <-Hz, bv_wrap_small; [done|]. bv_saturate. pose proof (bv_modulus_le_mono n' n). lia. - done. Qed. Global Hint Resolve bv_unfold_zero_extend | 10 : bv_unfold_db. Lemma bv_unfold_sign_extend s w n n' b z `{!TCFastDone (n' <=? n = true)%N} : BvUnfold n' true false b z → BvUnfold n s w (bv_sign_extend n b) (if w then z else if s then z else bv_wrap n z). Proof. intros [Hz]. constructor. unfold TCFastDone in *. rewrite ->?N.leb_le in *. destruct w, s; rewrite ?bv_sign_extend_signed, ?bv_sign_extend_unsigned, ?Hz by done; try bv_wrap_simplify_solve. - subst. rewrite <-(bv_sign_extend_signed n) at 2 by done. by rewrite bv_swrap_bv_signed, bv_sign_extend_signed. - done. Qed. Global Hint Resolve bv_unfold_sign_extend | 10 : bv_unfold_db. Lemma bv_unfold_extract s w n n' n1 b z : BvUnfold n' false false b z → BvUnfold n s w (bv_extract n1 n b) (if w then z ≫ Z.of_N n1 else bv_suwrap s n (z ≫ Z.of_N n1)). Proof. intros [Hz]. constructor. destruct w, s; rewrite ?bv_extract_signed, ?bv_extract_unsigned, ?Hz; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_extract | 10 : bv_unfold_db. Lemma bv_unfold_concat s w n n1 n2 b1 b2 z1 z2 `{!TCFastDone (n = n1 + n2)%N} : BvUnfold n1 false false b1 z1 → BvUnfold n2 false false b2 z2 → BvUnfold n s w (bv_concat n b1 b2) (if w then Z.lor (z1 ≪ Z.of_N n2) z2 else if s then bv_swrap n (Z.lor (z1 ≪ Z.of_N n2) z2) else Z.lor (z1 ≪ Z.of_N n2) z2). Proof. intros [Hz1] [Hz2]. constructor. unfold TCFastDone in *. destruct w, s; rewrite ?bv_concat_signed, ?bv_concat_unsigned, ?Hz1, ?Hz2 by done; try bv_wrap_simplify_solve. - subst. rewrite <-(bv_concat_unsigned (n1 + n2)) at 2 by done. by rewrite bv_wrap_bv_unsigned, bv_concat_unsigned. - done. Qed. Global Hint Resolve bv_unfold_concat | 10 : bv_unfold_db. Lemma bv_unfold_add_Z s w n b1 z1 z2 : BvUnfold n s true b1 z1 → BvUnfold n s w (bv_add_Z b1 z2) (if w then z1 + z2 else bv_suwrap s n (z1 + z2)). Proof. intros [Hz1]. constructor. destruct w, s; rewrite ?bv_add_Z_signed, ?bv_add_Z_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_add_Z | 10 : bv_unfold_db. Lemma bv_unfold_sub_Z s w n b1 z1 z2 : BvUnfold n s true b1 z1 → BvUnfold n s w (bv_sub_Z b1 z2) (if w then z1 - z2 else bv_suwrap s n (z1 - z2)). Proof. intros [Hz1]. constructor. destruct w, s; rewrite ?bv_sub_Z_signed, ?bv_sub_Z_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_sub_Z | 10 : bv_unfold_db. Lemma bv_unfold_mul_Z s w n b1 z1 z2 : BvUnfold n s true b1 z1 → BvUnfold n s w (bv_mul_Z b1 z2) (if w then z1 * z2 else bv_suwrap s n (z1 * z2)). Proof. intros [Hz1]. constructor. destruct w, s; rewrite ?bv_mul_Z_signed, ?bv_mul_Z_unsigned, ?Hz1, ?Hz2; bv_wrap_simplify_solve. Qed. Global Hint Resolve bv_unfold_mul_Z | 10 : bv_unfold_db. Ltac bv_unfold_eq := lazymatch goal with | |- @bv_unsigned ?n ?b = ?z => simple notypeclasses refine (@bv_unfold_proof n false false b z _) | |- @bv_signed ?n ?b = ?z => simple notypeclasses refine (@bv_unfold_proof n true false b z _) end; typeclasses eauto with bv_unfold_db. Ltac bv_unfold := repeat (match goal with (* TODO: Detect if there is a bv_wrap around the bv_unsigned (like after applying bv_eq_wrapped) *) | |- context [@bv_unsigned ?n ?b] => pattern (@bv_unsigned n b); simple refine (eq_rec_r _ _ _); [shelve| |bv_unfold_eq]; cbn beta | |- context [@bv_signed ?n ?b] => pattern (@bv_signed n b); simple refine (eq_rec_r _ _ _); [shelve| |bv_unfold_eq]; cbn beta end); unfold BV_UNFOLD_BLOCK. (** * [bv_unfolded_simplify] rewrite database *) (** The [bv_unfolded_simplify] database collects rewrite rules that should be used to simplify the goal after Z is bv_unfolded. *) Create HintDb bv_unfolded_simplify discriminated. (* Technically not necessary for rewrite db. *) Global Hint Rewrite Z.shiftr_0_r Z.lor_0_r Z.lor_0_l : bv_unfolded_simplify. Global Hint Rewrite Z.land_ones using lia : bv_unfolded_simplify. Global Hint Rewrite bv_wrap_bv_wrap using lia : bv_unfolded_simplify. Global Hint Rewrite Z_to_bv_small using unfold bv_modulus; lia : bv_unfolded_simplify. (** * [bv_unfolded_to_arith] rewrite database *) (** The [bv_unfolded_to_arith] database collects rewrite rules that convert bitwise operations to arithmetic operations in preparation for lia. *) Create HintDb bv_unfolded_to_arith discriminated. (* Technically not necessary for rewrite db. *) Global Hint Rewrite <-Z.opp_lnot : bv_unfolded_to_arith. Global Hint Rewrite Z.shiftl_mul_pow2 Z.shiftr_div_pow2 using lia : bv_unfolded_to_arith. (** * Reduction of closed terms *) Ltac reduce_closed_N_tac := idtac. Ltac reduce_closed_N := idtac; reduce_closed_N_tac; repeat match goal with | |- context [N.add ?a ?b] => progress reduce_closed (N.add a b) | H : context [N.add ?a ?b] |- _ => progress reduce_closed (N.add a b) end. Ltac reduce_closed_bv_simplify_tac := idtac. Ltac reduce_closed_bv_simplify := idtac; reduce_closed_bv_simplify_tac; (* reduce closed logical operators that lia does not understand *) repeat match goal with | |- context [Z.lor ?a ?b] => progress reduce_closed (Z.lor a b) | H : context [Z.lor ?a ?b] |- _ => progress reduce_closed (Z.lor a b) | |- context [Z.land ?a ?b] => progress reduce_closed (Z.land a b) | H : context [Z.land ?a ?b] |- _ => progress reduce_closed (Z.land a b) | |- context [Z.lxor ?a ?b] => progress reduce_closed (Z.lxor a b) | H : context [Z.lxor ?a ?b] |- _ => progress reduce_closed (Z.lxor a b) end. (** * [bv_simplify] tactic *) Tactic Notation "bv_simplify" := unfold_lets_in_context; (* We need to reduce operations on N in indices of bv because otherwise lia can get confused (it does not perform unification when finding identical subterms). This sometimes leads to problems with length of lists of bytes. *) reduce_closed_N; autorewrite with bv_simplify; lazymatch goal with | |- _ =@{bv _} _ => apply bv_eq_wrap | |- not (_ =@{bv _} _) => apply bv_neq_wrap | _ => idtac end; bv_unfold; autorewrite with bv_unfolded_simplify. Tactic Notation "bv_simplify" ident(H) := unfold_lets_in_context; autorewrite with bv_simplify in H; lazymatch (type of H) with | _ =@{bv _} _ => apply bv_eq in H | not (_ =@{bv _} _) => apply bv_neq in H | _ => idtac end; tactic bv_unfold in H; autorewrite with bv_unfolded_simplify in H. Tactic Notation "bv_simplify" "select" open_constr(pat) := select pat (fun H => bv_simplify H). Tactic Notation "bv_simplify_arith" := bv_simplify; autorewrite with bv_unfolded_to_arith; reduce_closed_bv_simplify. Tactic Notation "bv_simplify_arith" ident(H) := bv_simplify H; autorewrite with bv_unfolded_to_arith in H; reduce_closed_bv_simplify. Tactic Notation "bv_simplify_arith" "select" open_constr(pat) := select pat (fun H => bv_simplify_arith H). (** * [bv_solve] tactic *) Ltac bv_solve_unfold_tac := idtac. Ltac bv_solve := bv_simplify_arith; (* we unfold signed so we just need to saturate unsigned *) bv_saturate_unsigned; bv_solve_unfold_tac; unfold bv_signed, bv_swrap, bv_wrap, bv_half_modulus, bv_modulus, bv_unsigned in *; simpl; lia. Class BvSolve (P : Prop) : Prop := bv_solve_proof : P. Global Hint Extern 1 (BvSolve ?P) => (change P; bv_solve) : typeclass_instances. stdpp-coq-stdpp-1.9.0/test-normalizer.sed000066400000000000000000000005071451153341500204230ustar00rootroot00000000000000# adjust for https://github.com/coq/coq/pull/13656 s/subgoal/goal/g # merge with subsequent line for https://github.com/coq/coq/pull/14999 /[0-9]* focused goals\?$/{N;s/\n */ /;} # locations in Fail added in https://github.com/coq/coq/pull/15174 /^File/d # extra space removed in https://github.com/coq/coq/pull/16130 s/= $/=/ stdpp-coq-stdpp-1.9.0/tests/000077500000000000000000000000001451153341500157275ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/bitblast.ref000066400000000000000000000000001451153341500202170ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/bitblast.v000066400000000000000000000017351451153341500177300ustar00rootroot00000000000000From stdpp.unstable Require Import bitblast. Local Open Scope Z_scope. Goal ∀ x a k, Z.land x (Z.land (Z.ones k) (Z.ones k) ≪ a) = Z.land (Z.land (x ≫ a) (Z.ones k)) (Z.ones k) ≪ a. Proof. intros. bitblast. Qed. Goal ∀ i, 1 ≪ i = Z.land (Z.ones 1) (Z.ones 1) ≪ i. Proof. intros. bitblast. Qed. Goal ∀ N k, 0 ≤ k ≤ N → Z.ones N ≫ (N - k) = Z.ones k. Proof. intros. bitblast. Qed. Goal ∀ z, Z.land z (-1) = z. Proof. intros. bitblast. Qed. Goal ∀ z, Z.land z 0x20000 = 0 → Z.land (z ≫ 17) (Z.ones 1) = 0. Proof. intros ? Hz. bitblast as n. by bitblast Hz with (n + 17). Qed. Goal ∀ z, 0 ≤ z < 2 ^ 64 → Z.land z 0xfff0000000000007 = 0 ↔ z < 2 ^ 52 ∧ z `mod` 8 = 0. Proof. intros z ?. split. - intros Hx. split. + apply Z.bounded_iff_bits_nonneg; [lia..|]. intros n ?. bitblast. by bitblast Hx with n. + bitblast as n. by bitblast Hx with n. - intros [H1 H2]. bitblast as n. by bitblast H2 with n. Qed. stdpp-coq-stdpp-1.9.0/tests/bitvector.ref000066400000000000000000000005511451153341500204270ustar00rootroot00000000000000"notation_test" : string 3%bv = 5%bv : Prop The command has indeed failed with message: The term "5%bv" has type "bv 10" while it is expected to have type "bv 2". 3%bv = 5%bv : Prop 4%bv = 4%bv : Prop Z_to_bv 7 (-1) = Z_to_bv 7 (-1) : Prop "bvn_to_bv_test" : string 1 goal ============================ Some 3%bv = Some 3%bv stdpp-coq-stdpp-1.9.0/tests/bitvector.v000066400000000000000000000006161451153341500201220ustar00rootroot00000000000000From stdpp Require Import strings. From stdpp.unstable Require Import bitvector. Check "notation_test". Check (BV 10 3 = BV 10 5). Fail Check (BV 2 3 = BV 10 5). Check (BV 2 3 =@{bvn} BV 10 5). Check (4%bv = BV 4 4). Check ((-1)%bv = Z_to_bv 7 (-1)). Goal (-1 =@{bv 5} 31)%bv. compute_done. Qed. Check "bvn_to_bv_test". Goal bvn_to_bv 2 (BV 2 3) = Some (BV 2 3). Proof. simpl. Show. done. Abort. stdpp-coq-stdpp-1.9.0/tests/bitvector_tactics.ref000066400000000000000000000043741451153341500221500ustar00rootroot000000000000001 goal a : Z ============================ bv_wrap 64 (a + 1) = bv_wrap 64 (Z.succ a) 1 goal l, r, xs : bv 64 data : list (bv 64) H : bv_unsigned l < bv_unsigned r H0 : bv_unsigned r ≤ Z.of_nat (length data) H1 : bv_unsigned xs + Z.of_nat (length data) * 8 < 2 ^ 52 ============================ bv_wrap 64 (bv_unsigned xs + (bv_unsigned l + bv_wrap 64 (bv_unsigned r - bv_unsigned l) `div` 2 ^ 1) * 8) < 2 ^ 52 2 goals l, r : bv 64 data : list (bv 64) H : bv_unsigned l < bv_unsigned r H0 : bv_unsigned r ≤ Z.of_nat (length data) H1 : ¬ bv_swrap 128 (bv_unsigned l) >= bv_swrap 128 (bv_wrap 64 (bv_wrap 64 (bv_unsigned r - bv_unsigned l) `div` 2 ^ 1 + bv_unsigned l + 0)) ============================ bv_unsigned l < bv_wrap 64 (bv_wrap 64 (bv_unsigned r - bv_unsigned l) `div` 2 ^ 1 + bv_unsigned l + 0) goal 2 is: bv_wrap 64 (bv_wrap 64 (bv_unsigned r - bv_unsigned l) `div` 2 ^ 1 + bv_unsigned l + 0) ≤ Z.of_nat (length data) 1 goal r1 : bv 64 H : bv_unsigned r1 ≠ 22%Z ============================ bv_wrap 64 (bv_unsigned r1 + 18446744073709551593 + 1) ≠ bv_wrap 64 0 1 goal i, n : bv 64 H : bv_unsigned i < bv_unsigned n H0 : bv_wrap 64 (bv_unsigned n + bv_wrap 64 (- bv_wrap 64 (bv_unsigned i + 1) - 1) + 1) ≠ 0%Z ============================ bv_wrap 64 (bv_unsigned i + 1) < bv_unsigned n 1 goal b : bv 16 v : bv 64 ============================ bv_wrap 64 (Z.lor (Z.land (bv_unsigned v) 18446744069414649855) (bv_wrap 64 (bv_unsigned b ≪ 16))) = bv_wrap 64 (Z.lor (bv_wrap (16 * 2) (bv_unsigned v ≫ Z.of_N (16 * 2)) ≪ Z.of_N (16 * 2)) (Z.lor (bv_unsigned b ≪ Z.of_N (16 * 1)) (bv_wrap (16 * 1) (bv_unsigned v)))) 1 goal b : bv 16 ============================ bv_wrap 16 (bv_unsigned b) = bv_wrap 16 (bv_unsigned b) 1 goal b : bv 16 ============================ bv_wrap 16 (bv_unsigned b) ≠ bv_wrap 16 (bv_unsigned b + 1) 1 goal b : bv 16 H : bv_unsigned b = bv_unsigned b ============================ True 1 goal b : bv 16 H : bv_unsigned b ≠ bv_wrap 16 (bv_unsigned b + 1) ============================ True stdpp-coq-stdpp-1.9.0/tests/bitvector_tactics.v000066400000000000000000000061141451153341500216330ustar00rootroot00000000000000From stdpp Require Import strings. From stdpp.unstable Require Import bitblast bitvector_tactics. Unset Mangle Names. Local Open Scope Z_scope. Local Open Scope bv_scope. Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations. (** * Smoke tests *) (** Simple test *) Goal ∀ a : Z, Z_to_bv 64 a `+Z` 1 = Z_to_bv 64 (Z.succ a). Proof. intros. bv_simplify. Show. Restart. intros. bv_solve. Qed. (** More complex test *) Goal ∀ l r xs : bv 64, ∀ data : list (bv 64), bv_unsigned l < bv_unsigned r → bv_unsigned r ≤ Z.of_nat (length data) → bv_unsigned xs + Z.of_nat (length data) * 8 < 2 ^ 52 → bv_unsigned (xs + (bv_extract 0 64 (bv_zero_extend 128 l) + bv_extract 0 64 (bv_zero_extend 128 ((r - l) ≫ 1))) * 8) < 2 ^ 52. Proof. intros. bv_simplify_arith. Show. Restart. intros. bv_solve. Qed. (** Testing simplification in hypothesis *) Goal ∀ l r : bv 64, ∀ data : list (bv 64), bv_unsigned l < bv_unsigned r → bv_unsigned r ≤ Z.of_nat (length data) → ¬ bv_signed (bv_zero_extend 128 l) >= bv_signed (bv_zero_extend 128 (bv_zero_extend 128 ((r - l) ≫ 1 + l + 0))) → bv_unsigned l < bv_unsigned ((r - l) ≫ 1 + l + 0) ≤ Z.of_nat (length data). Proof. intros. bv_simplify_arith select (¬ _ >= _). bv_simplify_arith. split. (* We need to split since the [_ < _ ≤ _] notation differs between Coq versions. *) Show. Restart. intros. bv_simplify_arith select (¬ _ >= _). bv_solve. Qed. (** Testing inequality in goal. *) Goal ∀ r1 : bv 64, bv_unsigned r1 ≠ 22%Z → bv_extract 0 64 (bv_zero_extend 128 r1 + 0xffffffffffffffe9 + 1) ≠ 0. Proof. intros. bv_simplify. Show. Restart. intros. bv_solve. Qed. (** Testing inequality in hypothesis. *) Goal ∀ i n : bv 64, bv_unsigned i < bv_unsigned n → bv_extract 0 64 (bv_zero_extend 128 n + bv_zero_extend 128 (bv_not (bv_extract 0 64 (bv_zero_extend 128 i) + 1)) + 1) ≠ 0 → bv_unsigned (bv_extract 0 64 (bv_zero_extend 128 i) + 1) < bv_unsigned n. Proof. intros. bv_simplify_arith select (bv_extract _ _ _ ≠ _). bv_simplify. Show. Restart. intros. bv_simplify_arith select (bv_extract _ _ _ ≠ _). bv_solve. Qed. (** Testing combination of bitvector and bitblast. *) Goal ∀ b : bv 16, ∀ v : bv 64, bv_or (bv_and v 0xffffffff0000ffff) (bv_zero_extend 64 b ≪ 16) = bv_concat 64 (bv_extract (16 * (1 + 1)) (16 * 2) v) (bv_concat (16 * (1 + 1)) b (bv_extract 0 (16 * 1) v)). Proof. intros. bv_simplify. Show. bitblast. Qed. (** Regression test for https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/411 *) Goal ∀ b : bv 16, bv_wrap 16 (bv_unsigned b) = bv_wrap 16 (bv_unsigned b). Proof. intros. bv_simplify. Show. Restart. intros. bv_solve. Qed. Goal ∀ b : bv 16, bv_wrap 16 (bv_unsigned b) ≠ bv_wrap 16 (bv_unsigned (b + 1)). Proof. intros. bv_simplify. Show. Restart. intros. bv_solve. Qed. Goal ∀ b : bv 16, bv_unsigned b = bv_unsigned b → True. Proof. intros ? H. bv_simplify H. Show. Abort. Goal ∀ b : bv 16, bv_unsigned b ≠ bv_unsigned (b + 1) → True. Proof. intros ? H. bv_simplify H. Show. Abort. stdpp-coq-stdpp-1.9.0/tests/decidable.ref000066400000000000000000000001021451153341500203120ustar00rootroot00000000000000The command has indeed failed with message: No applicable tactic. stdpp-coq-stdpp-1.9.0/tests/decidable.v000066400000000000000000000006351451153341500200160ustar00rootroot00000000000000From stdpp Require Import list. (** Test that Coq does not infer [x ∈ xs] as [False] by eagerly using [False_dec] on a goal with unresolved type class instances. *) Example issue_165 (x : nat) : ¬ ∃ xs : list nat, (guard (x ∈ xs); Some x) ≠ None. Proof. intros [xs Hxs]. case_option_guard; [|done]. Fail done. (* Would succeed if the instance backing [x ∈ xs] is infered as [False]. *) Abort. stdpp-coq-stdpp-1.9.0/tests/eunify.ref000066400000000000000000000005031451153341500177220ustar00rootroot00000000000000"eunify_test" : string The command has indeed failed with message: No matching clauses for match. ((fix add (n m : nat) {struct n} : nat := match n with | 0 => m | S p => S (add p m) end) x y) "eunify_test_evars" : string The command has indeed failed with message: No matching clauses for match. stdpp-coq-stdpp-1.9.0/tests/eunify.v000066400000000000000000000020121451153341500174100ustar00rootroot00000000000000From stdpp Require Import tactics strings. Unset Mangle Names. Check "eunify_test". Lemma eunify_test : ∀ x y, 0 < S x + y. Proof. intros x y. (* Test that Ltac matching fails, otherwise this test is pointless *) Fail match goal with | |- 0 < S _ => idtac end. (* [eunify] succeeds *) match goal with | |- 0 < ?x => eunify x (S _) end. match goal with | |- 0 < ?x => let y := open_constr:(_) in eunify x (S y); idtac y end. lia. Qed. Check "eunify_test_evars". Lemma eunify_test_evars : ∃ x y, 0 < S x + y. Proof. eexists _, _. (* Test that Ltac matching fails, otherwise this test is pointless *) Fail match goal with | |- 0 < S _ => idtac end. (* [eunify] succeeds even if the goal contains evars *) match goal with | |- 0 < ?x => eunify x (S _) end. (* Let's try to use [eunify] to instantiate the first evar *) match goal with | |- 0 < ?x => eunify x (1 + _) end. (* And the other evar *) match goal with | |- 0 < ?x => eunify x 2 end. lia. Qed. stdpp-coq-stdpp-1.9.0/tests/fin.ref000066400000000000000000000000001451153341500171670ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/fin.v000066400000000000000000000001761451153341500166760ustar00rootroot00000000000000From stdpp Require Import fin. Definition f n m (p : fin n) := m < p. Lemma test : f 47 13 32. Proof. vm_compute. lia. Qed. stdpp-coq-stdpp-1.9.0/tests/fin_maps.ref000066400000000000000000000060021451153341500202170ustar00rootroot00000000000000The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ {[1; 2; 3]} = ∅ The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ elements {[1; 2; 3]} = [] The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ {[1; 2; 3]} ∖ {[1]} ∪ {[4]} ∩ {[10]} = ∅ ∖ {[2]} The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ 1%positive ∈ dom (<[1%positive:=2]> ∅) The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ 1 ∈ dom (<[1:=2]> ∅) The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ bool_decide (∅ = {[1; 2; 3]}) = false The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ bool_decide (∅ ≡ {[1; 2; 3]}) = false The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ bool_decide (1 ∈ {[1; 2; 3]}) = true The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ bool_decide (∅ ## {[1; 2; 3]}) = true The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. 1 goal ============================ bool_decide (∅ ⊆ {[1; 2; 3]}) = true The command has indeed failed with message: Nothing to inject. The command has indeed failed with message: Nothing to inject. The command has indeed failed with message: Failed to progress. "pmap_insert_positives_test" : string = true : bool = true : bool = true : bool "gmap_insert_positives_test" : string = true : bool = true : bool = true : bool "pmap_insert_comm" : string 1 goal ============================ {[3%positive := false; 2%positive := true]} = {[2%positive := true; 3%positive := false]} "pmap_lookup_concrete" : string 1 goal ============================ {[3%positive := false; 2%positive := true]} !! 2%positive = Some true "gmap_insert_comm" : string 1 goal ============================ {[3 := false; 2 := true]} = {[2 := true; 3 := false]} "gmap_lookup_concrete" : string 1 goal ============================ {[3 := false; 2 := true]} !! 2 = Some true stdpp-coq-stdpp-1.9.0/tests/fin_maps.v000066400000000000000000000367141451153341500177250ustar00rootroot00000000000000From stdpp Require Import fin_maps fin_map_dom. From stdpp Require Import strings pmap gmap. (** * Tests involving the [FinMap] interfaces, i.e., tests that are not specific to an implementation of finite maps. *) Section map_disjoint. Context `{FinMap K M}. Lemma solve_map_disjoint_singleton_1 {A} (m1 m2 : M A) i x : m1 ##ₘ <[i:=x]> m2 → {[ i:= x ]} ∪ m2 ##ₘ m1 ∧ m2 ##ₘ ∅. Proof. intros. solve_map_disjoint. Qed. Lemma solve_map_disjoint_singleton_2 {A} (m1 m2 : M A) i x : m2 !! i = None → m1 ##ₘ {[ i := x ]} ∪ m2 → m2 ##ₘ <[i:=x]> m1 ∧ m1 !! i = None. Proof. intros. solve_map_disjoint. Qed. Lemma solve_map_disjoint_compose_l_singleton_1 {A} (n : M K) (m1 m2 : M A) i x : m1 ##ₘ <[i:=x]> m2 → ({[ i:= x ]} ∪ m2) ∘ₘ n ##ₘ m1 ∘ₘ n ∧ m2 ##ₘ ∅. Proof. intros. solve_map_disjoint. Qed. Lemma solve_map_disjoint_compose_l_singleton_2 {A} (n : M K) (m1 m2 : M A) i x : m2 !! i = None → m1 ##ₘ {[ i := x ]} ∪ m2 → m2 ∘ₘ n ##ₘ <[i:=x]> m1 ∘ₘ n ∧ m1 !! i = None. Proof. intros. solve_map_disjoint. Qed. Lemma solve_map_disjoint_compose_r_singleton_1 {A} (m1 m2 : M K) (n : M A) i x : m1 ##ₘ <[i:=x]> m2 → n ∘ₘ ({[ i:= x ]} ∪ m2) ##ₘ n ∘ₘ m1 ∧ m2 ##ₘ ∅. Proof. intros. solve_map_disjoint. Qed. Lemma solve_map_disjoint_compose_r_singleton_2 {A} (m1 m2 : M K) (n : M A) i x : m2 !! i = None → m1 ##ₘ {[ i := x ]} ∪ m2 → n ∘ₘ m2 ##ₘ n ∘ₘ <[i:=x]> m1 ∧ m1 !! i = None. Proof. intros. solve_map_disjoint. Qed. End map_disjoint. Section map_dom. Context `{FinMapDom K M D}. Lemma set_solver_dom_subseteq {A} (i j : K) (x y : A) : {[i; j]} ⊆ dom (<[i:=x]> (<[j:=y]> (∅ : M A))). Proof. set_solver. Qed. Lemma set_solver_dom_disjoint {A} (X : D) : dom (∅ : M A) ## X. Proof. set_solver. Qed. End map_dom. Section map_img. Context `{FinMap K M, Set_ A SA}. Lemma set_solver_map_img i x : map_img (∅ : M A) ⊆@{SA} map_img ({[ i := x ]} : M A). Proof. set_unfold. set_solver. Qed. End map_img. (** * Tests for the [Pmap] and [gmap] instances. *) (** TODO: Fix [Pset] so that it satisfies the same [cbn]/[simpl] tests as [gset] below. *) Goal {[1; 2; 3]} =@{gset nat} ∅. Proof. Fail progress simpl. Fail progress cbn. Show. Abort. Goal elements (C := gset nat) {[1; 2; 3]} = []. Proof. Fail progress simpl. Fail progress cbn. Show. Abort. Goal {[1; 2; 3]} ∖ {[ 1 ]} ∪ {[ 4 ]} ∩ {[ 10 ]} =@{gset nat} ∅ ∖ {[ 2 ]}. Proof. Fail progress simpl. Fail progress cbn. Show. Abort. Goal 1%positive ∈ dom (M := Pmap nat) (<[ 1%positive := 2 ]> ∅). Proof. Fail progress simpl. Fail progress cbn. Show. Abort. Goal 1 ∈ dom (M := gmap nat nat) (<[ 1 := 2 ]> ∅). Proof. Fail progress simpl. Fail progress cbn. Show. Abort. Goal bool_decide (∅ =@{gset nat} {[ 1; 2; 3 ]}) = false. Proof. Fail progress simpl. Fail progress cbn. Show. reflexivity. Qed. Goal bool_decide (∅ ≡@{gset nat} {[ 1; 2; 3 ]}) = false. Proof. Fail progress simpl. Fail progress cbn. Show. reflexivity. Qed. Goal bool_decide (1 ∈@{gset nat} {[ 1; 2; 3 ]}) = true. Proof. Fail progress simpl. Fail progress cbn. Show. reflexivity. Qed. Goal bool_decide (∅ ##@{gset nat} {[ 1; 2; 3 ]}) = true. Proof. Fail progress simpl. Fail progress cbn. Show. reflexivity. Qed. Goal bool_decide (∅ ⊆@{gset nat} {[ 1; 2; 3 ]}) = true. Proof. Fail progress simpl. Fail progress cbn. Show. reflexivity. Qed. Lemma should_not_unfold (m1 m2 : gmap nat nat) k x : dom m1 = dom m2 → <[k:=x]> m1 = <[k:=x]> m2 → True. Proof. (** Make sure that [injection]/[simplify_eq] does not unfold constructs on [gmap] and [gset]. *) intros Hdom Hinsert. Fail injection Hdom. Fail injection Hinsert. Fail progress simplify_eq. done. Qed. (** Test case for issue #139 *) Lemma test_issue_139 (m : gmap nat nat) : ∃ x, x ∉ dom m. Proof. destruct (exist_fresh (dom m)); eauto. Qed. (** Make sure that unification does not eagerly unfold [map_fold] *) Definition only_evens (m : gmap nat nat) : gmap nat nat := filter (λ '(_,x), (x | 2)) m. Lemma only_evens_Some m i n : only_evens m !! i = Some n → (n | 2). Proof. intros Hev. apply map_lookup_filter_Some in Hev as [??]. done. Qed. (** Make sure that [pmap] and [gmap] compute *) Definition pmap_insert_positives (start step num : positive) : Pmap unit := Pos.iter (λ rec p m, rec (p + step)%positive (<[p:=tt]> m)) (λ _ m, m) num start ∅. Definition pmap_insert_positives_rev (start step num : positive) : Pmap unit := Pos.iter (λ rec p m, rec (p - step)%positive (<[p:=tt]> m)) (λ _ m, m) num start ∅. Definition pmap_insert_positives_test (num : positive) : bool := bool_decide (pmap_insert_positives 1 1 num = pmap_insert_positives_rev num 1 num). Definition pmap_insert_positives_union_test (num : positive) : bool := bool_decide (pmap_insert_positives 1 1 num = pmap_insert_positives 2 2 (Pos.div2_up num) ∪ pmap_insert_positives 1 2 (Pos.div2_up num)). Definition pmap_insert_positives_filter_test (num : positive) : bool := bool_decide (pmap_insert_positives 1 2 (Pos.div2_up num) = filter (λ '(p,_), Z.odd (Z.pos p)) (pmap_insert_positives 1 1 num)). (* Test that the time is approximately n-log-n. We cannot test this on CI since you get different timings all the time. Instead we just test for [128000], which likely takes forever if the complexity is not n-log-n. *) (* Time Eval vm_compute in pmap_insert_positives_test 1000. Time Eval vm_compute in pmap_insert_positives_test 2000. Time Eval vm_compute in pmap_insert_positives_test 4000. Time Eval vm_compute in pmap_insert_positives_test 8000. Time Eval vm_compute in pmap_insert_positives_test 16000. Time Eval vm_compute in pmap_insert_positives_test 32000. Time Eval vm_compute in pmap_insert_positives_test 64000. Time Eval vm_compute in pmap_insert_positives_test 128000. Time Eval vm_compute in pmap_insert_positives_test 256000. Time Eval vm_compute in pmap_insert_positives_test 512000. Time Eval vm_compute in pmap_insert_positives_test 1000000. *) Check "pmap_insert_positives_test". Eval vm_compute in pmap_insert_positives_test 128000. Eval vm_compute in pmap_insert_positives_union_test 128000. Eval vm_compute in pmap_insert_positives_filter_test 128000. Definition gmap_insert_positives (start step num : positive) : gmap positive unit := Pos.iter (λ rec p m, rec (p + step)%positive (<[p:=tt]> m)) (λ _ m, m) num start ∅. Definition gmap_insert_positives_rev (start step num : positive) : gmap positive unit := Pos.iter (λ rec p m, rec (p - step)%positive (<[p:=tt]> m)) (λ _ m, m) num start ∅. (* Test that the time increases linearly *) Definition gmap_insert_positives_test (num : positive) : bool := bool_decide (gmap_insert_positives 1 1 num = gmap_insert_positives_rev num 1 num). Definition gmap_insert_positives_union_test (num : positive) : bool := bool_decide (gmap_insert_positives 1 1 num = gmap_insert_positives 2 2 (Pos.div2_up num) ∪ gmap_insert_positives 1 2 (Pos.div2_up num)). Definition gmap_insert_positives_filter_test (num : positive) : bool := bool_decide (gmap_insert_positives 1 2 (Pos.div2_up num) = filter (λ '(p,_), Z.odd (Z.pos p)) (gmap_insert_positives 1 1 num)). (* Test that the time is approximately n-log-n. We cannot test this on CI since you get different timings all the time. Instead we just test for [128000], which likely takes forever if the complexity is not n-log-n. *) (* Time Eval vm_compute in gmap_insert_positives_test 1000. Time Eval vm_compute in gmap_insert_positives_test 2000. Time Eval vm_compute in gmap_insert_positives_test 4000. Time Eval vm_compute in gmap_insert_positives_test 8000. Time Eval vm_compute in gmap_insert_positives_test 16000. Time Eval vm_compute in gmap_insert_positives_test 32000. Time Eval vm_compute in gmap_insert_positives_test 64000. Time Eval vm_compute in gmap_insert_positives_test 128000. Time Eval vm_compute in gmap_insert_positives_test 256000. Time Eval vm_compute in gmap_insert_positives_test 512000. Time Eval vm_compute in gmap_insert_positives_test 1000000. *) Check "gmap_insert_positives_test". Eval vm_compute in gmap_insert_positives_test 128000. Eval vm_compute in gmap_insert_positives_union_test 128000. Eval vm_compute in gmap_insert_positives_filter_test 128000. (** Make sure that [pmap] and [gmap] have canonical representations, and compute reasonably efficiently even with [reflexivity]. *) Check "pmap_insert_comm". Theorem pmap_insert_comm : {[ 3:=false; 2:=true]}%positive =@{Pmap bool} {[ 2:=true; 3:=false ]}%positive. Proof. simpl. Show. reflexivity. Qed. Check "pmap_lookup_concrete". Theorem pmap_lookup_concrete : lookup (M:=Pmap bool) 2%positive {[ 3:=false; 2:=true ]}%positive = Some true. Proof. simpl. Show. reflexivity. Qed. Theorem pmap_insert_positives_reflexivity_500 : pmap_insert_positives 1 1 500 = pmap_insert_positives_rev 500 1 500. Proof. reflexivity. Qed. Theorem pmap_insert_positives_reflexivity_1000 : pmap_insert_positives 1 1 1000 = pmap_insert_positives_rev 1000 1 1000. Proof. (* this should take less than a second *) reflexivity. Qed. Theorem pmap_insert_positives_union_reflexivity_500 : (pmap_insert_positives_rev 1 1 400) ∪ (pmap_insert_positives 1 1 500 ∖ pmap_insert_positives_rev 1 1 400) = pmap_insert_positives 1 1 500. Proof. reflexivity. Qed. Theorem pmap_insert_positives_union_reflexivity_1000 : (pmap_insert_positives_rev 1 1 800) ∪ (pmap_insert_positives 1 1 1000 ∖ pmap_insert_positives_rev 1 1 800) = pmap_insert_positives 1 1 1000. Proof. (* this should less than a second *) reflexivity. Qed. Check "gmap_insert_comm". Theorem gmap_insert_comm : {[ 3:=false; 2:=true]} =@{gmap nat bool} {[ 2:=true; 3:=false ]}. Proof. simpl. Show. reflexivity. Qed. Check "gmap_lookup_concrete". Theorem gmap_lookup_concrete : lookup (M:=gmap nat bool) 2 {[ 3:=false; 2:=true ]} = Some true. Proof. simpl. Show. reflexivity. Qed. Theorem gmap_insert_positives_reflexivity_500 : gmap_insert_positives 1 1 500 = gmap_insert_positives_rev 500 1 500. Proof. reflexivity. Qed. Theorem gmap_insert_positives_reflexivity_1000 : gmap_insert_positives 1 1 1000 = gmap_insert_positives_rev 1000 1 1000. Proof. (* this should less than a second *) reflexivity. Qed. Theorem gmap_insert_positives_union_reflexivity_500 : (gmap_insert_positives_rev 1 1 400) ∪ (gmap_insert_positives 1 1 500 ∖ gmap_insert_positives_rev 1 1 400) = gmap_insert_positives 1 1 500. Proof. reflexivity. Qed. Theorem gmap_insert_positives_union_reflexivity_1000 : (gmap_insert_positives_rev 1 1 800) ∪ (gmap_insert_positives 1 1 1000 ∖ gmap_insert_positives_rev 1 1 800) = gmap_insert_positives 1 1 1000. Proof. (* this should less than a second *) reflexivity. Qed. (** This should be immediate, see std++ issue #183 *) Goal dom ((<[10%positive:=1]> ∅) : Pmap _) = dom ((<[10%positive:=2]> ∅) : Pmap _). Proof. reflexivity. Qed. Goal dom ((<["f":=1]> ∅) : gmap _ _) = dom ((<["f":=2]> ∅) : gmap _ _). Proof. reflexivity. Qed. (** Make sure that [pmap] and [gmap] can be used in nested inductive definitions *) Inductive test := Test : Pmap test → test. Fixpoint test_size (t : test) : nat := let 'Test ts := t in S (map_fold (λ _ t', plus (test_size t')) 0 ts). Fixpoint test_merge (t1 t2 : test) : test := match t1, t2 with | Test ts1, Test ts2 => Test $ union_with (λ t1 t2, Some (test_merge t1 t2)) ts1 ts2 end. Lemma test_size_merge : test_size (test_merge (Test {[ 10%positive := Test ∅; 50%positive := Test ∅ ]}) (Test {[ 10%positive := Test ∅; 32%positive := Test ∅ ]})) = 4. Proof. reflexivity. Qed. Global Instance test_eq_dec : EqDecision test. Proof. refine (fix go t1 t2 := let _ : EqDecision test := @go in match t1, t2 with | Test ts1, Test ts2 => cast_if (decide (ts1 = ts2)) end); abstract congruence. Defined. Inductive gtest K `{Countable K} := GTest : gmap K (gtest K) → gtest K. Arguments GTest {_ _ _} _. Fixpoint gtest_size `{Countable K} (t : gtest K) : nat := let 'GTest ts := t in S (map_fold (λ _ t', plus (gtest_size t')) 0 ts). Fixpoint gtest_merge `{Countable K} (t1 t2 : gtest K) : gtest K := match t1, t2 with | GTest ts1, GTest ts2 => GTest $ union_with (λ t1 t2, Some (gtest_merge t1 t2)) ts1 ts2 end. Lemma gtest_size_merge : gtest_size (gtest_merge (GTest {[ 10 := GTest ∅; 50 := GTest ∅ ]}) (GTest {[ 10 := GTest ∅; 32 := GTest ∅ ]})) = 4. Proof. reflexivity. Qed. Lemma gtest_size_merge_string : gtest_size (gtest_merge (GTest {[ "foo" := GTest ∅; "bar" := GTest ∅ ]}) (GTest {[ "foo" := GTest ∅; "baz" := GTest ∅ ]})) = 4. Proof. reflexivity. Qed. Global Instance gtest_eq_dec `{Countable K} : EqDecision (gtest K). Proof. refine (fix go t1 t2 := let _ : EqDecision (gtest K) := @go in match t1, t2 with | GTest ts1, GTest ts2 => cast_if (decide (ts1 = ts2)) end); abstract congruence. Defined. Lemma gtest_ind' `{Countable K} (P : gtest K → Prop) : (∀ ts, map_Forall (λ _, P) ts → P (GTest ts)) → ∀ t, P t. Proof. intros Hnode t. remember (gtest_size t) as n eqn:Hn. revert t Hn. induction (lt_wf n) as [n _ IH]; intros [ts] ->; simpl in *. apply Hnode. revert ts IH. apply (map_fold_ind (λ r ts, (∀ n', n' < S r → _) → map_Forall (λ _, P) ts)). - intros IH. apply map_Forall_empty. - intros k t m r ? IHm IHt. apply map_Forall_insert; [done|]. split. + eapply IHt; [|done]; lia. + eapply IHm. intros; eapply IHt;[|done]; lia. Qed. (** We show that [gtest K] is countable itself. This means that we can use [gtest K] (which involves nested uses of [gmap]) as keys in [gmap]/[gset], i.e., [gmap (gtest K) V] and [gset (gtest K)]. And even [gtest (gtest K)]. Showing that [gtest K] is countable is not trivial due to its nested-inductive nature. We need to write [encode] and [decode] functions, and prove that they are inverses. We do this by converting to/from [gen_tree]. This shows that Coq's guardedness checker accepts non-trivial recursive definitions involving [gtest], and we can do non-trivial induction proofs about [gtest]. *) Global Program Instance gtest_countable `{Countable K} : Countable (gtest K) := let enc := fix go t := let 'GTest ts := t return _ in GenNode 0 (map_fold (λ (k : K) t rec, GenLeaf k :: go t :: rec) [] ts) in let dec_list := λ dec : gen_tree K → gtest K, fix go ts := match ts return gmap K (gtest K) with | GenLeaf k :: t :: ts => <[k:=dec t]> (go ts) | _ => ∅ end in let dec := fix go t := match t return _ with | GenNode 0 ts => GTest (dec_list go ts) | _ => GTest ∅ (* dummy *) end in inj_countable' enc dec _. Next Obligation. intros K ?? enc dec_list dec t. remember (gtest_size t) as n eqn:Hn. revert t Hn. induction (lt_wf n) as [n _ IH]; intros [ts] ->; simpl in *; f_equal. revert ts IH. apply (map_fold_ind (λ r ts, _ → dec_list dec r = ts)); [done|]. intros i t ts r ? IHts IHt; simpl. f_equal. - eapply IHt; [|done]. rewrite map_fold_insert_L by auto with lia. lia. - apply IHts; intros n ? t' ->. eapply IHt; [|done]. rewrite map_fold_insert_L by auto with lia. lia. Qed. Goal ({[ GTest {[ 1 := GTest ∅ ]} := "foo" ]} : gmap (gtest nat) string) !! GTest {[ 1 := GTest ∅ ]} = Some "foo". Proof. reflexivity. Qed. Goal {[ GTest {[ 1 := GTest ∅ ]} ]} ≠@{gset (gtest nat)} {[ GTest ∅ ]}. Proof. discriminate. Qed. Goal GTest {[ GTest {[ 1 := GTest ∅ ]} := GTest ∅ ]} ≠@{gtest (gtest nat)} GTest ∅. Proof. discriminate. Qed. stdpp-coq-stdpp-1.9.0/tests/is_closed_term.ref000066400000000000000000000012711451153341500214210ustar00rootroot00000000000000"is_closed_term_test" : string The command has indeed failed with message: Tactic failure: The term x is not closed. The command has indeed failed with message: Tactic failure: The term (x + 1) is not closed. The command has indeed failed with message: Tactic failure: The term (x + y) is not closed. The command has indeed failed with message: Tactic failure: The term section_variable is not closed. The command has indeed failed with message: Tactic failure: The term (section_variable + 1) is not closed. The command has indeed failed with message: Tactic failure: The term P is not closed. The command has indeed failed with message: Tactic failure: The term (P ∧ True) is not closed. stdpp-coq-stdpp-1.9.0/tests/is_closed_term.v000066400000000000000000000024051451153341500211120ustar00rootroot00000000000000From stdpp Require Import tactics strings. Unset Mangle Names. Section test. Context (section_variable : nat). Axiom axiom : nat. Check "is_closed_term_test". Lemma is_closed_term_test : ∀ x y (P : Prop), let a := 10 in a = a → let b := (a + 11) in x + y = y + x. Proof. intros x y P a H b. (* Constructors are closed. *) is_closed_term 1. (* Functions on closed terms are closed. *) is_closed_term (1 + 1). (* Variables bound in the context are not closed. *) Fail is_closed_term x. Fail is_closed_term (x + 1). Fail is_closed_term (x + y). (* Section variables are not closed. *) Fail is_closed_term section_variable. Fail is_closed_term (section_variable + 1). (* Axioms are considered closed. (Arguably this is a bug, but there is nothing we can do about it.) *) is_closed_term axiom. is_closed_term (axiom + 1). (* Let-bindings are considered closed. *) is_closed_term a. is_closed_term (a + 1). is_closed_term b. is_closed_term (b + 1). (* is_closed_term also works for propositions. *) is_closed_term True. is_closed_term (True ∧ True). Fail is_closed_term P. Fail is_closed_term (P ∧ True). lia. Qed. End test. stdpp-coq-stdpp-1.9.0/tests/length.ref000066400000000000000000000010741451153341500177100ustar00rootroot00000000000000length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] length : list ?A → nat where ?A : [ |- Type] stdpp-coq-stdpp-1.9.0/tests/length.v000066400000000000000000000012151451153341500173760ustar00rootroot00000000000000From stdpp Require prelude strings list. (** Check that we always get the [length] function on lists, not on strings. *) Module test1. Import stdpp.base. Check length. Import stdpp.strings. Check length. Import stdpp.base. Check length. End test1. Module test2. Import stdpp.prelude. Check length. Import stdpp.strings. Check length. Import stdpp.prelude. Check length. End test2. Module test3. Import stdpp.strings. Check length. Import stdpp.prelude. Check length. End test3. Module test4. Import stdpp.list. Check length. Import stdpp.strings. Check length. Import stdpp.list. Check length. End test4. stdpp-coq-stdpp-1.9.0/tests/list.ref000066400000000000000000000005451451153341500174040ustar00rootroot000000000000001 goal ============================ None = None 1 goal ============================ Some 10 = Some 10 1 goal ============================ Some 11 = Some 11 1 goal l : list nat ============================ last (11 :: l) = last (11 :: l) 1 goal l : list nat ============================ last (10 :: l) = last (10 :: l) stdpp-coq-stdpp-1.9.0/tests/list.v000066400000000000000000000010631451153341500170710ustar00rootroot00000000000000From stdpp Require Import list. Lemma last_simpl_test_nil : last [] =@{option nat} None. Proof. simpl. Show. done. Qed. Lemma last_simpl_test_singleton : last [10] = Some 10. Proof. simpl. Show. done. Qed. Lemma last_simpl_test_double : last [10; 11] = Some 11. Proof. simpl. Show. done. Qed. Lemma last_simpl_test_cons_cons l : last (10 :: 11 :: l) = last (11 :: l). Proof. simpl. Show. done. Qed. (* The following should not [simpl] and result in a [match]. *) Lemma last_simpl_test_cons l : last (10 :: l) = last (10 :: l). Proof. simpl. Show. done. Qed. stdpp-coq-stdpp-1.9.0/tests/multiset_solver.ref000066400000000000000000000000001451153341500216530ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/multiset_solver.v000066400000000000000000000101301451153341500213510ustar00rootroot00000000000000From stdpp Require Import gmultiset sets. Section test. Context `{Countable A}. Implicit Types x y : A. Implicit Types X Y : gmultiset A. Lemma test_eq_1 x y X : {[+ x; y +]} ⊎ X = {[+ y; x +]} ⊎ X. Proof. multiset_solver. Qed. Lemma test_eq_2 x y z X Y : {[+ z +]} ⊎ X = {[+ y +]} ⊎ Y → {[+ x; z +]} ⊎ X = {[+ y; x +]} ⊎ Y. Proof. multiset_solver. Qed. Lemma test_eq_3 x : {[+ x; x +]} =@{gmultiset _} 2 *: {[+ x +]}. Proof. multiset_solver. Qed. Lemma test_eq_4 x y : {[+ x; y; x +]} =@{gmultiset _} 2 *: {[+ x +]} ⊎ {[+ y +]}. Proof. multiset_solver. Qed. Lemma test_neq_1 x y X : {[+ x; y +]} ⊎ X ≠ ∅. Proof. multiset_solver. Qed. Lemma test_neq_2 x : {[+ x +]} ⊎ ∅ ≠@{gmultiset A} ∅. Proof. multiset_solver. Qed. Lemma test_neq_3 X x : X ⊎ ∅ = {[+ x +]} → X ⊎ ∅ ≠@{gmultiset A} ∅. Proof. multiset_solver. Qed. Lemma test_neq_4 x y : {[+ x +]} ∖ {[+ y +]} ≠@{gmultiset A} ∅ → x ≠ y. Proof. multiset_solver. Qed. Lemma test_neq_5 x y Y : y ∈ Y → {[+ x +]} ∖ Y ≠ ∅ → x ≠ y. Proof. multiset_solver. Qed. Lemma test_multiplicity_1 x X Y : 2 < multiplicity x X → X ⊆ Y → 1 < multiplicity x Y. Proof. multiset_solver. Qed. Lemma test_multiplicity_2 x X : 2 < multiplicity x X → {[+ x; x; x +]} ⊆ X. Proof. multiset_solver. Qed. Lemma test_multiplicity_3 x X : multiplicity x X < 3 → {[+ x; x; x +]} ⊈ X. Proof. multiset_solver. Qed. Lemma test_multiplicity_4 x X : 2 < multiplicity x X → 3 *: {[+ x +]} ⊆ X. Proof. multiset_solver. Qed. Lemma test_multiplicity_5 x X : multiplicity x X < 3 → 3 *: {[+ x +]} ⊈ X. Proof. multiset_solver. Qed. Lemma test_elem_of_1 x X : x ∈ X ↔ {[+ x +]} ⊎ ∅ ⊆ X. Proof. multiset_solver. Qed. Lemma test_elem_of_2 x X : x ∈ X ↔ {[+ x +]} ∪ ∅ ⊆ X. Proof. multiset_solver. Qed. Lemma test_elem_of_3 x y X : x ≠ y → x ∈ X → y ∈ X → {[+ x; y +]} ⊆ X. Proof. multiset_solver. Qed. Lemma test_elem_of_4 x y X Y : x ≠ y → x ∈ X → y ∈ Y → {[+ x; y +]} ⊆ X ∪ Y. Proof. multiset_solver. Qed. Lemma test_elem_of_5 x y X Y : x ≠ y → x ∈ X → y ∈ Y → {[+ x +]} ⊆ (X ∪ Y) ∖ {[+ y +]}. Proof. multiset_solver. Qed. Lemma test_elem_of_6 x y X : {[+ x; y +]} ⊆ X → x ∈ X ∧ y ∈ X. Proof. multiset_solver. Qed. (** Tests where the goals do not involve the multiset connectives *) Lemma test_goal_1 x y X : {[+ x +]} ∪ X ⊆ {[+ y +]} → x = y. Proof. multiset_solver. Qed. Lemma test_goal_2 x y X : {[+ x +]} ∪ X ⊆ {[+ y +]} → [x] = [y]. Proof. multiset_solver. Qed. Lemma test_goal_3 x y X l : {[+ x +]} ∪ X ⊆ {[+ y +]} → [x] `suffix_of` l ++ [y]. Proof. (* [multiset_solver] will first substitute [x]/[y], and then [eauto] is used on the leaf. *) multiset_solver by eauto using suffix_app_r. Qed. Lemma test_big_1 x1 x2 x3 x4 : {[+ x1; x2; x3; x4; x4 +]} ⊆@{gmultiset A} {[+ x1; x1; x2; x3; x4; x4 +]}. Proof. multiset_solver. Qed. Lemma test_big_2 x1 x2 x3 x4 X : 2 ≤ multiplicity x4 X → {[+ x1; x2; x3; x4; x4 +]} ⊆@{gmultiset A} {[+ x1; x1; x2; x3 +]} ⊎ X. Proof. multiset_solver. Qed. Lemma test_big_3 x1 x2 x3 x4 X : 4 ≤ multiplicity x4 X → {[+ x1; x2; x3; x4; x4 +]} ⊎ {[+ x1; x2; x3; x4; x4 +]} ⊆@{gmultiset A} {[+ x1; x1; x2; x3 +]} ⊎ {[+ x1; x1; x2; x3 +]} ⊎ X. Proof. multiset_solver. Qed. Lemma test_big_4 x1 x2 x3 x4 x5 x6 x7 x8 x9 : {[+ x1; x2; x3; x4; x4 +]} ⊎ {[+ x5; x6; x7; x8; x8; x9 +]} ⊆@{gmultiset A} {[+ x1; x1; x2; x3; x4; x4 +]} ⊎ {[+ x5; x5; x6; x7; x9; x8; x8 +]}. Proof. multiset_solver. Qed. Lemma test_big_5 x1 x2 x3 x4 x5 x6 x7 x8 x9 : 2 *: {[+ x1; x2; x4 +]} ⊎ 2 *: {[+ x5; x6; x7; x8; x8; x9 +]} ⊆@{gmultiset A} {[+ x1; x1; x2; x3; x4; x4; x2 +]} ⊎ 3 *: {[+ x5; x5; x6; x7; x9; x8; x8 +]}. Proof. multiset_solver. Qed. Lemma test_firstorder_1 (P : A → Prop) x X : P x ∧ (∀ y, y ∈ X → P y) ↔ (∀ y, y ∈ {[+ x +]} ⊎ X → P y). Proof. multiset_solver. Qed. End test. stdpp-coq-stdpp-1.9.0/tests/notation.ref000066400000000000000000000017611451153341500202650ustar00rootroot00000000000000test_2 = {[10 := {[10 := 1]}; 20 := {[20 := 2]}]} : M (M nat) test_3 = {[10 := {[10 := 1]}; 20 := {[20 := 2]}; 30 := {[30 := 3]}]} : M (M nat) test_4 = {[10 := {[10 := 1]}; 20 := {[20 := 2]}; 30 := {[30 := 3]}; 40 := {[40 := 4]}]} : M (M nat) test_op_2 = {[10 := {[10 ^ 2 := 99]}; 10 + 1 := {[10 - 100 := 42 * 1337]}]} : M (M nat) test_op_3 = {[10 := {[20 - 2 := [11]; 1 := [22]]}; 20 := {[99 + length [1] := [1; 2; 3]]}; 4 := {[4 := [4]]}; 5 := {[5 := [5]]}]} : M (M (list nat)) test_op_4 = {[10 := {[20 - 2 := [11]; 1 := [22]; 3 := [23]; 4 := [1; 2; 3; 4; 5; 6; 7; 8; 9]]}; 20 := {[99 + length [1] := [1; 2; 3]]}; 4 := {[4 := [4]]}; 5 := {[5 := [5]]}]} : M (M (list nat)) test_gmultiset_1 = {[+ 10 +]} : gmultiset nat test_gmultiset_2 = {[+ 10; 11 +]} : gmultiset nat test_gmultiset_3 = {[+ 10; 11; 2 - 2 +]} : gmultiset nat test_gmultiset_4 = {[+ {[+ 10 +]}; ∅; {[+ 2 - 2; 10 +]} +]} : gmultiset (gmultiset nat) stdpp-coq-stdpp-1.9.0/tests/notation.v000066400000000000000000000042601451153341500177530ustar00rootroot00000000000000From stdpp Require Import base tactics fin_maps gmap gmultiset. (** Test parsing of variants of [(≡)] notation. *) Lemma test_equiv_annot_sections `{!Equiv A, !Equivalence (≡@{A})} (x : A) : x ≡@{A} x ∧ (≡@{A}) x x ∧ (x ≡.) x ∧ (.≡ x) x ∧ ((x ≡@{A} x)) ∧ ((≡@{A})) x x ∧ ((x ≡.)) x ∧ ((.≡ x)) x ∧ ( x ≡@{A} x) ∧ ( x ≡.) x ∧ (x ≡@{A} x ) ∧ (≡@{A} ) x x ∧ (.≡ x ) x. Proof. naive_solver. Qed. (** Test that notations for maps with multiple elements can be parsed and printed correctly. *) Section map_notations. (* Avoiding section variables so output is not affected by https://github.com/coq/coq/pull/16208 *) Notation M := (gmap nat). Definition test_2 : M (M nat) := {[ 10 := {[ 10 := 1 ]}; 20 := {[ 20 := 2]} ]}. Definition test_3 : M (M nat) := {[ 10 := {[ 10 := 1 ]}; 20 := {[ 20 := 2]}; 30 := {[ 30 := 3]} ]}. Definition test_4 : M (M nat) := {[ 10 := {[ 10 := 1 ]}; 20 := {[ 20 := 2]}; 30 := {[ 30 := 3]}; 40 := {[ 40 := 4 ]} ]}. Definition test_op_2 : M (M nat) := {[ 10 := {[Nat.pow 10 2 := 99]}; 10 + 1 := {[ 10 - 100 := 42 * 1337 ]} ]}. Definition test_op_3 : M (M (list nat)) := {[ 10 := {[ 20 - 2 := [11]; 1 := [22] ]}; 20 := {[ 99 + length ([1]) := [1;2;3] ]}; 4 := {[ 4:=[4] ]} ; 5 := {[ 5 := [5] ]} ]}. Definition test_op_4 : M (M (list nat)) := ({[ 10 := {[ 20 - 2 := [11]; 1 := [22]; 3 := [23]; 4:=[1;2;3;4;5;6;7;8;9]]}; 20 := {[ 99 + length ([1]) := [1;2;3] ]}; 4 := {[ 4:=[4] ]} ; 5 := {[ 5 := [5] ]} ]}). Print test_2. Print test_3. Print test_4. Print test_op_2. Print test_op_3. Print test_op_4. End map_notations. (** Test that notations for maps with multiple elements can be parsed and printed correctly. *) Section multiset_notations. Definition test_gmultiset_1 : gmultiset nat := {[+ 10 +]}. Definition test_gmultiset_2 : gmultiset nat := {[+ 10; 11 +]}. Definition test_gmultiset_3 : gmultiset nat := {[+ 10; 11; 2 - 2 +]}. Definition test_gmultiset_4 : gmultiset (gmultiset nat) := {[+ {[+ 10 +]}; ∅; {[+ 2 - 2; 10 +]} +]}. Print test_gmultiset_1. Print test_gmultiset_2. Print test_gmultiset_3. Print test_gmultiset_4. End multiset_notations. stdpp-coq-stdpp-1.9.0/tests/numbers.ref000066400000000000000000000003701451153341500201000ustar00rootroot00000000000000le : nat → nat → Prop lt : nat → nat → Prop le : nat → nat → Prop lt : nat → nat → Prop le : nat → nat → Prop lt : nat → nat → Prop le : nat → nat → Prop lt : nat → nat → Prop stdpp-coq-stdpp-1.9.0/tests/numbers.v000066400000000000000000000006211451153341500175700ustar00rootroot00000000000000From stdpp Require base numbers prelude. (** Check that we always get the [le] and [lt] functions on [nat]. *) Module test1. Import stdpp.base. Check le. Check lt. End test1. Module test2. Import stdpp.prelude. Check le. Check lt. End test2. Module test3. Import stdpp.numbers. Check le. Check lt. End test3. Module test4. Import stdpp.list. Check le. Check lt. End test4. stdpp-coq-stdpp-1.9.0/tests/pretty.ref000066400000000000000000000000001451153341500177420ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/pretty.v000066400000000000000000000043761451153341500174570ustar00rootroot00000000000000From stdpp Require Import pretty. From Coq Require Import Ascii. Section N. Local Open Scope N_scope. Lemma pretty_N_0 : pretty 0 = "0". Proof. reflexivity. Qed. Lemma pretty_N_1 : pretty 1 = "1". Proof. reflexivity. Qed. Lemma pretty_N_9 : pretty 9 = "9". Proof. reflexivity. Qed. Lemma pretty_N_10 : pretty 10 = "10". Proof. reflexivity. Qed. Lemma pretty_N_100 : pretty 100 = "100". Proof. reflexivity. Qed. Lemma pretty_N_123456789 : pretty 123456789 = "123456789". Proof. reflexivity. Qed. End N. (** Minimized version of: https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/Stack.20overflow.20in.20Qed.2E Fixed by making the [wp_guard] in [pretty_N_go] proportional to the size of the input so that it blocks in case the input is an open term. *) Lemma test_no_stack_overflow p n : get n (pretty (N.pos p)) ≠ Some "_"%char → get (S n) ("-" +:+ pretty (N.pos p)) ≠ Some "_"%char. Proof. intros Hlem. apply Hlem. Qed. Section nat. Local Open Scope nat_scope. Lemma pretty_nat_0 : pretty 0 = "0". Proof. reflexivity. Qed. Lemma pretty_nat_1 : pretty 1 = "1". Proof. reflexivity. Qed. Lemma pretty_nat_9 : pretty 9 = "9". Proof. reflexivity. Qed. Lemma pretty_nat_10 : pretty 10 = "10". Proof. reflexivity. Qed. Lemma pretty_nat_100 : pretty 100 = "100". Proof. reflexivity. Qed. Lemma pretty_nat_1234 : pretty 1234 = "1234". Proof. reflexivity. Qed. End nat. Section Z. Local Open Scope Z_scope. Lemma pretty_Z_0 : pretty 0 = "0". Proof. reflexivity. Qed. Lemma pretty_Z_1 : pretty 1 = "1". Proof. reflexivity. Qed. Lemma pretty_Z_9 : pretty 9 = "9". Proof. reflexivity. Qed. Lemma pretty_Z_10 : pretty 10 = "10". Proof. reflexivity. Qed. Lemma pretty_Z_100 : pretty 100 = "100". Proof. reflexivity. Qed. Lemma pretty_Z_123456789 : pretty 123456789 = "123456789". Proof. reflexivity. Qed. Lemma pretty_Z_opp_1 : pretty (-1) = "-1". Proof. reflexivity. Qed. Lemma pretty_Z_opp_9 : pretty (-9) = "-9". Proof. reflexivity. Qed. Lemma pretty_Z_opp_10 : pretty (-10) = "-10". Proof. reflexivity. Qed. Lemma pretty_Z_opp_100 : pretty (-100) = "-100". Proof. reflexivity. Qed. Lemma pretty_Z_opp_123456789 : pretty (-123456789) = "-123456789". Proof. reflexivity. Qed. End Z.stdpp-coq-stdpp-1.9.0/tests/proper.ref000066400000000000000000000001001451153341500177230ustar00rootroot00000000000000The command has indeed failed with message: No such assumption. stdpp-coq-stdpp-1.9.0/tests/proper.v000066400000000000000000000155621451153341500174360ustar00rootroot00000000000000From stdpp Require Import prelude fin_maps propset. (** Some tests for f_equiv. *) (* Similar to [f_equal], it should solve goals by [reflexivity]. *) Lemma test_f_equiv_refl {A} (R : relation A) `{!Equivalence R} x : R x x. Proof. f_equiv. Qed. (* And immediately solve sub-goals by reflexivity *) Lemma test_f_equiv_refl_nested {A} (R : relation A) `{!Equivalence R} g x y z : Proper (R ==> R ==> R) g → R y z → R (g x y) (g x z). Proof. intros ? Hyz. f_equiv. apply Hyz. Qed. Section f_equiv. Context `{!Equiv A, !Equiv B, !SubsetEq A}. Lemma f_equiv1 (fn : A → B) (x1 x2 : A) : Proper ((≡) ==> (≡)) fn → x1 ≡ x2 → fn x1 ≡ fn x2. Proof. intros. f_equiv. assumption. Qed. Lemma f_equiv2 (fn : A → B) (x1 x2 : A) : Proper ((⊆) ==> (≡)) fn → x1 ⊆ x2 → fn x1 ≡ fn x2. Proof. intros. f_equiv. assumption. Qed. (* Ensure that we prefer the ≡. *) Lemma f_equiv3 (fn : A → B) (x1 x2 : A) : Proper ((≡) ==> (≡)) fn → Proper ((⊆) ==> (≡)) fn → x1 ≡ x2 → fn x1 ≡ fn x2. Proof. (* The Coq tactic prefers the ⊆. *) intros. Morphisms.f_equiv. Fail assumption. Restart. intros. f_equiv. assumption. Qed. End f_equiv. (** Some tests for solve_proper (also testing f_equiv indirectly). *) (** Test case for #161 *) Lemma test_solve_proper_const {A} (R : relation A) `{!Equivalence R} x : Proper (R ==> R) (λ _, x). Proof. solve_proper. Qed. Section tests. Context {A B : Type} `{!Equiv A, !Equiv B}. Context (foo : A → A) (bar : A → B) (baz : B → A → A). Context `{!Proper ((≡) ==> (≡)) foo, !Proper ((≡) ==> (≡)) bar, !Proper ((≡) ==> (≡) ==> (≡)) baz}. Definition test1 (x : A) := baz (bar (foo x)) x. Goal Proper ((≡) ==> (≡)) test1. Proof. solve_proper. Qed. Definition test2 (b : bool) (x : A) := if b then bar (foo x) else bar x. Goal ∀ b, Proper ((≡) ==> (≡)) (test2 b). Proof. solve_proper. Qed. Definition test3 (f : nat → A) := baz (bar (f 0)) (f 2). Goal Proper (pointwise_relation nat (≡) ==> (≡)) test3. Proof. solve_proper. Qed. (* We mirror [discrete_fun] from Iris to have an equivalence on a function space. *) Definition discrete_fun {A} (B : A → Type) `{!∀ x, Equiv (B x)} := ∀ x : A, B x. Local Instance discrete_fun_equiv {A} {B : A → Type} `{!∀ x, Equiv (B x)} : Equiv (discrete_fun B) := λ f g, ∀ x, f x ≡ g x. Notation "A -d> B" := (@discrete_fun A (λ _, B) _) (at level 99, B at level 200, right associativity). Definition test4 x (f : A -d> A) := f x. Goal ∀ x, Proper ((≡) ==> (≡)) (test4 x). Proof. solve_proper. Qed. End tests. Global Instance from_option_proper_test1 `{Equiv A} {B} (R : relation B) (f : A → B) : Proper ((≡) ==> R) f → Proper (R ==> (≡) ==> R) (from_option f). Proof. apply _. Qed. Global Instance from_option_proper_test2 `{Equiv A} {B} (R : relation B) (f : A → B) : Proper ((≡) ==> R) f → Proper (R ==> (≡) ==> R) (from_option f). Proof. solve_proper. Qed. (** The following tests are inspired by Iris's [ofe] structure (here, simplified to just a type an arbitrary relation), and the discrete function space [A -d> B] on a Type [A] and OFE [B]. The tests occur when proving [Proper]s for higher-order functions, which typically occurs while defining functions using Iris's [fixpoint] operator. *) Record setoid := Setoid { setoid_car :> Type; setoid_equiv : relation setoid_car }. Arguments setoid_equiv {_} _ _. Definition myfun (A : Type) (B : setoid) := A → B. Definition myfun_equiv {A B} : relation (myfun A B) := pointwise_relation _ setoid_equiv. Definition myfunS (A : Type) (B : setoid) := Setoid (myfun A B) myfun_equiv. Section setoid_tests. Context {A : setoid} (f : A → A) (h : A → A → A). Context `{!Proper (setoid_equiv ==> setoid_equiv) f, !Proper (setoid_equiv ==> setoid_equiv ==> setoid_equiv) h}. Definition setoid_test1 (rec : myfunS nat A) : myfunS nat A := λ n, h (f (rec n)) (rec n). Goal Proper (setoid_equiv ==> setoid_equiv) setoid_test1. Proof. solve_proper. Qed. Definition setoid_test2 (rec : myfunS nat (myfunS nat A)) : myfunS nat A := λ n, h (f (rec n n)) (rec n n). Goal Proper (setoid_equiv ==> setoid_equiv) setoid_test2. Proof. solve_proper. Qed. Definition setoid_test3 (rec : myfunS nat A) : myfunS nat (myfunS nat A) := λ n m, h (f (rec n)) (rec m). Goal Proper (setoid_equiv ==> setoid_equiv) setoid_test3. Proof. solve_proper. Qed. End setoid_tests. Section map_tests. Context `{FinMap K M} `{Equiv A}. (** For higher-order functions on maps (like [map_with_with], [fmap], etc) we use "higher-order [Proper] instances" [Proper ((≡) ==> (≡)) ==> ...)] that also allow the function to differ. We test that we can derive simpler [Proper]s for a fixed function using both type class inference ([apply _]) and std++'s [solve_proper] tactic. *) Global Instance map_alter_proper_test (f : A → A) i : Proper ((≡) ==> (≡)) f → Proper ((≡) ==> (≡)) (alter (M:=M A) f i). Proof. apply _. Restart. solve_proper. Abort. Global Instance map_zip_proper_test `{Equiv B} : Proper ((≡@{M A}) ==> (≡@{M B}) ==> (≡@{M (A * B)})) map_zip. Proof. apply _. Restart. solve_proper. Abort. Global Instance map_zip_with_proper_test `{Equiv B, Equiv C} (f : A → B → C) : Proper ((≡) ==> (≡) ==> (≡)) f → Proper ((≡) ==> (≡) ==> (≡)) (map_zip_with (M:=M) f). Proof. apply _. Restart. solve_proper. Abort. Global Instance map_fmap_proper_test `{Equiv B} (f : A → B) : Proper ((≡) ==> (≡)) f → Proper ((≡) ==> (≡@{M _})) (fmap f). Proof. apply _. Restart. solve_proper. Abort. Global Instance map_omap_proper_test `{Equiv B} (f : A → option B) : Proper ((≡) ==> (≡)) f → Proper ((≡) ==> (≡@{M _})) (omap f). Proof. apply _. Restart. solve_proper. Abort. End map_tests. (** And similarly for lists *) Global Instance list_alter_proper_test `{!Equiv A} (f : A → A) i : Proper ((≡) ==> (≡)) f → Proper ((≡) ==> (≡)) (alter (M:=list A) f i). Proof. apply _. Restart. solve_proper. Abort. Global Instance list_fmap_proper_test `{!Equiv A, !Equiv B} (f : A → B) : Proper ((≡) ==> (≡)) f → Proper ((≡@{list A}) ==> (≡)) (fmap f). Proof. apply _. Restart. solve_proper. Abort. Global Instance list_bind_proper_test `{!Equiv A, !Equiv B} (f : A → list B) : Proper ((≡) ==> (≡)) f → Proper ((≡) ==> (≡)) (mbind f). Proof. apply _. Restart. solve_proper. Abort. Global Instance mapM_proper_test `{!Equiv A, !Equiv B} (f : A → option B) : Proper ((≡) ==> (≡)) f → Proper ((≡) ==> (≡)) (mapM f). Proof. apply _. Restart. solve_proper. Abort. Lemma test_prod_equivalence (X1 X2 X3 Y : propset nat * propset nat) : X3 ≡ X2 → X2 ≡ X1 → (X1,Y) ≡ (X3,Y). Proof. intros H1 H2. by rewrite H1, <-H2. Qed. stdpp-coq-stdpp-1.9.0/tests/sets.ref000066400000000000000000000000001451153341500173710ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/sets.v000066400000000000000000000013721451153341500170770ustar00rootroot00000000000000From stdpp Require Import sets gmap. Lemma foo `{Set_ A C} (x : A) (X Y : C) : x ∈ X ∩ Y → x ∈ X. Proof. intros Hx. set_unfold in Hx. tauto. Qed. (** Test [set_unfold_list_bind]. *) Lemma elem_of_list_bind_again {A B} (x : B) (l : list A) f : x ∈ l ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ l. Proof. set_solver. Qed. (** Should not leave any evars, see issue #163 *) Goal {[0]} ∪ dom (∅ : gmap nat nat) ≠ ∅. Proof. set_solver. Qed. (** Check that [set_solver] works with [set_Exists] and [set_Forall]. Test cases from issue #178. *) Lemma set_Exists_set_solver : set_Exists (.= 10) ({[ 10 ]} : gset nat). Proof. set_solver. Qed. Lemma set_Forall_set_solver `{Set_ A C} (X : C) x : set_Forall (.≠ x) X ↔ x ∉ X. Proof. set_solver. Qed. stdpp-coq-stdpp-1.9.0/tests/solve_ndisj.ref000066400000000000000000000000001451153341500207320ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/solve_ndisj.v000066400000000000000000000033141451153341500204360ustar00rootroot00000000000000From stdpp Require Import namespaces strings. Section tests. Implicit Types (N : namespace) (E : coPset). Lemma test1 N1 N2 : N1 ## N2 → ↑N1 ⊆@{coPset} ⊤ ∖ ↑N2. Proof. solve_ndisj. Qed. Lemma test2 N1 N2 : N1 ## N2 → ↑N1.@"x" ⊆@{coPset} ⊤ ∖ ↑N1.@"y" ∖ ↑N2. Proof. solve_ndisj. Qed. Lemma test3 N : ⊤ ∖ ↑N ⊆@{coPset} ⊤ ∖ ↑N.@"x". Proof. solve_ndisj. Qed. Lemma test4 N : ⊤ ∖ ↑N ⊆@{coPset} ⊤ ∖ ↑N.@"x" ∖ ↑N.@"y". Proof. solve_ndisj. Qed. Lemma test5 N1 N2 : ⊤ ∖ ↑N1 ∖ ↑N2 ⊆@{coPset} ⊤ ∖ ↑N1.@"x" ∖ ↑N2 ∖ ↑N1.@"y". Proof. solve_ndisj. Qed. Lemma test_ndisjoint_difference_l N : ⊤ ∖ ↑N ##@{coPset} ↑N. Proof. solve_ndisj. Qed. Lemma test_ndisjoint_difference_r N : ↑N ##@{coPset} ⊤ ∖ ↑N. Proof. solve_ndisj. Qed. Lemma test6 E N : ↑N ⊆ E → ↑N ⊆ ⊤ ∖ (E ∖ ↑N). Proof. solve_ndisj. Qed. Lemma test7 N : ↑N ⊆@{coPset} ⊤ ∖ ∅. Proof. solve_ndisj. Qed. Lemma test8 N1 N2 : ⊤ ∖ (↑N1 ∪ ↑N2) ⊆@{coPset} ⊤ ∖ ↑N1.@"counter". Proof. solve_ndisj. Qed. Lemma test9 N1 N2 : ⊤ ∖ (↑N1 ∪ ↑N2) ⊆@{coPset} ⊤ ∖ ↑N1.@"counter" ∖ ↑N1.@"state" ∖ ↑N2. Proof. solve_ndisj. Qed. Lemma test10 N1 N2 E : ↑N1 ∪ E ## ⊤ ∖ ↑N1 ∖ ↑N2 ∖ E. Proof. solve_ndisj. Qed. Lemma test11 N : ↑N.@"other" ⊆@{coPset} ⊤ ∖ (↑N.@"this" ∪ ↑N.@"that"). Proof. solve_ndisj. Qed. Lemma test12 N : ↑N.@"other" ##@{coPset} ↑N.@"this" ∪ ↑N.@"that" ∧ ↑N.@"other" ∪ ↑N.@"this" ##@{coPset} ↑N.@"that". Proof. split; solve_ndisj. Qed. Lemma test13 E N : ↑N ⊆ E → ⊤ ∖ E ⊆ ⊤ ∖ (E ∖ ↑N) ∖ ↑N. Proof. solve_ndisj. Qed. stdpp-coq-stdpp-1.9.0/tests/tactics.ref000066400000000000000000000011451451153341500200600ustar00rootroot00000000000000The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. The command has indeed failed with message: Failed to progress. "otest" : string The command has indeed failed with message: Cannot infer this placeholder of type "nat" in environment: P, Q, R : nat → Prop HPQR1 : ∀ m n : nat, P n → Q m → R (n + m) HPQR2 : ∀ m n : nat, P n → Q m → R (n + m) ∧ R 2 HP0 : P 0 HP1 : P 1 HQ : Q 5 The command has indeed failed with message: Tactic failure: ospecialize can only specialize a local hypothesis; use opose proof instead. stdpp-coq-stdpp-1.9.0/tests/tactics.v000066400000000000000000000130561451153341500175550ustar00rootroot00000000000000(** Basic tests for atctics that don't import anything else (and hence can be run even when nothing else even builds. *) From Coq Require Import String. From stdpp Require Import tactics. Local Unset Mangle Names. (* for stable goal printing *) Local Open Scope string_scope. Goal ∀ P1 P2 P3 P4 (P: Prop), P1 ∨ (Is_true (P2 || P3)) ∨ P4 → (P1 → P) → (P2 → P) → (P3 → P) → (P4 → P) → P. Proof. intros * HH X1 X2 X3 X4. destruct_or? HH; [ exact (X1 HH) | exact (X2 HH) | exact (X3 HH) | exact (X4 HH) ]. Qed. Goal ∀ P1 P2 P3 P4 (P: Prop), P1 ∨ P2 → P3 ∨ P4 → (P1 → P3 → P) → (P1 → P4 → P) → (P2 → P3 → P) → (P2 → P4 → P) → P. Proof. intros * HH1 HH2 X1 X2 X3 X4. destruct_or?; [ exact (X1 HH1 HH2) | exact (X3 HH1 HH2) | exact (X2 HH1 HH2) | exact (X4 HH1 HH2) ]. Qed. Goal ∀ P1 P2 P3 P4 (P: Prop), id (P1 ∨ P2) → id (P3 ∨ P4) → (P1 → P3 → P) → (P1 → P4 → P) → (P2 → P3 → P) → (P2 → P4 → P) → P. Proof. intros * HH1 HH2 X1 X2 X3 X4. Fail progress destruct_or?. Fail progress destruct_or!. destruct_or! HH1; destruct_or! HH2; [ exact (X1 HH1 HH2) | exact (X2 HH1 HH2) | exact (X3 HH1 HH2) | exact (X4 HH1 HH2) ]. Qed. Goal ∀ P1 P2 P3 P4, P1 ∧ (Is_true (P2 && P3)) ∧ P4 → P1 ∧ P2 ∧ P3. Proof. intros * HH. split_and!; [ destruct_and? HH; assumption | destruct_and?; assumption | ]. destruct_and?. Fail destruct_and!. assumption. Qed. (** Tests for [case_match] *) Goal ∀ n : nat, match n with | 0 => n = 0 | S n' => n = S n' end. Proof. intros. by case_match. Restart. intros. by case_match eqn:Heq; revert Heq. (* [revert Heq] checks that [Heq] exists *) Qed. Goal ∀ n m : nat, match n with | 0 => m = 0 | S n' => m = S n' end → n = m. Proof. intros. by case_match. Restart. intros. by case_match eqn:Heq; revert Heq. (* [revert Heq] checks that [Heq] exists *) Qed. (** Tests for [select] tactics *) Goal ∀ (n : nat), ∃ m : nat, True. Proof. intros ?. rename select nat into m. exists m. done. Qed. Goal ∀ (P : nat → Prop), P 3 → P 4 → P 4. Proof. intros P **. rename select (P _) into HP4. apply HP4. Qed. Goal ∀ P Q : Prop, True ∨ True → P ∨ Q → Q ∨ P. Proof. intros P Q ??. (* should select the last hypothesis *) destruct select (_ ∨ _); by constructor. Restart. intros P Q ??. (* should select the last hypothesis *) destruct select (_ ∨ _) as [H1|H2]. - right. exact H1. - left. exact H2. Qed. (** [mk_evar] works on things that coerce to types. *) (** This is a feature when we have packed structures, for example Iris's [ofe] (fields other than the carrier omitted). *) Structure ofe := Ofe { ofe_car :> Type }. Goal ∀ A : ofe, True. intros A. let x := mk_evar A in idtac. Abort. (** More surprisingly, it also works for other coercions into a universe, like [Is_true : bool → Prop]. *) Goal True. let x := mk_evar true in idtac. Abort. (** get_head tests. *) Lemma test_get_head (f : nat → nat → nat → nat) : True. Proof. let f' := get_head (f 0 1 2) in unify f f'. let f' := get_head f in unify f f'. Abort. (** o-tactic tests *) Check "otest". Lemma otest (P Q R : nat → Prop) (HPQR1 : ∀ m n, P n → Q m → R (n + m)) (HPQR2 : ∀ m n, P n → Q m → R (n + m) ∧ R 2) (HP0 : P 0) (HP1 : P 1) (HQ : Q 5) : R 6. Proof. (** Imagine we couldn't [apply] since the goal is still very different, we need forward reasoning. Also we don't have proof terms for [P n] and [Q m] but a short proof script can solve them. [n] needs to be specified, but [m] is huge and we don't want to specify it. What do we do? The "o" family of tactics for working with "o"pen terms helps. *) opose proof (HPQR1 _ (S _) _ _) as HR; [exact HP1|exact HQ|]. exact HR. Restart. (** We can have fewer [_]. *) opose proof (HPQR1 _ (S _) _) as HR; [exact HP1|]. exact (HR HQ). Restart. (** And even fewer. *) opose proof (HPQR1 _ (S _)) as HR. exact (HR HP1 HQ). Restart. (** The [*] variant automatically adds [_]. *) opose proof* (HPQR1 _ (S _)) as HR; [exact HP1|exact HQ|]. exact HR. Restart. (** Same deal for [generalize]. *) ogeneralize (HPQR1 _ 1). intros HR. exact (HR HP1 HQ). Restart. ogeneralize (HPQR1 _ 1 _); [exact HP1|]. intros HR. exact (HR HQ). Restart. ogeneralize* (HPQR1 _ 1); [exact HP1|exact HQ|]. intros HR. exact HR. Restart. (** [odestruct] also automatically adds subgoals until there is something to destruct, as usual. Note that [edestruct] wouldn't help here, it just complains that it cannot infer the placeholder. *) Fail edestruct (HPQR2 _ 1). odestruct (HPQR2 _ 1) as [HR1 HR2]; [exact HP1|exact HQ|]. exact HR1. Restart. (** [ospecialize] is like [opose proof] but it reuses the name. It only works on local assumptions. *) Fail ospecialize (plus 0 0). ospecialize (HPQR1 _ 1 _); [exact HP1|]. exact (HPQR1 HQ). Restart. ospecialize (HPQR1 _ 1). exact (HPQR1 HP1 HQ). Restart. ospecialize* (HPQR1 _ 1); [exact HP1|exact HQ|]. exact HPQR1. Qed. (** Make sure [∀] also get auto-instantiated by the [*] variant. *) Lemma o_tactic_with_forall (P Q R : nat → Prop) : P 1 → Q 1 → (∀ n, P n → Q n → R n) → R 1. Proof. intros HP HQ HR. ospecialize* HR; [exact HP|exact HQ|exact HR]. Restart. intros HP HQ HR. opose proof* HR as HR'; [exact HP|exact HQ|exact HR']. Qed. (** Regression tests for [naive_solver]. Requires a bunch of other tactics to work so it comes last in this file. *) Lemma naive_solver_issue_115 (P : nat → Prop) (x : nat) : (∀ x', P x' → x' = 10) → P x → x + 1 = 11. Proof. naive_solver. Qed. stdpp-coq-stdpp-1.9.0/tests/tactics_more.ref000066400000000000000000000000001451153341500210670ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/tactics_more.v000066400000000000000000000005511451153341500205730ustar00rootroot00000000000000From stdpp Require Import tactics option. (** Make sure that [done] is not called recursively when solving [is_Some], which might leave an unresolved evar before performing ex falso. *) Goal False → is_Some (@None nat). Proof. done. Qed. Goal ∀ mx, mx = Some 10 → is_Some mx. Proof. done. Qed. Goal ∀ mx, Some 10 = mx → is_Some mx. Proof. done. Qed. stdpp-coq-stdpp-1.9.0/tests/telescopes.ref000066400000000000000000000007121451153341500205730ustar00rootroot000000000000001 goal X : tele α, β, γ1, γ2 : X → Prop ============================ accessor α β γ1 → accessor α β (λ.. x : X, γ1 x ∨ γ2 x) 1 goal X : tele α, β, γ1, γ2 : X → Prop ============================ ∀.. x : X, γ1 x → (λ.. x0 : X, γ1 x0 ∨ γ2 x0) x 1 goal X : tele α, β, γ1, γ2 : X → Prop x : X Hγ : γ1 x ============================ γ1 x ∨ γ2 x [TEST x y : nat, x = y] : Prop stdpp-coq-stdpp-1.9.0/tests/telescopes.v000066400000000000000000000057051451153341500202730ustar00rootroot00000000000000From stdpp Require Import tactics telescopes. Local Unset Mangle Names. (* for stable goal printing *) Section universes. (** This test would fail without [Unset Universe Minimization ToSet] in [telescopes.v]. *) Lemma texist_exist_universes (X : Type) (P : TeleS (λ _ : X, TeleO) → Prop) : texist P ↔ ex P. Proof. by rewrite texist_exist. Qed. (** [tele_arg t] should live at the same universe as the types inside of [t] because [tele_arg t] is essentially just a (dependent) product. *) Definition no_bump@{u} (t : tele@{u}) : Type@{u} := tele_arg@{u} t. (* Assert that telescopes are cumulatively universe polymorphic. See https://gitlab.mpi-sws.org/iris/iris/-/issues/461 *) Section cumulativity. Monomorphic Universes Quant local. Monomorphic Constraint local < Quant. Example cumul (t : tele@{local}) : tele@{Quant} := t. End cumulativity. End universes. Section accessor. (* This is like Iris' accessors, but in Prop. Just to play with telescopes. *) Definition accessor {X : tele} (α β γ : X → Prop) : Prop := ∃.. x, α x ∧ (β x → γ x). (* Working with abstract telescopes. *) Section tests. Context {X : tele}. Implicit Types α β γ : X → Prop. Lemma acc_mono α β γ1 γ2 : (∀.. x, γ1 x → γ2 x) → accessor α β γ1 → accessor α β γ2. Proof. unfold accessor. rewrite tforall_forall, !texist_exist. intros Hγ12 Hacc. destruct Hacc as [x' [Hα Hclose]]. exists x'. split; [done|]. intros Hβ. apply Hγ12, Hclose. done. Qed. Lemma acc_mono_disj α β γ1 γ2 : accessor α β γ1 → accessor α β (λ.. x, γ1 x ∨ γ2 x). Proof. Show. apply acc_mono. Show. rewrite tforall_forall. intros x Hγ. rewrite tele_app_bind. Show. left. done. Qed. End tests. End accessor. (* Type inference for tele_app-based notation. (Relies on [&] bidirectionality hint of tele_app.) *) Definition test {TT : tele} (t : TT → Prop) : Prop := ∀.. x, t x ∧ t x. Notation "'[TEST' x .. z , P ']'" := (test (TT:=(TeleS (fun x => .. (TeleS (fun z => TeleO)) ..))) (tele_app (λ x, .. (λ z, P) ..))) (x binder, z binder). Check [TEST (x y : nat), x = y]. (** [tele_arg ..] notation tests. These tests mainly test type annotations and casts in the [tele_arg] notations. We test that Coq can typecheck literal telescope arguments in two ways: - tactic unification/old unification using [exact] - evarconv/new unification using [refine] *) Example tele_arg_notation_0 : [tele]. assert_succeeds exact [tele_arg]. assert_succeeds refine [tele_arg]. Abort. Example tele_arg_notation_1 : [tele (_:nat)]. assert_succeeds exact [tele_arg 0]. assert_succeeds refine [tele_arg 0]. Abort. Example tele_arg_notation_2 : [tele (_ : bool) (_ : nat)]. assert_succeeds exact [tele_arg true; 0]. assert_succeeds refine [tele_arg true; 0]. Abort. Example tele_arg_notation_2_dep : [tele (b : bool) (_ : if b then nat else False)]. assert_succeeds exact [tele_arg true; 0]. assert_succeeds refine [tele_arg true; 0]. Abort. stdpp-coq-stdpp-1.9.0/tests/typeclasses.ref000066400000000000000000000000001451153341500207520ustar00rootroot00000000000000stdpp-coq-stdpp-1.9.0/tests/typeclasses.v000066400000000000000000000011251451153341500204540ustar00rootroot00000000000000From stdpp Require Import prelude. (** Check that [@Reflexive Prop ?r] picks the instance setoid_rewrite needs. Really, we want to set [Hint Mode Reflexive] in a way that this fails, but we cannot [1]. So at least we try to make sure the first solution found is the right one, to not pay performance in the success case [2]. [1] https://github.com/coq/coq/issues/7916 [2] https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp/merge_requests/38 *) Lemma test_setoid_rewrite : ∃ R, @Reflexive Prop R ∧ R = iff. Proof. eexists. split. - apply _. - reflexivity. Qed. stdpp-coq-stdpp-1.9.0/tests/universes.ref000066400000000000000000000000621451153341500204460ustar00rootroot00000000000000gmap Z Z : Set : Set gset Z : Set : Set stdpp-coq-stdpp-1.9.0/tests/universes.v000066400000000000000000000003451451153341500201430ustar00rootroot00000000000000From stdpp Require Import gmap. (** Make sure that [gmap] and [gset] do not bump the universe. Since [Z : Set], the types [gmap Z Z] and [gset Z] should have universe [Set] too. *) Check (gmap Z Z : Set). Check (gset Z : Set).