pax_global_header00006660000000000000000000000064145043306350014515gustar00rootroot0000000000000052 comment=7b5e1744881cf130d0eb3ff86982c0bacb68f83c extructures-0.4.0/000077500000000000000000000000001450433063500141135ustar00rootroot00000000000000extructures-0.4.0/.circleci/000077500000000000000000000000001450433063500157465ustar00rootroot00000000000000extructures-0.4.0/.circleci/config.yml000066400000000000000000000032331450433063500177370ustar00rootroot00000000000000# Use the latest 2.1 version of CircleCI pipeline process engine. See: https://circleci.com/docs/2.0/configuration-reference version: 2.1 # Use a package of configuration called an orb. defaults: &defaults environment: OPAMJOBS: 2 OPAMVERBOSE: 1 OPAMYES: true TERM: xterm commands: startup: steps: - checkout prepare: parameters: mathcomp-version: type: string default: 2.0.0 deriving-version: type: string default: 0.2.0 steps: - run: name: Install dependencies command: | opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev opam update opam pin add coq-mathcomp-ssreflect \ --kind=version << parameters.mathcomp-version >> opam pin add coq-deriving \ --kind=version << parameters.deriving-version >> opam install --deps-only . build: steps: - run: name: Building extructures command: opam install --with-test . jobs: coq-8-17: <<: *defaults steps: - startup - prepare: mathcomp-version: 2.0.0 deriving-version: 0.2.0 - build docker: - image: coqorg/coq:8.17 coq-8-18: <<: *defaults steps: - startup - prepare: mathcomp-version: 2.0.0 deriving-version: 0.2.0 - build docker: - image: coqorg/coq:8.18 coq-dev: <<: *defaults steps: - startup - prepare: mathcomp-version: "dev" deriving-version: "dev" - build docker: - image: coqorg/coq:dev workflows: build: jobs: - coq-8-17 - coq-8-18 - coq-dev extructures-0.4.0/.gitignore000066400000000000000000000001301450433063500160750ustar00rootroot00000000000000*.glob *.v.d *.d *.vo *.vos *.vok *.aux .coq-native/ CoqMakefile CoqMakefile.bak *.conf extructures-0.4.0/CHANGELOG.md000066400000000000000000000050261450433063500157270ustar00rootroot00000000000000# Unreleased ## Added ## Changed ## Deprecated ## Fixed ## Removed # 0.4.0 (2023/09/25) ## Added - Infix notations for `fsubset` (`:<=:`) and `fdisjoint` (`:#:`). ## Changed - Use Hierarchy Builder to define the ordType interface. - `ordMixin` has been replaced with `hasOrd` - Use maximally implicit arguments for the type arguments of `getm`, `setm`, `repm`, `updm`, `mapim`, `mapm`, `filterm`, `remm`, `mkfmap`, `mkfmapf`, `mkfmapfp` and `domm`. ## Deprecated - `InjOrdMixin`, `PcanOrdMixin` and `CanOrdMixin` have been deprecated in favor of `InjHasOrd`, `PcanHasOrd` and `CanHasOrd`. - The `[ordMixin of T by <:]` notation has been deprecated in favor of `[Ord of T by <:]`. - The `[derive [] ordMixin for T]` notations have been deprecated in favor of `[derive [] hasOrd for T]`. ## Fixed - Make implicit arguments for `bigcupP` valid globally. # 0.3.1. (2021/10/28) ## Added - Support for SSReflect 1.13.0 ## Removed - Support for SSReflect 1.11.0 and earlier. # 0.3.0 (2021/08/31) ## Added - Type of finitely supported functions `ffun`. - A Deriving instance for `ordType` (cf. https://github.com/arthuraa/deriving). ### Functions `splits` and `splitm`, for extracting an element of a set or map. `filter_map` `pimfset`, an image operator for partial functions. ### Lemmas `sizesD`, about the size of a set difference `filterm0`, `remmI`, `setm_rem`, `filterm_set`, `domm_mkfmap'`, `val_domm`, `fmvalK`, `mkfmapK`, `getm_nth`, `eq_setm`, `sizeES`, `dommES`, `filter_mapE`, `domm_filter_map`, `mapimK`, `mapim_map`, `eq_mapm`, `mapm_comp`, `mapm_mkfmapf`, `fset1_inj`, `fsetUDr`, `val_fset_filter`, `fset_filter_subset`, `in_pimfset`, `bigcupS`, `in_bigcup`, `bigcup1_cond`, `bigcup1`. ## Changed - Implicit arguments for `fdisjointP`, `fsetIidPl`, `fsetIidPr`, `fsetUidPl`, `fsetUidPr`, `fsetDidPl`, `bigcupP`. - Implement `fperm` using `ffun`. - Generalize `supp` and `mem_suppN` to `ffun`. ## Removed - Support for Coq 8.10 # 0.2.2 (2020/08/13) - Fix compatibility issues with Coq 8.12 and Ssreflect 1.11. # 0.2.1 (2019/10/26) - Fix compatibility issue with Coq 8.10 # 0.2.0 (2019/08/21) - Separate phantom argument from the definitions of `fset`, `fmap` and `fperm`. - Add `ordType` instances for `mathcomp.choice.GenTree.tree` and `tuple`. - Add more implicit arguments for `fsubsetP`, `fset2P`, `imfsetP`, `dommP`, `dommPn`, `codommP` and `codommPn`. - Miscellaneous lemmas for finite sets. - Version of `mapm` that allows modifying the domain of a map. # 0.1.0 (2018/04/26) Initial release extructures-0.4.0/CoqMakefile.local000066400000000000000000000010111450433063500173000ustar00rootroot00000000000000TESTVFILES=$(wildcard tests/*.v) TESTVOFILES=$(TESTVFILES:.v=.vo) test: $(TESTVOFILES) .PHONY: test .CoqMakefile.test.d: $(TESTVFILES) $(SHOW)'COQDEP TESTVFILES' $(HIDE)$(COQDEP) -vos -dyndep var $(COQMF_COQLIBS_NOML) $^ $(redir_if_ok) -include .CoqMakefile.test.d $(TESTVOFILES): %.vo: %.v $(SHOW)TEST $< $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) clean:: $(HIDE)rm -f $(TESTVOFILES) $(HIDE)rm -f .CoqMakefile.test.d # Local Variables: # mode: Makefile # End: extructures-0.4.0/LICENSE000066400000000000000000000021071450433063500151200ustar00rootroot00000000000000The MIT License (MIT) Copyright (c) 2014-2018 Arthur Azevedo de Amorim Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.extructures-0.4.0/Makefile000066400000000000000000000017031450433063500155540ustar00rootroot00000000000000# KNOWNTARGETS will not be passed along to CoqMakefile KNOWNTARGETS := CoqMakefile extra-stuff extra-stuff2 # KNOWNFILES will not get implicit targets from the final rule, and so # depending on them won't invoke the submake # Warning: These files get declared as PHONY, so any targets depending # on them always get rebuilt KNOWNFILES := Makefile _CoqProject .DEFAULT_GOAL := invoke-coqmakefile CoqMakefile: Makefile _CoqProject $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile invoke-coqmakefile: CoqMakefile $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) .PHONY: invoke-coqmakefile $(KNOWNFILES) #################################################################### ## Your targets here ## #################################################################### # This should be the last rule, to handle any targets not declared above %: invoke-coqmakefile @true extructures-0.4.0/README.md000066400000000000000000000104351450433063500153750ustar00rootroot00000000000000# Extensional Structures [![arthuraa](https://circleci.com/gh/arthuraa/extructures.svg?style=shield)](https://circleci.com/gh/arthuraa/extructures) This package provides Coq data structures that support extensional reasoning, for which the notion of equality coincides with exhibiting the same _observable behavior_: sets are equal when they contain the same elements; functions are equal when that produce the same outputs; etc. ## Features *Axiom independent* ─ Unlike the case of built-in functions and predicates, these extensionality principles do not rely on any axioms beyond Coq's theory. *Executable* ─ Data structures are implemented as ordered lists and behave reasonably when extracted (as long as you do not have high expectations for performance). *Compatible with Mathematical Components* ─ The design is inspired by [SSReflect][1] and the [Mathematical Components libraries][2], and attempts to follow their style and philosophy. ## Usage Currently, four data structures are supported: - `{fset T}`, the type of finite sets of elements of `T` (defined in `fset`) - `{fmap T -> S}`, the type of maps, or partial functions from `T` to `S` with finite domain (defined in `fmap`) - `ffun def`, the type of finitely supported functions, which agree with `def : T -> S` on all but finitely many inputs - `{fperm T}`, the type of finitely supported permutations on `T`; that is, functions `f` from `T` to `T` that have a right and left inverse and such that `f x != x` only for finitely many values of `x` (defined in `fperm`) Here, `T` ranges over instances of `ordType` (defined in `ord`), which are types endowed with a decidable total order relation. (For `ffun def`, the codomain of `def` must be an `eqType` as well.) Basic data types such as `nat`, `bool`, `option`, products, and sums are all pre-declared as instances of `ordType`. Instances for other types can be transported via subtyping, injective functions, etc., as for other MathComp classes, or derived automatically using [Deriving][7]. The function-like structures coerce into Coq functions, allowing us to write `f x` to retrieve the value of the map `f` at `x`. Similarly, sets coerce to SSReflect collective predicates, allowing us to write `x \in A` to express that `x` belongs to the set `A`. Extensional reasoning is provided by the following lemmas: eq_fset : forall T (A B : {fset T}), A =i B <-> A = B eq_fmap : forall T S (f g : {fmap T -> S}), f =1 g <-> f = g eq_ffun : forall T S (def : T -> S) (f g : ffun def), f =1 g <-> f = g eq_fperm : forall T (f g : {fperm T}), f =1 g <-> f = g Documentation for the libraries is currently scarce, but will be progressively added as comments in the headers of the files. Once the package is installed, it can be required using the `extructures` qualifier. From extructures Require Import ord fset. Check the `tests/` directory for detailed examples. ## Installation The easiest way to install the package is through the [OPAM Coq archive][3]. After installing OPAM and adding the Coq archive, run: opam install coq-extructures Alternatively, you can compile the package by hand. You'll need the following dependencies: - Coq v8.17 -- v8.18 - [Ssreflect][2] v2.0 (`coq-mathcomp-ssreflect` on OPAM). - `deriving` v0.2 (https://github.com/arthuraa/deriving) To compile the package, simply run make After compilation, you can install the package by running make install ## Alternatives Other packages with similar goals are available out there. - Mathematical Components also includes implementations of sets and functions with extensional equality, but they only work for finite types. In contrast, the above definitions work with infinite types as well. - Cyril Cohen's `finmap` library, [available here][4]. - Pierre-Yves Strub's library, [available here][5]. - Christian Doczkal's library, [available here][6]. [1]: https://coq.inria.fr/distrib/current/refman/ssreflect.html [2]: https://github.com/math-comp/math-comp [3]: https://github.com/coq/opam-coq-archive [4]: https://github.com/math-comp/finmap [5]: https://github.com/strub/ssrmisc/blob/master/fset.v [6]: https://www.ps.uni-saarland.de/formalizations/fset/html/libs.fset.html [7]: https://github.com/arthuraa/deriving extructures-0.4.0/_CoqProject000066400000000000000000000003161450433063500162460ustar00rootroot00000000000000-arg "-w -parsing,-redundant-canonical-projection,-notation-overridden,-projection-no-head-constant" -R theories extructures theories/ord.v theories/fperm.v theories/fset.v theories/fmap.v theories/ffun.v extructures-0.4.0/extructures.opam000066400000000000000000000014771450433063500173770ustar00rootroot00000000000000synopsis: "Finite sets, maps, and other data structures with extensional reasoning" name: "coq-extructures" opam-version: "2.0" version: "dev" maintainer: "arthur.aa@gmail.com" homepage: "https://github.com/arthuraa/extructures" dev-repo: "git+https://github.com/arthuraa/extructures.git" bug-reports: "https://github.com/arthuraa/extructures/issues" authors: ["Arthur Azevedo de Amorim"] license: "MIT" build: [ [make "-j" "%{jobs}%"] ] run-test: [ [make "-j" "%{jobs}%" "test"] ] install: [ [make "install"] ] depends: [ "ocaml" "coq" {(>= "8.17" & < "8.19~") | (= "dev")} "coq-mathcomp-ssreflect" {(>= "2.0.0") | (= "dev")} "coq-deriving" {(>= "0.2.0") | (= "dev")} ] tags: [ "keyword:finite maps" "keyword:extensionality" "category:Computer Science/Data Types and Data Structures" "logpath:extructures" ] extructures-0.4.0/flake.lock000066400000000000000000000037761450433063500160640ustar00rootroot00000000000000{ "nodes": { "deriving": { "inputs": { "flake-utils": [ "flake-utils" ], "nixpkgs": [ "nixpkgs" ] }, "locked": { "lastModified": 1695416077, "narHash": "sha256-xPsuEayHstjF0PGFJZJ+5cm0oMUrpoGLXN23op97vjM=", "owner": "arthuraa", "repo": "deriving", "rev": "a6bcc47832bd6d082fdbee995ffaa6e549658451", "type": "github" }, "original": { "owner": "arthuraa", "ref": "v0.2.0", "repo": "deriving", "type": "github" } }, "flake-utils": { "inputs": { "systems": "systems" }, "locked": { "lastModified": 1694529238, "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", "owner": "numtide", "repo": "flake-utils", "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { "owner": "numtide", "repo": "flake-utils", "type": "github" } }, "nixpkgs": { "locked": { "lastModified": 1695227375, "narHash": "sha256-76WTkeCu3npPZDkay2hB2Dj3cOuCiF0P41dbmXWUKtA=", "owner": "NixOS", "repo": "nixpkgs", "rev": "fe977679240ac2027b151ecca1bc6ce808c2e8af", "type": "github" }, "original": { "id": "nixpkgs", "type": "indirect" } }, "root": { "inputs": { "deriving": "deriving", "flake-utils": "flake-utils", "nixpkgs": "nixpkgs" } }, "systems": { "locked": { "lastModified": 1681028828, "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", "owner": "nix-systems", "repo": "default", "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", "type": "github" }, "original": { "owner": "nix-systems", "repo": "default", "type": "github" } } }, "root": "root", "version": 7 } extructures-0.4.0/flake.nix000066400000000000000000000024321450433063500157160ustar00rootroot00000000000000{ description = '' Finite sets, maps, and other data structures with extensional reasoning ''; inputs.flake-utils.url = "github:numtide/flake-utils"; inputs.deriving.url = "github:arthuraa/deriving/v0.2.0"; inputs.deriving.inputs.nixpkgs.follows = "nixpkgs"; inputs.deriving.inputs.flake-utils.follows = "flake-utils"; outputs = { self, nixpkgs, flake-utils, deriving }: flake-utils.lib.eachDefaultSystem (system: let pkgs = nixpkgs.legacyPackages.${system}; derivingSrc = deriving; lib = pkgs.lib; in rec { packages = rec { coq = pkgs.coq_8_17; coqPackages = pkgs.coqPackages_8_17.overrideScope' (self: super: { mathcomp = super.mathcomp.override { version = "2.0.0"; }; deriving = super.deriving.overrideAttrs (s: { version = "0.2.0"; src = derivingSrc; }); }); ocaml = pkgs.ocaml; }; devShell = pkgs.mkShell { packages = with packages; [ coq coqPackages.mathcomp.ssreflect coqPackages.deriving ocaml ]; }; } ); } extructures-0.4.0/tests/000077500000000000000000000000001450433063500152555ustar00rootroot00000000000000extructures-0.4.0/tests/tutorial.v000066400000000000000000000165751450433063500173250ustar00rootroot00000000000000(** Here is a simple formalization of intuitionistic logic to illustrate the use of extructures. We're going to see how we can obtain the basic structural rules of intuitionistic logic for free simply by representing the contexts of assumptions as sets rather than lists. First, we import the main libraries. *) Require Import Coq.Strings.String. (* For atomic formulas *) From HB Require Import structures. From mathcomp Require Import all_ssreflect. From deriving Require Import deriving. From extructures Require Import ord fset fmap. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope fset_scope. (** A formula is built up by combining atomic formulas with conjunction, disjunction and implication. *) Notation atomic := string. Inductive formula : Type := | Atom of atomic | Conj of formula & formula | Disj of formula & formula | Impl of formula & formula. Coercion Atom : atomic >-> formula. Declare Scope formula_scope. Bind Scope formula_scope with formula. Delimit Scope formula_scope with form. Notation "A ∧ B" := (Conj A B) (at level 65, left associativity) : formula_scope. Notation "A ∨ B" := (Disj A B) (at level 67, left associativity) : formula_scope. Notation "A → B" := (Impl A B) (at level 70, right associativity) : formula_scope. (** To store formulas in sets, they need to have an order relation. We use the deriving library to define instances of Ord for the formula type. *) Definition formula_indDef := [indDef for formula_rect]. Canonical formula_indType := IndType formula formula_indDef. Definition formula_hasDecEq := [derive hasDecEq for formula]. HB.instance Definition _ := formula_hasDecEq. Definition formula_hasChoice := [derive hasChoice for formula]. #[hnf] HB.instance Definition _ := formula_hasChoice. Definition formula_hasOrd := [derive hasOrd for formula]. (* FIXME: This is taking way too long. *) #[hnf] HB.instance Definition _ := formula_hasOrd. Notation context := {fset formula}. Implicit Types X Y Z : atomic. Implicit Types A B C : formula. Implicit Types Γ Δ : context. (** Here is the definition of the entailment relation. Γ ⊢ A means that the formula A holds assuming the hypotheses in Γ. Note the use of the set insertion operation A |: Γ to extend the context in ImplI. *) Reserved Notation "Γ ⊢ A" (at level 80). Inductive entails : {fset formula} -> formula -> Prop := | Ax Γ A : A \in Γ -> Γ ⊢ A | ConjI Γ A B : Γ ⊢ A -> Γ ⊢ B -> Γ ⊢ A ∧ B | ConjEL Γ A B : Γ ⊢ A ∧ B -> Γ ⊢ A | ConjER Γ A B : Γ ⊢ A ∧ B -> Γ ⊢ B | DisjIL Γ A B : Γ ⊢ A -> Γ ⊢ A ∨ B | DisjIR Γ A B : Γ ⊢ B -> Γ ⊢ A ∨ B | DisjE Γ A B C : Γ ⊢ A ∨ B -> Γ ⊢ A → C -> Γ ⊢ B → C -> Γ ⊢ C | ImplI Γ A B : A |: Γ ⊢ B -> Γ ⊢ A → B | ImplE Γ A B : Γ ⊢ A → B -> Γ ⊢ A -> Γ ⊢ B where "Γ ⊢ A" := (entails Γ A). #[local] Hint Constructors entails : core. (** The entailment relation satisfies the structural rules of contraction, exchange and weakening. The proof of weakening follows by induction on the entailment derivation. Contraction and weakening, on the other hand, can be proved with basic properties of the set union operator: idempotence and commutativity. If contexts were represented as lists, these properties would fail, and the proofs would need induction too. *) Lemma contraction Γ A : Γ :|: Γ ⊢ A -> Γ ⊢ A. Proof. by rewrite fsetUid. Qed. Lemma exchange Γ Δ A : Γ :|: Δ ⊢ A -> Δ :|: Γ ⊢ A. Proof. by rewrite fsetUC. Qed. Lemma weakening Γ Δ A : Γ ⊢ A -> Γ :|: Δ ⊢ A. Proof. elim: Γ A /; eauto 2. - move=> Γ A Ain; have: A \in Γ :|: Δ by rewrite in_fsetU Ain. by eauto. - by move=> Γ A B C; rewrite -!fsetUA; eauto. Qed. (** Next, let us consider the soundness of the logic. Given a valuation ρ, a finite map from atomic formulas to propositions, each formula A corresponds to a proposition `F⟦A⟧^ρ. *) Reserved Notation "`F⟦ A ⟧^" (format "`F⟦ A ⟧^"). Implicit Types ρ : {fmap string -> Prop}. Fixpoint formula_den A ρ : Prop := match A with | Atom a => if ρ a is Some P then P else False | A ∧ B => `F⟦A⟧^ρ /\ `F⟦B⟧^ρ | A ∨ B => `F⟦A⟧^ρ \/ `F⟦B⟧^ρ | A → B => `F⟦A⟧^ρ -> `F⟦B⟧^ρ end%form where "`F⟦ A ⟧^" := (formula_den A). (** Valuations are extensional: if ρ1 and ρ2 agree on each atomic formula, noted ρ1 =1 ρ2, then ρ1 = ρ2. The extructures lemma eq_fmap allows us to convert back and forth between ρ1 =1 ρ2 and ρ1 = ρ2. It provides a short proof of the following result, which says that the interpretation of a formula A depends only on the interpretation of atomic formulas. *) Lemma eq_formula_den A ρ1 ρ2 : ρ1 =1 ρ2 -> `F⟦A⟧^ρ1 = `F⟦A⟧^ρ2. Proof. by move/eq_fmap=> ->. Qed. (** If we only consider atomic formulas that actually appear in A, we can strengthen this result a little bit. However, the proof becomes more involved. *) Fixpoint atoms A : {fset atomic} := match A with | Atom X => fset1 X | A ∧ B => atoms A :|: atoms B | A ∨ B => atoms A :|: atoms B | A → B => atoms A :|: atoms B end%form. Lemma in_eq_formula_den A ρ1 ρ2 : {in atoms A, ρ1 =1 ρ2} -> `F⟦A⟧^ρ1 = `F⟦A⟧^ρ2. Proof. move: {-1}(atoms A) (fsubsetxx (atoms A)) => Xs. by elim: A => /= [X|A IHA B IHB|A IHA B IHB|A IHA B IHB] AXs ρ12; do ?[move: AXs; rewrite fsubUset; case/andP => ??]; rewrite ?ρ12 // ?IHA ?IHB // -fsub1set. Qed. (** We lift the interpretation of formulas to contexts. Sets in extructures coerce to sequences, which allows us to write the following definition. *) Definition context_den Γ ρ := foldr and True [seq `F⟦A⟧^ρ | A <- Γ]. Notation "`C⟦ Γ ⟧^" := (context_den Γ) (format "`C⟦ Γ ⟧^"). (** This definition is equivalent to the following one, which is easier to use to prove soundness. *) Lemma context_denP Γ ρ : `C⟦Γ⟧^ρ <-> {in Γ, forall A, `F⟦A⟧^ρ}. Proof. rewrite -[mem Γ]/(mem (val Γ)) /context_den /=. elim: (val Γ) => /= [|A {}Γ ->]; split => // [[HA HΓ] B|]. rewrite inE; case/orP=> [/eqP -> //|]; exact: HΓ. by move=> HΓ; split=> [|B Bin]; apply: HΓ; rewrite inE ?eqxx // Bin orbT. Qed. (** Once again, we can prove two extensionality lemmas for the interpretation of contexts. The first one follows by eq_fmap, whereas the second one requires a more detailed argument. *) Lemma eq_context_den Γ ρ1 ρ2 : ρ1 =1 ρ2 -> `C⟦Γ⟧^ρ1 = `C⟦Γ⟧^ρ2. Proof. by move/eq_fmap=> ->. Qed. Definition ctx_atoms Γ : {fset string} := \bigcup_(A <- Γ) atoms A. Lemma in_eq_context_den Γ ρ1 ρ2 : {in ctx_atoms Γ, ρ1 =1 ρ2} -> `C⟦Γ⟧^ρ1 = `C⟦Γ⟧^ρ2. Proof. move: {-1}(ctx_atoms Γ) (fsubsetxx (ctx_atoms Γ)) => Xs. rewrite /ctx_atoms /context_den. elim: (val Γ) => //= A {}Γ IH; rewrite big_cons fsubUset. case/andP=> subA subΓ ρ12; rewrite IH //. suff /in_eq_formula_den -> : {in atoms A, ρ1 =1 ρ2} by []. move=> X Xin; apply: ρ12; exact: (fsubsetP subA). Qed. (** We can now state the soundness result of the logic. *) Lemma soundness Γ A : Γ ⊢ A -> forall ρ, `C⟦Γ⟧^ρ -> `F⟦A⟧^ρ. Proof. move=> ΓA ρ /context_denP; elim: Γ A / ΓA => //=; eauto. - by move=> ??? _ IH HΓ; case: IH. - by move=> ??? _ IH HΓ; case: IH. - by move=> ???? _ IHor _ IH1 _ IH2 HΓ; case: IHor; eauto. - move=> ??? _ IH HΓ HA; apply: IH. move=> C /fsetU1P [-> //|]; exact: HΓ. Qed. extructures-0.4.0/theories/000077500000000000000000000000001450433063500157355ustar00rootroot00000000000000extructures-0.4.0/theories/ffun.v000066400000000000000000000153721450433063500170720ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice seq. From extructures Require Import ord fset fmap. (******************************************************************************) (* Given a function def : T -> S, the type ffun def is the type of *) (* finitely supported functions of type T -> S. That is, f agrees with def *) (* on all but finitely many inputs. The type T must be an instance of *) (* ordType, and S must be an eqType. *) (* *) (* supp f == the finite set of inputs where f differs from def *) (* mkffun f xs == the finite function defined by *) (* mkffun f xs x = if x \in xs then f x else def x *) (* mkffunm m == complete a finite map m with def outside of the domain *) (* of m *) (* emptyf == the finite function with empty support; i.e. that agrees *) (* with def everywhere *) (* upd f x y == override the value of f at x to be y *) (* updfm f m == override the values of f with the finite map m *) (* mapf g f == compose the finite function f with g : S -> R; the result *) (* has type ffun (g \o def) *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope fset_scope. Section FFun. Context {T : ordType} {S : eqType} {def : T -> S}. Local Notation wf f := (all (fun x => f x != Some (def x)) (domm f)). Record ffun := FFun { ffval : {fmap T -> S}; _ : wf ffval; }. Arguments FFun _ _ : clear implicits. HB.instance Definition _ := [isSub of ffun for ffval]. Implicit Types (f g : ffun) (x : T) (y : S). Definition appf f x := if val f x is Some y then y else def x. Coercion appf : ffun >-> Funclass. Lemma eq_ffun f g : f =1 g <-> f = g. Proof. split=> [e|-> //]; apply/val_inj/eq_fmap=> x. move/(_ x): e; rewrite /appf. case efx: (val f x)=> [y1|]; case egx: (val g x)=> [y2|] // e. - congruence. - have {}xP: x \in domm (val f) by rewrite mem_domm efx. by move: (allP (valP f) _ xP); rewrite efx e eqxx. - have {}xP: x \in domm (val g) by rewrite mem_domm egx. by move: (allP (valP g) _ xP); rewrite egx e eqxx. Qed. Definition supp f := domm (val f). Lemma mem_supp f x : (x \in supp f) = (f x != def x). Proof. rewrite /appf /supp mem_domm. case efx: (val f x)=> [y|]; last by rewrite eqxx. have xP: x \in domm (val f) by rewrite mem_domm efx. by move: (allP (valP f) _ xP); rewrite efx => ->. Qed. Lemma mem_suppN f x : (x \notin supp f) = (f x == def x). Proof. by rewrite mem_supp negbK. Qed. Lemma suppPn f x : reflect (f x = def x) (x \notin supp f). Proof. rewrite mem_supp negbK; exact/eqP. Qed. Lemma emptyf_subproof : wf (@emptym T S). Proof. by rewrite domm0. Qed. Definition emptyf := FFun emptym emptyf_subproof. Lemma emptyfE x : emptyf x = def x. Proof. by []. Qed. Lemma supp0 : supp emptyf = fset0. Proof. exact/domm0. Qed. Definition upd_def f x y := if def x == y then remm (val f) x else setm (val f) x y. Lemma upd_subproof f x y : wf (upd_def f x y). Proof. rewrite /upd_def; apply/allP=> x'. case: (altP eqP)=> [e|ne]. - rewrite domm_rem; case/fsetD1P=> ne /(allP (valP f)). by rewrite remmE (negbTE ne). - rewrite domm_set in_fsetU1 setmE. by case: eqP=> [-> _|_ /(allP (valP f))]; rewrite // eq_sym. Qed. Definition upd f x y := FFun (upd_def f x y) (upd_subproof f x y). Lemma updE f x1 y x2 : upd f x1 y x2 = if x2 == x1 then y else f x2. Proof. rewrite /appf /= /upd_def; case: (altP (def x1 =P y)) => ey. rewrite remmE; case: (altP (x2 =P x1)) => ex //; congruence. by rewrite setmE; case: (altP (x2 =P x1)) => ex. Qed. Definition mkffun (fb : T -> S) (xs : seq T) := foldr (fun x f => upd f x (fb x)) emptyf xs. Lemma mkffunE fb xs x : mkffun fb xs x = if x \in xs then fb x else def x. Proof. elim: xs=> [|x' xs IH] //=; rewrite inE updE IH. by case: eqP => [<-|_]. Qed. Lemma supp_mkffun fb xs : supp (mkffun fb xs) = fset [seq x <- xs | fb x != def x]. Proof. apply/eq_fset=> x; rewrite mem_supp in_fset mem_filter mkffunE. by rewrite andbC; case: ifP=> //; rewrite eqxx. Qed. Lemma supp_mkffun_sub fb (X : {fset T}) : supp (mkffun fb X) :<=: X. Proof. by apply/fsubsetP => x; rewrite supp_mkffun in_fset mem_filter; case/andP. Qed. Definition updfm f (xs : {fmap T -> S}) : ffun := mkffun (fun v => if xs v is Some x then x else f v) (supp f :|: domm xs). Lemma updfmE f xs x : updfm f xs x = if xs x is Some y then y else f x. Proof. rewrite /updm mkffunE in_fsetU orbC mem_domm. case e: (xs x)=> [y|] //=. by case: ifPn=> // /suppPn ->. Qed. Definition mkffunm (m : {fmap T -> S}) : ffun := mkffun (fun x => odflt (def x) (m x)) (domm m). Lemma mkffunmE m x : mkffunm m x = odflt (def x) (m x). Proof. by rewrite /mkffunm mkffunE mem_domm; case: (m x). Qed. Lemma val_mkffun (f : T -> S) (X : {fset T}) : ffval (mkffun f X) = mkfmapfp (fun x => if f x == def x then None else Some (f x)) X. Proof. apply/eq_fmap=> x; rewrite mkfmapfpE. move: (mkffunE f X x); rewrite /appf /=. set ff := mkffun f X; case e: (ffval ff x) => [y|]. - have xdomm: x \in domm (ffval ff) by rewrite mem_domm e. move/allP/(_ _ xdomm): (valP ff); rewrite /= e => yP ey. move: yP; rewrite {}ey; case: ifP; last by rewrite eqxx. rewrite inj_eq; last exact: Some_inj. by move=> _ /negbTE ->. - by case: ifP=> // _ ->; rewrite eqxx. Qed. End FFun. Arguments ffun {T S} def. Arguments suppPn {T S def f x}. Section Mapping. Variables (T : ordType) (S R : eqType) (def : T -> S). Definition mapf (g : S -> R) (f : ffun def) : ffun (g \o def) := mkffun (g \o f) (supp f). Lemma mapfE (g : S -> R) (f : ffun def) x : mapf g f x = g (f x). Proof. rewrite /mapf mkffunE mem_supp /=. by case: eqP=> //= ->. Qed. Lemma val_mapf (g : S -> R) : injective g -> forall f : ffun def, ffval (mapf g f) = mapm g (ffval f). Proof. move=> g_inj f; apply/eq_fmap=> x. rewrite /mapf val_mkffun mkfmapfpE mapmE mem_supp /= /appf /=. rewrite inj_eq //. case e: (ffval f x)=> [y|] /=; last by rewrite eqxx. have xdomm: x \in domm (ffval f) by rewrite mem_domm e. move/allP/(_ _ xdomm): (valP f); rewrite e. rewrite inj_eq; last exact: Some_inj. by move=> /negbTE ->. Qed. End Mapping. HB.instance Definition _ T (S : eqType) def := [Equality of @ffun T S def by <:]. #[hnf] HB.instance Definition _ T (S : choiceType) def := [Choice of @ffun T S def by <:]. #[hnf] HB.instance Definition _ T (S : ordType) def := [Ord of @ffun T S def by <:]. extructures-0.4.0/theories/fmap.v000066400000000000000000001112311450433063500170460ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype path bigop. Require Import ord fset. (******************************************************************************) (* This file defines a type {fmap T -> S} of partial functions with finite *) (* domain from T to S, where T is assumed to have an ordType structure. *) (* Throughtout this development, we refer to such functions as (finite) maps. *) (* The type {fmap T -> S} is defined as a list of pairs (k, v) : T * S that *) (* is kept ordered by its keys. This implies that the type supports *) (* extensional equality, as shown by the lemma eq_fmap. *) (* *) (* getm m k == the value of the map f associated with the key k. getm *) (* is declared as a coercion into Funclass, allowing us to *) (* simply write m k instead. *) (* setm m k v == set the value of k in m to v, replacing any previous *) (* value. *) (* updm m k v == a partial version of setm, that only replaces the value *) (* of k if it is already present in m, and returns None *) (* otherwise. *) (* mapim f m == apply the function f : T -> S -> S' to all bindings in *) (* the map m : {fmap T -> S}. *) (* mapm f m == specialized version of mapim that ignores the key value. *) (* unionm m1 m2 == a map containing all the bindings of m1 and m2. If a *) (* key is present in both of them, the value of m1 is used. *) (* filterm a m == given a predicate a : T -> S -> bool, remove from m all *) (* bindings (k, v) such that a k v is false. *) (* remm m k == remove the value of k in m, if there is one. *) (* domm m == the domain of m: the set of keys associated with some *) (* value in m. *) (* codomm m == the codomain of m: the set of values associated with *) (* key in m. This requires an ordType structure on the *) (* type of values. *) (* injectivem m == the map m is injective on its domain (the type of *) (* values must be an eqType). *) (* invm m == the inverse of m. If multiple keys of m are mapped to *) (* the same value, only one of the bindings is used. *) (* fmap_of_seq s == convert s : seq T into a map {fmap nat -> T} that *) (* indexes into s. *) (* currym m == convert from {fmap T * S -> R} to *) (* {fmap T -> {fmap S -> R}}. *) (* uncurrym m == the left inverse of the previous function. *) (* enum_fmap s s' == sequence of all maps whose domain and codomain are *) (* contained in the sequences s and s'. *) (* *) (* The behavior of many of these functions is described by lemmas such as *) (* setmE, unionmE, etc. For example, setmE says that setm m k v k' is equal *) (* to if k' == k then Some v else m k'. Maps coerce to predicates: *) (* (k, v) \in m means that m k = Some v (cf. getmP). *) (* *) (* We provide the following map constructors: *) (* *) (* emptym == the empty map. *) (* mkfmap kvs == construct a map from kvs : seq (T * S). If multiple *) (* bindings are present in kvs for a given key k : T, the *) (* first one is used. *) (* mkfmapf f ks == construct a map that associates to each element k of *) (* the sequence ks the value f k, mapping all other keys to *) (* None. *) (* mkfmapfp f ks == same as above but for a partial function *) (* f : T -> option S. *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module FMap. Section Def. Variables (T : ordType) (S : Type). Local Open Scope ord_scope. Record fmap_type := FMap { fmval : seq (T * S); _ : sorted (@Ord.lt T) (unzip1 fmval) }. Definition fmap_of & phant (T -> S) := fmap_type. End Def. Module Exports. Identity Coercion fmap_of_fmap : fmap_of >-> fmap_type. Notation "{ 'fmap' T }" := (@fmap_of _ _ (Phant T)) (at level 0, format "{ 'fmap' T }") : type_scope. Section WithOrdType. Variable T : ordType. Coercion fmval : fmap_type >-> seq. HB.instance Definition _ S := [isSub of fmap_type T S for @fmval T S]. HB.instance Definition _ (S : eqType) := [Equality of fmap_type T S by <:]. #[hnf] HB.instance Definition _ (S : choiceType) := [Choice of fmap_type T S by <:]. #[hnf] HB.instance Definition _ (S : ordType) := [Ord of fmap_type T S by <:]. HB.instance Definition _ S := SubType.copy {fmap T -> S} (fmap_type T S). HB.instance Definition _ (S : eqType) := Equality.copy {fmap T -> S} (fmap_type T S). HB.instance Definition _ (S : choiceType) := Choice.copy {fmap T -> S} (fmap_type T S). HB.instance Definition _ (S : ordType) := Ord.Ord.copy {fmap T -> S} (fmap_type T S). (* FIXME: Allow defining fmaps as countTypes *) End WithOrdType. End Exports. End FMap. Export FMap.Exports. (* Redefine the fmap constructor with a different signature, in order to keep types consistent. *) Definition fmap (T : ordType) S s Ps : {fmap T -> S} := @FMap.FMap T S s Ps. Section Operations. Variables (T : ordType) (S : Type). Implicit Type m : {fmap T -> S}. Implicit Type k : T. Local Open Scope ord_scope. Fixpoint getm_def s k : option S := if s is p :: s then if k == p.1 then Some p.2 else getm_def s k else None. Definition getm (m : FMap.fmap_type T S) k := getm_def m k. Fixpoint setm_def s k v : seq (T * S) := if s is p :: s' then if k < p.1 then (k, v) :: s else if k == p.1 then (k, v) :: s' else p :: setm_def s' k v else [:: (k, v)]. Lemma setm_subproof m k v : sorted (@Ord.lt T) (unzip1 (setm_def m k v)). Proof. have E: forall s, [seq p.1 | p <- setm_def s k v] =i k :: unzip1 s. elim=> // p s /= IH k'; rewrite ![in X in X = _]fun_if /= !inE. rewrite IH inE. case: (Ord.ltgtP k p.1) => // H; try by bool_congr. by rewrite H orbA orbb. case: m; elim=> // p s /= IH Ps. move: (order_path_min (@Ord.lt_trans T) Ps) => lb. rewrite ![in X in is_true X]fun_if /= path_min_sorted; last exact: lb. rewrite (path_sorted Ps); case: Ord.ltgtP=> [k_p//|k_p|-> //] /=. rewrite path_min_sorted ?(IH (path_sorted Ps)) //=. by rewrite !(eq_all_r (E s)) {E} /= lb andbT. Qed. Definition setm (m : {fmap T -> S}) k v := fmap (setm_subproof m k v). Definition repm (m : {fmap T -> S}) k f : option {fmap T -> S} := omap (setm m k \o f) (getm m k). Definition updm (m : {fmap T -> S}) k v := if getm m k then Some (setm m k v) else None. Definition unionm (m1 m2 : {fmap T -> S}) := foldr (fun p m => setm m p.1 p.2) m2 m1. Lemma mapim_subproof S' (f : T -> S -> S') m : sorted (@Ord.lt T) (unzip1 (map (fun p => (p.1, f p.1 p.2)) m)). Proof. by rewrite /unzip1 -!map_comp; apply: (valP m). Qed. Definition mapim S' (f : T -> S -> S') m := fmap (mapim_subproof f m). Definition mapm S' (f : S -> S') := mapim (fun _ x => f x). Lemma filterm_subproof (a : T -> S -> bool) m : sorted (@Ord.lt T) (unzip1 [seq p | p <- m & a p.1 p.2]). Proof. rewrite (subseq_sorted _ _ (valP m)) //; first exact: Ord.lt_trans. rewrite /=; elim: {m} (FMap.fmval m) => // p s IH. rewrite (lock subseq) /=; case: (a _); rewrite /= -lock. by rewrite /= eqxx. by rewrite (subseq_trans IH) // subseq_cons. Qed. Definition filterm (a : T -> S -> bool) (m : {fmap T -> S}) := fmap (filterm_subproof a m). Fixpoint remm_def (s : seq (T * S)) k := if s is p :: s then if p.1 == k then s else p :: remm_def s k else [::]. Lemma remm_subproof m k : sorted (@Ord.lt T) (unzip1 (remm_def m k)). Proof. apply/(subseq_sorted _ _ (valP m)); first exact: Ord.lt_trans. rewrite /=; elim: {m} (FMap.fmval m) => // p s IH. rewrite (lock subseq) /=; case: (_ == _); rewrite /= -lock. by rewrite subseq_cons. by rewrite /= eqxx. Qed. Definition remm m k := fmap (remm_subproof m k). Definition emptym : {fmap T -> S} := @fmap T S [::] erefl. Definition mkfmap (kvs : seq (T * S)) : {fmap T -> S} := foldr (fun kv m => setm m kv.1 kv.2) emptym kvs. Definition mkfmapf (f : T -> S) (ks : seq T) : {fmap T -> S} := mkfmap [seq (k, f k) | k <- ks]. Definition mkfmapfp (f : T -> option S) (ks : seq T) : {fmap T -> S} := mkfmap (pmap (fun k => omap (pair k) (f k)) ks). Definition domm m := fset (unzip1 m). End Operations. Coercion getm : FMap.fmap_type >-> Funclass. Arguments getm {_ _} _ _. Arguments setm {_ _} _ _. Arguments repm {_ _} _ _ _. Arguments updm {_ _} _ _ _. Arguments unionm {_ _} _ _. Arguments mapim {_ _ _} _ _. Arguments mapm {_ _ _} _ _. Arguments filterm {_ _} _ _. Arguments remm {_ _} _ _. Arguments emptym {_ _}. Arguments mkfmap {_ _} _. Arguments mkfmapf {_ _} _ _. Arguments mkfmapfp {_ _} _ _. Arguments domm {_ _} _. Notation "[ 'fmap' kv1 ; .. ; kvn ]" := (mkfmap (cons kv1 .. (cons kvn nil) ..)) (at level 0, format "[ 'fmap' '[' kv1 ; '/' .. ; '/' kvn ']' ]") : form_scope. Section PredFmap. Variables (T : ordType) (S : eqType). Definition mem_fmap (m : {fmap T -> S}) := [pred p : T * S | p \in val m]. Canonical mem_fmap_predType := PredType mem_fmap. End PredFmap. Section Properties. Variables (T : ordType) (S : Type). Local Open Scope ord_scope. Local Open Scope fset_scope. Implicit Type (m : {fmap T -> S}) (k : T) (v : S). Lemma eq_fmap m1 m2 : m1 =1 m2 <-> m1 = m2. Proof. split; last congruence. have in_seq: forall s : seq (T * S), [pred k | getm_def s k] =i [seq p.1 | p <- s]. elim=> [|p s IH] k; rewrite /= !inE // -IH inE. by case: (k == p.1). case: m1 m2 => [s1 Ps1] [s2 Ps2]; rewrite /getm /= => s1_s2. apply: val_inj=> /=. elim: s1 Ps1 s2 Ps2 s1_s2 => [_|[k1 v1] s1 IH /= Ps1] [_|[k2 v2] s2 /= Ps2] // => [/(_ k2)|/(_ k1)| ]; try by rewrite eqxx. have lb1 := order_path_min (@Ord.lt_trans _) Ps1. have lb2 := order_path_min (@Ord.lt_trans _) Ps2. move: {Ps1 Ps2} (path_sorted Ps2) (path_sorted Ps1) => Ps1 Ps2. move: IH => /(_ Ps2 _ Ps1) {Ps1 Ps2} IH s1_s2. wlog: k1 k2 v1 v2 s1 s2 lb1 lb2 s1_s2 IH / k1 <= k2. move=> H. have [|k2_k1] := orP (Ord.leq_total k1 k2); first by eauto. symmetry; apply: H; eauto. by move=> k /=; rewrite s1_s2. by move=> H'; rewrite IH //. rewrite Ord.leq_eqVlt=> /orP [/eqP k1_k2|k1_k2]. rewrite -{}k1_k2 {k2} in lb2 s1_s2 *. move: (s1_s2 k1); rewrite eqxx=> - [->]. rewrite {}IH // => k; move: {s1_s2} (s1_s2 k). have [-> {k} _|ne ?] // := altP (_ =P _). move: (in_seq s1 k1) (in_seq s2 k1); rewrite !inE. case: (getm_def s1 k1) (getm_def s2 k1) => [v1'|] [v2'|] //=. - by move=> _ /esym/(allP lb2) /=; rewrite Ord.ltxx. - by move=> /esym/(allP lb1) /=; rewrite Ord.ltxx. by move=> _ /esym/(allP lb2) /=; rewrite Ord.ltxx. move/(_ k1)/esym: s1_s2 k1_k2; rewrite eqxx. have [->|_ s1_s2] := altP (_ =P _); first by rewrite Ord.ltxx. move/(_ s2 k1): in_seq; rewrite inE {}s1_s2 /= => /esym/(allP lb2)/Ord.ltW /=. by rewrite Ord.ltNge => ->. Qed. Lemma mem_domm m k : k \in domm m = m k. Proof. rewrite inE /domm /= in_fset. case: m => [s Ps] /=; rewrite /getm /=. by elim: s {Ps} => [|p s IH] //=; rewrite inE IH; case: (k == p.1). Qed. Lemma dommP m k : reflect (exists v, m k = Some v) (k \in domm m). Proof. by rewrite mem_domm; case: (m k) => /=; constructor; eauto; case. Qed. Lemma dommPn m k : reflect (m k = None) (k \notin domm m). Proof. by rewrite mem_domm; case: (m k)=> /=; constructor. Qed. Arguments dommP {_ _}. Arguments dommPn {_ _}. Lemma setmE m k v k' : setm m k v k' = if k' == k then Some v else getm m k'. Proof. case: m; rewrite /getm /setm /=; elim=> //= p s IH Ps. rewrite ![in LHS](fun_if, if_arg) /= {}IH; last exact: path_sorted Ps. have [->{k'}|Hne] := altP (k' =P k); case: (Ord.ltgtP k) => //. by move=> <-; rewrite (negbTE Hne). Qed. Lemma setmC m k v k' v' : k != k' -> setm (setm m k v) k' v' = setm (setm m k' v') k v. Proof. move=> ne; apply/eq_fmap=> k''; rewrite !setmE. have [->{k''}|//] := altP (k'' =P k'). by rewrite eq_sym (negbTE ne). Qed. Lemma setmxx m k v v' : setm (setm m k v) k v' = setm m k v'. Proof. by apply/eq_fmap=> k'; rewrite !setmE; case: eqP. Qed. Lemma repmE m m' k f : repm m k f = Some m' -> forall k', m' k' = if k' == k then omap f (m k) else getm m k'. Proof. by rewrite /repm; case: (m k) => [v [<-]|] //= k'; rewrite setmE. Qed. Lemma updm_set m m' k v : updm m k v = Some m' -> m' = setm m k v. Proof. by rewrite /updm; case: (getm m _) => [m''|] //= [<-]. Qed. Lemma unionmE m1 m2 k : unionm m1 m2 k = if m1 k then m1 k else m2 k. Proof. case: m1 => [m1 Pm1]; rewrite /unionm {2 3}/getm /= {Pm1}. elim: m1 => [|p m1 IH] //=. by rewrite setmE {}IH; case: (_ == _). Qed. Lemma domm_union m1 m2 : domm (unionm m1 m2) = domm m1 :|: domm m2. Proof. by apply/eq_fset=> k; rewrite in_fsetU !mem_domm unionmE; case: (m1 k). Qed. Lemma domm_set m k v : domm (setm m k v) = k |: domm m. Proof. apply/eq_fset=> k'; apply/(sameP dommP)/(iffP idP); rewrite setmE in_fsetU1. case/orP=> [->|]; first by eauto. by move=> /dommP [v' ->]; case: eq_op; eauto. by have [-> //|] := altP eqP => _ /= [v']; rewrite mem_domm => ->. Qed. Lemma emptymE k : @emptym T S k = None. Proof. by []. Qed. Lemma domm0 : domm (@emptym T S) = fset0. Proof. by apply/eq_fset=> k; rewrite mem_domm. Qed. Lemma emptymP m : reflect (m = emptym) (domm m == fset0). Proof. apply/(iffP eqP); last by move=> ->; rewrite domm0. by move=> e; apply/eq_fmap => x; apply/dommPn; rewrite e. Qed. Lemma mapimE S' (f : T -> S -> S') m k : mapim f m k = omap (f k) (m k). Proof. case: m=> [s Ps]; rewrite /mapim /getm /=. elim: s {Ps}=> [|[k' v] s IH] //=; rewrite {}IH ![in RHS]fun_if /=. by case: (k =P k') => [<-|]. Qed. Lemma mapmE S' (f : S -> S') m k : mapm f m k = omap f (m k). Proof. exact: mapimE. Qed. Lemma filtermE a m k : filterm a m k = obind (fun x => if a k x then Some x else None) (m k). Proof. case: m=> [s Ps]; rewrite /filterm /getm /=. elim: s Ps=> [|p s IH /= Ps] //=. rewrite ![in LHS](fun_if, if_arg) /= {}IH; last exact: path_sorted Ps. have [-> {k}|k_p] //= := altP (_ =P _); case: (a _)=> //. elim: s {Ps} (order_path_min (@Ord.lt_trans _) Ps) => [|p' s IH /andP /= [lb {}/IH IH]] //=. by move: lb; have [->|//] := altP (_ =P _); rewrite Ord.ltxx. Qed. Lemma filterm0 (a : T -> S -> bool) : filterm a emptym = emptym. Proof. by apply/eq_fmap=> x; rewrite filtermE. Qed. Lemma remmE m k k' : remm m k k' = if k' == k then None else getm m k'. Proof. case: m; rewrite /remm /getm /=; elim=> [|p s IH /= Ps] //=. by case: (_ == _). rewrite ![in LHS](fun_if, if_arg) /= {}IH //; last exact: path_sorted Ps. move: {Ps} (order_path_min (@Ord.lt_trans _) Ps). have [-> lb|ne lb] := altP (_ =P _). have [-> {k' p}|ne //] := altP (_ =P _). elim: s lb=> [|p s IH /= /andP [lb /IH {IH} ->]] //=. by move: lb; have [->|//] := altP (_ =P _); rewrite Ord.ltxx. have [-> {k'}|ne'] // := altP (k' =P k). by rewrite eq_sym (negbTE ne). Qed. Lemma remmI m k : k \notin domm m -> remm m k = m. Proof. move=> /dommPn m_k; apply/eq_fmap=> k'; rewrite remmE. by case: eqP=> // ->; rewrite m_k. Qed. Lemma setm_rem m k v : setm (remm m k) k v = setm m k v. Proof. apply/eq_fmap=> k'; rewrite !setmE !remmE; by case: eqP. Qed. Lemma filterm_set (a : T -> S -> bool) m x y : filterm a (setm m x y) = if a x y then setm (filterm a m) x y else remm (filterm a m) x. Proof. apply/eq_fmap=> x'; have [yes|no] := boolP (a x y). by rewrite !(setmE, filtermE); case: eqP=> //= ->; rewrite yes. by rewrite remmE !filtermE setmE; case: eqP no=> //= -> /negbTE ->. Qed. Lemma domm_rem m k : domm (remm m k) = domm m :\ k. Proof. by apply/eq_fset=> k'; rewrite in_fsetD1 !mem_domm remmE; case: eqP. Qed. Lemma domm_mkfmap (kvs : seq (T * S)) : domm (mkfmap kvs) =i unzip1 kvs. Proof. move=> k; rewrite mem_domm. elim: kvs => [|kv kvs IH] //=; rewrite !inE setmE -{}IH. by case: (_ == _). Qed. (* TODO rename this *) Lemma domm_mkfmap' (kvs : seq (T * S)) : domm (mkfmap kvs) = fset (unzip1 kvs). Proof. by apply/eq_fset=> x; rewrite domm_mkfmap in_fset. Qed. Lemma mkfmapE (kvs : seq (T * S)) : mkfmap kvs =1 getm_def kvs. Proof. by move=> k; elim: kvs=> [|p kvs IH] //=; rewrite setmE IH. Qed. Lemma mkfmapfE (f : T -> S) (ks : seq T) k : mkfmapf f ks k = if k \in ks then Some (f k) else None. Proof. rewrite /mkfmapf; elim: ks => [|k' ks IH] //=. by rewrite setmE inE {}IH; have [<-|?] := altP (k =P k'). Qed. Lemma mkfmapfpE (f : T -> option S) (ks : seq T) k : mkfmapfp f ks k = if k \in ks then f k else None. Proof. rewrite /mkfmapfp; elim: ks => [|k' ks IH] //=. case e: (f k') => [v|] //=. by rewrite setmE inE {}IH; have [->|? //] := altP (k =P k'); rewrite e. rewrite inE {}IH; have [->|?] //= := altP (k =P k'); rewrite e. by case: ifP. Qed. Lemma domm_mkfmapf (f : T -> S) (ks : seq T) : domm (mkfmapf f ks) = fset ks. Proof. apply/eq_fset=> k; rewrite mem_domm mkfmapfE in_fset. by case: (k \in ks). Qed. Lemma domm_mkfmapfp (f : T -> option S) (ks : seq T) : domm (mkfmapfp f ks) = fset [seq k <- ks | f k]. Proof. apply/eq_fset=> k; rewrite mem_domm mkfmapfpE in_fset mem_filter andbC. by case: (k \in ks). Qed. Lemma setm_union m1 m2 k v : setm (unionm m1 m2) k v = unionm (setm m1 k v) m2. Proof. apply/eq_fmap=> k'; rewrite !(setmE, unionmE). by have [->{k'}|] := altP (k' =P k). Qed. Lemma filterm_union p m1 m2 : fdisjoint (domm m1) (domm m2) -> filterm p (unionm m1 m2) = unionm (filterm p m1) (filterm p m2). Proof. move=> dis; apply/eq_fmap=> k; rewrite filtermE !unionmE !filtermE. case get_k1: (m1 k)=> [v|] //=. have: k \in domm m1 by rewrite mem_domm get_k1. move/fdisjointP: dis=> dis /dis; rewrite mem_domm. by case: (m2 k)=> //= _; case: ifP. Qed. Lemma eq_mkfmapf (f1 f2 : T -> S) : f1 =1 f2 -> mkfmapf f1 =1 mkfmapf f2. Proof. by move=> e ks; apply/eq_fmap=> k; rewrite !mkfmapfE e. Qed. Lemma eq_mkfmapfp (f1 f2 : T -> option S) : f1 =1 f2 -> mkfmapfp f1 =1 mkfmapfp f2. Proof. by move=> e ks; apply/eq_fmap=> k; rewrite !mkfmapfpE e. Qed. Lemma eq_filterm f1 f2 m : (f1 =2 f2) -> filterm f1 m = filterm f2 m. Proof. move=> e; apply/eq_fmap=> k; rewrite 2!filtermE. case: (m k) => [v|] //=. by rewrite e. Qed. Lemma domm_filter p m : domm (filterm p m) :<=: domm m. Proof. apply/fsubsetP=> k; rewrite !mem_domm filtermE. by case: (m k). Qed. Lemma setmI m k v : m k = Some v -> setm m k v = m. Proof. move=> get_k; apply/eq_fmap=> k'; rewrite setmE. by have [->{k'}|//] := altP (_ =P _); rewrite get_k. Qed. Lemma union0m : left_id (@emptym T S) unionm. Proof. by []. Qed. Lemma unionm0 : right_id (@emptym T S) unionm. Proof. move=> m; apply/eq_fmap=> k; rewrite unionmE emptymE /=. by case: (m k). Qed. Lemma unionmA : associative (@unionm T S). Proof. move=> m1 m2 m3; apply/eq_fmap=> k; rewrite !unionmE. by case: (m1 k). Qed. Lemma unionmI : idempotent (@unionm T S). Proof. move=> m; apply/eq_fmap=> k; rewrite !unionmE. by case: (m k). Qed. Lemma unionmC m1 m2 : fdisjoint (domm m1) (domm m2) -> unionm m1 m2 = unionm m2 m1. Proof. move=> dis; apply/eq_fmap=> k; rewrite !unionmE. have {dis}: ~~ (m1 k) || ~~ (m2 k). by rewrite -!mem_domm -implybE; apply/implyP/fdisjointP. by case: (m1 k) (m2 k)=> [?|] [?|] //=. Qed. Lemma unionmK m1 m2 : filterm (fun k _ => m1 k) (unionm m1 m2) = m1. Proof. apply/eq_fmap=> k; rewrite filtermE unionmE. by case: (m1 k) (m2 k)=> //= - []. Qed. Lemma fmap_rect (P : {fmap T -> S} -> Type) : P emptym -> (forall m, P m -> forall x y, x \notin domm m -> P (setm m x y)) -> forall m, P m. Proof. move=> H0 H1 m; move e: (domm m)=> X. elim/fset_rect: X m e=> [|x X x_X IH] m e. by move/eqP/emptymP: e=> ->. have : x \in domm m by rewrite e in_fsetU1 eqxx. rewrite mem_domm; case yP: (m x)=> [y|] // _. set m' := remm m x; have em : m = setm m' x y. apply/eq_fmap=> x'; rewrite /m' setmE remmE. by case: eqP => [->|]. have {}e : domm m' = X. apply/eq_fset=> x'; rewrite /m' domm_rem e in_fsetD1 in_fsetU1. by case: eqP=> // -> /=; rewrite (negbTE x_X). rewrite {}em; apply: H1; first by exact: IH. by rewrite e. Qed. Lemma fmap_ind (P : {fmap T -> S} -> Prop) : P emptym -> (forall m, P m -> forall x y, x \notin domm m -> P (setm m x y)) -> forall m, P m. Proof. exact: fmap_rect. Qed. Lemma val_domm m : domm m = unzip1 m :> seq _. Proof. apply: (sorted_eq (@Ord.lt_trans T)). - move=> x y /andP [/Ord.ltW xy /Ord.ltW yx]. by apply: Ord.anti_leq; rewrite xy. - exact: valP. - exact: (valP m). rewrite uniq_perm // ?uniq_fset //. apply: sorted_uniq. - exact: (@Ord.lt_trans T). - exact: Ord.ltxx. - exact: (valP m). by move=> x; rewrite in_fset. Qed. Lemma fmvalK : cancel val (@mkfmap T S). Proof. by move=> /= m; apply/eq_fmap=> x; rewrite mkfmapE. Qed. Lemma mkfmapK (kvs : seq (T * S)) : sorted Ord.lt (unzip1 kvs) -> mkfmap kvs = kvs :> seq (T * S). Proof. elim: kvs=> [|[k v] kvs IH]=> //= kvs_sorted. rewrite IH ?(path_sorted kvs_sorted) //. case: kvs kvs_sorted {IH} => [|[k' v'] kvs] //=. by case/andP=> ->. Qed. Lemma getm_nth p (m : {fmap T -> S}) i : (i < size m)%N -> m (nth p.1 (domm m) i) = Some (nth p m i).2. Proof. rewrite val_domm /getm; move: (valP m); rewrite /=. elim: (val m) i=> [//|[/= k v] kv IH] [|i] /= kv_sorted. by rewrite eqxx. rewrite ltnS=> isize; rewrite (IH _ (path_sorted kv_sorted) isize). case: eqP=> // kP; have kkv: k \in unzip1 kv. by rewrite -kP; apply/mem_nth; rewrite size_map. move/(order_path_min (@Ord.lt_trans T))/allP/(_ _ kkv): kv_sorted. by rewrite Ord.ltxx. Qed. End Properties. Arguments dommP {_ _ _ _}. Arguments dommPn {_ _ _ _}. Lemma eq_setm (T : ordType) (S : eqType) m1 m2 (x : T) (y1 y2 : S) : (setm m1 x y1 == setm m2 x y2) = (y1 == y2) && (remm m1 x == remm m2 x). Proof. apply/(sameP eqP)/(iffP andP). rewrite -[setm m1 x y1]setm_rem. by case=> /eqP -> /eqP ->; rewrite setm_rem. move=> /eq_fmap e. move: (e x); rewrite !setmE eqxx; case=> ->; split=> //. apply/eqP/eq_fmap=> x'; move: (e x'); rewrite !setmE !remmE. by case: eqP. Qed. Section MapSplitting. Local Open Scope fset_scope. Variables (T : ordType) (S : Type). Implicit Types m : {fmap T -> S}. Definition splitm m := match val m with | (x, y) :: ps => Some (x, y, mkfmap ps) | [::] => None end. Lemma sizeES m : size m = if splitm m is Some (_, _, m') then (size m').+1 else 0. Proof. rewrite /splitm /=; move: (valP m)=> /=. by case: (val m)=> [|[x y] m'] //= /path_sorted /mkfmapK ->. Qed. Lemma dommES m : domm m = if splitm m is Some (x, _, m) then x |: domm m else fset0. Proof. rewrite /domm /splitm /=. case: m=> [[|[x y] m] mP] //=; first by rewrite fset0E. move: mP=> /= /path_sorted/mkfmapK ->. by rewrite fset_cons. Qed. End MapSplitting. Section FilterMap. Variables T : ordType. Variables S R : Type. Implicit Types (f : T -> S -> option R) (m : {fmap T -> S}). Definition filter_map f m := mkfmapfp (fun x => obind (f x) (m x)) (domm m). Lemma filter_mapE f m x : filter_map f m x = obind (f x) (m x). Proof. by rewrite /filter_map mkfmapfpE mem_domm; case: (m x). Qed. Lemma domm_filter_map f m : domm (filter_map f m) = fset_filter (fun x => obind (f x) (m x)) (domm m). Proof. apply/eq_fset=> x. by rewrite mem_domm filter_mapE in_fset_filter mem_domm andbC; case: (m x). Qed. Lemma mapimK (g : T -> R -> S) f : (forall x y, f x (g x y) = Some y) -> cancel (mapim g) (filter_map f). Proof. move=> gK m; apply/eq_fmap=> x. by rewrite filter_mapE mapimE; case: (m x)=> //= z. Qed. End FilterMap. Section Map. Variables (T : ordType) (S S' : Type). Implicit Types (m : {fmap T -> S}) (k : T). Lemma domm_mapi (f : T -> S -> S') m : domm (mapim f m) = domm m. Proof. by apply/eq_fset=> k; rewrite !mem_domm mapimE; case: (m k). Qed. Lemma domm_map (f : S -> S') m : domm (mapm f m) = domm m. Proof. exact: domm_mapi. Qed. Lemma mapim_map (f : S -> S') m : mapim (fun=> f) m = mapm f m. Proof. by []. Qed. Lemma eq_mapm f g : f =1 g -> @mapm T S S' f =1 mapm g. Proof. move=> e m; apply/eq_fmap=> x; rewrite !mapmE. by case: (m x)=> [y|] //=; rewrite e. Qed. Lemma mapm_comp S'' (g : S' -> S'') (f : S -> S') m : mapm (g \o f) m = mapm g (mapm f m). Proof. by apply/eq_fmap=> x; rewrite !mapmE; case: (m x). Qed. Lemma mapm_mkfmapf (f : S -> S') (g : T -> S) (X : {fset T}) : mapm f (mkfmapf g X) = mkfmapf (f \o g) X. Proof. by apply/eq_fmap=> x; rewrite !mapmE !mkfmapfE /=; case: ifP. Qed. End Map. Section Map2. Implicit Types (T : ordType) (S : Type). Local Open Scope fset_scope. Definition mapm2 T T' S S' f g (m : {fmap T -> S}) : {fmap T' -> S'} := mkfmap [seq (f p.1, g p.2) | p <- m]. Lemma mapm2E T T' S S' (f : T -> T') (g : S -> S') m x : injective f -> mapm2 f g m (f x) = omap g (m x). Proof. rewrite /mapm2 => f_inj; rewrite mkfmapE /getm. case: m=> [/= m _]; elim: m=> [|[x' y] m IH] //=. by rewrite (inj_eq f_inj) [in RHS]fun_if IH. Qed. Lemma domm_map2 T T' S S' (f : T -> T') (g : S -> S') m : domm (mapm2 f g m) = f @: domm m. Proof. apply/eq_fset=> x; rewrite /mapm2 domm_mkfmap /unzip1 -map_comp /comp /=. by rewrite /domm imfset_fset in_fset -map_comp. Qed. Lemma mapm2_comp T T' T'' S S' S'' f f' g g' : injective f -> injective f' -> mapm2 (f' \o f) (g' \o g) =1 @mapm2 T' T'' S' T'' f' g' \o @mapm2 T T' S S' f g. Proof. move=> f_inj f'_inj m; apply/eq_fmap=> x /=. have [|xnin] := boolP (x \in domm (mapm2 (f' \o f) (g' \o g) m)). - rewrite domm_map2; case/imfsetP=> {}x xin ->. rewrite mapm2E /=; last exact: inj_comp. by rewrite !mapm2E //; case: (m x). - move: (xnin); rewrite (dommPn xnin). rewrite !domm_map2 // imfset_comp -(domm_map2 f g) -(domm_map2 f' g'). by move/dommPn=> ->. Qed. End Map2. Section EqType. Variables (T : ordType) (S : eqType). Implicit Types (m : {fmap T -> S}) (k : T) (v : S). Lemma getmP m k v : reflect (m k = Some v) ((k, v) \in m). Proof. case: m => [s Ps] /=; apply/(iffP idP); rewrite /getm /= inE /=. elim: s Ps => [|[k' v'] s IH] //= sorted_s. move/(_ (path_sorted sorted_s)) in IH. rewrite inE => /orP [/eqP [e_k e_v]|in_s]. by rewrite -{}e_k -{}e_v {k' v' sorted_s} eqxx. have [e_k {IH} |n_k] := altP (k =P k'); last by auto. rewrite -{}e_k {k'} in sorted_s. suff : Ord.lt k k by rewrite Ord.ltxx. move/allP: (order_path_min (@Ord.lt_trans T) sorted_s); apply. by apply: map_f in_s. elim: s Ps=> [|[k' v'] s IH] //= sorted_s. move/(_ (path_sorted sorted_s)) in IH. have [e_k [e_v]|n_k get_k] := altP (k =P k'). by rewrite -{}e_k {}e_v {k' v'} inE eqxx in sorted_s *. by rewrite inE IH // orbT. Qed. Lemma mkfmap_Some (kvs : seq (T * S)) k v : mkfmap kvs k = Some v -> (k, v) \in kvs. Proof. elim: kvs => [|[k' v'] kvs IH] //=; rewrite setmE. have [-> [->]|_ H] := altP (_ =P _); first by rewrite inE eqxx. by rewrite inE IH // orbT. Qed. Definition injectivem m := uniq (unzip2 m). Lemma injectivemP m : reflect {in domm m, injective m} (injectivem m). Proof. apply/(iffP idP). move=> inj_m k1; rewrite mem_domm; case m_k1: (m k1) => [v|] // _. move/getmP in m_k1; move=> k2 /esym/getmP. move: inj_m m_k1; rewrite /injectivem. have: uniq (unzip1 m). apply (sorted_uniq (@Ord.lt_trans T) (@Ord.ltxx T)). exact: (valP m). rewrite !inE /=; elim: (val m) => [|[k' v'] s IH] //=. move=>/andP [k'_nin_s {}/IH IH] /andP [v'_nin_s {}/IH IH]. rewrite !inE -pair_eqE /=. have [k1k'|k1k'] /= := altP (k1 =P k'). subst k'; have /negbTE ->: (k1, v) \notin s. apply: contra k'_nin_s => k'_in_s. by apply/mapP; exists (k1, v). rewrite orbF=> /eqP ?; subst v'; rewrite eqxx andbT. have /negbTE ->: (k2, v) \notin s. apply: contra v'_nin_s => v'_in_s. by apply/mapP; exists (k2, v). by rewrite orbF => /eqP ->. move=> k1_in_s; move: (k1_in_s)=> {}/IH IH. have [k2k'|k2k'] //= := altP (k2 =P k'). subst k'; case/orP=> [/eqP ?|//]; subst v'. suff c : v \in unzip2 s by rewrite c in v'_nin_s. by apply/mapP; exists (k1, v). move=> inj_m. rewrite /injectivem map_inj_in_uniq. apply: (@map_uniq _ _ (@fst T S)). apply: (sorted_uniq (@Ord.lt_trans T) (@Ord.ltxx T)). exact: (valP m). move=> [k1 v] [k2 v'] /= /getmP k1_in_m /getmP k2_in_m ?; subst v'. move: (inj_m k1); rewrite mem_domm k1_in_m => /(_ erefl k2 (esym k2_in_m)). congruence. Qed. Lemma eq_domm0 (S' : eqType) (m : {fmap T -> S'}) : (domm m == fset0) = (m == emptym). Proof. apply/(sameP idP)/(iffP idP)=> [/eqP->|/eqP Pdom]; first by rewrite domm0. apply/eqP/eq_fmap=> k; rewrite emptymE; apply/dommPn. by rewrite Pdom in_fset0. Qed. End EqType. Section Inverse. Section Def. Variables (T S : ordType). Implicit Type (m : {fmap T -> S}). Definition invm m := mkfmap [seq (p.2, p.1) | p <- m]. Definition codomm m := domm (invm m). End Def. Section Cancel. Variables (T S : ordType). Implicit Type (m : {fmap T -> S}). Open Scope fset_scope. Lemma getm_inv m k k' : invm m k = Some k' -> m k' = Some k. Proof. rewrite /invm =>/mkfmap_Some/mapP [[h h'] /getmP get_k /= [??]]. by subst h h'. Qed. Lemma codommP m k : reflect (exists k', m k' = Some k) (k \in codomm m). Proof. rewrite /codomm; apply/(iffP idP). rewrite mem_domm; case im_k: (invm m k) => [k'|] //= _. by rewrite -(getm_inv im_k); eauto. move=> [k' /getmP m_k']. rewrite /invm domm_mkfmap; apply/mapP; exists (k, k') => //. by apply/mapP; exists (k', k). Qed. Lemma codommPn m k : reflect (forall k', m k' != Some k) (k \notin codomm m). Proof. apply/(iffP idP). by move=> h k'; apply: contra h=> /eqP h; apply/codommP; eauto. move=> h; apply/negP=> /codommP [k' h']. by move: (h k'); rewrite h' eqxx. Qed. Arguments codommP {_ _}. Arguments codommPn {_ _}. Lemma codomm0 : codomm (@emptym T S) = fset0. Proof. by rewrite /codomm /domm fset0E. Qed. Lemma codomm_rem m k : codomm (remm m k) :<=: codomm m. Proof. apply/fsubsetP=> v /codommP [k']; rewrite remmE. by case: eqP=> // _ Pv; apply/codommP; eauto. Qed. Lemma invmE m k : obind m (invm m k) = if invm m k then Some k else None. Proof. case get_k: (invm m k) => [k'|] //=. rewrite /invm in get_k; move/mkfmap_Some/mapP in get_k. by case: get_k => [[h h'] /getmP get_k [??]]; subst k k'. Qed. End Cancel. Section CancelRev. Variables (T S : ordType). Implicit Type (m : {fmap T -> S}). Lemma invmEV m k : {in domm m, injective m} -> obind (invm m) (m k) = if m k then Some k else None. Proof. move=> inj_m; case m_k: (m k) => [k'|] //=. move: (invmE m k'). case im_k': (invm m k') => [k''|] //=. move=> m_k''; congr Some; apply: inj_m; last by congruence. by rewrite mem_domm m_k''. have /codommPn/(_ k) : k' \notin domm (invm m) by rewrite mem_domm im_k'. by rewrite m_k eqxx. Qed. End CancelRev. Variables (T S : ordType). Implicit Type (m : {fmap T -> S}). Lemma invm_inj m : {in codomm m, injective (invm m)}. Proof. move=> k1 in_im k2 h; rewrite mem_domm in in_im. have {h}: obind m (invm m k1) = obind m (invm m k2) by congruence. rewrite invmE {}in_im. case im_k2: (invm m k2) => [k|] //=. by move/getm_inv in im_k2; congruence. Qed. Lemma invmK m : {in domm m, injective m} -> invm (invm m) = m. Proof. move=> inj_m; apply/eq_fmap=> k. move: (invmEV k inj_m). case m_k: (m k) => [k'|] //= im_k'. by move: (invmEV k' (@invm_inj m)); rewrite im_k' /=. move {im_k'}. suff : k \notin domm (invm (invm m)) by rewrite mem_domm; case: (invm (invm m) k). apply/codommPn=> k'; apply/eqP=> im_k'. by move: (invmE m k'); rewrite im_k' /= m_k. Qed. End Inverse. Arguments codommP {_ _ _ _}. Arguments codommPn {_ _ _ _}. Section OfSeq. Variable (T : Type). Definition fmap_of_seq (xs : seq T) : {fmap nat -> T} := mkfmapfp (nth None [seq Some x | x <- xs]) (iota 0 (size xs)). Lemma fmap_of_seqE xs n : fmap_of_seq xs n = nth None [seq Some x | x <- xs] n. Proof. rewrite /fmap_of_seq mkfmapfpE mem_iota leq0n /= add0n. case: ltnP=> [l|g] //. by rewrite nth_default // size_map. Qed. End OfSeq. Section Currying. Variables (T S : ordType) (R : Type). Implicit Type (m : {fmap T * S -> R}). Implicit Type (n : {fmap T -> {fmap S -> R}}). Local Open Scope fset_scope. Definition currym m := mkfmapf (fun x => mkfmapfp (fun y => m (x, y)) (@snd _ _ @: domm m)) (@fst _ _ @: domm m). Definition uncurrym n : {fmap T * S -> R} := mkfmapfp (fun p : T * S => if n p.1 is Some n' then n' p.2 else None) (\bigcup_(x <- domm n) if n x is Some n' then pair x @: domm n' else fset0). Lemma currymP m x y v : (exists2 n, currym m x = Some n & n y = Some v) <-> m (x, y) = Some v. Proof. split. move=> [n]; rewrite /currym mkfmapfE. case: ifP=> [/imfsetP/= [[x' y'] /= E ?]|//]; subst x'. move=> [<-] {n}; rewrite mkfmapfpE. by case: ifP. move=> get_xy. exists (mkfmapfp (fun y' => m (x, y')) (@snd _ _ @: domm m)). rewrite /currym mkfmapfE -{1}[x]/(x, y).1 mem_imfset //. by rewrite mem_domm get_xy. by rewrite mkfmapfpE -{1}[y]/(x, y).2 mem_imfset // mem_domm get_xy. Qed. Lemma currymE m x y : m (x, y) = obind (fun n : {fmap S -> R} => n y) (currym m x). Proof. rewrite /currym mkfmapfE. case: imfsetP=> [[[x' y'] /=]|]. rewrite mem_domm => get_xy ?; subst x'. rewrite mkfmapfpE. case get_xy': (m (x, y))=> [v|] //=; last by case: ifP. by rewrite -{1}[y]/(x, y).2 mem_imfset // mem_domm get_xy'. case get_xy: (m (x, y))=> [v|] // h. suff: False by []. by apply: h; exists (x, y)=> //; rewrite mem_domm get_xy. Qed. Lemma domm_curry m : domm (currym m) = @fst _ _ @: (domm m). Proof. by apply/eq_fset=> x; rewrite /currym mem_domm mkfmapfE; case: ifP. Qed. Lemma uncurrymP n x y v : (exists2 n', n x = Some n' & n' y = Some v) <-> uncurrym n (x, y) = Some v. Proof. pose f x' := if n x' is Some n'' then pair x' @: domm n'' else fset0. split. move=> [n' get_x get_y]. rewrite /uncurrym mkfmapfpE /= get_x get_y. have inDn' : (x, y) \in f x. by rewrite /f get_x mem_imfset // mem_domm get_y. have inD : x \in domm n by rewrite mem_domm get_x. by move/fsubsetP/(_ _ inDn'): (bigcup_sup f inD erefl)=> ->. rewrite /uncurrym mkfmapfpE /=. by case: ifP=> [inU|] //=; case: (n x) => [n'|] //= get_y; eauto. Qed. Lemma uncurrymE n p : uncurrym n p = obind (fun nn => getm nn p.2) (n p.1). Proof. case: p=> x y /=. case e: (uncurrym n (x, y))=> [v|] /=. by case/uncurrymP: e => nn -> /= ->. case e': (n x) => [nn|] //=. case e'': (nn y) => [v|] //=. have/uncurrymP : exists2 n', n x = Some n' & n' y = Some v by eauto. by rewrite e. Qed. Lemma currymK : cancel currym uncurrym. Proof. move=> m; apply/eq_fmap=> - [x y]. case get_m: (m _)=> [v|]; first by move/currymP/uncurrymP: get_m. case get_ucm : (uncurrym _ _)=> [v|] //. by move/uncurrymP/currymP: get_ucm get_m => ->. Qed. End Currying. Section Enumeration. Variables (T S : ordType). Implicit Types (m : {fmap T -> S}) (xs : seq T) (ys : seq S). Local Open Scope fset_scope. Definition enum_fmap xs ys := foldr (fun x ms => ms ++ [seq setm m x y | m <- ms, y <- ys]) [:: emptym] xs. Lemma enum_fmapP xs ys m : reflect ({subset domm m <= xs} /\ {subset codomm m <= ys}) (m \in enum_fmap xs ys). Proof. elim: xs m=> [|x xs IHx] //= m. rewrite inE; apply/(iffP eqP)=> [->|[eq0 _]]. by rewrite domm0 codomm0; split=> ?; rewrite in_fset0. apply/eqP; rewrite -eq_domm0 -fsubset0. by apply/fsubsetP=> x /eq0. rewrite mem_cat. apply/(iffP orP) => [[/IHx [subx suby] | /allpairsP h] | [subx suby]]. - by split=> // x' x'_in; rewrite inE; apply/orP; right; apply: subx. - move: m h => m' [[m y] /= [/IHx [subx suby] h ->]] {m'}; split. rewrite domm_set=> x' /fsetU1P [->|/subx]; rewrite inE ?eqxx //. by move=> ->; rewrite orbT. move=> y' /codommP [x']; rewrite setmE. case: eqP=> [_ [<-] //| _ m_x']; apply: suby. by apply/codommP; eauto. have [/dommP [y h]|x_nin] := boolP (x \in domm m). right; apply/allpairsP; exists (remm m x, y)=> /=; split. - apply/IHx; rewrite domm_rem; split. by move=> x' /fsetDP [/subx]; rewrite inE => /orP [/eqP -> /fset1P|]. move=> y' /codommP [x' m_x']; apply: suby; apply/codommP. by exists x'; move: m_x'; rewrite remmE; case: ifP. - by apply: suby; apply/codommP; exists x. by apply/eq_fmap=> x'; rewrite setmE remmE; case: eqP => [->|]. left; apply/IHx; split=> // x' x'_in; move/(_ _ x'_in): subx (x'_in) x_nin. by rewrite inE => /orP [/eqP -> ->|]. Qed. End Enumeration. extructures-0.4.0/theories/fperm.v000066400000000000000000000462571450433063500172530ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype path bigop. Require Import ord fset fmap ffun. (******************************************************************************) (* This file defines a type {fperm T} of finite permutations of an ordType *) (* T. By "finite", we mean that that there are only finitely many x such *) (* that s x != x. Permutations are a subtype of finite functions (cf. ffun) *) (* and thus support extensional equality (cf. eq_fperm). *) (* *) (* fperm_one, 1 == Identity permutation. *) (* supp s == The support of s (the set of elements that are not *) (* fixed by s). *) (* fperm f X == Builds a permutation out of a function f. If f is *) (* bijective on X and x \in X, then fperm f X x = f x *) (* fperm_inv s, s^-1 == Inverse of a permutation. *) (* s1 * s2 == Permutation composition. *) (* fperm2 x y == Transposition of x and y (i.e. the permutation *) (* that swaps these elements) *) (* fperm2_rect == Induction on the number of transpositions *) (* enum_fperm X == The set of all permutations with support in X *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module FPerm. Section Def. Variables (T : ordType). Local Open Scope ord_scope. Local Open Scope fset_scope. Definition axiom (f : ffun (@id T)) := f @: supp f == supp f. Record fperm_type := FPerm { fpval : ffun id; _ : axiom fpval }. Definition fperm_of & phant T := fperm_type. End Def. Module Exports. Identity Coercion fperm_of_fperm : fperm_of >-> fperm_type. Coercion fpval : fperm_type >-> ffun. Notation "{ 'fperm' T }" := (@fperm_of _ (Phant T)) (at level 0, format "{ 'fperm' T }") : type_scope. Section WithOrdType. Variable T : ordType. HB.instance Definition _ := [isSub of fperm_type T for @fpval T]. HB.instance Definition _ := [Equality of fperm_type T by <:]. #[hnf] HB.instance Definition _ := [Choice of fperm_type T by <:]. #[hnf] HB.instance Definition _ := [Ord of fperm_type T by <:]. HB.instance Definition _ := SubType.copy {fperm T} (fperm_type T). HB.instance Definition _ := Equality.copy {fperm T} (fperm_type T). HB.instance Definition _ := Choice.copy {fperm T} (fperm_type T). HB.instance Definition _ := Ord.Ord.copy {fperm T} (fperm_type T). End WithOrdType. End Exports. End FPerm. Export FPerm.Exports. Declare Scope fperm_scope. Delimit Scope fperm_scope with fperm. Section Operations. Variable T : ordType. Implicit Types (s : {fperm T}) (x : T) (X Y : {fset T}). Local Open Scope fset_scope. Lemma eq_fperm s1 s2 : s1 =1 s2 <-> s1 = s2. Proof. split; last congruence; by move=> /eq_ffun /val_inj. Qed. Lemma imfset_supp s : s @: supp s = supp s. Proof. exact/eqP/(valP s). Qed. Lemma imfset_suppS s X : supp s :<=: X -> s @: X = X. Proof. move=> subX; rewrite -(fsetID X (supp s)) imfsetU. rewrite (fsetIidPr subX) imfset_supp; congr fsetU. under eq_in_imfset => x /fsetDP [] _ /suppPn -> do []. by rewrite imfset_id. Qed. Lemma fperm_inj s : injective s. Proof. move=> x y. have inj : {in x |: (y |: supp s) &, injective s}. apply/imfset_injP; rewrite imfset_suppS //. by rewrite fsubsetU // fsubsetU ?fsubsetxx orbT. by apply: inj; rewrite ?in_fsetU1 ?eqxx // ?orbT. Qed. Lemma fperm_supp s x : (s x \in supp s) = (x \in supp s). Proof. rewrite -{1}imfset_supp; apply/(sameP idP)/(iffP idP). by apply: mem_imfset. by case/imfsetP=> x' hx' /fperm_inj ->. Qed. Lemma fperm_one_subproof : FPerm.axiom (@emptyf T _ _). Proof. by rewrite /FPerm.axiom supp0 imfset0. Qed. Definition fperm_one : {fperm T} := @FPerm.FPerm T emptyf fperm_one_subproof. Notation "1" := fperm_one. Lemma fperm1 x : 1 x = x. Proof. by []. Qed. Lemma mem_suppN s x : (x \notin supp s) = (s x == x). Proof. by rewrite mem_supp negbK. Qed. Lemma imfset_supp_sub s X : supp s :<=: X -> s @: X = X. Proof. move=> h_sub; apply/eq_fset=> x; have h_im_sub := imfsetS s h_sub. have [in_supp|nin_supp] := boolP (x \in supp s). rewrite (fsubsetP h_sub _ in_supp); move/fsubsetP: h_im_sub; apply. by rewrite imfset_supp. move: nin_supp; rewrite mem_supp negbK =>/eqP ex. apply/(sameP idP)/(iffP idP); first by rewrite -{2}ex; apply: mem_imfset. case/imfsetP=> [y Py ey]; rewrite {2}ey in ex. by move/fperm_inj in ex; rewrite ex. Qed. Lemma supp1 : supp 1 = fset0. Proof. apply/eqP; rewrite -fsubset0; apply/fsubsetP=> x. by rewrite mem_supp fperm1 eqxx. Qed. Lemma supp_eq0 s : (supp s == fset0) = (s == 1). Proof. apply/(sameP idP)/(iffP idP)=> [/eqP->|]; first by rewrite supp1. move=> /eqP e; apply/eqP/eq_fperm=> x; rewrite fperm1; apply/suppPn. by rewrite e in_fset0. Qed. Section Build. Implicit Types (f : T -> T). Lemma fperm_def_aux f X : f @: X = X -> FPerm.axiom (mkffun f X). Proof. move=> fP; apply/eqP/eq_fset => x; apply/(sameP idP)/(iffP idP). - rewrite {1}supp_mkffun in_fset mem_filter; case/andP => fx_x x_X. move: x x_X fx_x; rewrite -{1}fP => _ /imfsetP [] x x_X -> ffx_fx. apply/imfsetP; exists x. by rewrite mem_supp mkffunE x_X; apply: contraNN ffx_fx => /eqP {1}->. by rewrite mkffunE x_X. - case/imfsetP => {}x x_X ->. move: x_X; rewrite !mem_supp !mkffunE. case: ifP => [x_X fx_x|]; last by rewrite eqxx. have fx_X : f x \in X by rewrite -fP mem_imfset. have inj : {in X &, injective f} by apply/imfset_injP; rewrite fP. by rewrite fx_X; apply: contraNN fx_x => /eqP /inj ->. Qed. Definition fperm_def f X x := let Y1 := f @: X :\: X in let Y2 := X :\: f @: X in if x \in Y1 then nth x Y2 (index x Y1) else f x. Definition fperm f X := odflt 1 (insub (mkffun (fperm_def f X) (X :|: f @: X))). Lemma fpermE f X : {in X &, injective f} -> {in X, fperm f X =1 f}. Proof. move=> /imfset_injP inj x x_X; rewrite /fperm insubT /=; last first. by move=> _; rewrite mkffunE in_fsetU /fperm_def /= in_fsetD x_X. apply/fperm_def_aux; rewrite /fperm_def {x x_X}. set Y1 := f @: X :\: X; set Y2 := X :\: f @: X. set g := fun x => if _ then _ else _. pose h x := if x \in Y2 then nth x Y1 (index x Y2) else odflt x (fpick (fun y => f y == x) Y1). set D := X :|: f @: X. have sY12 : size Y1 = size Y2. apply: (@addnI (size (f @: X :&: X))). rewrite -sizesD fsetIC -sizesD; exact/eqP. have nY1_X x : x \in D -> x \notin Y1 -> x \in X. case/fsetUP=> //; by rewrite in_fsetD => ->; rewrite andbT negbK. have nth_Y2 x : x \in D -> x \in Y1 -> nth x Y2 (index x Y1) \in Y2. move=> ??; by rewrite mem_nth // -sY12 index_mem. have /imfset_injP/eqP g_inj: {in D &, injective g}. move=> x y x_D y_D. rewrite /g; case: ifPn => x_Y1; case: ifPn => y_Y1. - rewrite (set_nth_default y) -?sY12 ?index_mem // => exy. have {}exy : index x Y1 = index y Y1. by apply/uniqP; eauto; rewrite ?uniq_fset // -?sY12 inE ?index_mem. by rewrite -[x](nth_index x x_Y1) exy nth_index. - move=> exy; move: (nth_Y2 _ x_D x_Y1). by rewrite in_fsetD exy mem_imfset // nY1_X. - move=> exy; move: (nth_Y2 _ y_D y_Y1). by rewrite in_fsetD -exy mem_imfset // nY1_X. - by apply: (imfset_injP _ _ inj); rewrite nY1_X. apply/eqP; rewrite eqEfsize g_inj leqnn andbT. apply/fsubsetP => _ /imfsetP [] {}x {}x_X ->. rewrite /g; case: ifPn => x_Y1; last first. by apply/fsetUP; right; rewrite mem_imfset // nY1_X. by case/fsetDP: (nth_Y2 _ x_X x_Y1) => ? ?; apply/fsetUP; left. Qed. Lemma supp_fperm f X : supp (fperm f X) :<=: X :|: f @: X. Proof. rewrite /fperm; case: insubP => /= [g _ ->|_]; first exact: supp_mkffun_sub. by rewrite supp0 fsub0set. Qed. Lemma fpermEst f X x : f @: X = X -> fperm f X x = if x \in X then f x else x. Proof. move=> st; case: ifPn=> /= [|x_nin]. by apply/fpermE/imfset_injP/eqP; rewrite st. apply/suppPn; apply: contra x_nin; apply/fsubsetP. rewrite -{2}[X]fsetUid -{3}st; exact: supp_fperm. Qed. End Build. Section Renaming. (* FIXME: find a better name for this *) Lemma find_fperm (X Y : {fset T}) : size X = size Y -> exists2 s : {fperm T}, supp s :<=: X :|: Y & s @: X = Y. Proof. move=> size_X. suff [f f_inj im_f]: exists2 f, {in X &, injective f} & f @: X = Y. rewrite -im_f. exists (fperm f X); first by rewrite supp_fperm. by apply: eq_in_imfset; apply: fpermE. elim/fset_ind: X Y size_X => [|x X x_nin_X IH] Y. rewrite /=; move/esym/eqP; rewrite sizes_eq0=> /eqP ->. exists id; first by move=> x; rewrite in_fset0. by rewrite imfset0. rewrite sizesU1 x_nin_X add1n. elim/fset_ind: Y => [|y Y y_nin_Y _]; first by rewrite sizes0. rewrite sizesU1 y_nin_Y /= add1n=> - [/IH [f Pf PXY]]. exists (fun x' => if x' == x then y else f x'). move=> x1 x2 /=; rewrite !in_fsetU1. have [-> _|ne1] /= := altP (x1 =P x). have [-> _|ne2] //= := altP (x2 =P x). move=> x2_in_X ey; move: y_nin_Y; rewrite {}ey -PXY. by rewrite mem_imfset. move=> x1_in_X. have [-> _|ne2] /= := altP (x2 =P x). by move=> ey; move: y_nin_Y; rewrite -{}ey -PXY mem_imfset. by move: x1_in_X; apply: Pf. rewrite imfsetU1 eqxx -{}PXY; congr fsetU. apply/eq_in_imfset=> x' x'_in_X. by move: x'_in_X x_nin_X; have [->|//] := altP eqP=> ->. Qed. End Renaming. Section Inverse. Variable s : {fperm T}. Local Notation inv_def := (fun x => odflt x (fpick (pred1 x \o s) (supp s))). Lemma fperm_inv_subproof : inv_def @: supp s = supp s. Proof. apply/eq_fset=> x; apply/(sameP idP)/(iffP idP). move=> x_in_supp; apply/imfsetP; exists (s x). by rewrite -imfset_supp (mem_imfset _ x_in_supp). case: fpickP=> [y' /= /eqP/esym e _|/(_ _ x_in_supp) /=]. exact: fperm_inj e. by rewrite eqxx. by case/imfsetP=> [y Py -> {x}]; case: fpickP. Qed. Definition fperm_inv := locked (fperm inv_def (supp s)). Lemma fpermK : cancel s fperm_inv. Proof. move=> x; rewrite /fperm_inv -lock fpermEst; last exact: fperm_inv_subproof. rewrite fperm_supp; case: ifPn=> [x_in_supp|]; last exact/suppPn. case: fpickP => [y /= /eqP/esym /fperm_inj-> //|/(_ _ x_in_supp) /=]. by rewrite eqxx. Qed. Lemma fpermKV : cancel fperm_inv s. Proof. move=> x; rewrite /fperm_inv -lock fpermEst; last exact: fperm_inv_subproof. case: ifPn=> [x_in_supp|]. case: fpickP=> [x' /= /eqP/esym -> //|/=]. rewrite -imfset_supp in x_in_supp; case/imfsetP: x_in_supp=> [x' Px' ->]. by move/(_ _ Px'); rewrite eqxx. by rewrite mem_supp negbK => /eqP. Qed. Lemma supp_inv : supp fperm_inv = supp s. Proof. apply/eq_fset=> x; apply/(sameP idP)/(iffP idP). by rewrite !mem_supp; apply: contra => /eqP {1}<-; rewrite fpermKV eqxx. by rewrite !mem_supp; apply: contra=> /eqP {1}<-; rewrite fpermK eqxx. Qed. Lemma fperm_suppV x : (fperm_inv x \in supp s) = (x \in supp s). Proof. by rewrite -{1}supp_inv fperm_supp supp_inv. Qed. End Inverse. Lemma fperm_mul_subproof s1 s2 : (s1 \o s2) @: (supp s1 :|: supp s2) = supp s1 :|: supp s2. Proof. by rewrite imfset_comp !imfset_supp_sub // ?fsubsetUr // fsubsetUl. Qed. Definition fperm_mul s1 s2 := locked (fperm (s1 \o s2) (supp s1 :|: supp s2)). Infix "*" := fperm_mul. Notation "x ^-1" := (fperm_inv x). Lemma fpermM s1 s2 : s1 * s2 =1 s1 \o s2. Proof. move=> x; rewrite /fperm_mul -lock fpermEst; last exact: fperm_mul_subproof. have [|nin_supp] //= := boolP (x \in _). rewrite in_fsetU negb_or !mem_supp !negbK in nin_supp. by case/andP: nin_supp=> [/eqP h1 /eqP ->]; rewrite h1. Qed. Lemma supp_mul s1 s2 : supp (s1 * s2) :<=: supp s1 :|: supp s2. Proof. apply/fsubsetP=> x; rewrite in_fsetU !mem_supp fpermM /=. have [-> -> //|] := altP (s2 x =P x). by rewrite orbT. Qed. Lemma suppJ s1 s2 : supp (s1 * s2 * s1^-1) = s1 @: supp s2. Proof. apply/eq_fset=> x; apply/esym/imfsetP; rewrite mem_supp fpermM /= fpermM /=. rewrite (can2_eq (fpermK s1) (fpermKV s1)). have [e|ne] /= := altP eqP. case=> [y Py e']; move: e Py. by rewrite e' fpermK mem_supp=> ->; rewrite eqxx. exists (s1^-1 x); last by rewrite fpermKV. by rewrite mem_supp. Qed. Lemma fperm_mulC s1 s2 : fdisjoint (supp s1) (supp s2) -> s1 * s2 = s2 * s1. Proof. move=> dis; apply/eq_fperm=> x; rewrite !fpermM /=. have [ins1|nins1] := boolP (x \in supp s1). move: (ins1); rewrite -fperm_supp=> ins1'. move/fdisjointP in dis. move/suppPn: (dis _ ins1)=> ->. by move/suppPn: (dis _ ins1')=> ->. have [ins2|nins2] := boolP (x \in supp s2). move: (ins2); rewrite -fperm_supp=> ins2'. move: dis; rewrite fdisjointC=> /fdisjointP dis. move/suppPn: (dis _ ins2)=> ->. by move/suppPn: (dis _ ins2')=> ->. move: nins1 nins2=> /suppPn nins1 /suppPn nins2. by rewrite nins1 nins2. Qed. Lemma fperm_mul1s : left_id 1 fperm_mul. Proof. by move=> s; apply/eq_fperm=> x; rewrite fpermM. Qed. Lemma fperm_muls1 : right_id 1 fperm_mul. Proof. by move=> s; apply/eq_fperm=> x; rewrite fpermM. Qed. Lemma fperm_mulsV : right_inverse 1 fperm_inv fperm_mul. Proof. by move=> s; apply/eq_fperm=> x; rewrite fpermM /= fpermKV. Qed. Lemma fperm_mulVs : left_inverse 1 fperm_inv fperm_mul. Proof. by move=> s; apply/eq_fperm=> x; rewrite fpermM /= fpermK. Qed. Lemma fperm_mulA : associative fperm_mul. Proof. by move=> s1 s2 s3; apply/eq_fperm=> x; rewrite !fpermM /= !fpermM. Qed. Lemma fperm_inv_mul : {morph fperm_inv : s1 s2 / s1 * s2 >-> s2 * s1}. Proof. move=> s1 s2 /=. rewrite -[s2^-1 * _]fperm_mul1s -(fperm_mulVs (s1 * s2)) -2!fperm_mulA. by rewrite (fperm_mulA s2) fperm_mulsV fperm_mul1s fperm_mulsV fperm_muls1. Qed. Lemma fperm_mulsK : right_loop fperm_inv fperm_mul. Proof. by move=> s1 s2; rewrite -fperm_mulA fperm_mulsV fperm_muls1. Qed. Lemma fperm_mulKs : left_loop fperm_inv fperm_mul. Proof. by move=> s1 s2; rewrite fperm_mulA fperm_mulVs fperm_mul1s. Qed. Lemma fperm_mulsI : right_injective fperm_mul. Proof. by move=> s1 s2 s3 e; rewrite -(fperm_mulKs s1 s2) e fperm_mulKs. Qed. Lemma fperm_mulIs : left_injective fperm_mul. Proof. by move=> s1 s2 s3 e; rewrite -(fperm_mulsK s1 s2) e fperm_mulsK. Qed. Lemma fperm_invK : involutive fperm_inv. Proof. by move=> s; apply (@fperm_mulsI s^-1); rewrite fperm_mulsV fperm_mulVs. Qed. Lemma fperm_mulsKV : rev_right_loop fperm_inv fperm_mul. Proof. by move=> s1 s2; rewrite -{2}(fperm_invK s1) fperm_mulsK. Qed. Lemma fperm_mulKVs : rev_left_loop fperm_inv fperm_mul. Proof. by move=> s1 s2; rewrite -{1}(fperm_invK s1) fperm_mulKs. Qed. Notation fperm2_def x y := [fun z => z with x |-> y, y |-> x]. Lemma fperm2_subproof x y : fperm2_def x y @: [fset x; y] = [fset x; y]. Proof. apply/eq_fset=> z; apply/(sameP idP)/(iffP idP). case/fset2P=> [->|->] /=; apply/imfsetP; [exists y; try apply fset22|exists x; try apply fset21]. by rewrite /= eqxx; have [->|] //= := altP eqP. by rewrite /= eqxx. case/imfsetP=> [w /fset2P [->|->] ->] /=; rewrite eqxx ?fset22 //. case: ifP=> ?; by [apply fset21|apply fset22]. Qed. Definition fperm2 x y := fperm (fperm2_def x y) [fset x; y]. Lemma fperm2E x y : fperm2 x y =1 [fun z => z with x |-> y, y |-> x]. Proof. move=> z; rewrite fpermEst; last exact: fperm2_subproof. rewrite /= in_fset2. have [->|] := altP eqP => //= ?. by have [?|] := altP eqP => //= ?. Qed. CoInductive fperm2_spec x y z : T -> Type := | FPerm2First of z = x : fperm2_spec x y z y | FPerm2Second of z = y : fperm2_spec x y z x | FPerm2None of z <> x & z <> y : fperm2_spec x y z z. Lemma fperm2P x y z : fperm2_spec x y z (fperm2 x y z). Proof. by rewrite fperm2E /=; do 2?[case: eqP=> //]; constructor; auto. Qed. Lemma fperm2L x y : fperm2 x y x = y. Proof. by rewrite fperm2E /= eqxx. Qed. Lemma fperm2R x y : fperm2 x y y = x. Proof. by rewrite fperm2E /= eqxx; case: eqP=> [->|]. Qed. Lemma fperm2D x y z : z != x -> z != y -> fperm2 x y z = z. Proof. by rewrite fperm2E /= => /negbTE-> /negbTE->. Qed. Lemma fperm2C x y : fperm2 x y = fperm2 y x. Proof. apply/eq_fperm=> z; do 2?[case: fperm2P=> //]; congruence. Qed. Lemma fperm2V x y : (fperm2 x y)^-1 = fperm2 x y. Proof. rewrite -[in LHS](fperm_muls1 _^-1). apply/(canLR (fperm_mulKs (fperm2 x y)))/eq_fperm=> z. rewrite fperm1 fpermM /= !fperm2E /=; have [->{z}|] := altP (z =P x). by rewrite eqxx; case: ifP=> // /eqP ->. have [->{z}|] := altP (z =P y); first by rewrite eqxx. by move=> /negbTE -> /negbTE ->. Qed. Lemma fperm2xx x : fperm2 x x = 1. Proof. apply/eq_fperm=> y; rewrite fperm2E fperm1 /=. by have [->|] := altP (y =P x). Qed. Lemma supp_fperm2 x y : supp (fperm2 x y) = if x == y then fset0 else [fset x; y]. Proof. have [<-{y}|ne] := altP eqP; first by rewrite fperm2xx supp1. apply/eq_fset=> z; rewrite mem_supp /= in_fset2. case: fperm2P => [->|->|]; [rewrite eq_sym| |]; rewrite ?ne ?eqxx ?orbT //. by move=> /eqP/negbTE-> /eqP/negbTE->. Qed. Lemma fsubset_supp_fperm2 x y : supp (fperm2 x y) :<=: [fset x; y]. Proof. by rewrite supp_fperm2 fun_if if_arg fsub0set fsubsetxx; case: (_ == _). Qed. Lemma fperm2_rect (P : {fperm T} -> Type) : P 1 -> (forall x y s, x \notin supp s -> y \in supp (fperm2 x y * s) -> P s -> P (fperm2 x y * s)) -> forall s, P s. Proof. move=> P1 PM s; move: {2}(size _) (leqnn (size (supp s)))=> n. elim: n s=> [|n IH] s; first by rewrite leqn0 sizes_eq0 supp_eq0=> /eqP ->. case e: (supp s) / fsetP=>[|x X Px]. by move/eqP: e; rewrite supp_eq0=> /eqP ->. rewrite sizesU1 Px ltnS -(fperm_mulKs (fperm2 x (s x)) s) fperm2V=> es. apply: PM; first by apply/suppPn; rewrite fpermM /= fperm2R. by rewrite -{1}fperm2V fperm_mulKs fperm_supp e in_fsetU1 eqxx. apply: IH; rewrite (leq_trans _ es) // {es}; apply/fsubset_leq_size/fsubsetP. move=> y; rewrite mem_supp fpermM /=; case: fperm2P. - move=> ex ny; have: y \in supp s. by have [//|/suppPn ey] := boolP (y \in _); rewrite -ex !ey eqxx in ny. by rewrite e; case/fsetU1P=> [ey|//]; rewrite -ey ex ey eqxx in ny. - by move/fperm_inj=> ->; rewrite eqxx. move=> _ /eqP; rewrite (inj_eq (@fperm_inj _))=> e2. by rewrite -mem_supp e in_fsetU1 (negbTE e2). Qed. Definition enum_fperm X : {fset {fperm T}} := fset (pmap (obind (insub : ffun _ -> option {fperm T}) \o insub) (enum_fmap X X)). Lemma enum_fpermE X s : supp s :<=: X = (s \in enum_fperm X). Proof. rewrite /enum_fperm in_fset mem_pmap; apply/idP/mapP. move=> supp_s; exists (val (val s)); last by rewrite /= !valK /= valK. apply/enum_fmapP; split; first by move/fsubsetP: supp_s. move=> x /codommP [x' Px']; move/fsubsetP: supp_s; apply. have <- : s x' = x by rewrite /appf Px'. by rewrite fperm_supp /supp mem_domm Px'. move=> [s' Ps' Pss']; case/enum_fmapP: Ps' => /fsubsetP. move: Pss' => /=; case: insubP => //= ? _ <-. by case: insubP => //= ? _ <- [] <-. Qed. End Operations. Arguments fperm_one {_}. Prenex Implicits fperm_inv fperm_mul fperm2. Delimit Scope fperm_scope with fperm. Notation "1" := fperm_one : fperm_scope. Infix "*" := fperm_mul : fperm_scope. Notation "x ^-1" := (fperm_inv x) : fperm_scope. Section Trans. Local Open Scope fperm_scope. Lemma inj_fperm2 (T T' : ordType) (f : T -> T') x y z : injective f -> f (fperm2 x y z) = fperm2 (f x) (f y) (f z). Proof. move=> f_inj; case: (fperm2P x)=> [->|->| ]; rewrite ?fperm2L ?fperm2R //. by move=>/eqP hx /eqP hy; apply/esym/fperm2D; rewrite (inj_eq f_inj). Qed. Lemma fperm2J (T : ordType) s (x y : T) : s * fperm2 x y * s^-1 = fperm2 (s x) (s y). Proof. apply/eq_fperm=> z; rewrite fpermM /= fpermM /= inj_fperm2 ?fpermKV //. exact: fperm_inj. Qed. End Trans. extructures-0.4.0/theories/fset.v000066400000000000000000001206661450433063500171000ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype path bigop tuple. Require Import ord. (******************************************************************************) (* This file defines a type {fset T} of finite sets over an ordType T. *) (* This is a subtype of seq T: we represent a set as a sorted list of set *) (* elements, allowing us to show extensional equality: two sets are equal if *) (* they have the same elements (cf. eq_fset). *) (* *) (* These definitions and notations are largely similar to the finset *) (* library of the Mathematical Components distribution. *) (* *) (* fset s == the set of elements contained in the sequence s. *) (* x \in s == {fset T} coerces into a collective predicate. *) (* Membership is computed like for sequences. *) (* size s == the cardinality of s, defined by converting it to a *) (* sequence. *) (* fset0 == the empty set. *) (* fset1 x == the singleton set that contains x. *) (* fset_filter p s == remove the elements of s that do not satisfy the *) (* predicate p : T -> bool. *) (* s1 :|: s2 == the union of s1 and s2. *) (* x |: s == notation for fset1 x :|: s. *) (* s1 :&: s2 == the intersection of s1 and s2. *) (* s1 :\: s2 == remove all elements of s2 from s1. *) (* s :\ x == notation for s :\: fset1 x. *) (* s1 :#: s2 == the sets s1 and s2 are disjoint. *) (* s1 :<=: s2 == s1 is a subset of s2. *) (* f @: s == the image of s by f: the set containing all elements of *) (* the form f x, where x \in s. *) (* powerset s == set of all subsets of s. *) (* *) (* We provide lemmas and notations for big versions of idempotent *) (* operations (in the sense of the bigop library) indexed by sets, as well as *) (* a \bigcup form for taking the union of a family of sets. We do not *) (* a \bigcap operation for computing intersections because it does not have a *) (* neutral element: most types are infinite, but ours sets are merely finite. *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module FSet. Section Def. Variables (T : ordType). Local Open Scope ord_scope. Record fset_type := FSet { fsval : seq T; _ : sorted (@Ord.lt T) fsval }. Lemma fset_subproof (s : seq T) : sorted (@Ord.lt T) (sort (@Ord.leq T) (undup s)). Proof. move: (undup s) (undup_uniq s)=> {}s. move/permPl/perm_uniq: (perm_sort (@Ord.leq T) s)=> <- u_s. move: {s} (sort _ _) u_s (sort_sorted (@Ord.leq_total T) s)=> [|x s] //=. case/andP; elim: s x => //= x' s IH x; rewrite inE negb_or Ord.leq_eqVlt. rewrite eq_sym=> /andP [/negbTE -> /= _] /andP [nin u_s] /andP [-> /=]. exact: IH. Qed. End Def. Module Exports. Definition fset_of (T : ordType) & phant T := fset_type T. Identity Coercion fset_of_fset : fset_of >-> fset_type. Notation "{ 'fset' T }" := (@fset_of _ (Phant T)) (at level 0, format "{ 'fset' T }") : type_scope. Coercion fsval : fset_type >-> seq. Section Instances. Variable T : ordType. HB.instance Definition _ := [isSub of fset_type T for @fsval T]. HB.instance Definition _ := [Equality of fset_type T by <:]. #[hnf] HB.instance Definition _ := [Choice of fset_type T by <:]. #[hnf] HB.instance Definition _ := [Ord of fset_type T by <:]. #[hnf] HB.instance Definition _ := SubType.copy {fset T} (fset_type T). #[hnf] HB.instance Definition _ := Equality.copy {fset T} (fset_type T). #[hnf] HB.instance Definition _ := Choice.copy {fset T} (fset_type T). #[hnf] HB.instance Definition _ := Ord.Ord.copy {fset T} (fset_type T). End Instances. End Exports. End FSet. Export FSet.Exports. Declare Scope fset_scope. Delimit Scope fset_scope with fset. Lemma fset_key : unit. Proof. exact: tt. Qed. Definition fset (T : ordType) : seq T -> {fset T} := locked_with fset_key (fun (s : seq T) => @FSet.FSet T _ (FSet.fset_subproof s)). Prenex Implicits fset. Section Basics. Variable T : ordType. Local Open Scope ord_scope. Definition pred_of_fset (s : {fset T}) := [pred x : T | x \in val s]. Canonical fset_predType := PredType pred_of_fset. Lemma in_fset s x : (x \in fset s) = (x \in s). Proof. by rewrite [fset]unlock inE /= mem_sort mem_undup. Qed. Implicit Type s : {fset T}. Definition fset0 := @FSet.FSet T [::] erefl : {fset T}. Definition fset1 x := @FSet.FSet T [:: x] erefl : {fset T}. Definition fsetU s1 s2 := fset (val s1 ++ val s2). Definition fset_filter P s := fset [seq x <- s | P x]. Definition fsetI s1 s2 := fset_filter (mem s1) s2. Definition fsetD s1 s2 := fset_filter [pred x | x \notin s2] s1. Definition fsubset s1 s2 := fsetU s1 s2 == s2. Definition fdisjoint s1 s2 := fsetI s1 s2 == fset0. End Basics. Arguments fset0 {_}. Prenex Implicits fsetU fsetI fsubset. Notation "s1 :|: s2" := (fsetU s1 s2) : fset_scope. Notation "x |: s" := (fsetU (fset1 x) s) : fset_scope. Notation "s1 :&: s2" := (fsetI s1 s2) : fset_scope. Notation "s1 :\: s2" := (fsetD s1 s2) : fset_scope. Notation "s :\ x" := (fsetD s (fset1 x)) : fset_scope. Notation "s1 :<=: s2" := (fsubset s1 s2) (at level 55, no associativity) : fset_scope. Notation "s1 :#: s2" := (fdisjoint s1 s2) (at level 55, no associativity) : fset_scope. Notation "[ 'fset' a1 ; .. ; an ]" := (fsetU (fset1 a1) .. (fsetU (fset1 an) fset0) .. ) (at level 0, format "[ 'fset' a1 ; .. ; an ]") : fset_scope. Section Properties. Variables (T : ordType). Local Open Scope fset_scope. Implicit Types (s : {fset T}) (x y : T) (xs : seq T). Lemma all_fset P xs : all P (fset xs) = all P xs. Proof. apply/(sameP allP)/(iffP allP)=> h x; first by rewrite in_fset; eauto. by move/(_ x): h; rewrite in_fset. Qed. Lemma has_fset P xs : has P (fset xs) = has P xs. Proof. apply/(sameP hasP)/(iffP hasP)=> - [x x_in Px]; exists x=> //; by rewrite ?in_fset // -in_fset. Qed. Lemma eq_fset s1 s2 : s1 =i s2 <-> s1 = s2. Proof. split; last congruence. case: s1 s2 => [s1 Ps1] [s2 Ps2] /= E; apply/val_inj=> /=. have anti: antisymmetric (@Ord.lt T). move=> x y /andP [/Ord.ltW xy /Ord.ltW yx]. exact: Ord.anti_leq (introT andP (conj xy yx)). rewrite -[s1 =i s2]/(_) in E; apply: (sorted_eq _ _ Ps1 Ps2) => //. exact: Ord.lt_trans. apply: uniq_perm => //; [move: Ps1|move: Ps2]; apply/sorted_uniq => //; by [apply: Ord.ltxx|apply: Ord.lt_trans]. Qed. Lemma fsvalK : cancel val (@fset T). Proof. by move=> X; apply/eq_fset=> x; rewrite in_fset. Qed. Lemma fset0E : @fset0 T = fset [::]. Proof. by apply/eq_fset=> x; rewrite in_fset. Qed. Lemma fset1E x : fset1 x = fset [:: x]. Proof. by apply/eq_fset=> x'; rewrite in_fset. Qed. Lemma in_fset0 x : x \in fset0 = false. Proof. by []. Qed. Lemma in_fset1 x y : x \in fset1 y = (x == y). Proof. by rewrite /= inE. Qed. Lemma fset1P x y : reflect (x = y) (x \in fset1 y). Proof. by rewrite in_fset1; apply/eqP. Qed. Lemma fset1_inj : injective (@fset1 T). Proof. by move=> x y e; apply/fset1P; rewrite -e; apply/fset1P. Qed. Lemma in_fsetU x s1 s2 : (x \in s1 :|: s2) = (x \in s1) || (x \in s2). Proof. by rewrite /fsetU in_fset mem_cat. Qed. Lemma in_fsetU1 x y s : x \in y |: s = (x == y) || (x \in s). Proof. by rewrite in_fsetU in_fset1. Qed. Lemma fset_cat xs ys : fset (xs ++ ys) = fset xs :|: fset ys. Proof. by apply/eq_fset=> x; rewrite in_fsetU !in_fset mem_cat. Qed. Lemma all_fsetU P s1 s2 : all P (s1 :|: s2) = all P s1 && all P s2. Proof. by rewrite /fsetU all_fset all_cat. Qed. Lemma in_fset2 x y z : x \in [fset y; z] = (x == y) || (x == z). Proof. by rewrite !in_fsetU1 in_fset0 orbF. Qed. Lemma fset21 x y : x \in [fset x; y]. Proof. by rewrite in_fset2 eqxx. Qed. Lemma fset22 x y : y \in [fset x; y]. Proof. by rewrite in_fset2 eqxx orbT. Qed. Lemma fset2P x y z : reflect (x = y \/ x = z) (x \in [fset y; z]). Proof. rewrite in_fset2; apply/(iffP idP). by case/orP=> [/eqP->|/eqP->]; auto. by case=> [->|->]; rewrite eqxx ?orbT. Qed. Arguments fset2P {_ _ _}. CoInductive fset_spec : {fset T} -> Type := | FSetSpec0 : fset_spec fset0 | FSetSpecS x s of x \notin s : fset_spec (x |: s). (* FIXME: This name is inconsistent with MathComp *) Lemma fsetP s : fset_spec s. Proof. case: s=> [[|x xs] /= Pxs]; first by rewrite eq_axiomK; apply: FSetSpec0. have Pxs' := path_sorted Pxs. set s' : {fset T} := FSet.FSet Pxs'; set s : {fset T} := FSet.FSet _. have x_nin_s : x \notin s'. apply/negP=> /(allP (order_path_min (@Ord.lt_trans T) Pxs)). by rewrite Ord.ltxx. suff ->: s = x |: s' by apply: FSetSpecS. by apply/eq_fset=> x'; rewrite in_fsetU1 !inE. Qed. Lemma fset_rect (P : {fset T} -> Type) : P fset0 -> (forall x s, x \notin s -> P s -> P (x |: s)) -> forall s, P s. Proof. move=> H0 HS []; elim=> [|/= x xs IH] Pxs; first by rewrite eq_axiomK. move: IH => /(_ (path_sorted Pxs)). set s : {fset T} := FSet.FSet _; set s' : {fset T} := FSet.FSet _ => Ps. have x_nin_s : x \notin s. apply/negP=> /(allP (order_path_min (@Ord.lt_trans T) Pxs)). by rewrite Ord.ltxx. suff ->: s' = x |: s by eauto. by apply/eq_fset=> x'; rewrite in_fsetU1 !inE. Qed. Definition fset_ind (P : {fset T} -> Prop) : P fset0 -> (forall x s, x \notin s -> P s -> P (x |: s)) -> forall s, P s := @fset_rect P. Lemma fsetU1P x y s : reflect (x = y \/ x \in s) (x \in y |: s). Proof. by rewrite in_fsetU1; apply/predU1P. Qed. Lemma fsetUP x s1 s2 : reflect (x \in s1 \/ x \in s2) (x \in s1 :|: s2). Proof. by rewrite in_fsetU; apply/orP. Qed. Lemma fsetUC : commutative (@fsetU T). Proof. by move=> s1 s2; apply/eq_fset=> x; rewrite !in_fsetU orbC. Qed. Lemma fsetUA : associative (@fsetU T). Proof. by move=> s1 s2 s3; apply/eq_fset=> x; rewrite !in_fsetU orbA. Qed. Lemma fset0U : left_id fset0 (@fsetU T). Proof. by move=> s; apply/eq_fset=> x; rewrite in_fsetU in_fset0. Qed. Lemma fsetU0 : right_id fset0 (@fsetU T). Proof. by move=> s; rewrite fsetUC fset0U. Qed. Lemma fsetUid : idempotent (@fsetU T). Proof. by move=> s; apply/eq_fset=> x; rewrite in_fsetU orbb. Qed. Lemma fsubsetP s1 s2 : reflect {subset s1 <= s2} (s1 :<=: s2). Proof. apply/(iffP idP)=> [/eqP <- x|hs1s2]; first by rewrite in_fsetU => ->. apply/eqP/eq_fset=> x; rewrite in_fsetU. have [/hs1s2|//] //= := boolP (x \in s1). Qed. Arguments fsubsetP {_ _}. Lemma fsubsetxx s : s :<=: s. Proof. by apply/fsubsetP. Qed. Lemma fsubset_trans : transitive (@fsubset T). Proof. by move=> s1 s2 s3 /fsubsetP ? /fsubsetP ?; apply/fsubsetP=> x; eauto. Qed. Lemma fsubsetUl s1 s2 : s1 :<=: s1 :|: s2. Proof. by rewrite /fsubset fsetUA fsetUid. Qed. Lemma fsubsetUr s1 s2 : s2 :<=: s1 :|: s2. Proof. by rewrite fsetUC fsubsetUl. Qed. Lemma fsubU1set x s1 s2 : x |: s1 :<=: s2 = (x \in s2) && (s1 :<=: s2). Proof. apply/(sameP idP)/(iffP idP). case/andP=> [hx /fsubsetP hs1]; apply/fsubsetP=> x'. by rewrite in_fsetU1=> /orP [/eqP ->|hx']; eauto. move/fsubsetP=> h; apply/andP; split. by apply: h; rewrite in_fsetU1 eqxx. by apply/fsubsetP=> x' hx'; apply: h; rewrite in_fsetU1 hx' orbT. Qed. Lemma fsubUset s1 s2 s3 : s1 :|: s2 :<=: s3 = (s1 :<=: s3) && (s2 :<=: s3). Proof. apply/(sameP idP)/(iffP idP). case/andP=> [/fsubsetP hs1 /fsubsetP hs2]; apply/fsubsetP=> x. by rewrite in_fsetU=> /orP [hx|hx]; eauto. by move/fsubsetP=> h; apply/andP; split; apply/fsubsetP=> x hx; apply: h; rewrite in_fsetU hx ?orbT. Qed. Lemma fsubsetU s1 s2 s3 : (s1 :<=: s2) || (s1 :<=: s3) -> s1 :<=: s2 :|: s3. Proof. by case/orP=> [/fsubsetP h | /fsubsetP h]; apply/fsubsetP=> x hx; rewrite in_fsetU h /= ?orbT. Qed. Lemma fsetUS s1 s2 s3 : s1 :<=: s2 -> s3 :|: s1 :<=: s3 :|: s2. Proof. rewrite fsubUset fsubsetUl /= => sub; rewrite fsubsetU //. by rewrite sub orbT. Qed. Lemma fsetSU s1 s2 s3 : s1 :<=: s2 -> s1 :|: s3 :<=: s2 :|: s3. Proof. by rewrite !(fsetUC _ s3); apply: fsetUS. Qed. Lemma fsetUSS s1 s2 s3 s4 : s1 :<=: s2 -> s3 :<=: s4 -> s1 :|: s3 :<=: s2 :|: s4. Proof. by move=> P1 P2; rewrite (fsubset_trans (fsetSU _ P1)) // fsetUS. Qed. Lemma fsub1set x s1 : fset1 x :<=: s1 = (x \in s1). Proof. apply/(sameP fsubsetP)/(iffP idP); last by [apply; rewrite in_fset1]. by move=> x_in x' /fset1P ->. Qed. Lemma fset_cons x xs : fset (x :: xs) = x |: fset xs. Proof. by apply/eq_fset=> x'; rewrite in_fset in_fsetU1 inE in_fset. Qed. Lemma uniq_fset s : uniq s. Proof. exact: (sorted_uniq (@Ord.lt_trans T) (@Ord.ltxx T) (valP s)). Qed. Lemma in_fset_filter P s x : (x \in fset_filter P s) = P x && (x \in s). Proof. by rewrite /fset_filter in_fset mem_filter. Qed. Lemma in_fsetI x s1 s2 : (x \in s1 :&: s2) = (x \in s1) && (x \in s2). Proof. by rewrite in_fset_filter. Qed. Lemma fsetIP x s1 s2 : reflect (x \in s1 /\ x \in s2) (x \in s1 :&: s2). Proof. by rewrite in_fsetI; apply/andP. Qed. Lemma fsetIC : commutative (@fsetI T). Proof. by move=> s1 s2; apply/eq_fset=> x; rewrite !in_fsetI andbC. Qed. Lemma fsetIA : associative (@fsetI T). Proof. by move=> s1 s2 s3; apply/eq_fset=> x; rewrite !in_fsetI andbA. Qed. Lemma fsetIid : idempotent (@fsetI T). Proof. by move=> s; apply/eq_fset=> x; rewrite !in_fsetI andbb. Qed. Lemma fset0I : left_zero (@fset0 T) fsetI. Proof. by move=> s; apply/eq_fset=> x; rewrite in_fsetI !in_fset0. Qed. Lemma fsetI0 : right_zero (@fset0 T) fsetI. Proof. by move=> s; apply/eq_fset=> x; rewrite in_fsetI andbF. Qed. Lemma fsetUIl : left_distributive (@fsetU T) fsetI. Proof. by move=> s1 s2 s3; apply/eq_fset=> x; rewrite !(in_fsetU,in_fsetI) !orb_andl. Qed. Lemma fsetUIr : right_distributive (@fsetU T) fsetI. Proof. by move=> s1 s2 s3; apply/eq_fset=> x; rewrite !(in_fsetU,in_fsetI) !orb_andr. Qed. Lemma fsetIUl : left_distributive (@fsetI T) fsetU. Proof. by move=> s1 s2 s3; apply/eq_fset=> x; rewrite !(in_fsetU,in_fsetI) !andb_orl. Qed. Lemma fsetIUr : right_distributive (@fsetI T) fsetU. Proof. by move=> s1 s2 s3; apply/eq_fset=> x; rewrite !(in_fsetU,in_fsetI) !andb_orr. Qed. Lemma fsubsetIl s1 s2 : s1 :&: s2 :<=: s1. Proof. by apply/fsubsetP=> x /fsetIP []. Qed. Lemma fsubsetIr s1 s2 : s1 :&: s2 :<=: s2. Proof. by apply/fsubsetP=> x /fsetIP []. Qed. Lemma fsubsetI s1 s2 s3 : s1 :<=: s2 :&: s3 = (s1 :<=: s2) && (s1 :<=: s3). Proof. apply/(sameP idP)/(iffP idP). move=> /andP [/fsubsetP h2 /fsubsetP h3]; apply/fsubsetP=> x hx. by apply/fsetIP; eauto. by move=> /fsubsetP=> h; apply/andP; split; apply/fsubsetP=> x /h/fsetIP [??]. Qed. Lemma fsubIset s1 s2 s3 : (s1 :<=: s3) || (s2 :<=: s3) -> s1 :&: s2 :<=: s3. Proof. by case/orP=> [/fsubsetP h|/fsubsetP h]; apply/fsubsetP=> x /fsetIP[]; eauto. Qed. Lemma fsetIS s1 s2 s3 : s1 :<=: s2 -> s3 :&: s1 :<=: s3 :&: s2. Proof. by rewrite fsubsetI fsubsetIl /= => s1s2; rewrite fsubIset // s1s2 orbT. Qed. Lemma fsetSI s1 s2 s3 : s1 :<=: s2 -> s1 :&: s3 :<=: s2 :&: s3. Proof. by rewrite 2!(fsetIC _ s3); apply: fsetIS. Qed. Lemma fsetISS s1 s2 s3 s4 : s1 :<=: s2 -> s3 :<=: s4 -> s1 :&: s3 :<=: s2 :&: s4. Proof. move=> sub1 sub2; rewrite (fsubset_trans (fsetIS _ sub2)) //. by rewrite fsetSI. Qed. Lemma fsetIidPl s1 s2 : reflect (s1 :&: s2 = s1) (s1 :<=: s2). Proof. apply: (iffP fsubsetP) => [sAB | <- x /fsetIP[] //]. apply/eq_fset=> x; rewrite in_fsetI; apply: andb_idr; exact: sAB. Qed. Lemma fsetIidPr s1 s2 : reflect (s1 :&: s2 = s2) (s2 :<=: s1). Proof. rewrite fsetIC; exact: fsetIidPl. Qed. Lemma fsetUidPl s1 s2 : reflect (s1 :|: s2 = s1) (s2 :<=: s1). Proof. by rewrite /fsubset fsetUC; apply: eqP. Qed. Lemma fsetUidPr s1 s2 : reflect (s1 :|: s2 = s2) (s1 :<=: s2). Proof. exact: eqP. Qed. Lemma fset1I x s : fset1 x :&: s = if x \in s then fset1 x else fset0. Proof. apply/eq_fset=> x'; rewrite 2!fun_if in_fsetI in_fset1. by case: eqP=> [->|]; case: ifP=> //=. Qed. Lemma fdisjointC : commutative (@fdisjoint T). Proof. by move=> s1 s2; rewrite /fdisjoint fsetIC. Qed. Lemma fdisjointP s1 s2 : reflect (forall x, x \in s1 -> x \notin s2) (s1 :#: s2). Proof. apply/(iffP eqP)=> [e x h1|]. apply/negP=> h2; have: x \in s1 :&: s2 by apply/fsetIP; split. by rewrite e in_fset0. move=> dis; apply/eq_fset=> x; rewrite in_fset0 in_fsetI. by have [h|//] := boolP (x \in s1); rewrite (negbTE (dis _ h)). Qed. Lemma fdisjoint_trans s1 s2 s3 : s1 :<=: s2 -> s2 :#: s3 -> s1 :#: s3. Proof. by move=> /fsubsetP sub /fdisjointP dis; apply/fdisjointP=> x /sub; eauto. Qed. Lemma fdisjoint0s s : fset0 :#: s. Proof. by rewrite /fdisjoint fset0I. Qed. Lemma fdisjoints0 s : s :#: fset0. Proof. by rewrite fdisjointC fdisjoint0s. Qed. Lemma fdisjoints1 s x : s :#: fset1 x = (x \notin s). Proof. apply/fdisjointP; have [ins|nins] /= := boolP (x \in s). by move/(_ _ ins)/fset1P. by move=> x' ins'; apply: contra nins=> /fset1P <-. Qed. Lemma fdisjoint1s s x : fset1 x :#: s = (x \notin s). Proof. by rewrite fdisjointC fdisjoints1. Qed. Lemma in_fsetD x s1 s2 : (x \in s1 :\: s2) = (x \notin s2) && (x \in s1). Proof. by rewrite in_fset_filter. Qed. Lemma in_fsetD1 x s y : (x \in s :\ y) = (x != y) && (x \in s). Proof. by rewrite in_fsetD in_fset1. Qed. Lemma fsetDP x s1 s2 : reflect (x \in s1 /\ x \notin s2) (x \in s1 :\: s2). Proof. rewrite in_fsetD andbC; exact: andP. Qed. Lemma fsetD1P x s y : reflect (x != y /\ x \in s) (x \in s :\ y). Proof. rewrite in_fsetD1; exact/andP. Qed. Lemma fsubDset s1 s2 s3 : s1 :\: s2 :<=: s3 = s1 :<=: s2 :|: s3. Proof. apply/fsubsetP/fsubsetP=> [h x in1|h x ]; move/(_ x): h; rewrite in_fsetD in_fsetU. by rewrite in1 andbT -implyNb=> /implyP. by move=> h /andP [nin2 in1]; move: nin2; apply: implyP; rewrite implyNb; auto. Qed. Lemma fsubD1set s1 x s2 : s1 :\ x :<=: s2 = s1 :<=: x |: s2. Proof. by apply/fsubsetP/fsubsetP=> h x'; move/(_ x'): h; rewrite in_fsetD1 in_fsetU1; case: eqP. Qed. Lemma fsetID s1 s2 : s1 :&: s2 :|: s1 :\: s2 = s1. Proof. apply/eq_fset=> x; rewrite in_fsetU in_fsetI in_fsetD. by rewrite (andbC _ (x \in s1)) -andb_orr orbN andbT. Qed. Lemma fsetDUl : left_distributive (@fsetD T) (@fsetU T). Proof. move=> s1 s2 s3; apply/eq_fset=> x; rewrite !(in_fsetU, in_fsetD). by rewrite andb_orr. Qed. Lemma fsetDUr s1 s2 s3 : s1 :\: (s2 :|: s3) = (s1 :\: s2) :&: (s1 :\: s3). Proof. apply/eq_fset=> x; rewrite !(in_fsetD, in_fsetU, in_fsetI). rewrite negb_or (andbC (x \notin s3)) andbA. rewrite -[in RHS](andbA (x \notin s2)) andbb -!andbA; congr andb. exact: andbC. Qed. Lemma fsetUDr (A B C : {fset T}) : A :|: B :\: C = (A :|: B) :\: (C :\: A). Proof. apply/eq_fset=> x; rewrite !(in_fsetU, in_fsetD). by case: (x \in A). Qed. Lemma fsetDIl s1 s2 s3 : (s1 :&: s2) :\: s3 = (s1 :\: s3) :&: (s2 :\: s3). Proof. by apply/eq_fset=> x; rewrite !(in_fsetD, in_fsetI); case: (x \notin s3). Qed. Lemma fsetIDA s1 s2 s3 : s1 :&: (s2 :\: s3) = (s1 :&: s2) :\: s3. Proof. by apply/eq_fset=> x; rewrite !(in_fsetD, in_fsetI); bool_congr. Qed. Lemma fsetIDAC s1 s2 s3 : (s1 :\: s2) :&: s3 = (s1 :&: s3) :\: s2. Proof. by apply/eq_fset=> x; rewrite !(in_fsetD, in_fsetI) andbA. Qed. Lemma fsetDIr s1 s2 s3 : s1 :\: (s2 :&: s3) = (s1 :\: s2) :|: (s1 :\: s3). Proof. apply/eq_fset=> x. by rewrite !(in_fsetD, in_fsetU, in_fsetI) negb_and andb_orl. Qed. Lemma fsetDDl s1 s2 s3 : (s1 :\: s2) :\: s3 = s1 :\: (s2 :|: s3). Proof. by apply/eq_fset=> x; rewrite !(in_fsetD, in_fsetU) negb_or; bool_congr. Qed. Lemma fsetDDr s1 s2 s3 : s1 :\: (s2 :\: s3) = (s1 :\: s2) :|: (s1 :&: s3). Proof. apply/eq_fset=> x; rewrite !(in_fsetD, in_fsetU, in_fsetI) negb_and negbK. by rewrite orbC andb_orl; do !bool_congr. Qed. Lemma fsetSD s1 s2 s3 : s1 :<=: s2 -> s1 :\: s3 :<=: s2 :\: s3. Proof. move=> /fsubsetP sub; apply/fsubsetP=> x /fsetDP [/sub ??]. by apply/fsetDP; split. Qed. Lemma fsetDS s1 s2 s3 : s1 :<=: s2 -> s3 :\: s2 :<=: s3 :\: s1. Proof. move=> /fsubsetP sub; apply/fsubsetP=> x /fsetDP [hin hnin]. by apply/fsetDP; split=> //; apply: contra hnin; apply: sub. Qed. Lemma fdisjoint_fsetI0 s1 s2 : s1 :#: s2 -> s1 :&: s2 = fset0. Proof. by move=> ?; apply/eqP. Qed. Definition fpick P s := ohead (fset_filter P s). CoInductive fpick_spec (P : pred T) s : option T -> Type := | FPickSome x of P x & x \in s : fpick_spec P s (Some x) | FPickNone of (forall x, x \in s -> ~~ P x) : fpick_spec P s None. Lemma fpickP P s : fpick_spec P s (fpick P s). Proof. rewrite /fpick; case E: (val (fset_filter P s))=> [|x xs] /=. constructor=> x x_in_s; apply/negP => Px. by move: (in_fset_filter P s x); rewrite inE E Px x_in_s. move: (in_fset_filter P s x); rewrite inE E inE eqxx /=. by case/esym/andP=> ??; constructor. Qed. Lemma sizes0 : size (@fset0 T) = 0. Proof. by []. Qed. Lemma sizes1 x : size (fset1 x) = 1. Proof. by []. Qed. Lemma sizesU s1 s2 : s1 :#: s2 -> size (s1 :|: s2) = size s1 + size s2. Proof. move=> dis /=; apply/eqP; move: (size_undup (s1 ++ s2)). rewrite /fsetU [fset]unlock size_sort leq_eqVlt ltn_size_undup cat_uniq. rewrite !uniq_fset /= andbT orbC -implybE size_cat=> /implyP; apply. by apply/hasPn=> x; apply: contraTN; move/fdisjointP: dis; apply. Qed. Lemma sizesU1 x s : size (x |: s) = (x \notin s) + size s. Proof. have [|x_nin] := boolP (x \in s). by rewrite -fsub1set => /fsetUidPr ->. by rewrite sizesU // fdisjointC fdisjoints1. Qed. Lemma sizesD1 x s : size s = (x \in s) + size (s :\ x). Proof. rewrite -[in LHS](fsetID s (fset1 x)) sizesU fsetIC. by rewrite fset1I 2![in LHS]fun_if //=. apply/fdisjointP=> x' /fsetIP [/fset1P -> x_in]. by rewrite in_fsetD in_fset1 eqxx. Qed. Lemma sizesD s1 s2 : size s1 = size (s1 :&: s2) + size (s1 :\: s2). Proof. rewrite -{1}(fsetID s1 s2) sizesU //. apply/fdisjointP => x /fsetIP [x_s1 x_s2]. by rewrite in_fsetD x_s1 x_s2. Qed. Lemma size_fset xs : size (fset xs) <= size xs. Proof. have fsub: {subset fset xs <= xs} by move=> x; rewrite in_fset. exact: (uniq_leq_size (uniq_fset _) fsub). Qed. Lemma uniq_size_fset xs : uniq xs = (size xs == size (fset xs)). Proof. exact: (uniq_size_uniq (uniq_fset _) (fun x => in_fset xs x)). Qed. Lemma fsubset_leq_size s1 s2 : s1 :<=: s2 -> size s1 <= size s2. Proof. elim/fset_ind: s1 s2 => [|x s1 Px IH] s2; first by rewrite leq0n. rewrite fsubU1set sizesU1 (sizesD1 x s2) Px add1n. case/andP=> [-> ]; rewrite ltnS=> /fsubsetP hs1s2. apply: IH; apply/fsubsetP=> x' Hx'; rewrite in_fsetD1 hs1s2 // andbT. by apply: contra Px=> /eqP <-. Qed. Lemma sizes_eq0 s : (size s == 0) = (s == fset0). Proof. case: s / fsetP=> [|x s Px] //; rewrite sizesU1 Px /= add1n eqE /=. by apply/esym/negbTE/eqP=> h; move: (in_fset0 x); rewrite -h in_fsetU1 eqxx. Qed. Lemma fset0Pn s : reflect (exists x, x \in s) (s != fset0). Proof. rewrite -val_eqE; case: s => [[|x xs] Pxs] /=; constructor. by case=> x; rewrite inE /=. by exists x; rewrite inE eqxx. Qed. Lemma fsubset_sizeP s1 s2 : size s1 = size s2 -> reflect (s1 = s2) (s1 :<=: s2). Proof. elim/fset_rect: s1 s2=> [|x s1 Px IH] s2. rewrite sizes0 => /esym/eqP; rewrite sizes_eq0=> /eqP ->. by rewrite fsubsetxx; constructor. rewrite sizesU1 Px add1n fsubU1set => h_size. apply/(iffP idP)=> [/andP [x_in_s2 hs1s2]|]. have ->: s2 = x |: s2 :\ x. apply/eq_fset=> x'; rewrite in_fsetU1 in_fsetD1 orb_andr orbN /=. by have [->|] := altP (x' =P x). congr fsetU; apply: IH. by move: h_size; rewrite (sizesD1 x s2) x_in_s2 add1n=> - [?]. apply/fsubsetP=> x' x'_in_s1; rewrite in_fsetD1 (fsubsetP hs1s2) //. by rewrite andbT; apply: contraTN x'_in_s1 => /eqP ->. move=> hs2; rewrite -{}hs2 {s2} in h_size *. by rewrite in_fsetU1 eqxx /= fsubsetUr. Qed. Lemma eqEfsubset s1 s2 : (s1 == s2) = (s1 :<=: s2) && (s2 :<=: s1). Proof. apply/(sameP idP)/(iffP idP)=> [|/eqP ->]; last by rewrite fsubsetxx. case/andP=> [/fsubsetP s1s2 /fsubsetP s2s1]; apply/eqP/eq_fset=> x. by apply/(sameP idP)/(iffP idP); eauto. Qed. Lemma eqEfsize s1 s2 : (s1 == s2) = (s1 :<=: s2) && (size s2 <= size s1). Proof. apply/(sameP idP)/(iffP idP)=> [/andP [hsub hsize]|/eqP ->]; last first. by rewrite fsubsetxx leqnn. apply/eqP/fsubset_sizeP=> //; apply/eqP; rewrite eqn_leq hsize andbT. by apply: fsubset_leq_size. Qed. Lemma fsub0set s : fset0 :<=: s. Proof. by rewrite /fsubset fset0U. Qed. Lemma fsubset0 s : s :<=: fset0 = (s == fset0). Proof. by rewrite eqEfsize sizes0 andbT. Qed. Lemma fsubset1 x s : s :<=: fset1 x = (s == fset1 x) || (s == fset0). Proof. rewrite eqEfsize /= -sizes_eq0 orbC andbC. by case: posnP => // /eqP; rewrite sizes_eq0 => /eqP ->; rewrite fsub0set. Qed. Lemma fsetU_eq0 s1 s2 : (s1 :|: s2 == fset0) = (s1 == fset0) && (s2 == fset0). Proof. by rewrite -!fsubset0 fsubUset. Qed. Lemma fdisjointUl s1 s2 s3 : s1 :|: s2 :#: s3 = (s1 :#: s3) && (s2 :#: s3). Proof. by rewrite /fdisjoint fsetIUl -fsubset0 fsubUset 2!fsubset0. Qed. Lemma fdisjointUr s1 s2 s3 : s1 :#: s2 :|: s3 = (s1 :#: s2) && (s1 :#: s3). Proof. by rewrite /fdisjoint fsetIUr -fsubset0 fsubUset 2!fsubset0. Qed. Lemma fset0D s : fset0 :\: s = fset0. Proof. by apply/eq_fset=> x; rewrite in_fsetD andbF. Qed. Lemma fsetD0 s : s :\: fset0 = s. Proof. by apply/eq_fset=> x; rewrite in_fsetD. Qed. Lemma fsetDv s : s :\: s = fset0. Proof. by apply/eqP; rewrite -fsubset0; apply/fsubsetP=> x; rewrite in_fsetD andNb. Qed. Lemma fsetDidPl s1 s2 : reflect (s1 :\: s2 = s1) (s1 :#: s2). Proof. apply/(iffP idP). by move=> /fdisjoint_fsetI0 dis; rewrite -[LHS]fset0U -dis fsetID. by move=> dis; rewrite /fdisjoint -dis fsetIDAC -fsetIDA fsetDv fsetI0 eqxx. Qed. Lemma val_fset_filter (P : T -> bool) (X : {fset T}) : fset_filter P X = filter P X :> seq T. Proof. apply: (sorted_eq (@Ord.lt_trans T)). - move=> x y /andP [/Ord.ltW xy /Ord.ltW yx]. by apply: Ord.anti_leq; rewrite xy. - rewrite /fset_filter /fset unlock /=. exact: FSet.fset_subproof. - rewrite sorted_filter ?valP //. exact: Ord.lt_trans. rewrite uniq_perm ?filter_uniq ?uniq_fset //. by move=> x; rewrite /= in_fset_filter mem_filter. Qed. Lemma fset_filter_subset (P : T -> bool) X : fset_filter P X :<=: X. Proof. by apply/fsubsetP=> x; rewrite in_fset_filter; case/andP. Qed. End Properties. Arguments fsubsetP {_ _ _}. Arguments fdisjointP {_ _ _}. Arguments fset2P {_ _ _}. Arguments fsetIidPl {T s1 s2}. Arguments fsetIidPr {T s1 s2}. Arguments fsetUidPl {T s1 s2}. Arguments fsetUidPr {T s1 s2}. Arguments fsetDidPl {T s1 s2}. Section setOpsAlgebra. Import Monoid. Variable T : ordType. HB.instance Definition _ := isComLaw.Build {fset T} fset0 fsetU (@fsetUA T) (@fsetUC T) (@fset0U T). End setOpsAlgebra. Notation "\bigcup_ ( i <- r | P ) F" := (\big[@fsetU _/fset0]_(i <- r | P) F%fset) : fset_scope. Notation "\bigcup_ ( i <- r ) F" := (\big[@fsetU _/fset0]_(i <- r) F%fset) : fset_scope. Notation "\bigcup_ ( m <= i < n | P ) F" := (\big[@fsetU _/fset0]_(m <= i < n | P%B) F%fset) : fset_scope. Notation "\bigcup_ ( m <= i < n ) F" := (\big[@fsetU _/fset0]_(m <= i < n) F%fset) : fset_scope. Notation "\bigcup_ ( i | P ) F" := (\big[@fsetU _/fset0]_(i | P%B) F%fset) : fset_scope. Notation "\bigcup_ i F" := (\big[@fsetU _/fset0]_i F%fset) : fset_scope. Notation "\bigcup_ ( i : t | P ) F" := (\big[@fsetU _/fset0]_(i : t | P%B) F%fset) (only parsing): fset_scope. Notation "\bigcup_ ( i : t ) F" := (\big[@fsetU _/fset0]_(i : t) F%fset) (only parsing) : fset_scope. Notation "\bigcup_ ( i < n | P ) F" := (\big[@fsetU _/fset0]_(i < n | P%B) F%fset) : fset_scope. Notation "\bigcup_ ( i < n ) F" := (\big[@fsetU _/fset0]_ (i < n) F%fset) : fset_scope. Notation "\bigcup_ ( i 'in' A | P ) F" := (\big[@fsetU _/fset0]_(i in A | P%B) F%fset) : fset_scope. Notation "\bigcup_ ( i 'in' A ) F" := (\big[@fsetU _/fset0]_(i in A) F%fset) : fset_scope. Section BigSetOps. Local Open Scope fset_scope. Section General. Variable T : ordType. Variable I : eqType. Implicit Types (U : pred T) (P : pred I) (F : I -> {fset T}). Lemma bigcup_sup j s P F : j \in s -> P j -> F j :<=: \bigcup_(i <- s | P i) F i. Proof. elim: s=> [|j' s IH] //=; rewrite inE=> /orP [/eqP <-|]; rewrite big_cons. by move=> ->; rewrite fsubsetUl. case: ifP => // _ {}/IH IH {}/IH IH. by rewrite (fsubset_trans IH) // fsubsetUr. Qed. CoInductive bigcup_spec x (s : seq I) P F : Prop := | BigCupSpec i of i \in s & P i & x \in F i. Lemma bigcupP x s P F : reflect (bigcup_spec x s P F) (x \in \bigcup_(i <- s | P i) F i). Proof. apply/(iffP idP)=> [|[i Ps Pi]]; last first. apply: fsubsetP x; exact: bigcup_sup. elim: s=> [|i s IH]; first by rewrite big_nil. rewrite big_cons; case: ifP=> [Pi /fsetUP [x_in|]|_]. - by apply: BigCupSpec; eauto; rewrite inE eqxx. - case/IH=> [i' i'_in Pi' x_in]; apply: BigCupSpec; eauto. by rewrite inE i'_in orbT. case/IH=> [i' i'_in Pi' x_in]; apply: BigCupSpec; eauto. by rewrite inE i'_in orbT. Qed. End General. Arguments bigcupP {_ _ _ _ _ _}. Section Finite. Variable T : ordType. Variable I : finType. Implicit Types (U : pred T) (P : pred I) (F : I -> {fset T}). Lemma bigcup_fin_sup j P F : P j -> F j :<=: \bigcup_(i | P i) F i. Proof. by apply: bigcup_sup; rewrite mem_index_enum. Qed. Lemma bigcup_finP x P F : reflect (exists2 i, P i & x \in F i) (x \in \bigcup_(i | P i) F i). Proof. apply/(iffP bigcupP)=> [[i _ Pi x_in]|[i Pi x_in]]; eauto. by econstructor; eauto. Qed. End Finite. End BigSetOps. Arguments bigcupP {_ _ _ _ _ _}. Section Image. Variables T S : ordType. Implicit Type s : {fset T}. Local Open Scope fset_scope. Definition imfset (f : T -> S) s := fset (map f s). Local Notation "f @: s" := (imfset f s) (at level 24). Lemma imfsetP f s x : reflect (exists2 y, y \in s & x = f y) (x \in f @: s). Proof. apply/(iffP idP). rewrite /imfset in_fset=> /mapP [y Py ->]. by eexists; eauto. move=> [y Py {x}->]; rewrite /imfset in_fset. by apply/mapP; eauto. Qed. Arguments imfsetP {_ _ _}. Lemma eq_imfset f1 f2 : f1 =1 f2 -> imfset f1 =1 imfset f2. Proof. move=> h_f s; apply/eq_fset=> x. by apply/(sameP idP)/(iffP idP)=> /imfsetP [y Py ->]; apply/imfsetP; eexists; eauto. Qed. Lemma eq_in_imfset f1 f2 s : {in s, f1 =1 f2} -> f1 @: s = f2 @: s. Proof. move=> h_f; apply/eq_fset=> x. apply/(sameP idP)/(iffP idP)=> /imfsetP [y Py ->]; apply/imfsetP; eexists; eauto. by apply/esym/h_f. Qed. Lemma mem_imfset f x s : x \in s -> f x \in f @: s. Proof. by move=> Px; apply/imfsetP; eauto. Qed. Lemma imfset0 f : f @: fset0 = fset0. Proof. by rewrite /imfset [fset]unlock /=; apply/val_inj. Qed. Lemma imfset1 f x : f @: fset1 x = fset1 (f x). Proof. by apply/eq_fset=> y; rewrite in_fset1 /imfset in_fset /= inE. Qed. Lemma imfsetU f s1 s2 : f @: (s1 :|: s2) = f @: s1 :|: f @: s2. Proof. apply/eq_fset=> y; apply/(sameP idP)/(iffP idP)=> [/fsetUP|/imfsetP]. move=> [|] => /imfsetP [x' x'_in_s ->{y}]; apply/imfsetP; exists x'=> //; apply/fsetUP; eauto. by move=> [y' /fsetUP [?|?] -> {y}]; apply/fsetUP; [left|right]; apply/imfsetP; eauto. Qed. Lemma imfsetU1 f x s : f @: (x |: s) = f x |: f @: s. Proof. by rewrite imfsetU imfset1. Qed. Lemma imfsetI f s1 s2 : {in s1 & s2, injective f} -> f @: (s1 :&: s2) = f @: s1 :&: f @: s2. Proof. move=> inj; apply/eq_fset=> x; apply/imfsetP/fsetIP. case=> [{}x x_in ->]; case/fsetIP: x_in=> [x_in1 x_in2]. by apply/andP; rewrite ?mem_imfset. case=> [/imfsetP [y1 y1_in ->] /imfsetP [y2 y2_in]] e. by exists y1; rewrite // in_fsetI y1_in /= (inj _ _ y1_in y2_in e). Qed. Lemma imfset_fset f xs : f @: fset xs = fset [seq f x | x <- xs]. Proof. apply/eq_fset=> x; rewrite in_fset. apply/(sameP imfsetP)/(iffP mapP). - by case=> {}x xin ->; exists x; rewrite ?in_fset. - by case=> {}x xin ->; exists x; rewrite -1?in_fset. Qed. Lemma imfset_eq0 f X : (f @: X == fset0) = (X == fset0). Proof. apply/(sameP idP)/(iffP idP)=> [/eqP ->|]; first by rewrite imfset0. apply: contraTT; case/fset0Pn=> x xX; apply/fset0Pn; exists (f x). by rewrite mem_imfset. Qed. (* TODO Find a notation for this *) Definition pimfset (f : T -> option S) X : {fset S} := fset (pmap f X). End Image. Notation "f @: s" := (imfset f s) (at level 24) : fset_scope. Prenex Implicits imfset. Arguments imfsetP {_ _ _ _ _}. Section ImageProps. Local Open Scope fset_scope. Variables T S R : ordType. Implicit Types (s : {fset T}) (f : T -> S) (g : S -> R). Lemma imfset_id s : id @: s = s. Proof. apply/eq_fset=> x; apply/(sameP idP)/(iffP idP). by move=> x_in; apply/imfsetP; eauto. by case/imfsetP=> [/= ? ? ->]. Qed. Lemma imfset_comp f g s : (g \o f) @: s = g @: (f @: s). Proof. apply/eq_fset=> x; apply/(sameP idP)/(iffP idP). case/imfsetP=> [y /imfsetP [z Pz ->] ->]. by apply/imfsetP; eauto. case/imfsetP=> [y /= Py ->]; apply/imfsetP; exists (f y)=> //. exact: mem_imfset. Qed. Lemma imfsetK f f_inv : cancel f f_inv -> cancel (imfset f) (imfset f_inv). Proof. move=> fK s; apply/eq_fset=> x; apply/(sameP idP)/(iffP idP). move=> x_in; apply/imfsetP; exists (f x); first by apply mem_imfset. by rewrite fK. case/imfsetP=> [y /imfsetP [z Pz ->] ->]. by rewrite fK. Qed. Lemma imfset_inj f : injective f -> injective (imfset f). Proof. move=> f_inj s1 s2 e; apply/eq_fset=> x; apply/(sameP idP)/(iffP idP). by move=> /(mem_imfset f); rewrite -{}e=> /imfsetP [y Py /f_inj ->]. by move=> /(mem_imfset f); rewrite {}e=> /imfsetP [y Py /f_inj ->]. Qed. Lemma imfsetS f s1 s2 : s1 :<=: s2 -> f @: s1 :<=: f @: s2. Proof. move/fsubsetP=> h_sub; apply/fsubsetP=> x /imfsetP [y /h_sub Py ->]. by apply: mem_imfset. Qed. Lemma mem_imfset_can f f_inv x s : cancel f f_inv -> cancel f_inv f -> (x \in f @: s) = (f_inv x \in s). Proof. move=> fK fKV; apply/(sameP idP)/(iffP idP). by move=> h_x; apply/imfsetP; eexists; eauto. by case/imfsetP=> [y Py ->]; rewrite fK. Qed. Lemma mem_imfset_inj f y s : injective f -> (f y \in f @: s) = (y \in s). Proof. move=> f_inj; apply/(sameP imfsetP)/(iffP idP); first by eauto. by move=> [y' Py' /f_inj ->]. Qed. Lemma size_imfset f s : size (f @: s) <= size s. Proof. by rewrite /imfset (leq_trans (size_fset (map f s))) // size_map. Qed. Lemma imfset_injP f s : reflect {in s &, injective f} (size (f @: s) == size s). Proof. elim/fset_rect: s => [|x s Px IH]; first by rewrite imfset0 eqxx; constructor. rewrite imfsetU1 !sizesU1 Px add1n /=; apply/(iffP idP). have [hin|hnin] /= := boolP (f x \in _). by rewrite add0n=> /eqP him; move: (size_imfset f s); rewrite him ltnn. rewrite add1n eqSS => /IH hinj y1 y2 /fsetU1P[->{y1}|hy1] /fsetU1P[->{y2}|hy2] //=; last by eauto. by move=> hfx; rewrite hfx (mem_imfset f hy2) in hnin. by move=> hfx; rewrite -hfx (mem_imfset f hy1) in hnin. move=> hinj; have /IH/eqP ->: {in s &, injective f}. by move=> y1 y2 hy1 hy2 /=; apply:hinj; apply/fsetU1P; auto. suff ->: f x \notin f @: s by []. apply: contra Px=> /imfsetP [x' Px' hfx']; suff -> : x = x' by []. by apply: hinj _ _ hfx'; apply/fsetU1P; auto. Qed. Lemma in_pimfset (f : T -> option S) (X : {fset T}) y : y \in (pimfset f X) = (Some y \in f @: X). Proof. rewrite /pimfset in_fset mem_pmap. by apply/(sameP mapP)/(iffP imfsetP). Qed. Lemma pimfsetP(f : T -> option S) (X : {fset T}) y : reflect (exists2 x, x \in X & f x = Some y) (y \in pimfset f X). Proof. rewrite in_pimfset; apply/(iffP imfsetP); case=> ??. - by move=> ->; eauto. - by move=> <-; eauto. Qed. End ImageProps. Section Powerset. Local Open Scope fset_scope. Variable T : ordType. Implicit Types (x : T) (s : {fset T}). Definition powerset s := fset [seq fset (mask (val m) s) | m : (size s).-tuple bool <- enum predT]. Lemma powersetE s1 s2 : (s1 \in powerset s2) = s1 :<=: s2. Proof. rewrite /powerset in_fset; apply/(sameP mapP)/(iffP idP). move=> /fsubsetP s12. exists [tuple of [seq x \in s1 | x <- in_tuple s2]]. by rewrite mem_enum. apply/eq_fset => x; rewrite in_fset -filter_mask mem_filter /=. by have [/s12|] := boolP (x \in s1). case=> m _ -> {s1}; apply/fsubsetP => x; rewrite in_fset; exact: mem_mask. Qed. Lemma powersetS s1 s2 : powerset s1 :<=: powerset s2 = s1 :<=: s2. Proof. apply/(sameP fsubsetP)/(iffP idP). - move=> s1s2 s3; rewrite !powersetE => sub'; exact: fsubset_trans s1s2. - move/(_ s1); rewrite !powersetE; apply; exact: fsubsetxx. Qed. Lemma powerset0 : powerset fset0 = fset1 fset0. Proof. by apply/eq_fset=> s; rewrite powersetE fsubset0 in_fset1. Qed. Lemma powerset1 x : powerset (fset1 x) = [fset fset1 x; fset0]. Proof. by apply/eq_fset=> s; rewrite in_fset2 powersetE fsubset1. Qed. End Powerset. Section SetSplitting. Variables (T : ordType). Implicit Types X : {fset T}. Definition splits X := if val X is x :: xs then Some (x, fset xs) else None. End SetSplitting. Section BigOp. Variables (R : Type) (idx : R) (op : Monoid.com_law idx). Local Notation "1" := idx. Local Notation "*%M" := op (at level 0). Local Notation "x * y" := (op x y). Local Open Scope fset_scope. Section Basic. Variables (I : ordType) (J : Type). Variables (F : I -> R) (G : J -> {fset I}). Implicit Types (x y : I) (X Y : {fset I}) (P : pred I). Lemma big_fsetU1 x X P : x \notin X -> let y := \big[op/idx]_(i <- X | P i) F i in \big[op/idx]_(i <- x |: X | P i) F i = if P x then op (F x) y else y. Proof. move=> x_X. have e: perm_eq (x |: X) (x :: X). apply: uniq_perm; rewrite /= ?x_X ?uniq_fset // => x'. by rewrite inE in_fsetU1. by rewrite /= (perm_big _ e) big_cons. Qed. Lemma big_fsetU X Y P : X :#: Y -> \big[*%M/1]_(x <- X :|: Y | P x) F x = (\big[*%M/1]_(x <- X | P x) F x) * (\big[*%M/1]_(x <- Y | P x) F x). Proof. elim/fset_ind: X=> [|x X x_X IH]. by rewrite fset0U big_nil Monoid.mul1m. rewrite fdisjointUl fdisjoint1s; case/andP=> x_Y dis. rewrite -fsetUA !big_fsetU1 ?in_fsetU ?negb_or ?x_X ?IH //. by case: (P x)=> //; rewrite Monoid.mulmA. Qed. End Basic. End BigOp. Section BigOpIdempotent. Variables (R : Type) (idx : R). Local Notation "1" := idx. Variable op : Monoid.com_law 1. Local Notation "*%M" := op (at level 0). Local Notation "x * y" := (op x y). Hypothesis opxx : idempotent op. Local Open Scope fset_scope. Section Basic. Variables (I : ordType) (J : Type). Variables (F : I -> R) (G : J -> {fset I}). Lemma big_idem_fsetU1 i0 s : \big[*%M/1]_(i <- i0 |: s) F i = F i0 * \big[*%M/1]_(i <- s) F i. Proof. have e: i0 |: s =i i0 :: s. by move=> i; rewrite in_fsetU1 [in RHS]inE. by rewrite (eq_big_idem _ _ _ e) /= ?big_cons. Qed. Lemma big_idem_fsetU s1 s2 : \big[*%M/1]_(i <- s1 :|: s2) F i = (\big[*%M/1]_(i <- s1) F i) * (\big[*%M/1]_(i <- s2) F i). Proof. elim/fset_ind: s1 => [|i s1 _ IH]; first by rewrite big_nil 2!Monoid.mul1m. by rewrite -fsetUA !big_idem_fsetU1 // IH Monoid.mulmA. Qed. Lemma big_idem_bigcup s : \big[*%M/1]_(i <- \bigcup_(j <- s) G j) F i = \big[*%M/1]_(j <- s) \big[*%M/1]_(i <- G j) F i. Proof. elim: s => [|j s IH]; first by rewrite 3!big_nil. by rewrite 2!big_cons big_idem_fsetU IH. Qed. End Basic. Section Image. Variables (I J : ordType). Variables (F : I -> R) (G : J -> I). Lemma big_idem_imfset s : \big[*%M/1]_(i <- G @: s) F i = \big[*%M/1]_(i <- s) F (G i). Proof. elim/fset_ind: s => [|j s _ IH]; first by rewrite imfset0 2!big_nil. by rewrite imfsetU1 2!big_idem_fsetU1 IH. Qed. End Image. End BigOpIdempotent. Section BigOpUnion. Local Open Scope fset_scope. Section WithVariables. Variables (I J R : ordType) (P : I -> bool). Variables (F : I -> {fset R}) (G : J -> {fset I}). Lemma bigcup_fsetU1 i0 s : \bigcup_(i <- i0 |: s) F i = F i0 :|: \bigcup_(i <- s) F i. Proof. apply: big_idem_fsetU1; exact: fsetUid. Qed. Lemma bigcup_fsetU s1 s2 : \bigcup_(i <- s1 :|: s2) F i = (\bigcup_(i <- s1) F i) :|: (\bigcup_(i <- s2) F i). Proof. apply: big_idem_fsetU; exact: fsetUid. Qed. Lemma bigcup_bigcup s : \bigcup_(i <- \bigcup_(j <- s) G j) F i = \bigcup_(j <- s) \bigcup_(i <- G j) F i. Proof. apply: big_idem_bigcup; exact: fsetUid. Qed. Lemma bigcupS s X : reflect (forall i : I, i \in s -> P i -> F i :<=: X) (\bigcup_(i <- s | P i) F i :<=: X). Proof. apply/(iffP fsubsetP). - move=> sub i i_s Pi; apply/fsubsetP=> x x_i. by apply: sub; apply/bigcupP; exists i. - move=> FX x /bigcupP [i i_s Pi]; apply/fsubsetP; exact: FX. Qed. Lemma in_bigcup s x : x \in \bigcup_(i <- s | P i) F i = has (fun i => P i && (x \in F i)) s. Proof. elim: s=> [|y s IH] /=; first by rewrite big_nil. by rewrite big_cons; case: ifP; rewrite // in_fsetU IH. Qed. End WithVariables. Lemma bigcup1_cond (T : ordType) (P : T -> bool) s : \bigcup_(x <- s | P x) fset1 x = fset [seq x <- s | P x]. Proof. apply/eq_fset=> x; rewrite in_bigcup in_fset mem_filter. apply/(sameP hasP)/(iffP andP). by case=> Px xs; exists x; rewrite // Px in_fset1 eqxx. by case=> {}x xs /andP [] Px /fset1P ->. Qed. Lemma bigcup1 (T : ordType) (s : seq T) : \bigcup_(x <- s) fset1 x = fset s. Proof. by rewrite bigcup1_cond filter_predT. Qed. End BigOpUnion. extructures-0.4.0/theories/ord.v000066400000000000000000000514211450433063500167130ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype generic_quotient tuple. From deriving Require base. From deriving Require Import deriving. From Coq Require Import ZArith NArith Ascii String. (******************************************************************************) (* Class of types with a decidable total order relation. Its main purpose *) (* is to supply an interface for aggregate structures (sets, maps) that *) (* support extensional equality and executable operations; accordingly, it *) (* sticks to basic constructions and results. *) (* *) (* hasOrd T == a structure of a total order relation on T *) (* hasOrd.Build == the constructor of hasOrd *) (* ordType == a type with a total order relation. *) (* x <= y == order relation of an ordType (Ord.leq in prefix form). *) (* x < y == strict ordering. *) (* *) (* These notations are delimited by the %ord key, and are not open by *) (* default, to avoid conflicts with the standard ordering of nat. Ternary *) (* variants such as x <= y <= z are also available. *) (* Currently, ord is defined as a subclass of choice, in order to simplify *) (* the class hierarchy while supporting the use of generic quotients on *) (* things that involve ordTypes, in particular finite maps. *) (* In addition to instances for basic types such as bool, nat, seq, and *) (* quotients, this file provides infrastructure for defining some derived *) (* instances. *) (* *) (* PcanHasOrd fK == the mixin for T, given f : T -> S and g with S *) (* an ordType and fK : pcancel f g. *) (* CanHasOrd fK == the mixin for T, given f : T -> S and g with S *) (* an ordType and fK : cancel f g. *) (* InjHasOrd fI == the mixin for T, given f : T -> S with S *) (* an ordType and fI : injective f. *) (* [Ord of T by <:] == if T is a subType of S : ordType, this defines *) (* an order structure on T inherited from S *) (* [derive hasOrd for T] == derive an hasOrd mixin for T automatically, *) (* assuming that T is an instance of indType *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* Interface of types with a total order relation. *) Declare Scope ord_scope. Delimit Scope ord_scope with ord. HB.mixin Record hasOrd T := { leq : rel T; leqxx : reflexive leq; leq_trans : transitive leq; anti_leq : antisymmetric leq; leq_total : total leq; }. Module Ord. #[short(type="ordType")] HB.structure Definition Ord := {T of hasOrd T & Choice T}. Definition lt (T : ordType) (x y : T) := leq x y && (x != y). Notation "x <= y" := (leq x y) : ord_scope. Notation "x < y" := (lt x y) : ord_scope. Notation "x <= y <= z" := (leq x y && leq y z) : ord_scope. Notation "x <= y < z" := (leq x y && lt y z) : ord_scope. Notation "x < y <= z" := (lt x y && leq y z) : ord_scope. Notation "x < y < z" := (lt x y && lt y z) : ord_scope. Section Theory. Local Open Scope ord_scope. Variable T : ordType. Implicit Types x y : T. Lemma eq_leq x y : x = y -> x <= y. Proof. by move=> ->; rewrite leqxx. Qed. Lemma ltW (x y : T) : x < y -> x <= y. Proof. by case/andP. Qed. Lemma ltxx (x : T) : (x < x) = false. Proof. by rewrite /lt eqxx andbF. Qed. Lemma lt_trans : transitive (@lt T). Proof. move=> y x z /= /andP [lxy exy] /andP [lyz eyz]. rewrite /lt (@leq_trans _ y) //=. apply: contra eyz; move=> /eqP exz; move: (@anti_leq _ x y). by rewrite -{}exz {z} in lyz * => -> //; apply/andP; split. Qed. Lemma eq_op_leq (x y : T) : (x == y) = (x <= y <= x). Proof. apply/(sameP idP)/(iffP idP); first by move=> /anti_leq ->. by move=> /eqP ->; rewrite leqxx. Qed. Lemma leq_eqVlt (x y : T) : (x <= y) = (x == y) || (x < y). Proof. rewrite /lt; have [<-{y}|] /= := altP (_ =P _); first by rewrite leqxx. by rewrite andbT. Qed. Lemma lt_neqAle (x y : T) : (x < y) = (x != y) && (x <= y). Proof. by rewrite /lt andbC. Qed. Lemma leqNgt x y : (x <= y) = ~~ (y < x). Proof. rewrite /lt. have [lxy|] := boolP (x <= y). have [lyx|gyx] //= := boolP (y <= x). rewrite negbK (@anti_leq _ x y) ?eqxx //. by rewrite lxy lyx. have [->{y}|nyx gyx] /= := altP (y =P x). by rewrite leqxx. by move: (leq_total x y); rewrite (negbTE gyx) /= => ->. Qed. Lemma ltNge x y : (x < y) = ~~ (y <= x). Proof. by rewrite leqNgt negbK. Qed. CoInductive compare_ord x y : bool -> bool -> bool -> Set := | CompareOrdLt of x < y : compare_ord x y true false false | CompareOrdGt of y < x : compare_ord x y false true false | CompareOrdEq of x = y : compare_ord x y false false true. Lemma ltgtP x y : compare_ord x y (x < y) (y < x) (x == y). Proof. rewrite lt_neqAle. have [<- {y}|Hne] //= := altP (_ =P _). by rewrite ltxx; constructor. rewrite ltNge; have [Hl|Hg] := boolP (x <= y); constructor=> //. by rewrite /lt Hl. by rewrite ltNge. Qed. End Theory. Module Exports. HB.reexport. End Exports. End Ord. Export Ord.Exports. Notation "x <= y" := (Ord.leq x y) : ord_scope. Notation "x < y" := (Ord.lt x y) : ord_scope. Notation "x <= y <= z" := (Ord.leq x y && Ord.leq y z) : ord_scope. Notation "x <= y < z" := (Ord.leq x y && Ord.lt y z) : ord_scope. Notation "x < y <= z" := (Ord.lt x y && Ord.leq y z) : ord_scope. Notation "x < y < z" := (Ord.lt x y && Ord.lt y z) : ord_scope. Arguments Ord.leq {_}. Arguments Ord.lt {_}. HB.instance Definition _ := hasOrd.Build nat leqnn leq_trans anti_leq leq_total. Module DerOrdType. Import base. Section OrdType. Variable (T : indChoiceType). Notation n := (Ind.Def.n T). Notation D := (Ind.Def.decl T). Notation arg_class := (arg_class Ord.Ord.sort). Notation arg_inst := (arg_inst n Ord.Ord.sort). Notation arity_inst := (arity_inst n Ord.Ord.sort). Notation sig_inst := (sig_inst n Ord.Ord.sort). Notation decl_inst := (decl_inst n Ord.Ord.sort). Variable (sT : forall i, sig_class Ord.Ord.sort (D i)). Import IndF. Definition leq_branch As (cAs : hlist' arg_class As) : hlist' (type_of_arg (T *F (fun i => T i -> bool))) As -> hlist' (type_of_arg T) As -> bool := @arity_rec _ _ _ (fun a => hlist' (type_of_arg (T *F (fun i => T i -> bool))) a -> hlist' (type_of_arg T) a -> bool) (fun _ _ => true) (fun R As rec x y => if x.(hd) == y.(hd) then rec x.(tl) y.(tl) else (x.(hd) <= y.(hd))%ord) (fun j As rec x y => if x.(hd).1 == y.(hd) then rec x.(tl) y.(tl) else x.(hd).2 y.(hd)) As cAs. Definition leq : forall i, T i -> T i -> bool := rec (fun i args1 => case (fun args2 => match leq_fin (IndF.constr args2) (IndF.constr args1) with | inl e => leq_branch (hnth (sT i) (IndF.constr args1)) (IndF.args args1) (cast (hlist' (type_of_arg T) \o @nth_fin _ _) e (IndF.args args2)) | inr b => ~~ b end)). Lemma refl' i : reflexive (@leq i). Proof. elim/indP: i / => i [j args]. rewrite /leq recE /= -/leq caseE leq_finii /=. elim/arity_ind: {j} _ / (hnth _ _) args=> [[]|R As cAs IH|j As cAs IH] //=. case=> [x args]; rewrite /= eqxx; exact: IH. by case=> [[x xP] args] /=; rewrite eqxx; exact: IH. Qed. Lemma anti' i : antisymmetric (@leq i). Proof. elim/indP: i / => i [xi xargs] y. rewrite -(unrollK y); case: {y} (unroll y)=> [yi yargs]. rewrite /leq !recE -/leq /= !caseE /=. case ie: (leq_fin yi xi) (leq_nat_of_fin yi xi)=> [e|b]. case: xi / e {ie} xargs=> xargs _ /=; rewrite leq_finii /= => h. congr (Roll (IndF.Cons _))=> /=. elim/arity_ind: {yi} (nth_fin yi) / (hnth _ _) xargs yargs h => [[] []|R As cAs IH|j As cAs IH] //=. case=> [x xargs] [y yargs] /=. rewrite eq_sym; case: (altP (_ =P _))=> [-> /IH <-|yx] //. by move=> /Ord.anti_leq e; rewrite e eqxx in yx. case=> [[x xP] xargs] [y yargs] /=. rewrite eq_sym; case: (altP (_ =P _))=> [-> /IH <-|yx /xP e] //. by rewrite e eqxx in yx. case: (leq_fin xi yi) (leq_nat_of_fin xi yi)=> [e|b']. by rewrite e leq_finii in ie. move=> <- <-. have ne: nat_of_fin yi != nat_of_fin xi. by apply/eqP=> /nat_of_fin_inj e; rewrite e leq_finii in ie. by case: ltngtP ne. Qed. Lemma trans' i : transitive (@leq i). Proof. move=> y x z; elim/indP: i / x y z => i' [xi xargs] y z. rewrite -(unrollK y) -(unrollK z). move: (unroll y) (unroll z)=> {y z} [yi yargs] [zi zargs]. rewrite /leq !recE /= -/leq !caseE /=. case: (leq_fin yi xi) (leq_nat_of_fin yi xi)=> [e _|b] //. case: xi / e xargs=> /= xargs. case: (leq_fin zi yi) (leq_nat_of_fin zi yi)=> [e _|b] //. case: yi / e xargs yargs => xargs yargs /=. elim/arity_ind: {zi} _ / (hnth _ _) xargs yargs zargs => [//|R|j] As cAs IH /=. case=> [x xargs] [y yargs] [z zargs] /=. case: (altP (_ =P _)) => [<-|xy]. case: ifP=> // /eqP _; exact: IH. case: (altP (_ =P _)) => [<-|yz]; first by rewrite (negbTE xy). case: (altP (_ =P _)) => [<-|xz]; last exact: Ord.leq_trans. move=> c1 c2; suffices e: x = y by rewrite e eqxx in xy. by have /andP/Ord.anti_leq := conj c1 c2. case=> [[x xP] xargs] [y yargs] [z zargs] /=. case: (altP (x =P y))=> [<-|xy]. case: (altP (x =P z))=> [_|//]; exact: IH. case: (altP (x =P z))=> [<-|yz]. rewrite eq_sym (negbTE xy)=> le1 le2. suffices e : x = y by rewrite e eqxx in xy. by apply: anti'; rewrite le1. case: (altP (_ =P _))=> [<-|_] //; exact: xP. move=> <- {b} ei. case: (leq_fin zi yi) (leq_nat_of_fin zi yi)=> [e _|_ <-]. case: yi / e yargs ei=> /= yargs. by rewrite leq_nat_of_fin; case: (leq_fin zi xi). case: (leq_fin zi xi) (leq_nat_of_fin zi xi)=> [e|_ <-]. by case: xi / e ei xargs; rewrite -ltnNge => /ltnW ->. move: ei; rewrite -!ltnNge; exact: ltn_trans. Qed. Lemma total' i : total (@leq i). Proof. elim/indP: i / => i [xi xargs] y. rewrite -(unrollK y); case: {y} (unroll y)=> [yi yargs]. rewrite /leq !recE /= -/leq !caseE /= (leq_fin_swap xi yi). case: (leq_fin yi xi)=> [e|[] //]. case: xi / e xargs=> /= xargs. elim/arity_ind: {yi} _ / (hnth _ _) xargs yargs=> [[] []|R|j] //= As cAs IH. case=> [x xargs] [y yargs] /=. rewrite eq_sym; case: (altP eqP)=> [{y} _|]; first exact: IH. by rewrite Ord.leq_total. case=> /= [[x xP] xargs] [y yargs] /=. by rewrite eq_sym; case: (altP eqP)=> ?; [apply: IH|apply: xP]. Qed. Definition mixin_for i op (p : @leq i = op) := @hasOrd.Build (T i) op (cast (@reflexive (T i)) p (@refl' i)) (cast (@transitive (T i)) p (@trans' i)) (cast (@antisymmetric (T i)) p (@anti' i)) (cast (@total (T i)) p (@total' i)). End OrdType. Definition pack_for T := [infer indType of T with Ord.Ord.sort as sT n Ts' D cD in fun (Ts : lift_class Choice.sort n) => fun & phant_id Ts' (untag_sort Ts) => fun T_choice & phant_id (lift_class_proj Choice.class Ts) T_choice => let T_ind_choice := @IndChoiceType _ _ _ T_choice sT in fun cD' & phant_id cD cD' => @mixin_for T_ind_choice cD' (Ind.idx sT)]. End DerOrdType. Notation "[ 'derive' 'nored' 'hasOrd' 'for' T ]" := (@DerOrdType.pack_for T _ id _ _ _ _ _ _ id _ id _ id _ id _ id _ id _ erefl) (at level 0) : form_scope. Ltac derive_hasOrd T := let pack := constr:(@DerOrdType.pack_for T _ id _ _ _ _ _ _ id _ id _ id _ id _ id _ id) in match type of pack with | forall op, ?leq = op -> _ => let leq := eval unfold DerOrdType.leq, DerOrdType.leq_branch in leq in let leq := eval deriving_compute in leq in exact (pack leq erefl : hasOrd T) end. Notation "[ 'derive' 'hasOrd' 'for' T ]" := (ltac:(derive_hasOrd T)) (at level 0, format "[ 'derive' 'hasOrd' 'for' T ]") : form_scope. Ltac derive_lazy_hasOrd T := let pack := constr:(@DerOrdType.pack_for T _ id _ _ _ _ _ _ id _ id _ id _ id _ id _ id) in match type of pack with | forall op, ?leq = op -> _ => let leq := eval unfold DerOrdType.leq, DerOrdType.leq_branch in leq in let leq := eval deriving_lazy in leq in exact (pack leq erefl : hasOrd T) end. Notation "[ 'derive' 'lazy' 'hasOrd' 'for' T ]" := (ltac:(derive_hasOrd T)) (at level 0, format "[ 'derive' 'lazy' 'hasOrd' 'for' T ]") : form_scope. #[deprecated(since="extructures 0.4.0", note="Use [derive nored hasOrd for _] instead")] Notation "[ 'derive' 'nored' 'ordMixin' 'for' T ]" := ([derive nored hasOrd for T]) (at level 0) : form_scope. #[deprecated(since="extructures 0.4.0", note="Use [derive hasOrd for _] instead")] Notation "[ 'derive' 'ordMixin' 'for' T ]" := ([derive hasOrd for T]) (at level 0) : form_scope. #[deprecated(since="extructures 0.4.0", note="Use [derive lazy hasOrd for _] instead")] Notation "[ 'derive' 'lazy' 'ordMixin' 'for' T ]" := ([derive lazy hasOrd for T]) (at level 0) : form_scope. Section BasicInstances. Variables T S : ordType. Definition prod_hasOrd := [derive hasOrd for (T * S)%type]. HB.instance Definition _ := prod_hasOrd. Definition sum_hasOrd := [derive hasOrd for (T + S)%type]. HB.instance Definition _ := sum_hasOrd. Definition option_hasOrd := [derive hasOrd for option T]. HB.instance Definition _ := option_hasOrd. Definition seq_hasOrd := [derive hasOrd for seq T]. HB.instance Definition _ := seq_hasOrd. Definition void_hasOrd := [derive hasOrd for void]. HB.instance Definition _ := void_hasOrd. Definition comparison_hasOrd := [derive hasOrd for comparison]. HB.instance Definition _ := comparison_hasOrd. Definition bool_hasOrd := [derive hasOrd for bool]. HB.instance Definition _ := bool_hasOrd. Definition unit_hasOrd := [derive hasOrd for unit]. HB.instance Definition _ := unit_hasOrd. Definition ascii_hasOrd := [derive hasOrd for ascii]. HB.instance Definition _ := ascii_hasOrd. Definition string_hasOrd := [derive hasOrd for string]. HB.instance Definition _ := string_hasOrd. (* NB: These instances use a different ordering than the standard numeric one. *) Definition positive_hasOrd := [derive hasOrd for positive]. HB.instance Definition _ := positive_hasOrd. Definition N_hasOrd := [derive hasOrd for N]. HB.instance Definition _ := N_hasOrd. Definition Z_hasOrd := [derive hasOrd for Z]. HB.instance Definition _ := Z_hasOrd. End BasicInstances. Section TransferOrdType. Variables (T : Type) (eT : ordType) (f : T -> eT). Local Open Scope ord_scope. Local Notation le := (fun x y => f x <= f y). Lemma inj_le_refl : reflexive le. Proof. by move=> x; rewrite /= Ord.leqxx. Qed. Lemma inj_le_trans : transitive le. Proof. by move=> x y z /=; exact: Ord.leq_trans. Qed. Lemma inj_le_anti : injective f -> antisymmetric le. Proof. by move=> f_inj x y /= /Ord.anti_leq /f_inj. Qed. Lemma inj_le_total : total le. Proof. by move=> x y; exact: Ord.leq_total. Qed. Definition InjHasOrd (f_inj : injective f) : hasOrd (inj_type f_inj) := hasOrd.Build (inj_type f_inj) inj_le_refl inj_le_trans (inj_le_anti f_inj) inj_le_total. Definition PcanHasOrd g (fK : pcancel f g) : hasOrd (pcan_type fK) := InjHasOrd (pcan_inj fK). Definition CanHasOrd g (fK : cancel f g) : hasOrd (can_type fK) := InjHasOrd (can_inj fK). End TransferOrdType. #[deprecated(since="extructures 0.4.0", note="Use InjHasOrd")] Notation InjOrdMixin := InjHasOrd. #[deprecated(since="extructures 0.4.0", note="Use PcanHasOrd")] Notation PcanOrdMixin := PcanHasOrd. #[deprecated(since="extructures 0.4.0", note="Use CanHasOrd")] Notation CanOrdMixin := CanHasOrd. (* FIXME: This is not generating an instance for inj_type... *) HB.instance Definition _ (T : choiceType) (S : ordType) (f : T -> S) (f_inj : injective f) : hasOrd (inj_type f_inj) := InjHasOrd f_inj. HB.instance Definition _ (T : choiceType) (S : ordType) (f : T -> S) g (fK : pcancel f g) := PcanHasOrd fK. HB.instance Definition _ (T : choiceType) (S : ordType) (f : T -> S) g (fK : cancel f g) := CanHasOrd fK. HB.instance Definition _ (S : ordType) (P : pred S) (T : subType P) : hasOrd (sub_type T) := PcanHasOrd (@valK _ _ T). Notation "[ 'Ord' 'of' T 'by' <: ]" := (Ord.Ord.copy T%type (sub_type T%type)) (at level 0, format "[ 'Ord' 'of' T 'by' <: ]") : form_scope. #[deprecated(since="extructures 0.4.0", note="Use [Ord of _ by <:] instead")] Notation "[ 'ordMixin' 'of' T 'by' <: ]" := [Ord of T by <:] (at level 0, format "[ 'ordMixin' 'of' T 'by' <: ]") : form_scope. (* FIXME: Why is this generating an instance of eqtype? *) HB.instance Definition _ (T : ordType) (P : pred T) := [Ord of {x | P x} by <:]. HB.instance Definition _ (n : nat) := [Ord of 'I_n by <:]. Section Tagged. Variables (I : ordType) (T_ : I -> ordType). Implicit Types u v : {x : I & T_ x}. Local Open Scope ord_scope. Definition tag_leq u v := (tag u < tag v) || (tag u == tag v) && (tagged u <= tagged_as u v). Lemma tag_leq_refl : reflexive tag_leq. Proof. rewrite /tag_leq. by move=> [i x] /=; rewrite Ord.ltxx eqxx tagged_asE Ord.leqxx. Qed. Lemma tag_leq_trans : transitive tag_leq. Proof. rewrite /tag_leq. move=> [i2 x2] [i1 x1] [i3 x3] /=. case: Ord.ltgtP x2=> [i1i2 x2 _|?|<- {i2} x2] //=. case: Ord.ltgtP x3=> [i2i3 x3 _|?|<- {i3} x3] //=; last by rewrite i1i2. by rewrite (Ord.lt_trans i1i2 i2i3). case: Ord.ltgtP x3=> //= <- {i3} x3; rewrite !tagged_asE. exact: Ord.leq_trans. Qed. Lemma tag_leq_anti : antisymmetric tag_leq. Proof. rewrite /tag_leq. move=> [i1 x1] [i2 x2] /=; rewrite [i2 == i1]eq_sym. case: Ord.ltgtP x2=> //= i1i2; rewrite -{}i1i2 {i2} => x2. by rewrite !tagged_asE => /Ord.anti_leq ->. Qed. Lemma tag_leq_total : total tag_leq. Proof. rewrite /tag_leq. move=> [i1 x1] [i2 x2] /=; rewrite [i2 == i1]eq_sym. by case: Ord.ltgtP x2 => //= <- {i2} x2; rewrite !tagged_asE Ord.leq_total. Qed. HB.instance Definition _ := hasOrd.Build {i : I & T_ i} tag_leq_refl tag_leq_trans tag_leq_anti tag_leq_total. End Tagged. Section EquivQuotOrd. Local Open Scope quotient_scope. Variable T : ordType. Variable e : equiv_rel T. HB.instance Definition _ := Ord.Ord.copy {eq_quot e} (can_type (@reprK _ {eq_quot e})). End EquivQuotOrd. Section TreeOrdType. Variable T : ordType. Implicit Types t : GenTree.tree T. Fixpoint tree_leq t1 t2 := match t1, t2 with | GenTree.Leaf x1, GenTree.Leaf x2 => (x1 <= x2)%ord | GenTree.Leaf x1, _ => true | GenTree.Node n1 s1, GenTree.Leaf _ => false | GenTree.Node n1 s1, GenTree.Node n2 s2 => let fix loop s1 s2 {struct s1} := match s1, s2 with | [::], _ => true | t1 :: s1, [::] => false | t1 :: s1, t2 :: s2 => if t1 == t2 then loop s1 s2 else tree_leq t1 t2 end in (n1 < n2) || (n1 == n2) && loop s1 s2 end. Lemma tree_leq_anti : antisymmetric tree_leq. Proof. elim=> [x1|n1 s1 IH] [x2|n2 s2] //= => [/Ord.anti_leq ->|] //. have [l21|l12] /= := leqP n2 n1. case: eqP=> [->|] //; rewrite eqxx ltnn /= => H. rewrite (_ : s1 = s2) //. elim: s1 s2 IH H {l21 n1 n2} => [|t1 s1 IH] [|t2 s2] //=. case=> anti_t1 {}/IH IH. by rewrite [t2 == _]eq_sym; case: eqP=> [-> /IH ->|_ /anti_t1] //. by rewrite gtn_eqF //= ltnNge ltnW //=. Qed. Lemma tree_leq_refl : reflexive tree_leq. Proof. elim=> [x|n s IH] //=; first exact: Ord.leqxx. apply/orP; right; rewrite eqxx /=. elim: s IH {n}=> /= [|t s IHs [-> /IHs ->]] //. by rewrite eqxx. Qed. Lemma tree_leq_trans : transitive tree_leq. Proof. elim=> [x2|n2 s2 IH] [x1|n1 s1] [x3|n3 s3] //=. exact: Ord.leq_trans. case/orP=> [e12|]. case/orP=> [e23|]; first by rewrite (ltn_trans e12 e23). by case/andP=> [/eqP <-]; rewrite e12. case/andP=> [/eqP <- e12]. case/orP=> [->|/andP [-> e23]] //=. apply/orP; right. elim: s2 s1 s3 IH e12 e23=> [|t2 s2 IH] [|t1 s1] [|t3 s3] //=. case=> t2_trans {}/IH IH. case: ifPn => [/eqP <-|ne12]; first by case: eqP; eauto. case: ifPn => [/eqP <-|ne23]; first by rewrite (negbTE ne12). move: ne12 ne23; case: (t1 =P t3) => [<-|]; last by eauto. move=> ne _ l12 l21; move: (@tree_leq_anti t1 t2) ne; rewrite l12 l21. by move=> /(_ erefl) ->; rewrite eqxx. Qed. Lemma tree_leq_total : total tree_leq. Proof. elim=> [x1|n1 s1 IH] [x2|n2 s2] //=; first exact: Ord.leq_total. case: ltngtP=> //= _. elim: s1 s2 IH {n1 n2}=> [|t1 s1 IH] [|t2 s2] //= [total_t1 {}/IH IH]. by rewrite [t2 == _]eq_sym; case: (t1 =P t2)=> //. Qed. HB.instance Definition _ := hasOrd.Build (GenTree.tree T) tree_leq_refl tree_leq_trans tree_leq_anti tree_leq_total. End TreeOrdType. HB.instance Definition _ (T : ordType) (n : nat) := Ord.Ord.copy (n.-tuple T) (sub_type (n.-tuple T)).