├── .github └── workflows │ └── build-relation-algebra.yml ├── AUTHORS ├── CHANGELOG ├── CONTRIBUTORS ├── COPYING ├── COPYING.LESSER ├── CodeMeta.json ├── Makefile ├── README.md ├── TODO.txt ├── _CoqProject ├── configure ├── coq-relation-algebra.opam ├── description ├── examples ├── compiler_opts.v ├── imp.v └── paterson.v ├── index.html ├── ra.png ├── src ├── META.coq-relation-algebra ├── common.ml ├── common.mli ├── fold.ml ├── fold.mli ├── fold_g.mlg ├── fold_g.mli ├── kat_dec.ml ├── kat_dec.mli ├── kat_reification.ml ├── kat_reification.mli ├── kat_reification_g.mlg ├── kat_reification_g.mli ├── mrewrite.ml ├── mrewrite.mli ├── mrewrite_g.mlg ├── mrewrite_g.mli ├── packed_fold.mlpack ├── packed_kat.mlpack ├── packed_mrewrite.mlpack ├── packed_reification.mlpack ├── plugins.mlpack ├── reification.ml ├── reification.mli ├── reification_g.mlg └── reification_g.mli └── theories ├── all.v ├── atoms.v ├── bmx.v ├── boolean.v ├── common.v ├── comparisons.v ├── denum.v ├── dfa.v ├── factors.v ├── fhrel.v ├── glang.v ├── gregex.v ├── ka_completeness.v ├── kat.v ├── kat_completeness.v ├── kat_reification.v ├── kat_tac.v ├── kat_untyping.v ├── kleene.v ├── lang.v ├── lattice.v ├── level.v ├── lset.v ├── lsyntax.v ├── matrix.v ├── matrix_ext.v ├── monoid.v ├── move.v ├── nfa.v ├── normalisation.v ├── ordinal.v ├── pair.v ├── positives.v ├── powerfix.v ├── prop.v ├── regex.v ├── rel.v ├── relalg.v ├── rewriting.v ├── rewriting_aac.v ├── rmx.v ├── srel.v ├── sums.v ├── sups.v ├── syntax.v ├── traces.v ├── ugregex.v ├── ugregex_dec.v └── untyping.v /.github/workflows/build-relation-algebra.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | - v9.0 8 | pull_request: 9 | branches: 10 | - '**' 11 | 12 | jobs: 13 | build: 14 | runs-on: ubuntu-latest # container actions require GNU/Linux 15 | strategy: 16 | matrix: 17 | image: 18 | - 'rocq/rocq-prover:dev' 19 | - 'rocq/rocq-prover:9.0-rc1' 20 | fail-fast: false 21 | 22 | steps: 23 | - uses: actions/checkout@v2 24 | - uses: coq-community/docker-coq-action@v1 25 | with: 26 | opam_file: 'coq-relation-algebra.opam' 27 | custom_image: ${{ matrix.image }} 28 | 29 | # See also: 30 | # https://github.com/coq-community/docker-coq-action#readme 31 | # https://github.com/erikmd/docker-coq-github-action-demo 32 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Damien Pous 2 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- 1 | == RelationAlgebra 1.7.12 (2025, February 2nd) == 2 | 3 | - compatibility with Rocq 9.0 4 | 5 | == RelationAlgebra 1.7.11 (2024, September 18th) == 6 | 7 | - compatibility with Coq 8.20 8 | 9 | == RelationAlgebra 1.7.10 (2023, October 20th) == 10 | 11 | - compatibility with Coq 8.18 12 | 13 | == RelationAlgebra 1.7.9 (2023, March 17th) == 14 | 15 | - compatibility with Coq 8.17 16 | 17 | == RelationAlgebra 1.7.8 (2022, September 8th) == 18 | 19 | - compatibility with Coq 8.16 20 | - minor fixes, including w.r.t. licensing issues 21 | 22 | == RelationAlgebra 1.7.7 (2022, March 22nd) == 23 | 24 | - compatibility with Coq 8.15 25 | - model of setoid-preserving heterogeneous relations 26 | 27 | == RelationAlgebra 1.7.6 (2021, November 11th) == 28 | 29 | - compatibility with Coq 8.14 30 | - support for idempotency of \cup and \cap when using coq-aac-tactics 31 | 32 | == RelationAlgebra 1.7.5 (2020, December 29th) == 33 | 34 | - compatibility with Coq 8.13 35 | 36 | == RelationAlgebra 1.7.4 (2020, October 20th) == 37 | 38 | - compatibility with Coq 8.11 & 8.12 39 | - optional dependency on coq-aac-tactics (module [rewriting_aac]) 40 | - a few compilation warnings removed 41 | 42 | == RelationAlgebra 1.7.3 (2020, February 27th) == 43 | 44 | - compatibility with Coq 8.11 45 | 46 | == RelationAlgebra 1.7.2 (2020, February 27th) == 47 | 48 | - compatibility with Coq 8.10 49 | 50 | == RelationAlgebra 1.7.1 (2019, February 8th) == 51 | 52 | - compatibility with Coq 8.9 53 | 54 | == RelationAlgebra 1.7 (2018, December 17th) == 55 | 56 | - compatibility with Coq 8.8.2 (intermediate versions for Coq 8.6 and 8.7 can be found on github) 57 | - unicode notations (i.e., "x ≡ y", "x ≦ y", "x⋅y") 58 | - support heterogeneous relations on large types (outside [Set]) 59 | - [fhrel]: heterogeneous relations between finite types 60 | (available if coq-mathcomp-ssreflect is present [optional dependency]) 61 | 62 | == RelationAlgebra 1.6 (2016, May 10th) == 63 | 64 | - minor fix to make it compile with Coq 8.5pl1 65 | 66 | == RelationAlgebra 1.5 (2016, March 4th) == 67 | 68 | - few additions to the [relalg] and [lattice] modules 69 | 70 | == RelationAlgebra 1.4 (2016, February 9th) == 71 | 72 | - distribution through opam, for Coq 8.5.0 73 | - new module [relalg] for standard relation algebra facts and definitions 74 | 75 | == RelationAlgebra 1.3 (2015, July 27th) == 76 | 77 | - distribution through opam, for Coq 8.4pl6 78 | - fixing some notation levels in [sups], [sums] 79 | 80 | == RelationAlgebra 1.2 (2013, February 25th) == 81 | 82 | - make it compile with Coq 8.4pl4 83 | 84 | == RelationAlgebra 1.1 (2013, February 15th) == 85 | 86 | - [paterson]: proof of equivalence of two flowchart schemes, due to Paterson 87 | - [compiler_opts]: added the two missing compiler optimisations 88 | - [imp]: nicer presentation, using a partially shallow embedding 89 | - [move]: tools to easily move subterms inside a product 90 | - [lset]: fixed a typo 91 | 92 | == RelationAlgebra 1.0 (2012, December 16th) == 93 | 94 | First release of the library 95 | 96 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Christian Doczkal (2018-2021) 2 | Insa Stucke (2015-2016) 3 | Coq development team (2013-) 4 | -------------------------------------------------------------------------------- /COPYING.LESSER: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /CodeMeta.json: -------------------------------------------------------------------------------- 1 | { 2 | "@context": "https://doi.org/10.5063/schema/codemeta-2.0", 3 | "type": "SoftwareSourceCode", 4 | "applicationCategory": "Relation algebra", 5 | "author": [ 6 | { 7 | "id": "https://perso.ens-lyon.fr/damien.pous/", 8 | "type": "Person", 9 | "affiliation": { 10 | "type": "Organization", 11 | "name": "Plume team, LIP, CNRS" 12 | }, 13 | "email": "Damien.Pous@ens-lyon.fr", 14 | "familyName": "Pous", 15 | "givenName": "Damien" 16 | } 17 | ], 18 | "codeRepository": "https://github.com/damien-pous/relation-algebra", 19 | "dateCreated": "2012-09-01", 20 | "datePublished": "2012-12-16", 21 | "description": "A modular library about relation algebra, from idempotent semirings to residuated Kleene allegories, including a decision tactic for Kleene algebra with Tests (KAT)", 22 | "keywords": [ 23 | "relation algebra", 24 | "Kleene algebra", 25 | "Kleene algebra with tests", 26 | "automata", 27 | "allegories", 28 | "automation tactics", 29 | "regular expressions", 30 | "Coq", 31 | "Rocq" 32 | ], 33 | "license": "LGPL", 34 | "name": "relation-algebra", 35 | "programmingLanguage": "Coq", 36 | "referencePublication": "https://doi.org/10.1007/978-3-642-39634-2_15" 37 | } 38 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | -include Makefile.coq 2 | 3 | Makefile.coq: 4 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 5 | 6 | cleanall:: clean 7 | rm -f Makefile.coq* depgraph.* */*.d 8 | 9 | depgraph.dot:: 10 | @echo building dependency graph 11 | @echo "digraph {" > $@ 12 | @ls -1 theories/*.v | grep -v theories/all |sed 's#theories/\(.*\)\.v#\1 [URL=".\/html\/RelationAlgebra.\1.html"];#g' >> $@ 13 | @coqdep -f _CoqProject -dyndep no -m src/META.coq-relation-algebra \ 14 | | grep vio \ 15 | | sed 's#: [^ ]*\.v #->{#g' \ 16 | | sed 's#src/META.coq-relation-algebra[ ]*##g' \ 17 | | sed 's/\.vio//g' \ 18 | | sed 's/[ ]*$$/};/g' \ 19 | | sed 's/ /;/g' \ 20 | | sed 's#theories/##g' \ 21 | | sed 's#examples/.*##g' \ 22 | | sed 's#all.*##g' \ 23 | >> $@; 24 | @echo "}" >> $@ 25 | 26 | %.svg: %.dot 27 | tred $< | dot -Tsvg -o $@ 28 | 29 | ## used to use [coqdep -dumpgraph] as follows 30 | # coqdep theories/*.v -dumpgraph depgraph.dot 1>/dev/null 2>/dev/null 31 | # sed -i 's/\[label=\"\([^"]*\)\"]/[label="\1";URL=".\/html\/RelationAlgebra.\1.html"]/g' depgraph.dot 32 | # dot depgraph.dot -Tsvg -o depgraph.svg 33 | 34 | enable-ssr:: 35 | sed -i '/theories\/fhrel\.v/d' _CoqProject 36 | echo "theories/fhrel.v" >>_CoqProject 37 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 38 | 39 | disable-ssr:: 40 | sed -i '/theories\/fhrel\.v/d' _CoqProject 41 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 42 | 43 | enable-aac:: 44 | sed -i '/theories\/rewriting_aac\.v/d' _CoqProject 45 | echo "theories/rewriting_aac.v" >>_CoqProject 46 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 47 | 48 | disable-aac:: 49 | sed -i '/theories\/rewriting_aac\.v/d' _CoqProject 50 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Relation Algebra for Rocq 3 | 4 | Webpage of the project: http://perso.ens-lyon.fr/damien.pous/ra 5 | 6 | 7 | ## DESCRIPTION 8 | 9 | This Rocq development is a modular library about relation algebra: 10 | those algebras admitting heterogeneous binary relations as a model, 11 | ranging from partially ordered monoid to residuated Kleene allegories 12 | and Kleene algebra with tests (KAT). 13 | 14 | This library presents this large family of algebraic theories in a 15 | modular way; it includes several high-level reflexive tactics: 16 | - [kat], which decides the (in)equational theory of KAT; 17 | - [hkat], which decides the Hoare (in)equational theory of KAT 18 | (i.e., KAT with Hoare hypotheses); 19 | - [ka], which decides the (in)equational theory of KA; 20 | - [ra], a normalisation based partial decision procedure for Relation 21 | algebra; 22 | - [ra_normalise], the underlying normalisation tactic. 23 | 24 | The tactic for Kleene algebra with tests is obtained by reflection, 25 | using a simple bisimulation-based algorithm working on the appropriate 26 | automaton of partial derivatives, for the generalised regular 27 | expressions corresponding to KAT. 28 | 29 | Combined with a formalisation of KA completeness, and then of KAT 30 | completeness on top of it, this provides entirely axiom-free decision 31 | procedures for all model of these theories (including relations, 32 | languages, traces, min-max and max-plus algebras, etc...). 33 | 34 | Algebraic structures are generalised in a categorical way: composition 35 | is typed like in categories, allowing us to reach "heterogeneous" 36 | models like rectangular matrices or heterogeneous binary relations, 37 | where most operations are partial. We exploit untyping theorems to 38 | avoid polluting decision algorithms with these additional typing 39 | constraints. 40 | 41 | 42 | ## APPLICATIONS 43 | 44 | We give a few examples of applications of this library to program 45 | verification: 46 | - a formalisation of a paper by Dexter Kozen and Maria-Cristina Patron. 47 | showing how to certify compiler optimisations using KAT. 48 | - a formalisation of the IMP programming language, followed by: 1/ some 49 | simple program equivalences that become straightforward to prove 50 | using our tactics; 2/ a formalisation of Hoare logic rules for partial 51 | correctness in the above language: all rules except the assignation one 52 | are proved by a single call to the hkat tactic. 53 | - a proof of the equivalence of two flowchart schemes, due to 54 | Paterson. The informal paper proof takes one page; Allegra Angus and 55 | Dexter Kozen gave a six pages long proof using KAT; our Rocq proof is 56 | about 100 lines. 57 | 58 | 59 | ## INSTALLATION 60 | 61 | The easiest way to install this library is via OPAM. For the current 62 | stable release of Rocq, the library can be installed directly through 63 | the `released` repository: 64 | ``` 65 | opam repo add coq-released https://coq.inria.fr/opam/released 66 | opam install coq-relation-algebra 67 | ``` 68 | Otherwise, use the provided opam file using `opam pin add .` (from the project directory) 69 | 70 | To compile manually use `./configure --enable-ssr` to enable building 71 | the finite types model (requires `coq-mathcomp-ssreflect`). Also use `--enable-aac` to enable building the bridge with AAC rewriting tactics (requires `coq-aac-tactics`). 72 | Then compile using `make` and install using `make install`. 73 | 74 | 75 | ## DOCUMENTATION 76 | 77 | Each module is documented, see index.html or 78 | http://perso.ens-lyon.fr/damien.pous/ra 79 | for: 80 | - a description of each module's role and dependencies 81 | - a list of the available user-end tactics 82 | - the coqdoc generated documentation. 83 | 84 | 85 | ## LICENSE 86 | 87 | This library is free software: you can redistribute it and/or modify 88 | it under the terms of the GNU Lesser General Public License as 89 | published by the Free Software Foundation, either version 3 of the 90 | License, or (at your option) any later version. 91 | 92 | This library is distributed in the hope that it will be useful, but 93 | WITHOUT ANY WARRANTY; without even the implied warranty of 94 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 95 | Lesser General Public License for more details. 96 | 97 | You should have received a copy of the GNU Lesser General Public 98 | License along with this library. If not, see 99 | . 100 | 101 | 102 | ## AUTHORS 103 | 104 | * Main author 105 | - Damien Pous (2012-), CNRS - LIP, ENS Lyon (UMR 5668), France 106 | 107 | * Additional authors 108 | - Christian Doczkal (2018-), CNRS - LIP, ENS Lyon (UMR 5668), France 109 | - Insa Stucke (2015-2016), Dpt of CS, University of Kiel, Germany 110 | - Coq development team (2013-) 111 | -------------------------------------------------------------------------------- /TODO.txt: -------------------------------------------------------------------------------- 1 | - ssrefleft/self 2 | "_ ^+" defined at level 5 with arguments constr at level 5 3 | vs "_ ^+ _" defined at level 29 with arguments constr at level 29 4 | 5 | 6 | - remove useless ra_ prefixes in src/ files 7 | 8 | - some tutorial file 9 | - dune support ? 10 | 11 | 12 | - exploit universe polymorphism (see file rel.v) 13 | 14 | - rebase lattice.ops on top of a setoid structure ? 15 | 16 | - complete lattice operations / theory ? 17 | 18 | - more efficient decision procedure for KAT 19 | 20 | - KAPT 21 | - tactics for Kleene algebra with top/converse 22 | - tactics for residuals 23 | 24 | - have [ka] work without 0 25 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | # Suppress harmless compiler warnings we can't do anything about. 2 | -arg -w -arg -projection-no-head-constant 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -redundant-canonical-projection 5 | -arg -w -arg -future-coercion-class-field 6 | 7 | -R theories/ RelationAlgebra 8 | -I src/ 9 | 10 | theories/common.v 11 | theories/comparisons.v 12 | theories/positives.v 13 | theories/ordinal.v 14 | theories/denum.v 15 | theories/pair.v 16 | theories/powerfix.v 17 | theories/level.v 18 | theories/lattice.v 19 | theories/monoid.v 20 | theories/kleene.v 21 | theories/factors.v 22 | theories/kat.v 23 | theories/rewriting.v 24 | theories/move.v 25 | theories/lsyntax.v 26 | theories/syntax.v 27 | theories/normalisation.v 28 | theories/prop.v 29 | theories/boolean.v 30 | theories/rel.v 31 | theories/srel.v 32 | theories/lang.v 33 | theories/lset.v 34 | theories/sups.v 35 | theories/sums.v 36 | theories/matrix.v 37 | theories/matrix_ext.v 38 | theories/untyping.v 39 | theories/regex.v 40 | theories/rmx.v 41 | theories/bmx.v 42 | theories/dfa.v 43 | theories/nfa.v 44 | theories/ka_completeness.v 45 | theories/atoms.v 46 | theories/traces.v 47 | theories/glang.v 48 | theories/gregex.v 49 | theories/kat_completeness.v 50 | theories/ugregex.v 51 | theories/ugregex_dec.v 52 | theories/kat_untyping.v 53 | theories/kat_reification.v 54 | theories/kat_tac.v 55 | theories/relalg.v 56 | theories/all.v 57 | 58 | # examples of applications 59 | examples/compiler_opts.v 60 | examples/imp.v 61 | examples/paterson.v 62 | 63 | # plugin files 64 | 65 | ## shared utilities 66 | src/common.ml 67 | src/common.mli 68 | src/plugins.mlpack 69 | 70 | ## the various plugins are packed separately: they don't load the same Coq refs 71 | src/fold.ml 72 | src/fold.mli 73 | src/fold_g.mlg 74 | src/fold_g.mli 75 | src/packed_fold.mlpack 76 | 77 | src/mrewrite.ml 78 | src/mrewrite.mli 79 | src/mrewrite_g.mlg 80 | src/mrewrite_g.mli 81 | src/packed_mrewrite.mlpack 82 | 83 | src/reification.ml 84 | src/reification.mli 85 | src/reification_g.mlg 86 | src/reification_g.mli 87 | src/packed_reification.mlpack 88 | 89 | src/kat_dec.ml 90 | src/kat_dec.mli 91 | src/kat_reification.ml 92 | src/kat_reification.mli 93 | src/kat_reification_g.mlg 94 | src/kat_reification_g.mli 95 | src/packed_kat.mlpack 96 | 97 | src/META.coq-relation-algebra 98 | 99 | # optional theory files are set below, via [configure] script 100 | 101 | # theories/fhrel.v 102 | # theories/rewriting_aac.v 103 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | while [ "$1" != "" ]; do 4 | case "$1" in 5 | --enable-ssr) 6 | echo "theories/fhrel.v" >>_CoqProject 7 | ;; 8 | --disable-ssr) 9 | sed --in-place '/theories\/fhrel\.v/d' _CoqProject || echo "warning: sed failed to remove fhrel.v" 10 | ;; 11 | --enable-aac) 12 | echo "theories/rewriting_aac.v" >>_CoqProject 13 | ;; 14 | --disable-aac) 15 | sed --in-place '/theories\/rewriting_aac\.v/d' _CoqProject || echo "warning: sed failed to remove rewriting_aac.v" 16 | ;; 17 | *) 18 | echo "unknown option" 19 | ;; 20 | esac 21 | shift 22 | done 23 | -------------------------------------------------------------------------------- /coq-relation-algebra.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Relation Algebra and KAT in Rocq" 3 | name: "coq-relation-algebra" 4 | maintainer: "Damien Pous " 5 | #TO SET BEFORE RELEASE 6 | version: "dev" 7 | homepage: "http://perso.ens-lyon.fr/damien.pous/ra/" 8 | dev-repo: "git+https://github.com/damien-pous/relation-algebra.git" 9 | bug-reports: "https://github.com/damien-pous/relation-algebra/issues" 10 | license: "LGPL-3.0-or-later" 11 | depends: [ 12 | "ocaml" 13 | #TO SET BEFORE RELEASE 14 | "coq" {>= "9.0"} 15 | # "coq" {>= "9.0" & < "9.1~"} 16 | #TO REMOVE BEFORE RELEASE (TO MAKE THEM OPTIONAL) 17 | "coq-mathcomp-ssreflect" 18 | "coq-aac-tactics" 19 | ] 20 | #TO SET BEFORE RELEASE 21 | # depopts: [ "coq-mathcomp-ssreflect" "coq-aac-tactics" ] 22 | build: [ 23 | ["sh" "-exc" "./configure --%{coq-mathcomp-ssreflect:enable}%-ssr --%{coq-aac-tactics:enable}%-aac"] 24 | [make "-j%{jobs}%"] 25 | ] 26 | install: [make "install"] 27 | tags: [ 28 | "keyword:relation algebra" 29 | "keyword:kleene algebra with tests" 30 | "keyword:kat" 31 | "keyword:allegories" 32 | "keyword:residuated structures" 33 | "keyword:automata" 34 | "keyword:regular expressions" 35 | "keyword:matrices" 36 | "category:Mathematics/Algebra" 37 | "logpath:RelationAlgebra" ] 38 | authors: [ 39 | "Damien Pous " 40 | "Christian Doczkal " 41 | ] 42 | 43 | 44 | ## CHECK BEFORE RELEASING: 45 | # CHANGELOG 46 | # README.md 47 | # webpage 48 | # above updates to the opam file in coq-opam-archive 49 | -------------------------------------------------------------------------------- /description: -------------------------------------------------------------------------------- 1 | Name: RelationAlgebra 2 | Title: Relation Algebra, Kleene algegra, and KAT 3 | Url: http://perso.ens-lyon.fr/damien.pous/ra/ 4 | Description: A modular library about relation algebra, from idempotent semirings to residuated Kleene allegories, including a decision tactic for Kleene algebra with Tests (KAT). 5 | Keywords: relation algebra, Kleene algebra with tests, KAT, allegories, residuated structures, automata, regular expressions, matrices 6 | Category: Mathematics/Algebra 7 | Author: Damien Pous 8 | Email: Damien.Pous@ens-lyon.fr 9 | Homepage: http://perso.ens-lyon.fr/damien.pous/ 10 | Institution: CNRS, LIP - ENS Lyon - UMR 5668 11 | Require: 12 | License: LGPL 13 | -------------------------------------------------------------------------------- /examples/compiler_opts.v: -------------------------------------------------------------------------------- 1 | (** * compiler_opts: certifying compiler optimisations *) 2 | 3 | (** To illustrate some usage of the kat and hkat tactics, we formalise 4 | most of the compiler optimisations studied in the following paper: 5 | 6 | Dexter Kozen and Maria-Cristina Patron. 7 | Certification of compiler optimizations using Kleene algebra with tests. 8 | In Proc. 1st Int. Conf. Computational Logic (CL2000), 9 | Vol. 1861 of LNAI, pages 568-582, July 2000. Springer-Verlag. 10 | 11 | Most goals are solved with one single call to [kat] or [hkat]. 12 | 13 | The remaining cases correspond to situations where one has to 14 | exploit permutations of some Kleene variables (the Horn theory of 15 | KA with such commutation hypotheses is undecidable). *) 16 | 17 | From RelationAlgebra Require Import kat normalisation rewriting kat_tac. 18 | Set Implicit Arguments. 19 | 20 | (** in this module, we prefer the ";" notation for composition *) 21 | Infix " ;" := (dot _ _ _) (left associativity, at level 40): ra_terms. 22 | 23 | 24 | (** ** preliminary lemmas *) 25 | 26 | Lemma lemma_1 `{L: monoid.laws} `{Hl: BKA ≪ l} n (x y: X n n): 27 | x;y ≡ x;y;x -> x;y^* ≡ x;(y;x)^*. 28 | Proof. 29 | intro H. apply antisym. apply str_ind_r'. ka. 30 | rewrite str_dot, <-dotA. rewrite H at 2. ka. 31 | rewrite str_dot. apply str_ind_l'. ka. 32 | rewrite str_unfold_l. ra_normalise. rewrite <-H. ka. 33 | Qed. 34 | 35 | Lemma lemma_1' `{L: monoid.laws} `{Hl: BKA ≪ l} n (x y: X n n): 36 | y;x ≡ x;(y;x) -> y^*;x ≡ (x;y)^*;x. 37 | Proof. monoid.dual @lemma_1. Qed. 38 | 39 | Lemma lemma_1'' `{L: monoid.laws} `{Hl: BKA ≪ l} n (p q r: X n n): 40 | p;q ≡ q;p -> p;r ≡ r -> (p;q)^*;r ≡ q^*;r. 41 | Proof. 42 | intros Hpq Hpr. apply antisym. 43 | rewrite Hpq. apply str_ind_l'. ka. apply str_move in Hpq. mrewrite Hpq. mrewrite Hpr. ka. 44 | apply str_ind_l'. ka. rewrite <-str_snoc at 2. rewrite Hpq at 2 3. mrewrite Hpr. ka. 45 | Qed. 46 | 47 | Lemma lemma_2 `{L: laws} n b (q: X n n): 48 | [b];q ≡ q;[b] -> [b];q^* ≡ [b];(q;[b])^*. 49 | Proof. hkat. Qed. 50 | 51 | 52 | (** ** 3.1 Deadcode elimination *) 53 | 54 | Lemma opti_3_1_a `{L: laws} n (a: tst n) (p q: X n n): 55 | p ≡ p;[!a] -> p;([a];q+[!a]) ≡ p. 56 | Proof. hkat. Qed. 57 | 58 | Lemma opti_3_1_b `{L: laws} n (a: tst n) (p q: X n n): 59 | p ≡ p;[!a] -> p;([a];q)^*;[!a] ≡ p. 60 | Proof. hkat. Qed. 61 | 62 | 63 | (** ** 3.2 Common sub-expression elimination *) 64 | 65 | Lemma opti_3_2 `{L: laws} n (a b: tst n) (p q r w: X n n): 66 | p ≡ p;[a] -> 67 | [a];q ≡ [a];q;[b] -> 68 | [b];r ≡ [b] -> 69 | r ≡ w;r -> 70 | q;w ≡ w -> 71 | p;q ≡ p;r. 72 | Proof. 73 | intros Hpa Haq Hbr Hr Hw. 74 | rewrite Hr, <-Hw. mrewrite <-Hr. 75 | hkat. 76 | Qed. 77 | 78 | 79 | (** ** 3.3 Copy propagation *) 80 | 81 | Lemma opti_3_3 `{L: laws} n (a b: tst n) (p q r s v w: X n n): 82 | q ≡ q;[a] -> 83 | [a];r ≡ [a];r;[b] -> 84 | [b];s ≡ [b] -> 85 | s ≡ w;s -> 86 | r;w ≡ w -> 87 | s;v ≡ v;s -> 88 | q;v ≡ v -> 89 | p;q;r;v ≡ p;s;v. 90 | Proof. 91 | intros Hqa Har Hbs Hs Hw Hsv Hv. 92 | mrewrite Hsv. rewrite <-Hv at 2. mrewrite <-Hsv. 93 | rewrite Hs, <-Hw. mrewrite <-Hs. 94 | hkat. 95 | Qed. 96 | 97 | 98 | (** ** 3.4 Loop Hoisting *) 99 | 100 | Lemma opti_3_4i `{L: laws} n (a b: tst n) (p q r s u w: X n n): 101 | u;[b] ≡ u -> 102 | [b];u ≡ [b] -> 103 | [b];q ≡ q;[b] -> 104 | [b];s ≡ s;[b] -> 105 | [b];r ≡ r;[b] -> 106 | [a];w ≡ w;[a] -> 107 | u;r ≡ q -> 108 | u;w ≡ w -> 109 | q;s;w ≡ w;q;s -> 110 | p;u;([a];r;s)^*;[!a];w ≡ p;([a];q;s)^*;[!a];w. 111 | Proof. 112 | intros ? ? ? ? ? ? Hur Huw Hqsw. 113 | transitivity (p;u;[b];([a];[b];(u;r);s)^*;[!a];w). hkat. rewrite Hur. 114 | transitivity (p;u;([a];q;s)^*;w;[!a]). hkat. 115 | assert (E: w;([a];q;s)^* ≡ ([a];q;s)^*;w) by (apply str_move; mrewrite Hqsw; hkat). 116 | mrewrite <-E. mrewrite Huw. mrewrite E. hkat. 117 | Qed. 118 | 119 | Lemma opti_3_4ii `{L: laws} n (a: tst n) (p q u w: X n n): 120 | u ≡ w;u -> 121 | u;w ≡ w -> 122 | w;p;q ≡ p;q;w -> 123 | w;[a] ≡ [a];w -> 124 | ([a];u;p;q)^*;[!a];u ≡ ([a];p;q)^*;[!a];u. 125 | Proof. 126 | intros Hwu Huw Hpq Hw. rewrite Hwu at 1 2. transitivity (w;([a];u;(p;q;w))^*;[!a];u). hkat. 127 | rewrite <-Hpq. mrewrite Huw. mrewrite Hpq. rewrite <-lemma_1. 128 | rewrite (str_move (z:=[a];p;q)). rewrite Hwu at 2. hkat. mrewrite <-Hpq. hkat. 129 | mrewrite <-Hpq. rewrite <-Huw at 1. rewrite Hwu. mrewrite Huw. hkat. 130 | (* intros Hwu Huw Hpq Hw. rewrite Hwu at 1 2. transitivity (w;([a];u;(p;q;w))^*;[!a];u). hkat. *) 131 | (* rewrite <-Hpq. mrewrite Huw. mrewrite Hpq. transitivity ((w;[a];p;q)^*;[!a];(w;u)). hkat. *) 132 | (* rewrite <-3dotA, lemma_1'', <-Hwu. ra. mrewrite <-Hpq. hkat. rewrite <-Hwu at 1. hkat. *) 133 | Qed. 134 | 135 | 136 | (** ** 3.5 Induction variable elimination *) 137 | 138 | Lemma opti_3_5 `{L: laws} n (a b c: tst n) (p q r: X n n): 139 | q ≡ q;[b] -> 140 | [b] ≡ [b];q -> 141 | [c];r ≡ [c];r;[b] -> 142 | [b];p ≡ [b];p;[c] -> 143 | [c];q ≡ [c];r -> 144 | q;([a];p;q)^* ≡ q;([a];p;r)^*. 145 | Proof. 146 | intros Hq Hb Hr Hbp Hcq. 147 | assert (E: [b];p;q ≡ [b];p;r) by (rewrite Hbp; mrewrite Hcq; hkat). 148 | transitivity (q;([a];([b];p;q))^*;[b]). hkat. rewrite E. hkat. 149 | Qed. 150 | 151 | 152 | (** ** (3.6 and 3.7 are void) *) 153 | 154 | 155 | (** ** 3.8 Loop unrolling *) 156 | 157 | Lemma lemma_3 `{L: monoid.laws} `{Hl: BKA ≪ l} n (u: X n n): u^* ≡ (1+u);(u;u)^*. 158 | Proof. ka. Qed. 159 | 160 | Lemma opti_3_8 `{L: laws} n a (p: X n n): 161 | ([a];p)^*;[!a] ≡ ([a];p;([a];p+[!a]))^*;[!a]. 162 | Proof. kat. Qed. 163 | 164 | 165 | (** ** 3.9 Redundant loads and stores *) 166 | 167 | Lemma opti_3_9 `{L: laws} n a (p q: X n n): 168 | p ≡ p;[a] -> [a];q ≡ [a] -> p;q ≡ p. 169 | Proof. intros Hp Hq. hkat. Qed. 170 | 171 | 172 | (** ** 3.10 Array bounds check elimination *) 173 | 174 | Lemma opti_3_10'i `{L: laws} n (a b: tst n) (u v p q s: X n n): 175 | u;[a] ≡ u -> 176 | [a ⊓ b];p ≡ p;[a ⊓ b] -> 177 | [a];([b];p;q;v) ≡ ([b];p;q;v);[a] -> 178 | u;([b];p;([a ⊓ b];q+[!(a ⊓ b)];s);v)^*;[!b] ≡ u;([b];p;q;v)^*;[!b]. 179 | Proof. hkat. Qed. 180 | 181 | Lemma opti_3_10' `{L: laws} n (a b c: tst n) (u v p q s: X n n): 182 | a ⊓ b ≡ c -> 183 | u;[a] ≡ u -> 184 | [c];p ≡ p;[c] -> 185 | [a];([b];p;q;v) ≡ ([b];p;q;v);[a] -> 186 | u;([b];p;([c];q+[!c];s);v)^*;[!b] ≡ u;([b];p;q;v)^*;[!b]. 187 | Proof. hkat. Qed. 188 | 189 | 190 | (** ** 3.11 Introduction of sentinels *) 191 | 192 | Lemma opti_3_11 `{L: laws} n (a b c d: tst n) (u p q s t: X n n): 193 | u;[c] ≡ u -> 194 | [c];p ≡ p;[c] -> 195 | [c];q ≡ q;[c] -> 196 | p;[d] ≡ p -> 197 | [a];q;[d] ≡ [a];q -> 198 | c ⊓ d ⊓ b ≦ a -> 199 | u;p;([a ⊓ b];q)^*;[!(a ⊓ b)];([a];t+[!a];s) ≡ u;p;([b];q)^*;[!b];([a];t+[!a];s). 200 | Proof. hkat. Qed. 201 | 202 | (* note that it takes about 2s to solve this last one, thus 203 | illustrating the limits of our very basic algorithm *) 204 | -------------------------------------------------------------------------------- /ra.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/damien-pous/relation-algebra/4db15229396abfd8913685be5ffda4f0fdb593d9/ra.png -------------------------------------------------------------------------------- /src/META.coq-relation-algebra: -------------------------------------------------------------------------------- 1 | package "common" ( 2 | requires = "coq-core.plugins.ltac" 3 | description = "shared utilities for relation algebra plugins" 4 | archive(byte) = "plugins.cma" 5 | archive(native) = "plugins.cmxa" 6 | plugin(byte) = "plugins.cma" 7 | plugin(native) = "plugins.cmxs" 8 | directory = "." 9 | ) 10 | 11 | package "reification" ( 12 | requires = "coq-core.plugins.ltac coq-relation-algebra.common" 13 | description = "reification plugin for relation algebra tactics" 14 | archive(byte) = "packed_reification.cma" 15 | archive(native) = "packed_reification.cmxa" 16 | plugin(byte) = "packed_reification.cma" 17 | plugin(native) = "packed_reification.cmxs" 18 | directory = "." 19 | ) 20 | 21 | package "fold" ( 22 | requires = "coq-core.plugins.ltac coq-relation-algebra.common" 23 | description = "folding plugin for relation algebra" 24 | archive(byte) = "packed_fold.cma" 25 | archive(native) = "packed_fold.cmxa" 26 | plugin(byte) = "packed_fold.cma" 27 | plugin(native) = "packed_fold.cmxs" 28 | directory = "." 29 | ) 30 | 31 | package "mrewrite" ( 32 | requires = "coq-core.plugins.ltac coq-relation-algebra.common" 33 | description = "rewriting modulo A plugin for relation algebra" 34 | archive(byte) = "packed_mrewrite.cma" 35 | archive(native) = "packed_mrewrite.cmxa" 36 | plugin(byte) = "packed_mrewrite.cma" 37 | plugin(native) = "packed_mrewrite.cmxs" 38 | directory = "." 39 | ) 40 | 41 | package "kat" ( 42 | requires = "coq-core.plugins.ltac coq-relation-algebra.common" 43 | description = "KAT reification plugin for relation algebra" 44 | archive(byte) = "packed_kat.cma" 45 | archive(native) = "packed_kat.cmxa" 46 | plugin(byte) = "packed_kat.cma" 47 | plugin(native) = "packed_kat.cmxs" 48 | directory = "." 49 | ) 50 | 51 | directory = "." 52 | -------------------------------------------------------------------------------- /src/fold.ml: -------------------------------------------------------------------------------- 1 | (** Definition of the [ra_fold] tactic, used to fold concrete 2 | Relation algebra expressions *) 3 | 4 | (*i camlp4deps: "parsing/grammar.cma" i*) 5 | (*i camlp4use: "pa_extend.cmo" i*) 6 | 7 | open Plugins.Common 8 | open Constr 9 | open EConstr 10 | open Context.Named.Declaration 11 | open Proofview 12 | 13 | let ra_fold_term env sigma ops ob t = 14 | let _,tops = Typing.type_of env sigma ops in (* FIXME: leak? *) 15 | let rec fill sigma ops tops = 16 | if EConstr.eq_constr sigma tops (Lazy.force Monoid.ops) then (sigma,ops) 17 | else 18 | match kind sigma (Termops.strip_outer_cast sigma tops) with 19 | | Prod(_,s,t) -> 20 | let sigma,x = new_evar env sigma s in 21 | fill sigma (mkApp(ops,[|x|])) t 22 | | _ -> error "provided argument is not a monoid operation" 23 | in 24 | let sigma,ops = fill sigma ops tops in 25 | let sigma = ref sigma in 26 | let obt = Monoid.ob ops in 27 | (* TOTKINK: Use Evarconv.conv ? *) 28 | let unifiable sg env x y = 29 | try sigma := snd @@ Unification.w_unify env sg Conversion.CONV x y; true 30 | with _ -> false 31 | in 32 | 33 | let is_pls env s' t' = is_cup (env,!sigma) max_level (Monoid.mor ops s' t') in 34 | let is_cap env s' t' = is_cap (env,!sigma) max_level (Monoid.mor ops s' t') in 35 | let is_neg env s' t' = is_neg (env,!sigma) max_level (Monoid.mor ops s' t') in 36 | let is_dot env = is_dot (env,!sigma) ops (fun _ -> ()) () in 37 | let is_itr env = is_itr (env,!sigma) max_level ops in 38 | let is_str env = is_str (env,!sigma) max_level ops in 39 | let is_cnv env = is_cnv (env,!sigma) max_level ops in 40 | let is_ldv env = is_ldv (env,!sigma) max_level ops (fun _ -> ()) () in 41 | let is_rdv env = is_rdv (env,!sigma) max_level ops (fun _ -> ()) () in 42 | 43 | (* folding a relation algebra term [e], with domain [s'] and codomain [t'] *) 44 | let rec ra_fold env s' t' e = 45 | let k' _ = 46 | let x = Monoid.one ops s' in 47 | if convertible env !sigma e x then x else 48 | let x = Lattice.bot (Monoid.mor ops s' t') in 49 | if convertible env !sigma e x then x else 50 | let x = Lattice.top (Monoid.mor ops s' t') in 51 | if convertible env !sigma e x then x else 52 | gen_fold env e 53 | in 54 | match kind !sigma (Termops.strip_outer_cast !sigma e) with App(c,ca) -> 55 | (* note that we give priority to dot/one over cap/top 56 | (they coincide on flat structures) *) 57 | is_dot env s' (fun x () r' y -> Monoid.dot ops s' r' t' (ra_fold env s' r' x) (ra_fold env r' t' y)) ( 58 | is_pls env s' t' (fun x y -> Lattice.cup (Monoid.mor ops s' t') (ra_fold env s' t' x) (ra_fold env s' t' y)) ( 59 | is_cap env s' t' (fun x y -> Lattice.cap (Monoid.mor ops s' t') (ra_fold env s' t' x) (ra_fold env s' t' y)) ( 60 | is_neg env s' t' (fun x -> Lattice.neg (Monoid.mor ops s' t') (ra_fold env s' t' x)) ( 61 | is_itr env s' (fun x -> Monoid.itr ops s' (ra_fold env s' s' x)) ( 62 | is_str env s' (fun x -> Monoid.str ops s' (ra_fold env s' s' x)) ( 63 | is_cnv env s' t' (fun x -> Monoid.cnv ops t' s' (ra_fold env t' s' x)) ( 64 | is_ldv env s' (fun x () r' y -> Monoid.ldv ops r' s' t' (ra_fold env r' s' x) (ra_fold env r' t' y)) ( 65 | is_rdv env s' (fun x () r' y -> Monoid.rdv ops r' t' s' (ra_fold env t' r' x) (ra_fold env s' r' y)) ( 66 | k'))))))))) (c,ca,Array.length ca) 67 | | _ -> k' () 68 | 69 | and gen_fold env e = 70 | match kind !sigma (Termops.strip_outer_cast !sigma e) with 71 | | App(c,ca) -> mkApp(c,Array.map (fold env) ca) 72 | | Prod(x,e,f) -> mkProd(x, fold env e, fold (push x e env) f) 73 | | Lambda(x,t,e) -> mkLambda(x, t, fold (push x t env) e) 74 | | LetIn(x,e,t,f) -> mkLetIn(x, fold env e, t, fold (push x t env )f) 75 | | Case(ci,u,pms,t,iv,e,f) -> 76 | let map i (nas, c as br) = 77 | let ctx = expand_branch env !sigma u pms (ci.ci_ind, i + 1) br in 78 | (nas, fold (push_rel_context ctx env) c) 79 | in 80 | mkCase(ci, u, pms, t, iv, fold env e, Array.mapi map f) 81 | | _ -> e 82 | 83 | and fold env e = 84 | let _,t = Typing.type_of env !sigma e in 85 | match ob with 86 | | Some o when convertible env !sigma t (Lattice.car (Monoid.mor ops o o)) -> ra_fold env o o e 87 | | Some o when EConstr.eq_constr !sigma t mkProp -> 88 | (match kind !sigma (Termops.strip_outer_cast !sigma e) with 89 | | App(c,ca) when 2 <= Array.length ca -> 90 | let n = Array.length ca in 91 | let rel = (partial_app (n-2) c ca) in 92 | let lops = Monoid.mor ops o o in 93 | let leq = Lattice.leq1 lops in 94 | let weq = Lattice.weq1 lops in 95 | if unifiable !sigma env rel weq then 96 | mkApp(weq,[|ra_fold env o o ca.(n-2);ra_fold env o o ca.(n-1)|]) else 97 | if unifiable !sigma env rel leq then 98 | mkApp(leq,[|ra_fold env o o ca.(n-2);ra_fold env o o ca.(n-1)|]) else 99 | gen_fold env e 100 | | _ -> gen_fold env e) 101 | | _ when EConstr.eq_constr !sigma t mkProp -> 102 | (match kind !sigma (Termops.strip_outer_cast !sigma e) with 103 | | App(c,ca) when 2 <= Array.length ca -> 104 | let n = Array.length ca in 105 | let rel = (partial_app (n-2) c ca) in 106 | let sg,s = new_evar env !sigma obt in 107 | let sg,t = new_evar env sg obt in 108 | let lops = Monoid.mor ops s t in 109 | let leq = Lattice.leq1 lops in 110 | let weq = Lattice.weq1 lops in 111 | if unifiable sg env rel weq 112 | then mkApp(weq,[|ra_fold env s t ca.(n-2);ra_fold env s t ca.(n-1)|]) 113 | else if unifiable sg env rel leq 114 | then mkApp(leq,[|ra_fold env s t ca.(n-2);ra_fold env s t ca.(n-1)|]) 115 | else gen_fold env e 116 | | _ -> gen_fold env e) 117 | | _ -> 118 | let sg,s' = new_evar env !sigma obt in 119 | let sg,t' = new_evar env sg obt in 120 | if unifiable sg env t (Lattice.car (Monoid.mor ops s' t')) 121 | then ra_fold env s' t' e 122 | else gen_fold env e 123 | in 124 | let t = fold env t in 125 | t,!sigma 126 | 127 | let ra_fold_concl ops ob = Goal.enter (fun goal -> 128 | let env = Tacmach.pf_env goal in 129 | let f,sigma = ra_fold_term env (Tacmach.project goal) ops ob (Tacmach.pf_concl goal) in 130 | Proofview.tclORELSE 131 | (tclTHEN (Unsafe.tclEVARS sigma) (Tactics.convert_concl ~cast:false ~check:true f DEFAULTcast)) 132 | (fun (e, info) -> Feedback.msg_warning (Printer.pr_leconstr_env env sigma f); tclZERO ~info e)) 133 | 134 | let ra_fold_hyp ops ob hyp = 135 | Proofview.Goal.enter begin fun gl -> 136 | let env = Tacmach.pf_env gl in 137 | let sigma = Tacmach.project gl in 138 | let decl = Tacmach.pf_get_hyp hyp gl in 139 | let id,ddef,dtyp = to_tuple decl in 140 | let decl,sigma = 141 | match ddef with 142 | | Some def -> 143 | (* try to fold both the body and the type of local definitions *) 144 | let def,sg = ra_fold_term env sigma ops ob def in 145 | let typ,sigma = ra_fold_term env sg ops ob dtyp in 146 | LocalDef(id,def,typ),sigma 147 | | None -> 148 | (* only fold the type of local assumptions *) 149 | let typ,sigma = ra_fold_term env sigma ops ob dtyp in 150 | LocalAssum(id,typ),sigma 151 | in 152 | tclTHEN (Unsafe.tclEVARS sigma) (Tactics.convert_hyp ~check:true ~reorder:true decl) 153 | end 154 | 155 | let ra_fold_hyps ops ob = 156 | List.fold_left (fun acc hyp -> tclTHEN (ra_fold_hyp ops ob hyp) acc) (tclUNIT()) 157 | 158 | let ra_fold_all ops ob = Goal.enter (fun goal -> 159 | let hyps = Goal.hyps goal in 160 | List.fold_left (fun acc hyp -> tclTHEN (ra_fold_hyp ops ob (get_id hyp)) acc) 161 | (ra_fold_concl ops ob) hyps) 162 | -------------------------------------------------------------------------------- /src/fold.mli: -------------------------------------------------------------------------------- 1 | val ra_fold_concl : 2 | EConstr.constr -> EConstr.t option -> unit Proofview.tactic 3 | val ra_fold_hyps : 4 | EConstr.constr -> 5 | EConstr.t option -> Names.Id.t list -> unit Proofview.tactic 6 | val ra_fold_all : EConstr.constr -> EConstr.t option -> unit Proofview.tactic 7 | -------------------------------------------------------------------------------- /src/fold_g.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "coq-relation-algebra.fold" 2 | 3 | { 4 | open Ltac_plugin 5 | open Stdarg 6 | open Fold 7 | } 8 | 9 | (* tactic grammar entries *) 10 | TACTIC EXTEND ra_fold 11 | | [ "ra_fold" constr(ops) ] -> { ra_fold_concl ops None } 12 | | [ "ra_fold" constr(ops) constr(ob)] -> { ra_fold_concl ops (Some ob) } 13 | | [ "ra_fold" constr(ops) "in" var_list(l)] -> { ra_fold_hyps ops None l } 14 | | [ "ra_fold" constr(ops) constr(ob) "in" var_list(l)] -> { ra_fold_hyps ops (Some ob) l } 15 | END 16 | 17 | TACTIC EXTEND ra_fold_in_star 18 | | [ "ra_fold" constr(ops) "in" "*"] -> { ra_fold_all ops None } 19 | | [ "ra_fold" constr(ops) constr(ob) "in" "*"] -> { ra_fold_all ops (Some ob) } 20 | END 21 | (* DAMIEN: gives "Alert deprecated: Stdarg.wit_var (8.13) Use Stdarg.wit_hyp", 22 | don't know how to fix it *) 23 | -------------------------------------------------------------------------------- /src/fold_g.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/damien-pous/relation-algebra/4db15229396abfd8913685be5ffda4f0fdb593d9/src/fold_g.mli -------------------------------------------------------------------------------- /src/kat_dec.ml: -------------------------------------------------------------------------------- 1 | (** * A simple algorithm for deciding KAT (in)equivalence 2 | (providing counter-examples in case of failure) 3 | 4 | Computing counter-examples in OCaml has three advantages: 5 | - it's faster so that failures are detected earlier; 6 | - the Coq algorithm don't need to compute them; 7 | - the proof of correctness of the Coq algorithm is not polluted 8 | by the corresponding additional computations. 9 | 10 | There are two inconvenients: 11 | - the code is duplicated, and the OCaml one could be wrong; 12 | - in case of success we do the computations twice (in OCaml, then 13 | in Coq). 14 | 15 | *) 16 | 17 | (** ** KAT expressions *) 18 | 19 | type var = int (* propositional variables *) 20 | type rel = int (* relational variables *) 21 | 22 | (* predicates *) 23 | type pred = 24 | | P_bot 25 | | P_top 26 | | P_cup of pred * pred 27 | | P_cap of pred * pred 28 | | P_neg of pred 29 | | P_var of var 30 | 31 | let p_bot = P_bot 32 | let p_top = P_top 33 | let p_cup x y = P_cup(x,y) 34 | let p_cap x y = P_cap(x,y) 35 | let p_neg x = P_neg x 36 | let p_var x = P_var x 37 | 38 | (* propositional atoms *) 39 | type atom = (var*bool) list 40 | 41 | (* KAT expresions *) 42 | type gregex = 43 | | G_rel of rel 44 | | G_prd of pred 45 | | G_pls of gregex * gregex 46 | | G_dot of gregex * gregex 47 | | G_itr of gregex 48 | 49 | let g_rel x = G_rel x 50 | let g_prd x = G_prd x 51 | let g_zer = G_prd P_bot 52 | let g_one = G_prd P_top 53 | let g_pls x y = G_pls(x,y) 54 | let g_dot x y = G_dot(x,y) 55 | let g_itr e = G_itr e 56 | let g_str e = G_pls (g_one,(G_itr e)) 57 | 58 | 59 | (** ** very basic algorithm for deciding KAT (in)equations, through partial derivatives *) 60 | (** (actually extracted from the formalised one in Coq, and then 61 | reworked manually to include counter-example generation) *) 62 | 63 | 64 | (* sorted list membership *) 65 | let rec mem x = function 66 | | [] -> false 67 | | y::q -> match compare x y with 68 | | 1 -> mem x q 69 | | 0 -> true 70 | | _ -> false 71 | 72 | (* sorted list insertion *) 73 | let rec insert x = function 74 | | [] -> [x] 75 | | y::q as l -> match compare x y with 76 | | 1 -> y::insert x q 77 | | 0 -> l 78 | | _ -> x::l 79 | 80 | (* sorted union of sorted lists *) 81 | let rec union h k = match h,k with 82 | | l,[] | [],l -> l 83 | | x::h', y::k' -> match compare x y with 84 | | 1 -> y::union h k' 85 | | 0 -> y::union h' k' 86 | | _ -> x::union h' k 87 | 88 | let rec epsilon_pred a = function 89 | | P_bot -> false 90 | | P_top -> true 91 | | P_cup (e,f) -> epsilon_pred a e || epsilon_pred a f 92 | | P_cap (e,f) -> epsilon_pred a e && epsilon_pred a f 93 | | P_neg e -> not (epsilon_pred a e) 94 | | P_var i -> mem i a 95 | 96 | let rec epsilon a = function 97 | | G_rel i -> false 98 | | G_prd p -> epsilon_pred a p 99 | | G_pls (e,f) -> epsilon a e || epsilon a f 100 | | G_dot (e,f) -> epsilon a e && epsilon a f 101 | | G_itr e -> epsilon a e 102 | 103 | let rec pderiv a i = function 104 | | G_rel j -> if i=j then [g_one] else [] 105 | | G_prd p -> [] 106 | | G_pls (e,f) -> union (pderiv a i e) (pderiv a i f) 107 | | G_dot (e,f) -> 108 | let l = List.map (fun e' -> G_dot(e',f)) (pderiv a i e) in 109 | if epsilon a e then union l (pderiv a i f) 110 | else l 111 | | G_itr e as ei -> 112 | let es = G_pls(g_one,ei) in 113 | List.map (fun e' -> G_dot (e',es)) (pderiv a i e) 114 | 115 | let epsilon' a = List.exists (epsilon a) 116 | 117 | let pderiv' a i l = 118 | List.fold_right (fun e -> union (pderiv a i e)) l [] 119 | 120 | let rec vars = function 121 | | G_rel i -> [i] 122 | | G_prd p -> [] 123 | | G_pls (e,f) | G_dot(e,f)-> union (vars e) (vars f) 124 | | G_itr e -> vars e 125 | 126 | let rec vars_pred = function 127 | | P_bot | P_top -> [] 128 | | P_cup (e,f) | P_cap (e,f) -> union (vars_pred e) (vars_pred f) 129 | | P_neg e -> vars_pred e 130 | | P_var i -> [i] 131 | 132 | let rec pvars = function 133 | | G_rel i -> [] 134 | | G_prd p -> vars_pred p 135 | | G_pls (e,f) | G_dot(e,f)-> union (pvars e) (pvars f) 136 | | G_itr e -> pvars e 137 | 138 | let obind f = function 139 | | `Some x -> f x 140 | | `Err a -> `Err a 141 | 142 | let rec ofold f l y = 143 | match l with 144 | | [] -> `Some y 145 | | x::q -> obind (f x) (ofold f q y) 146 | 147 | let loop_aux vars w e f a todo = 148 | if epsilon' a e = epsilon' a f then 149 | `Some (List.fold_right 150 | (fun i x -> ((a,i)::w, pderiv' a i e, pderiv' a i f)::x) vars todo) 151 | else `Err a 152 | 153 | let rec loop vars atoms rel = function 154 | | [] -> None 155 | | (w,e,f)::todo -> 156 | if mem (e,f) rel then loop vars atoms rel todo 157 | else match ofold (loop_aux vars w e f) atoms todo with 158 | | `Some todo -> loop vars atoms (insert (e,f) rel) todo 159 | | `Err a -> Some (List.rev w,a) 160 | 161 | let rec atoms = function 162 | | [] -> [[]] 163 | | x::q -> 164 | let f = atoms q in 165 | f @ List.map (fun q -> x::q) f 166 | 167 | let rec ext w pvars = 168 | match w,pvars with 169 | | [],_ -> List.map (fun x -> (x,false)) pvars 170 | | _,[] -> failwith "ext: w not in pvars" 171 | | x::w',y::pvars' -> match compare x y with 172 | | 1 -> (y,false)::ext w pvars' 173 | | 0 -> (x,true)::ext w' pvars' 174 | | _ -> failwith "ext: w not in pvars" 175 | 176 | let kat_weq' pvars vars e f = 177 | let atoms = atoms pvars in 178 | match loop vars atoms [] [([],e,f)] with 179 | | Some (w,a) -> Some (List.map (fun (a,i) -> (ext a pvars,i)) w, ext a pvars) 180 | | None -> None 181 | 182 | let kat_weq e f = kat_weq' (pvars (G_pls(e,f))) (vars (G_pls(e,f))) [e] [f] 183 | let kat_leq e f = kat_weq' (pvars (G_pls(e,f))) (vars (G_pls(e,f))) (union [e] [f]) [f] 184 | -------------------------------------------------------------------------------- /src/kat_dec.mli: -------------------------------------------------------------------------------- 1 | type var = int (* propositional variables *) 2 | type rel = int (* relational variables *) 3 | type atom = (var*bool) list (* propositional atoms *) 4 | 5 | type pred (* predicates *) 6 | type gregex (* KAT predessions *) 7 | 8 | val p_bot: pred 9 | val p_top: pred 10 | val p_var: var -> pred 11 | val p_neg: pred -> pred 12 | val p_cup: pred -> pred -> pred 13 | val p_cap: pred -> pred -> pred 14 | 15 | val g_zer: gregex 16 | val g_one: gregex 17 | val g_rel: rel -> gregex 18 | val g_prd: pred -> gregex 19 | val g_itr: gregex -> gregex 20 | val g_str: gregex -> gregex 21 | val g_pls: gregex -> gregex -> gregex 22 | val g_dot: gregex -> gregex -> gregex 23 | 24 | val kat_weq: gregex -> gregex -> ((atom * rel) list * atom) option 25 | val kat_leq: gregex -> gregex -> ((atom * rel) list * atom) option 26 | -------------------------------------------------------------------------------- /src/kat_reification.mli: -------------------------------------------------------------------------------- 1 | val reify_kat_goal : ?kat:EConstr.t -> bool -> unit Proofview.tactic 2 | val get_kat_alphabet : unit Proofview.tactic 3 | -------------------------------------------------------------------------------- /src/kat_reification_g.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "coq-relation-algebra.kat" 2 | 3 | { 4 | 5 | open Stdarg 6 | open Ltac_plugin 7 | open Kat_reification 8 | 9 | } 10 | 11 | (* tactic grammar entries *) 12 | TACTIC EXTEND ra_kat_reify_nocheck 13 | | [ "ra_kat_reify_nocheck" constr(kat) ] -> { reify_kat_goal ~kat false } END 14 | TACTIC EXTEND ra_kat_reify_check 15 | | [ "ra_kat_reify" constr(kat) ] -> { reify_kat_goal ~kat true } END 16 | TACTIC EXTEND ra_get_kat_alphabet 17 | | [ "ra_get_kat_alphabet" ] -> { get_kat_alphabet } END 18 | -------------------------------------------------------------------------------- /src/kat_reification_g.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/damien-pous/relation-algebra/4db15229396abfd8913685be5ffda4f0fdb593d9/src/kat_reification_g.mli -------------------------------------------------------------------------------- /src/mrewrite.ml: -------------------------------------------------------------------------------- 1 | (*i camlp4deps: "parsing/grammar.cma" i*) 2 | (*i camlp4use: "pa_extend.cmo" i*) 3 | 4 | (** Simple helper to define basic rewriting modulo A (associativity) tactics: 5 | (see the comments in [rewriting.v]) *) 6 | 7 | open Plugins.Common 8 | open Constr 9 | open EConstr 10 | 11 | module Ext = struct 12 | let path = ra_path@["rewriting"] 13 | let leq_2 = get_fun_10 path "ext_leq_2" 14 | let leq_3 = get_fun_12 path "ext_leq_3" 15 | let leq_4 = get_fun_14 path "ext_leq_4" 16 | let weq_2 = get_fun_10 path "ext_weq_2" 17 | let weq_3 = get_fun_12 path "ext_weq_3" 18 | let weq_4 = get_fun_14 path "ext_weq_4" 19 | let leq_2' = get_fun_10 path "ext_leq_2'" 20 | let leq_3' = get_fun_12 path "ext_leq_3'" 21 | let leq_4' = get_fun_14 path "ext_leq_4'" 22 | let weq_2' = get_fun_10 path "ext_weq_2'" 23 | let weq_3' = get_fun_12 path "ext_weq_3'" 24 | let weq_4' = get_fun_14 path "ext_weq_4'" 25 | end 26 | 27 | 28 | let rec length sigma t = 29 | match kind sigma (Termops.strip_outer_cast sigma t) with 30 | | Prod(_,_,t) -> 1+length sigma t 31 | | _ -> 0 32 | 33 | let extend ist k dir h = 34 | Proofview.Goal.enter (fun goal -> 35 | let fst,snd = match dir with `LR -> 2,1 | `RL -> 1,2 in 36 | let ext_2 rel = match dir,rel with 37 | | `LR,`Weq -> Ext.weq_2 38 | | `RL,`Weq -> Ext.weq_2' 39 | | `LR,`Leq -> Ext.leq_2 40 | | `RL,`Leq -> Ext.leq_2' 41 | in 42 | let ext_3 rel = match dir,rel with 43 | | `LR,`Weq -> Ext.weq_3 44 | | `RL,`Weq -> Ext.weq_3' 45 | | `LR,`Leq -> Ext.leq_3 46 | | `RL,`Leq -> Ext.leq_3' 47 | in 48 | let ext_4 rel = match dir,rel with 49 | | `LR,`Weq -> Ext.weq_4 50 | | `RL,`Weq -> Ext.weq_4' 51 | | `LR,`Leq -> Ext.leq_4 52 | | `RL,`Leq -> Ext.leq_4' 53 | in 54 | let sigma = ref (Tacmach.project goal) in 55 | let rec dots env t = 56 | match kind !sigma (Termops.strip_outer_cast !sigma t) with 57 | | App(c,ca) when EConstr.eq_constr !sigma c (Lazy.force Monoid.dot0) -> 58 | (match dots env ca.(4) with 59 | | None -> 60 | let ops = ca.(0) in 61 | let sg,l = new_evar env !sigma (Lazy.force Level.t) in 62 | let sg,laws = 63 | try Class_tactics.resolve_one_typeclass env sg (Monoid.laws l ops) 64 | with Not_found -> error "could not find monoid laws" 65 | in 66 | let l = Evarutil.nf_evar sg l in 67 | sigma := sg; 68 | Some(l,ops,laws,ca.(3), [ca.(1),ca.(4); ca.(2),ca.(5)]) 69 | 70 | | Some(l,ops,laws,r,q) -> Some(l,ops,laws,ca.(3), q@[ca.(2),ca.(5)])) 71 | | _ -> None 72 | in 73 | let rec ext env i h t = 74 | match kind !sigma (Termops.strip_outer_cast !sigma t) with 75 | | App(c,ca) -> 76 | (match 77 | if EConstr.eq_constr !sigma c (Lazy.force Lattice.weq) then Some `Weq 78 | else if EConstr.eq_constr !sigma c (Lazy.force Lattice.leq) then Some `Leq 79 | else None 80 | with 81 | | None -> error "the provided term does not end with a relation algebra (in)equation" 82 | | Some rel -> 83 | let n = Array.length ca in 84 | match dots env (ca.(n-fst)), ca.(n-snd) with 85 | | Some(l,ops,laws,p,[n,x;m,y]),v -> ext_2 rel l ops laws n m p x y v h 86 | | Some(l,ops,laws,q,[n,x;m,y;p,z]),v -> ext_3 rel l ops laws n m p q x y z v h 87 | | Some(l,ops,laws,r,[n,x;m,y;p,z;q,t]),v -> ext_4 rel l ops laws n m p q r x y z t v h 88 | | Some(_,_,_,_,_),_ -> error "pattern to large, please submit a feature wish" 89 | | None,_ -> h (* no need for modulo A rewriting *) 90 | ) 91 | | Prod(x,s,t) -> mkLambda(x,s,ext (push x s env) (i-1) (mkApp(h,[|mkRel i|])) t) 92 | | _ -> error "the provided term does not end with a relation algebra (in)equation" 93 | in 94 | let _,t = Tacmach.pf_type_of goal h in 95 | let h = ext (Proofview.Goal.env goal) (length !sigma t) h t in 96 | (* Tacticals.tclTHEN (Proofview.Unsafe.tclEVARS !sigma) *) 97 | (ltac_apply ist k h) 98 | ) 99 | -------------------------------------------------------------------------------- /src/mrewrite.mli: -------------------------------------------------------------------------------- 1 | val extend : 2 | Geninterp.interp_sign -> 3 | Ltac_plugin.Tacinterp.value -> 4 | [< `LR | `RL ] -> EConstr.constr -> unit Proofview.tactic 5 | -------------------------------------------------------------------------------- /src/mrewrite_g.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "coq-relation-algebra.mrewrite" 2 | 3 | { 4 | open Ltac_plugin 5 | open Stdarg 6 | open Tacarg 7 | open Mrewrite 8 | } 9 | 10 | TACTIC EXTEND ra_extend_lr 11 | | [ "ra_extend" tactic(k) "->" constr(h) ] -> { extend ist k `LR h } END 12 | TACTIC EXTEND ra_extend_rl 13 | | [ "ra_extend" tactic(k) "<-" constr(h) ] -> { extend ist k `RL h } END 14 | -------------------------------------------------------------------------------- /src/mrewrite_g.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/damien-pous/relation-algebra/4db15229396abfd8913685be5ffda4f0fdb593d9/src/mrewrite_g.mli -------------------------------------------------------------------------------- /src/packed_fold.mlpack: -------------------------------------------------------------------------------- 1 | Fold 2 | Fold_g 3 | -------------------------------------------------------------------------------- /src/packed_kat.mlpack: -------------------------------------------------------------------------------- 1 | Kat_dec 2 | Kat_reification 3 | Kat_reification_g 4 | -------------------------------------------------------------------------------- /src/packed_mrewrite.mlpack: -------------------------------------------------------------------------------- 1 | Mrewrite 2 | Mrewrite_g 3 | -------------------------------------------------------------------------------- /src/packed_reification.mlpack: -------------------------------------------------------------------------------- 1 | Reification 2 | Reification_g 3 | -------------------------------------------------------------------------------- /src/plugins.mlpack: -------------------------------------------------------------------------------- 1 | Common 2 | -------------------------------------------------------------------------------- /src/reification.ml: -------------------------------------------------------------------------------- 1 | (*i camlp4deps: "parsing/grammar.cma" i*) 2 | (*i camlp4use: "pa_extend.cmo" i*) 3 | 4 | (** reification plugin, for the [ra_normalise], [ra_simpl], and 5 | [ra] tactics: we reify [monoid] and [lattice] 6 | operations into [syntax.expr] expressions *) 7 | 8 | open Plugins.Common 9 | open Constr 10 | open EConstr 11 | 12 | (* RelationAlgebra.mono Coq module *) 13 | (* module Mono = struct *) 14 | (* let path = ra_path@["mono"] *) 15 | (* let mono = get_fun_3 path "mono" *) 16 | (* end *) 17 | 18 | let retype c = 19 | Proofview.Goal.enter begin fun gl -> 20 | let (sigma, _) = Typing.type_of (Tacmach.pf_env gl) (Tacmach.project gl) c in 21 | Proofview.Unsafe.tclEVARS sigma 22 | end 23 | 24 | module Syntax = Make_Syntax(struct let typ = Pos.t end) 25 | 26 | module Tbl : sig 27 | type t 28 | (* create an empty table *) 29 | val create: unit -> t 30 | (* [insert gl t x y] adds the association [x->y] to [t] and returns 31 | the corresponding (coq) index ; [gl] is the current goal, used 32 | to compare terms *) 33 | val insert: Environ.env -> Evd.evar_map -> t -> constr -> constr -> constr 34 | (* [to_env t typ def] returns (coq) environment corresponding to [t], 35 | yielding elements of type [typ], with [def] as default value *) 36 | val to_env: t -> constr -> constr -> constr 37 | end = struct 38 | type t = ((constr*constr*constr) list * int) ref 39 | 40 | let create () = ref([],1) 41 | 42 | let rec find env sigma x = function 43 | | [] -> raise Not_found 44 | | (x',i,_)::q -> if convertible env sigma x x' then i else find env sigma x q 45 | 46 | let insert env sigma t x y = 47 | let l,i = !t in 48 | try find env sigma x l 49 | with Not_found -> 50 | let j = Pos.of_int i in 51 | t := ((x,j,y)::l,i+1); j 52 | 53 | let to_env t typ def = match fst !t with 54 | | [] -> mkLambda (anonR,Lazy.force Pos.t,def) 55 | | [_,_,x] -> mkLambda (anonR,Lazy.force Pos.t,x) 56 | | (_,_,x)::q -> 57 | Pos.sigma_get typ x 58 | (List.fold_left 59 | (fun acc (_,i,x) -> Pos.sigma_add typ i x acc 60 | ) (Pos.sigma_empty typ) q 61 | ) 62 | end 63 | 64 | 65 | 66 | (** main entry point: reification of the current goal. 67 | [l] is the level at which reification should be performed; 68 | this tactic simply converts the goal into a sequence of "let ... in", 69 | so that we can later get all reification ingredients from Ltac, 70 | just by doing "intros ..." *) 71 | 72 | let reify_goal l = 73 | Proofview.Goal.enter begin fun goal -> 74 | let env0 = Tacmach.pf_env goal in 75 | let sigma = Tacmach.project goal in 76 | let concl = Tacmach.pf_concl goal in 77 | (* getting the level *) 78 | let l = read_level env0 sigma l in 79 | 80 | (* variables for referring to the environments *) 81 | let tenv_n,tenv_ref = fresh_name env0 "tenv" in 82 | let env_n,env_ref = fresh_name env0 "env" in 83 | 84 | (* table associating indices to encountered types *) 85 | let tenv = Tbl.create() in 86 | let insert_type t = Tbl.insert env0 sigma tenv t t in 87 | 88 | (* table associating indices to encountered atoms *) 89 | let env = Tbl.create() in 90 | let insert_atom ops x s s' t = 91 | Tbl.insert env0 sigma env x ((* lazy *) ( 92 | (* let m = *) 93 | (* try if s<>t then raise Not_found else *) 94 | (* let h = resolve_one_typeclass goal (Mono.mono ops s' x) in *) 95 | (* Syntax.im_true ops tenv_ref s x h *) 96 | (* with Not_found -> Syntax.im_false ops tenv_ref s t x *) 97 | (* in *) 98 | Syntax.pack ops tenv_ref s t x (* m *) 99 | )) 100 | in 101 | 102 | (* get the (in)equation *) 103 | let rel,lops,lhs,rhs = 104 | match kind sigma (Termops.strip_outer_cast sigma concl) with 105 | | App(c,ca) when EConstr.eq_constr sigma c (Lazy.force Lattice.leq_or_weq) 106 | -> mkApp (c,[|ca.(0);ca.(1)|]), ca.(1), ca.(2), ca.(3) 107 | | App(c,ca) when EConstr.eq_constr sigma c (Lazy.force Lattice.leq) || EConstr.eq_constr sigma c (Lazy.force Lattice.weq) 108 | -> mkApp (c,[|ca.(0)|]), ca.(0), ca.(1), ca.(2) 109 | | _ -> error "unrecognised goal" 110 | in 111 | 112 | (* get the monoid.ops and the domain/codomain types *) 113 | let ops,src',tgt' = 114 | match kind sigma (Termops.strip_outer_cast sigma lops) with 115 | | App(c,ca) when EConstr.eq_constr sigma c (Lazy.force Monoid.mor0) -> ca.(0),ca.(1),ca.(2) 116 | | _ -> error "could not find monoid operations" 117 | in 118 | let src = insert_type src' in 119 | let tgt = insert_type tgt' in 120 | let pck = Syntax.pack_type ops tenv_ref in (* type of packed elements *) 121 | let typ = Monoid.ob ops in (* type of types *) 122 | let src_v,(src_n,src_) = Syntax.src_ ops tenv_ref env_ref, fresh_name env0 "src" in 123 | let tgt_v,(tgt_n,tgt_) = Syntax.tgt_ ops tenv_ref env_ref, fresh_name env0 "tgt" in 124 | 125 | let es = env0, sigma in 126 | let is_pls s' t' = is_cup es l (Monoid.mor ops s' t') in 127 | let is_cap s' t' = is_cap es l (Monoid.mor ops s' t') in 128 | let is_neg s' t' = is_neg es l (Monoid.mor ops s' t') in 129 | let is_dot = is_dot es ops insert_type in 130 | let is_itr = is_itr es l ops in 131 | let is_str = is_str es l ops in 132 | let is_cnv = is_cnv es l ops in 133 | let is_ldv = is_ldv es l ops insert_type in 134 | let is_rdv = is_rdv es l ops insert_type in 135 | 136 | (* reification of a term [e], with domain [s] and codomain [t] *) 137 | let rec reify (s,s' as ss) (t,t' as tt) e = 138 | let k' _ = 139 | (* conversion here is untyped, so we need to ensure s' = t' when recognizing one *) 140 | if convertible env0 sigma e (Monoid.one ops s') && convertible env0 sigma s' t' then 141 | Syntax.one src_ tgt_ s 142 | else if l.has_bot && convertible env0 sigma e (Lattice.bot (Monoid.mor ops s' t')) then 143 | Syntax.zer src_ tgt_ s t 144 | else if l.has_top && convertible env0 sigma e (Lattice.top (Monoid.mor ops s' t')) then 145 | Syntax.top src_ tgt_ s t 146 | else 147 | Syntax.var src_ tgt_ (insert_atom ops e s s' t) 148 | in 149 | match kind sigma (Termops.strip_outer_cast sigma e) with App(c,ca) -> 150 | (* note that we give priority to dot/one over cap/top 151 | (they coincide on flat structures) *) 152 | is_dot s s' (fun x r r' y -> 153 | Syntax.dot src_ tgt_ s r t (reify ss (r,r') x) (reify (r,r') tt y)) ( 154 | is_pls s' t' (fun x y -> Syntax.pls src_ tgt_ s t (reify ss tt x) (reify ss tt y)) ( 155 | is_cap s' t' (fun x y -> Syntax.cap src_ tgt_ s t (reify ss tt x) (reify ss tt y)) ( 156 | is_neg s' t' (fun x -> Syntax.neg src_ tgt_ s t (reify ss tt x)) ( 157 | is_itr s' (fun x -> Syntax.itr src_ tgt_ s (reify ss ss x)) ( 158 | is_str s' (fun x -> Syntax.str src_ tgt_ s (reify ss ss x)) ( 159 | is_cnv s' t' (fun x -> Syntax.cnv src_ tgt_ t s (reify tt ss x)) ( 160 | is_ldv s s' (fun x r r' y -> 161 | Syntax.ldv src_ tgt_ r s t (reify (r,r') ss x) (reify (r,r') tt y)) ( 162 | is_rdv s s' (fun x r r' y -> 163 | Syntax.rdv src_ tgt_ r t s (reify tt (r,r') x) (reify ss (r,r') y)) ( 164 | k'))))))))) (c,ca,Array.length ca) 165 | | _ -> k' () 166 | in 167 | 168 | (* reification of left and right members *) 169 | let lhs_v,(lhs_n,lhs) = reify (src,src') (tgt,tgt') lhs, fresh_name env0 "lhs" in 170 | let rhs_v,(rhs_n,rhs) = reify (src,src') (tgt,tgt') rhs, fresh_name env0 "rhs" in 171 | 172 | (* apply "eval" around the reified terms *) 173 | let lhs = Syntax.eval ops tenv_ref env_ref src tgt lhs in 174 | let rhs = Syntax.eval ops tenv_ref env_ref src tgt rhs in 175 | let x = Syntax.expr src_ tgt_ src tgt in 176 | 177 | (* construction of coq' types index *) 178 | let tenv = Tbl.to_env tenv typ src' in 179 | 180 | (* construction of coq' reification environment *) 181 | let env = 182 | let def = 183 | let one = Monoid.one ops src' in 184 | Syntax.pack ops tenv_ref src src one 185 | (* (Syntax.im_false ops tenv_ref src src one) *) 186 | in 187 | Tbl.to_env env pck def 188 | in 189 | 190 | (* reified goal conclusion: add the relation over the two evaluated members *) 191 | let reified = 192 | mkNamedLetIn sigma tenv_n tenv (mkArrowR (Lazy.force Pos.t) typ) ( 193 | mkNamedLetIn sigma env_n env (mkArrowR (Lazy.force Pos.t) pck) ( 194 | mkNamedLetIn sigma src_n src_v (mkArrowR (Lazy.force Pos.t) (Lazy.force Pos.t)) ( 195 | mkNamedLetIn sigma tgt_n tgt_v (mkArrowR (Lazy.force Pos.t) (Lazy.force Pos.t)) ( 196 | mkNamedLetIn sigma lhs_n lhs_v x ( 197 | mkNamedLetIn sigma rhs_n rhs_v x ( 198 | (mkApp (rel, [|lhs;rhs|])))))))) 199 | in 200 | Proofview.tclORELSE 201 | (Tacticals.tclTHEN (retype reified) (Tactics.convert_concl ~cast:false ~check:true reified DEFAULTcast)) 202 | (fun (e, info) -> Feedback.msg_warning (Printer.pr_leconstr_env (fst es) (snd es) reified); Proofview.tclZERO ~info e) 203 | end 204 | -------------------------------------------------------------------------------- /src/reification.mli: -------------------------------------------------------------------------------- 1 | val reify_goal : EConstr.t -> unit Proofview.tactic 2 | -------------------------------------------------------------------------------- /src/reification_g.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "coq-relation-algebra.reification" 2 | 3 | { 4 | 5 | open Stdarg 6 | open Ltac_plugin 7 | open Reification 8 | 9 | } 10 | 11 | (* tactic grammar entries *) 12 | TACTIC EXTEND ra_reify 13 | | [ "ra_reify" constr(level) ] -> { reify_goal level } END 14 | -------------------------------------------------------------------------------- /src/reification_g.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/damien-pous/relation-algebra/4db15229396abfd8913685be5ffda4f0fdb593d9/src/reification_g.mli -------------------------------------------------------------------------------- /theories/all.v: -------------------------------------------------------------------------------- 1 | (** Import everything except the examples *) 2 | 3 | Require Export common. 4 | Require Export comparisons. 5 | Require Export positives. 6 | Require Export ordinal. 7 | Require Export denum. 8 | Require Export pair. 9 | Require Export powerfix. 10 | 11 | Require Export level. 12 | Require Export lattice. 13 | Require Export monoid. 14 | Require Export kleene. 15 | Require Export factors. 16 | Require Export kat. 17 | 18 | Require Export rewriting. 19 | Require Export move. 20 | 21 | Require Export lsyntax. 22 | Require Export syntax. 23 | Require Export normalisation. 24 | 25 | Require Export prop. 26 | Require Export boolean. 27 | Require Export rel. 28 | Require Export srel. 29 | Require Export lang. 30 | Require Export lset. 31 | 32 | Require Export sups. 33 | Require Export sums. 34 | Require Export matrix. 35 | Require Export matrix_ext. 36 | 37 | Require Export untyping. 38 | 39 | Require Export regex. 40 | Require Export rmx. 41 | Require Export bmx. 42 | Require Export dfa. 43 | Require Export nfa. 44 | Require Export ka_completeness. 45 | 46 | Require Export atoms. 47 | Require Export traces. 48 | Require Export glang. 49 | Require Export gregex. 50 | Require Export kat_completeness. 51 | Require Export ugregex. 52 | Require Export ugregex_dec. 53 | Require Export kat_untyping. 54 | Require Export kat_reification. 55 | Require Export kat_tac. 56 | 57 | Require Export relalg. 58 | -------------------------------------------------------------------------------- /theories/atoms.v: -------------------------------------------------------------------------------- 1 | (** * atoms: atoms of the free Boolean lattice over a finite set *) 2 | 3 | (** An atom is an expression that cannot be decomposed into a 4 | non-trivial disjunction. When the set of variables is finite, the 5 | atoms are the complete conjunctions of literals, and any expression 6 | can be decomposed as a sum of atoms, in a unique way. 7 | 8 | We work with ordinals to get the finiteness property for free: the 9 | set of variables is [ord n], for some natural number [n]. 10 | Atoms are in bijection with [ord n -> bool], and thus, [ord (pow2 n)]. *) 11 | 12 | Require Import lattice lsyntax comparisons lset boolean sups. 13 | Set Implicit Arguments. 14 | 15 | (** Atom corresponding to a subset of variables, encoded as an ordinal *) 16 | Definition atom {n} (f: ord (pow2 n)): expr_ops (ord n) BL := 17 | sup (X:=dual (expr_ops _ BL)) 18 | (fun i => if set.mem f i then e_var i else ! e_var i) (seq n). 19 | 20 | 21 | (** * Decomposition of the [top] element into atoms *) 22 | 23 | (** Alternative definition of the [top] element, as the sum of all atoms 24 | the first step consists in proving that this is actaully the [top] element. *) 25 | 26 | Definition e_top' n: expr_ BL := \sup_(a e_var (ordS i)) (atom f). 46 | Proof. 47 | unfold atom. simpl. rewrite set.mem_xO_0. apply cap_weq. reflexivity. 48 | setoid_rewrite eval_inf with (g := fun i => e_var (ordS i)). rewrite sup_map. 49 | apply (sup_weq (l:=BL) (L:=lattice.dual_laws _ _ _)). 2: reflexivity. intro i. 50 | rewrite set.mem_xO_S. now case set.mem. 51 | Qed. 52 | 53 | Lemma atom_xI n (f: ord (pow2 n)): 54 | @atom (S n) (set.xI f) ≡ e_var ord0 ⊓ eval (fun i => e_var (ordS i)) (atom f). 55 | Proof. 56 | unfold atom. simpl. rewrite set.mem_xI_0. apply cap_weq. reflexivity. 57 | setoid_rewrite eval_inf with (g := fun i => e_var (ordS i)). rewrite sup_map. 58 | apply (sup_weq (l:=BL) (L:=lattice.dual_laws _ _ _)). 2: reflexivity. intro i. 59 | rewrite set.mem_xI_S. now case set.mem. 60 | Qed. 61 | 62 | (** the deomposition of [top] into atoms follow by induction *) 63 | Theorem decomp_top n: top ≡ e_top' n. 64 | Proof. 65 | unfold e_top'. induction n. symmetry. apply cupxb. 66 | simpl pow2. rewrite seq_double, sup_app. 67 | rewrite 2sup_map. setoid_rewrite atom_xO. setoid_rewrite atom_xI. 68 | rewrite <- 2capxsup. rewrite capC, (capC (e_var _)), <- capcup. 69 | rewrite cupC, cupneg, capxt. 70 | intros X L f. simpl. rewrite (IHn X L (fun i => f (ordS i))). 71 | rewrite 2eval_sup. apply sup_weq. 2: reflexivity. intro i. 72 | induction (atom i); first [reflexivity|apply cup_weq|apply cap_weq|apply neg_weq]; assumption. 73 | Qed. 74 | 75 | 76 | (** * Decomposition of the other expressions into atoms *) 77 | 78 | Section atom_props. 79 | Variable n: nat. 80 | Notation Atom := (ord (pow2 n)). 81 | 82 | (** auxiliary lemmas *) 83 | Lemma cap_var_atom (a: Atom) b: 84 | e_var b ⊓ atom a ≡ (if set.mem a b then atom a else bot). 85 | Proof. 86 | generalize (in_seq b). unfold atom. induction (seq n). intros []. 87 | simpl (sup _ _). intros [->|Hl]. 88 | case set.mem. lattice. rewrite capA, capneg. apply capbx. 89 | rewrite capA, (capC (e_var _)), <-capA, IHl by assumption. 90 | case (set.mem a b). reflexivity. apply capxb. 91 | Qed. 92 | 93 | Lemma cup_var_atom (a: Atom) b: 94 | e_var b ⊔ !atom a ≡ (if set.mem a b then top else !atom a). 95 | Proof. 96 | generalize (in_seq b). unfold atom. induction (seq n). intros []. 97 | simpl (sup _ _). intros [->|Hl]. 98 | case set.mem. rewrite negcap, cupA, cupneg. apply cuptx. 99 | rewrite negcap, negneg. lattice. 100 | rewrite negcap at 1. rewrite cupA, (cupC (e_var _)), <-cupA, IHl by assumption. 101 | case (set.mem a b). apply cupxt. now rewrite negcap. 102 | Qed. 103 | 104 | Lemma eval_mem_cap (a: Atom) e: e ⊓ atom a ≡ if eval (set.mem a) e then atom a else bot 105 | with eval_mem_cup (a: Atom) e: e ⊔ !atom a ≡ if eval (set.mem a) e then top else !atom a. 106 | Proof. 107 | - destruct e; simpl eval. 108 | apply capbx. 109 | apply captx. 110 | rewrite capC, capcup, capC, eval_mem_cap, capC, eval_mem_cap. 111 | case (eval (set.mem a) e1); case (eval (set.mem a) e2); lattice. 112 | transitivity ((e1 ⊓ atom a) ⊓ (e2 ⊓ atom a)). lattice. rewrite 2eval_mem_cap. 113 | case (eval (set.mem a) e1); case (eval (set.mem a) e2); lattice. 114 | neg_switch. rewrite negcap, negneg, eval_mem_cup. 115 | case (eval (set.mem a) e). now rewrite <-negbot. reflexivity. 116 | apply cap_var_atom. 117 | - destruct e; simpl eval. 118 | apply cupbx. 119 | apply cuptx. 120 | transitivity ((e1 ⊔ !atom a) ⊔ (e2 ⊔ !atom a)). lattice. rewrite 2eval_mem_cup. 121 | case (eval (set.mem a) e1); case (eval (set.mem a) e2); lattice. 122 | rewrite cupC, cupcap, cupC, eval_mem_cup, cupC, eval_mem_cup. 123 | case (eval (set.mem a) e1); case (eval (set.mem a) e2); lattice. 124 | neg_switch. rewrite negcup, 2negneg, eval_mem_cap. 125 | case (eval (set.mem a) e). apply negneg. apply negtop. 126 | apply cup_var_atom. 127 | Qed. 128 | 129 | (** decomposition of arbitrary expressions *) 130 | Theorem decomp_expr e: 131 | e ==_[BL] \sup_(i \in filter (fun f => eval (set.mem f) e) (seq (pow2 n))) atom i. 132 | Proof. 133 | rewrite <-capxt. setoid_rewrite decomp_top. setoid_rewrite capxsup. 134 | setoid_rewrite eval_mem_cap. 135 | induction (seq (pow2 n)). reflexivity. simpl filter. simpl (sup _ _). 136 | case (eval (set.mem a) e). now apply cup_weq. now rewrite cupbx. 137 | Qed. 138 | 139 | (** * Atoms are pairwise disjoint *) 140 | 141 | Lemma eval_atom (a b: Atom): eval (set.mem a) (atom b) -> a=b. 142 | Proof. 143 | intro. apply set.ext. intro i. 144 | unfold atom in H. setoid_rewrite eval_inf with (g := set.mem a) in H. 145 | rewrite is_true_inf in H; cbv beta in H. specialize (H i (in_seq i)). 146 | destruct (set.mem b i). assumption. apply Bool.negb_true_iff. assumption. 147 | Qed. 148 | 149 | Lemma empty_atom_cap (a b: Atom): a<>b -> atom a ⊓ atom b ≡ bot. 150 | Proof. 151 | intro E. rewrite eval_mem_cap. generalize (eval_atom b a). 152 | case (eval (set.mem b) (atom a)). 2: reflexivity. 153 | intro. elim E. symmetry; auto. 154 | Qed. 155 | 156 | End atom_props. 157 | -------------------------------------------------------------------------------- /theories/bmx.v: -------------------------------------------------------------------------------- 1 | (** * bmx: Boolean matrices, characterisation of reflexive transitive closure *) 2 | 3 | Require Import kleene boolean sups matrix. 4 | Set Implicit Arguments. 5 | 6 | Notation bmx := (mx_ops bool_ops bool_tt). 7 | 8 | (** intermediate alternative definition of the star of a Boolean matrix *) 9 | 10 | Fixpoint bmx_str n: bmx n n -> bmx n n := 11 | match n with 12 | | O => fun M => M 13 | | S n => fun M => 14 | let b := sub01_mx (n1:=1) (m1:=1) M in 15 | let c := sub10_mx (n1:=1) (m1:=1) M in 16 | let d := bmx_str (sub11_mx (n1:=1) (m1:=1) M) in 17 | blk_mx 1 (b⋅d) (d⋅c) (d+d⋅c⋅(b⋅d)) 18 | end. 19 | 20 | Lemma bmx_top_1: top ≡ (1: bmx 1%nat 1%nat). 21 | Proof. intros i j. now setoid_rewrite ord0_unique. Qed. 22 | 23 | Lemma bmx_str_str n (M: bmx n n): M^* ≡ bmx_str M. 24 | Proof. 25 | induction n as [|n IHn]. intro i. elim (ord_0_empty i). 26 | change (M^*) with (mx_str _ _ _ M). 27 | simpl mx_str. simpl bmx_str. unfold mx_str_build. 28 | ra_fold (mx_ops bool_ops bool_tt). rewrite bmx_top_1. 29 | now rewrite IHn, dot1x, dotx1. 30 | Qed. 31 | 32 | (** reflexive transitive closure as an inductive predicate *) 33 | 34 | Inductive rt_clot n (M: bmx n n): ord n -> ord n -> Prop := 35 | | clot_nil: forall i, rt_clot M i i 36 | | clot_cons: forall i j k, M i j -> rt_clot M j k -> rt_clot M i k. 37 | 38 | Lemma clot_app n (M: bmx n n): forall i j k, rt_clot M i j -> rt_clot M j k -> rt_clot M i k. 39 | Proof. induction 1; eauto using clot_cons. Qed. 40 | 41 | Lemma clot_snoc n (M: bmx n n): forall i j k, rt_clot M i j -> M j k -> rt_clot M i k. 42 | Proof. intros. eapply clot_app. eassumption. eapply clot_cons. eassumption. constructor. Qed. 43 | 44 | Lemma rt_clot_S_S n (M: bmx (1+n)%nat (1+n)%nat): forall i j, 45 | rt_clot (sub11_mx M) i j -> rt_clot M (rshift i) (rshift j). 46 | Proof. induction 1. constructor. eapply clot_cons; eassumption. Qed. 47 | 48 | (** characterisation theorem *) 49 | 50 | Theorem bmx_str_clot n (M: bmx n n) i j: M^* i j <-> rt_clot M i j. 51 | Proof. 52 | split. 53 | - assert (M^* i j ≡ bmx_str M i j). (*MS: FIXME, why is it needed now ? *) 54 | apply bmx_str_str. rewrite H. clear H. revert i j. 55 | induction n as [|n IH]; intros i' j'. 56 | simpl. intro. eapply clot_cons. eassumption. constructor. 57 | unfold bmx_str; fold (@bmx_str n). set (M' := sub11_mx (n1:=1) (m1:=1) M). 58 | specialize (IH M'). unfold blk_mx, row_mx, col_mx. 59 | case ordinal.split_spec; intros i ->; case ordinal.split_spec; intros j -> Hij. 60 | + setoid_rewrite ord0_unique. constructor. 61 | + setoid_rewrite is_true_sup in Hij. destruct Hij as [k [_ Hk]]. 62 | apply Bool.andb_true_iff in Hk as [Hik Hkj]. 63 | apply IH in Hkj. unfold M' in Hkj. 64 | eapply clot_cons. eassumption. now apply rt_clot_S_S. 65 | + setoid_rewrite is_true_sup in Hij. destruct Hij as [k [_ Hk]]. 66 | apply Bool.andb_true_iff in Hk as [Hik Hkj]. 67 | apply IH in Hik. unfold M' in Hik. 68 | eapply clot_snoc. apply rt_clot_S_S; eassumption. assumption. 69 | + setoid_rewrite Bool.orb_true_iff in Hij. destruct Hij as [Hij|Hij]. 70 | apply IH in Hij. now apply rt_clot_S_S. 71 | setoid_rewrite is_true_sup in Hij. destruct Hij as [k [_ Hk]]. 72 | apply Bool.andb_true_iff in Hk as [Hik Hkj]. 73 | setoid_rewrite is_true_sup in Hik. destruct Hik as [i' [_ Hi']]. 74 | apply Bool.andb_true_iff in Hi' as [Hii' Hi'k]. 75 | setoid_rewrite is_true_sup in Hkj. destruct Hkj as [j' [_ Hj']]. 76 | apply Bool.andb_true_iff in Hj' as [Hkj' Hj'j]. 77 | apply IH in Hii'. apply IH in Hj'j. 78 | eapply clot_app. apply rt_clot_S_S, Hii'. 79 | eapply clot_cons. apply Hi'k. 80 | eapply clot_cons. apply Hkj'. 81 | apply rt_clot_S_S, Hj'j. 82 | - induction 1 as [i|i j k Hij Hjk IH]. 83 | + pose proof (str_refl (X:=bmx) M i i). simpl in H. 84 | apply H. unfold mx_one. now rewrite eqb_refl. 85 | + pose proof (str_cons (X:=bmx) M i k). simpl in H. 86 | apply H. clear H. 87 | unfold mx_dot. rewrite is_true_sup. eexists. split. apply in_seq. 88 | apply Bool.andb_true_iff. split; eassumption. 89 | Qed. 90 | -------------------------------------------------------------------------------- /theories/boolean.v: -------------------------------------------------------------------------------- 1 | (** * boolean: Booleans as a lattice, and as a monoid *) 2 | 3 | Require Import monoid prop sups. 4 | 5 | (** * Booleans as a lattice *) 6 | 7 | Canonical Structure bool_lattice_ops: lattice.ops := {| 8 | leq := le_bool; 9 | weq := eq; 10 | cup := orb; 11 | cap := andb; 12 | neg := negb; 13 | bot := false; 14 | top := true 15 | |}. 16 | 17 | (** [is_true] is a bounded distributive lattice homomorphism from [bool] to [Prop]. 18 | (Actually a Boolean lattice homomorphism, but we don't need it here.) *) 19 | #[export] Instance mm_bool_Prop: morphism BDL is_true. 20 | Proof. 21 | constructor; simpl. 22 | now auto. 23 | intros ? ?. now rewrite eq_bool_iff. 24 | intros _ [|] [|]; firstorder. 25 | intros _ [|] [|]; firstorder. 26 | intros _. easy. 27 | tauto. 28 | intros _ [|]. firstorder auto with bool. easy. 29 | Qed. 30 | 31 | (* #[export] Instance mm_negb l: morphism l bool_lops (dual_ops bool_ops) negb. *) 32 | 33 | (** we get most lattice laws by the faithful embedding into [Prop] *) 34 | #[export] Instance bool_lattice_laws: lattice.laws (BL+STR+CNV+DIV) bool_lattice_ops. 35 | Proof. 36 | assert(H: lattice.laws BDL bool_lattice_ops). 37 | apply (laws_of_injective_morphism is_true mm_bool_Prop). 38 | auto. 39 | intros x y. apply eq_bool_iff. 40 | constructor; try apply H; (try now left); intros _ [|]; reflexivity. 41 | Qed. 42 | 43 | (** simple characterisation of finite sups and infs in [bool] *) 44 | 45 | Lemma is_true_sup I J (f: I -> bool): \sup_(i\in J) f i <-> (exists i, List.In i J /\ f i). 46 | Proof. 47 | unfold is_true. induction J; simpl. firstorder; discriminate. 48 | rewrite Bool.orb_true_iff. firstorder congruence. 49 | Qed. 50 | 51 | Lemma is_true_inf I J (f: I -> bool): \inf_(i\in J) f i <-> (forall i, List.In i J -> f i). 52 | Proof. 53 | unfold is_true. induction J; simpl. firstorder. 54 | rewrite Bool.andb_true_iff. firstorder congruence. 55 | Qed. 56 | 57 | 58 | 59 | 60 | (** * Boolean as a (flat) monoid 61 | this is useful: 62 | - to construct boolean matrices, 63 | - to consider regex.epsilon as a functor) *) 64 | 65 | (** this monoid is flat: this is a one object category. 66 | We use the following singleton type to avoid confusion with the 67 | singleton types of other flat structures *) 68 | CoInductive bool_unit := bool_tt. 69 | 70 | (** note that the trivial type information is simply ignored *) 71 | Canonical Structure bool_ops: monoid.ops := {| 72 | ob := bool_unit; 73 | mor n m := bool_lattice_ops; 74 | dot n m p := andb; 75 | one n := true; 76 | itr n x := x; 77 | str n x := true; 78 | cnv n m x := x; 79 | ldv n m p x y := !x ⊔ y; 80 | rdv n m p x y := !x ⊔ y 81 | |}. 82 | 83 | (** shorthand for [bool], when a morphism is expected *) 84 | Notation bool' := (bool_ops bool_tt bool_tt). 85 | 86 | (** we actually have all laws on [bool] *) 87 | #[export] Instance bool_laws: laws (BL+STR+CNV+DIV) bool_ops. 88 | Proof. 89 | constructor; (try now left);repeat right; intros. 90 | apply bool_lattice_laws. 91 | apply capA. 92 | apply captx. 93 | apply weq_leq. simpl. apply capC. 94 | reflexivity. 95 | now intros ? ? ?. 96 | reflexivity. 97 | all: try setoid_rewrite <- le_bool_spec. 98 | all: try case x; try case y; try case z; reflexivity. 99 | Qed. 100 | 101 | 102 | 103 | (** * properties of the [ofbool] injection *) 104 | 105 | Section ofbool. 106 | 107 | Open Scope bool_scope. 108 | Implicit Types a b c: bool. 109 | Context {X: ops} {l} {L: laws l X} {n: ob X}. 110 | Notation ofbool := (@ofbool X n). 111 | 112 | Lemma andb_dot `{BOT ≪ l} a b: ofbool (a&&b) ≡ ofbool a ⋅ ofbool b. 113 | Proof. 114 | symmetry. case a. apply dot1x. 115 | apply antisym. now apply weq_leq, dot0x. apply leq_bx. 116 | Qed. 117 | 118 | Lemma orb_pls `{CUP+BOT ≪ l} a b: ofbool (a||b) ≡ ofbool a + ofbool b. 119 | Proof. symmetry. case a; simpl. case b; simpl; lattice. lattice. Qed. 120 | 121 | #[export] Instance ofbool_leq `{BOT ≪ l}: Proper (leq ==> leq) ofbool. 122 | Proof. intros [|] b E; simpl. now rewrite E. apply leq_bx. Qed. 123 | 124 | Lemma dot_ofboolx `{BOT ≪ l} b (x: X n n): ofbool b⋅x ≡ x⋅ofbool b. 125 | Proof. case b; simpl. now rewrite dot1x, dotx1. now rewrite dot0x, dotx0. Qed. 126 | 127 | End ofbool. 128 | 129 | (** [is_true] is also monotone *) 130 | #[export] Instance is_true_leq: Proper (leq ==> leq) is_true. 131 | Proof. intros [|] b E; simpl. now rewrite E. discriminate. Qed. 132 | -------------------------------------------------------------------------------- /theories/common.v: -------------------------------------------------------------------------------- 1 | (** * common: basic modules, utilities, and tactics *) 2 | 3 | Require Export Setoid Morphisms. 4 | Require Import BinNums. 5 | Set Implicit Arguments. 6 | 7 | Bind Scope nat_scope with nat. 8 | 9 | (** this lemma is useful when applied in hypotheses 10 | ([apply apply in H] makes it possible to specialize an hypothesis [H] 11 | by generating the corresponding subgoals) *) 12 | Definition apply X x Y (f: X -> Y) := f x. 13 | 14 | (** for debugging *) 15 | Ltac print_goal := match goal with |- ?x => idtac x end. 16 | 17 | (** closing tactic *) 18 | Ltac Now tac := tac; solve [auto]. 19 | 20 | 21 | (** coercion from Booleans to propositions *) 22 | Coercion is_true: bool >-> Sortclass. 23 | (* TOTHINK: do we really want to pollute the core database? *) 24 | #[export] Hint Unfold is_true : core. 25 | 26 | (** lazy Boolean connectives *) 27 | Notation "a <<< b" := (if (a:bool) then (b:bool) else true) (at level 49). 28 | Notation "a &&& b" := (if (a:bool) then (b:bool) else false) (right associativity, at level 59). 29 | Notation "a ||| b" := (if (a:bool) then true else (b:bool)) (right associativity, at level 60). 30 | 31 | 32 | (** Booleans inclusion *) 33 | Definition le_bool (a b : bool) := a -> b. 34 | #[export] Hint Unfold le_bool : core. 35 | 36 | (** specification in Prop of the above operations *) 37 | Lemma le_bool_spec a b: is_true (a<< le_bool a b. 38 | Proof. case a; intuition. discriminate. Qed. 39 | Lemma landb_spec a b: is_true (a&&&b) <-> a /\ b. 40 | Proof. case a; intuition. discriminate. Qed. 41 | Lemma lorb_spec a b: is_true (a|||b) <-> a \/ b. 42 | Proof. case a; intuition. discriminate. Qed. 43 | Lemma negb_spec a: is_true (negb a) <-> a = false. 44 | Proof. case a; intuition. Qed. 45 | 46 | Lemma eq_bool_iff (a b: bool): (a<->b) <-> a=b. 47 | Proof. 48 | split. unfold is_true. 2: now intros <-. 49 | case a; case b; intuition discriminate. 50 | Qed. 51 | 52 | (** coercion from sums to Booleans *) 53 | Definition bool_of_sumbool A B (c: sumbool A B): bool := if c then true else false. 54 | Coercion bool_of_sumbool: sumbool >-> bool. 55 | 56 | Lemma sumbool_true A (c: sumbool A (~A)): A -> c. 57 | Proof. intro HA. case c; intro F. reflexivity. elim (F HA). Qed. 58 | 59 | Lemma is_true_sumbool A (c: {A}+{~A}): is_true c <-> A. 60 | Proof. case c; simpl; intuition; discriminate. Qed. 61 | 62 | Lemma sumbool_iff A B: (A<->B) -> {A}+{~A} -> {B}+{~B}. 63 | Proof. tauto. Qed. 64 | 65 | 66 | (** simplifictation hints *) 67 | Arguments Basics.flip {_ _ _} _ _ _/. 68 | Arguments Basics.impl _ _ /. 69 | Arguments Proper {_} _ _ /. 70 | Arguments respectful {_ _} _ _ / _ _. 71 | Arguments pointwise_relation _ {_} _ / _ _. 72 | Arguments Transitive {_} _ /. 73 | Arguments Symmetric {_} _ /. 74 | Arguments Reflexive {_} _ /. 75 | Notation flip := Basics.flip. 76 | Notation impl := Basics.impl. 77 | Notation pwr := (pointwise_relation _). 78 | 79 | 80 | (** opaque identity, used to document impossible cases *) 81 | Definition assert_false {A} (x: A): A. Proof. assumption. Qed. 82 | 83 | 84 | (** 2^n (defined through the [double] function to ease definition of finite sets as ordinals) *) 85 | Fixpoint double n := match n with 0 => 0 | S n => S (S (double n)) end. 86 | Fixpoint pow2 n := match n with 0 => 1 | S n => double (pow2 n) end. 87 | 88 | 89 | (** closing tactics by reflection, without re-computing at Qed-time *) 90 | Ltac close_by_reflection val := (abstract (vm_cast_no_check (eq_refl val))). 91 | 92 | (** introduce non propositional variables *) 93 | Ltac intro_vars := 94 | match goal with 95 | | |- ?H -> _ => 96 | match type of H with 97 | | Prop => let H' := fresh in intro H'; intro_vars; revert H' 98 | | _ => intro; intro_vars 99 | end 100 | | |- _ => idtac 101 | end. 102 | 103 | (** revert all propositional variables *) 104 | Ltac revert_prop := 105 | match goal with 106 | | H:?t |- _ => match type of t with Prop => revert H; revert_prop end 107 | | _ => idtac 108 | end. 109 | -------------------------------------------------------------------------------- /theories/comparisons.v: -------------------------------------------------------------------------------- 1 | (** * comparisons: types equiped with a comparison function *) 2 | 3 | From Stdlib Require Import List. 4 | From Stdlib Require Import Eqdep Eqdep_dec. 5 | Import ListNotations. 6 | Set Implicit Arguments. 7 | 8 | (** * Specifying Boolean *) 9 | 10 | Inductive reflect (P: Prop): bool -> Set := 11 | | reflect_t : P -> reflect P true 12 | | reflect_f : ~ P -> reflect P false. 13 | 14 | 15 | (** * Specifying ternary comparisons *) 16 | (** note that [Lt] and [Gt] have the same meaning, i.e., not [Eq] *) 17 | 18 | Inductive compare_spec (P: Prop): comparison -> Set := 19 | | compare_eq: P -> compare_spec P Eq 20 | | compare_lt: ~P -> compare_spec P Lt 21 | | compare_gt: ~P -> compare_spec P Gt. 22 | 23 | (** turning a comparison function into a Boolean test *) 24 | Definition eqb_of_compare A (f: A -> A -> comparison): A -> A -> bool := 25 | fun x y => match f x y with Eq => true | _ => false end. 26 | 27 | Lemma eqb_of_compare_spec A f: 28 | (forall a b: A, compare_spec (a=b) (f a b)) -> 29 | forall a b, reflect (a=b) (eqb_of_compare f a b). 30 | Proof. unfold eqb_of_compare. intros H a b. now case H; constructor. Qed. 31 | 32 | (** lexicographic ternary comparison *) 33 | Notation lex a b := match a with Eq => b | Lt => Lt | Gt => Gt end. 34 | 35 | Lemma lex_spec P Q R a b (H: R<->P/\Q): 36 | compare_spec P a -> compare_spec Q b -> compare_spec R (lex a b). 37 | Proof. 38 | destruct 1; try (constructor; tauto). 39 | destruct 1; constructor; tauto. 40 | Qed. 41 | 42 | Lemma compare_lex_eq a b: lex a b = Eq <-> a = Eq /\ b = Eq. 43 | Proof. destruct a; intuition discriminate. Qed. 44 | 45 | 46 | (** * Structure for types equiped with a Boolean equality and a comparison function. 47 | Note that the specification of [cmp] is weak: we only have 48 | [cmp a b = Eq <-> a=b]. As a consequence, the difference betwen 49 | [Lt] and [Gt] can only be used as a heuristic. *) 50 | Structure cmpType := mk_cmp { 51 | carr:> Set; 52 | eqb: carr -> carr -> bool; 53 | _: forall x y, reflect (x=y) (eqb x y); 54 | cmp: carr -> carr -> comparison; 55 | _: forall x y, compare_spec (x=y) (cmp x y) 56 | }. 57 | Arguments cmp {c} x y. 58 | Arguments eqb {c} x y. 59 | 60 | Lemma eqb_spec (A: cmpType): forall x y: A, reflect (x=y) (eqb x y). 61 | Proof. now case A. Qed. 62 | Lemma cmp_spec (A: cmpType): forall x y: A, compare_spec (x=y) (cmp x y). 63 | Proof. now case A. Qed. 64 | 65 | (** building comparison types without providing an equality function *) 66 | Definition mk_simple_cmp A cmp cmp_spec := 67 | @mk_cmp A _ (eqb_of_compare_spec _ cmp_spec) cmp cmp_spec. 68 | 69 | (** phantom identity to generate cmpTypes by unification (see ssreflect) *) 70 | Definition cmp_id (A: cmpType) (X: Set) (_:X -> carr A): cmpType := A. 71 | Notation "[ X :cmp]" := (@cmp_id _ X%type (fun x => x)) (at level 0). 72 | 73 | (** basic properties *) 74 | Lemma cmp_eq (A: cmpType) (x y: A): cmp x y = Eq -> x=y. 75 | Proof. case cmp_spec; congruence. Qed. 76 | 77 | Lemma cmp_refl (A: cmpType) (x: A): cmp x x = Eq. 78 | Proof. case cmp_spec; congruence. Qed. 79 | 80 | Lemma eqb_eq (A: cmpType) (x y: A): eqb x y = true -> x = y. 81 | Proof. case eqb_spec; congruence. Qed. 82 | 83 | Lemma eqb_refl (A: cmpType) (x: A): eqb x x = true. 84 | Proof. case eqb_spec; congruence. Qed. 85 | 86 | Lemma eqb_sym (A: cmpType) (x y: A): eqb x y = eqb y x. 87 | Proof. case eqb_spec; case eqb_spec; congruence. Qed. 88 | 89 | Lemma cmp_dec (A: cmpType) (x y: A): {x=y}+{x<>y}. 90 | Proof. case (eqb_spec A x y); tauto. Qed. 91 | 92 | (** equality on cmpTypes being decidable, we get uniqueness of identity 93 | proofs and elimination of dependent equality *) 94 | Lemma cmp_eq_dep_eq (A: cmpType) (P: A -> Type): 95 | forall p (x y: P p), eq_dep A P p x p y -> x = y. 96 | Proof. apply eq_dep_eq_dec, cmp_dec. Qed. 97 | 98 | Lemma cmp_eq_rect_eq (A: cmpType): 99 | forall (p: A) Q (x: Q p) (h: p = p), eq_rect p Q x p h = x. 100 | Proof. symmetry. apply eq_rect_eq_dec, cmp_dec. Qed. 101 | 102 | Lemma UIP_cmp (A: cmpType) (p q: A) (x y: p=q): x = y. 103 | Proof. apply UIP_dec, cmp_dec. Qed. 104 | 105 | 106 | (** * Natural numbers as a [cmpType] *) 107 | Fixpoint eqb_nat i j := 108 | match i,j with 109 | | O,O => true 110 | | S i,S j=> eqb_nat i j 111 | | _,_ => false 112 | end. 113 | Lemma eqb_nat_spec: forall i j, reflect (i=j) (eqb_nat i j). 114 | Proof. 115 | induction i; intros [|j]; try (constructor; congruence). 116 | simpl. case IHi; constructor; congruence. 117 | Qed. 118 | Fixpoint nat_compare i j := 119 | match i,j with 120 | | O,O => Eq 121 | | S i,S j=> nat_compare i j 122 | | O,_ => Lt 123 | | _,O => Gt 124 | end. 125 | Lemma nat_compare_spec: forall i j, compare_spec (i=j) (nat_compare i j). 126 | Proof. 127 | induction i; intros [|j]; try (constructor; congruence). 128 | simpl. case IHi; constructor; congruence. 129 | Qed. 130 | Canonical Structure cmp_nat := mk_cmp _ eqb_nat_spec _ nat_compare_spec. 131 | 132 | 133 | (** * Booleans as a [cmpType] *) 134 | Definition eqb_bool i j := 135 | match i,j with 136 | | false,false | true,true => true 137 | | _,_ => false 138 | end. 139 | Arguments eqb_bool !i !j/. 140 | Lemma eqb_bool_spec: forall i j, reflect (i=j) (eqb_bool i j). 141 | Proof. destruct i; destruct j; constructor; congruence. Qed. 142 | Definition bool_compare i j := 143 | match i,j with 144 | | false,false | true,true => Eq 145 | | false,true => Lt 146 | | true,false => Gt 147 | end. 148 | Arguments bool_compare !i !j/. 149 | Lemma bool_compare_spec: forall i j, compare_spec (i=j) (bool_compare i j). 150 | Proof. destruct i; destruct j; constructor; congruence. Qed. 151 | Canonical Structure cmp_bool := mk_cmp _ eqb_bool_spec _ bool_compare_spec. 152 | 153 | 154 | (** * Pairs of [cmpType]s *) 155 | Section p. 156 | Variables A B: cmpType. 157 | Definition eqb_pair (x y: A*B) := 158 | let '(x1,x2) := x in 159 | let '(y1,y2) := y in 160 | if (eqb x1 y1) then (eqb x2 y2) else false. 161 | Lemma eqb_pair_spec: forall x y, reflect (x=y) (eqb_pair x y). 162 | Proof. 163 | unfold eqb_pair. intros [? ?] [? ?]; simpl; 164 | repeat case eqb_spec; constructor; congruence. 165 | Qed. 166 | Definition pair_compare (x y: A*B) := 167 | let '(x1,x2) := x in 168 | let '(y1,y2) := y in 169 | lex (cmp x1 y1) (cmp x2 y2). 170 | Lemma pair_compare_spec: forall x y, compare_spec (x=y) (pair_compare x y). 171 | Proof. 172 | unfold pair_compare. intros [? ?] [? ?]; simpl; 173 | repeat case cmp_spec; constructor; congruence. 174 | Qed. 175 | Canonical Structure cmp_pair := mk_cmp _ eqb_pair_spec _ pair_compare_spec. 176 | End p. 177 | 178 | 179 | (** * Sums of [cmpType]s *) 180 | Section s. 181 | Variables A B: cmpType. 182 | Definition eqb_sum (x y: A+B) := 183 | match x,y with 184 | | inl x,inl y | inr x,inr y => eqb x y 185 | | _,_ => false 186 | end. 187 | Lemma eqb_sum_spec: forall x y, reflect (x=y) (eqb_sum x y). 188 | Proof. 189 | unfold eqb_sum. intros [?|?] [?|?]; simpl; 190 | try case eqb_spec; constructor; congruence. 191 | Qed. 192 | Definition sum_compare (x y: A+B) := 193 | match x,y with 194 | | inl x,inl y | inr x,inr y => cmp x y 195 | | inl _,inr _ => Lt 196 | | inr _,inl _ => Gt 197 | end. 198 | Lemma sum_compare_spec: forall x y, compare_spec (x=y) (sum_compare x y). 199 | Proof. 200 | unfold sum_compare. intros [?|?] [?|?]; simpl; 201 | try case cmp_spec; constructor; congruence. 202 | Qed. 203 | Canonical Structure cmp_sum := mk_cmp _ eqb_sum_spec _ sum_compare_spec. 204 | End s. 205 | 206 | 207 | (** * Lists of a [cmpType] *) 208 | Section l. 209 | Variables A: cmpType. 210 | Fixpoint eqb_list (h k: list A) := 211 | match h,k with 212 | | nil, nil => true 213 | | u::h, v::k => if eqb u v then eqb_list h k else false 214 | | _, _ => false 215 | end. 216 | Fixpoint list_compare (h k: list A) := 217 | match h,k with 218 | | nil, nil => Eq 219 | | nil, _ => Lt 220 | | _, nil => Gt 221 | | u::h, v::k => lex (cmp u v) (list_compare h k) 222 | end. 223 | Lemma eqb_list_spec: forall h k, reflect (h=k) (eqb_list h k). 224 | Proof. 225 | induction h as [|x h IH]; destruct k; simpl; 226 | try case eqb_spec; try case IH; constructor; congruence. 227 | Qed. 228 | Lemma list_compare_spec: forall h k, compare_spec (h=k) (list_compare h k). 229 | Proof. 230 | induction h as [|x h IH]; destruct k; simpl; 231 | try case cmp_spec; try case IH; constructor; congruence. 232 | Qed. 233 | Canonical Structure cmp_list := mk_cmp _ eqb_list_spec _ list_compare_spec. 234 | End l. 235 | 236 | -------------------------------------------------------------------------------- /theories/denum.v: -------------------------------------------------------------------------------- 1 | (** * denum: retracting various countable types into positives *) 2 | 3 | Require Import common positives ordinal. 4 | Set Implicit Arguments. 5 | 6 | (** * Sums *) 7 | 8 | Definition mk_sum (x: positive+positive) := 9 | match x with 10 | | inl p => xO p 11 | | inr p => xI p 12 | end. 13 | Definition get_sum x := 14 | match x with 15 | | xO p => inl p 16 | | xI p => inr p 17 | | _ => assert_false (inl xH) 18 | end. 19 | Lemma get_mk_sum x: get_sum (mk_sum x) = x. 20 | Proof. now destruct x. Qed. 21 | 22 | (** * Pairs *) 23 | 24 | Fixpoint xpair y x := 25 | match x with 26 | | xH => xI (xO y) 27 | | xO x => xO (xO (xpair y x)) 28 | | xI x => xI (xI (xpair y x)) 29 | end. 30 | Definition mk_pair (x: positive*positive) := xpair (snd x) (fst x). 31 | Fixpoint get_pair x := 32 | match x with 33 | | xI (xO p) => (xH,p) 34 | | xO (xO x) => let '(x,y) := get_pair x in (xO x,y) 35 | | xI (xI x) => let '(x,y) := get_pair x in (xI x,y) 36 | | _ => assert_false (xH,xH) 37 | end. 38 | Lemma get_mk_pair x: get_pair (mk_pair x) = x. 39 | Proof. 40 | destruct x as [x y]. unfold mk_pair. simpl. 41 | induction x; simpl; now rewrite ?IHx. 42 | Qed. 43 | 44 | (** * Natural numbers *) 45 | 46 | (** we use a much simpler function than the standard bijection, 47 | since we only need a retract *) 48 | Definition mk_nat := nat_rec (fun _=>positive) xH (fun _ => xO). 49 | Fixpoint get_nat x := 50 | match x with 51 | | xH => O 52 | | xO x => S (get_nat x) 53 | | _ => assert_false O 54 | end. 55 | Lemma get_mk_nat x: get_nat (mk_nat x) = x. 56 | Proof. induction x; simpl; now rewrite ?IHx. Qed. 57 | 58 | (** * Ordinals *) 59 | 60 | Definition mk_ord n (x: ord n) := mk_nat x. 61 | (** get_ord returns an option since [n] could be 0, 62 | this is not problematic in practice *) 63 | Definition get_ord n (x: positive): option (ord n). 64 | set (y:=get_nat x). case (lt_ge_dec y n). 65 | intro Hy. exact (Some (Ord y Hy)). 66 | intros _. exact None. 67 | Defined. 68 | Lemma get_mk_ord n x: get_ord n (mk_ord x) = Some x. 69 | Proof. 70 | unfold mk_ord, get_ord. destruct x as [i Hi]; simpl. 71 | rewrite get_mk_nat. case lt_ge_dec. 72 | intro. f_equal. now apply eq_ord. 73 | rewrite Hi at 1. discriminate. 74 | Qed. 75 | -------------------------------------------------------------------------------- /theories/dfa.v: -------------------------------------------------------------------------------- 1 | (** * dfa: Deterministic Finite Automata, decidability of language inclusion *) 2 | 3 | Require Import comparisons positives ordinal pair lset. 4 | Require Import monoid boolean prop sups bmx. 5 | Set Implicit Arguments. 6 | Unset Printing Implicit Defensive. 7 | 8 | (** * DFA and associated language *) 9 | 10 | (** A DFA is given by its number of states, a deterministic transition 11 | function, an acceptance condition, and a finite subset of the 12 | alphabet. 13 | 14 | States are represented by ordinals of the appropriate size. 15 | 16 | Making the finite subset of the alphabet explicit avoids us to use 17 | ordinals for the alphabet. *) 18 | 19 | Record t := mk { 20 | n: nat; 21 | u: ord n; 22 | M: ord n -> positive -> ord n; 23 | v: ord n -> bool; 24 | vars: list positive 25 | }. 26 | Notation "x ^u" := (u x) (at level 2, left associativity, format "x ^u"). 27 | Notation "x ^M" := (M x) (at level 2, left associativity, format "x ^M"). 28 | Notation "x ^v" := (v x) (at level 2, left associativity, format "x ^v"). 29 | 30 | (** changing the initial state *) 31 | Definition reroot A i := mk i A^M A^v (vars A). 32 | 33 | Lemma reroot_id A: A = reroot A (A^u). 34 | Proof. destruct A; reflexivity. Qed. 35 | 36 | (** language of a DFA [A], starting from state [i] *) 37 | Fixpoint lang A i w := 38 | match w with 39 | | nil => is_true (A^v i) 40 | | cons a w => In a (vars A) /\ lang A (A^M i a) w 41 | end. 42 | 43 | 44 | (** * Reduction of DFA language inclusion to DFA language emptiness *) 45 | 46 | Section diff. 47 | 48 | Variables A B: t. 49 | 50 | (** automaton for [A\B] *) 51 | Definition diff := mk 52 | (pair.mk (u A) (u B)) 53 | (fun p a => pair.mk (M A (pair.pi1 p) a) (M B (pair.pi2 p) a)) 54 | (fun p => v A (pair.pi1 p) ⊓ ! v B (pair.pi2 p)) 55 | (vars A). 56 | 57 | (** specification of its language *) 58 | Lemma diff_spec: vars A ≦ vars B -> 59 | forall i j, lang A i ≦ lang B j <-> lang diff (pair.mk i j) ≦ bot. 60 | Proof. 61 | intro H. 62 | cut (forall w i j, lang A i w ≦ lang B j w <-> ~ lang diff (pair.mk i j) w). 63 | intros G i j. split. intros Hij w Hw. apply G in Hw as []. apply Hij. 64 | intros Hij w. apply G. intro Hw. elim (Hij _ Hw). 65 | induction w; intros i j; simpl lang; rewrite pair.pi1mk, pair.pi2mk. 66 | case (v A i); case (v B j); firstorder discriminate. 67 | split. intros Hij [HaB Hw]. apply IHw in Hw as []. intro Aw. apply Hij. now split. 68 | intros Hw [Ha Aw]. split. apply H, Ha. eapply IHw. 2: eassumption. tauto. 69 | Qed. 70 | 71 | End diff. 72 | 73 | 74 | (** * Decidability of DFA language emptiness 75 | 76 | We proceed as follows: 77 | 1. we forget all transition labels to get a directed graph whose 78 | nodes have an accepting status. 79 | 2. we compute the reflexive and transitive closure of this graph 80 | 3. we deduce the set of all states reachable from the initial state. 81 | 4. the DFA is empty iff this set does not contain any accepting 82 | states. 83 | 84 | All these computations are straightforward, except for 2, for which 85 | we exploit Kleene star on Boolean matrices. 86 | 87 | The resulting algorithm is not efficient at all. We don't care 88 | because this is not the one we execute in the end: this one is just 89 | used to establish KA completeness. *) 90 | 91 | Section empty_dec. 92 | 93 | Variables A: t. 94 | 95 | (** erased transition graph, represented as a Boolean matrix *) 96 | Definition step: bmx (n A) (n A) := fun i j => \sup_(a\in vars A) eqb_ord (M A i a) j. 97 | 98 | (** reflexive transitive closure of this graph *) 99 | Definition steps := (@str bmx _ step). 100 | 101 | Variable i: ord (n A). 102 | 103 | (** basic properties of this closed graph *) 104 | Lemma steps_refl: steps i i. 105 | Proof. apply bmx_str_clot. constructor. Qed. 106 | 107 | Lemma steps_snoc: forall j a, steps i j -> In a (vars A) -> steps i (M A j a). 108 | Proof. 109 | setoid_rewrite bmx_str_clot. intros. eapply clot_snoc. eassumption. 110 | setoid_rewrite is_true_sup. eexists. split. eassumption. apply eqb_refl. 111 | Qed. 112 | 113 | (** state reached from [i] by following a word [w] in the DFA *) 114 | Fixpoint Ms i w := match w with nil => i | cons a w => Ms (M A i a) w end. 115 | 116 | (** each unlabelled path in the erased graph corresponds to a labelled 117 | path (word) in the DFA *) 118 | Lemma steps_least: forall j, steps i j -> exists w, w ≦ vars A /\ j = Ms i w. 119 | Proof. 120 | intros j H. apply bmx_str_clot in H. induction H as [i|i j k Hij _ [w [Hw ->]]]. 121 | exists nil. split. lattice. reflexivity. 122 | setoid_rewrite is_true_sup in Hij. destruct Hij as [a [Ha Hij]]. 123 | exists (a::w). split. intros b [<-|Hb]. assumption. now apply Hw. 124 | revert Hij. case eqb_ord_spec. 2: discriminate. now intros <-. 125 | Qed. 126 | 127 | (** can we reach an accepting state from [i] *) 128 | Definition empty := \inf_(j<_) (steps i j <<< !v A j). 129 | 130 | (* TODO: les deux lemmes suivants sont certainement simplifiables en 131 | prouvant directement l'équivalence *) 132 | 133 | (** if not, all states reachable from [i] map to the empty language *) 134 | Lemma empty_lang1 j: steps i j -> empty -> lang A j ≦ bot. 135 | Proof. 136 | intros Hj He. setoid_rewrite is_true_inf in He. setoid_rewrite le_bool_spec in He. 137 | pose proof (fun i => He i (ordinal.in_seq _)) as H. clear He. 138 | intro w. revert j Hj. induction w as [|a w IH]; simpl lang; intros j Hj. 139 | apply (H j), negb_spec in Hj. rewrite Hj. discriminate. 140 | intros [Ha Hj']. apply IH in Hj' as []. now apply steps_snoc. 141 | Qed. 142 | 143 | (** conversely, if [i] maps to them empty language, then there is no 144 | reachable accepting state *) 145 | Lemma empty_lang2: lang A i ≦ bot -> empty. 146 | Proof. 147 | intro H. setoid_rewrite is_true_inf. intros j _. 148 | rewrite le_bool_spec. intro Hj. apply steps_least in Hj as [w [Hw ->]]. 149 | generalize i (H w) Hw. clear. induction w; intros i Hi Hw. 150 | simpl in *. destruct (v A i). now elim Hi. reflexivity. 151 | apply IHw. intro H. elim Hi. split. apply Hw. now left. assumption. 152 | intros ? ?. apply Hw. now right. 153 | Qed. 154 | 155 | (** decidability of language emptiness follows *) 156 | Theorem empty_dec: {lang A i ≦ bot} + {~ (lang A i ≦ bot)}. 157 | Proof. 158 | case_eq empty; [left|right]. 159 | apply (empty_lang1 _ steps_refl H). 160 | intro E. apply empty_lang2 in E. rewrite H in E. discriminate. 161 | Qed. 162 | 163 | End empty_dec. 164 | 165 | 166 | (** * Decidability of DFA language inclusion *) 167 | 168 | Corollary lang_incl_dec A B: vars A ≦ vars B -> 169 | forall i j, {lang A i ≦ lang B j} + {~(lang A i ≦ lang B j)}. 170 | Proof. intros. eapply sumbool_iff. symmetry. now apply diff_spec. apply empty_dec. Qed. 171 | -------------------------------------------------------------------------------- /theories/factors.v: -------------------------------------------------------------------------------- 1 | (** * factors: additional properties of left and right factors *) 2 | 3 | Require Import kleene. 4 | Set Implicit Arguments. 5 | 6 | Lemma ldv_dotx `{laws} `{DIV ≪ l} n m p q (x: X n m) (y: X m p) (z: X n q): x⋅y -o z ≡ y -o x -o z. 7 | Proof. 8 | apply from_below. intro t. 9 | now rewrite 3ldv_spec, dotA. 10 | Qed. 11 | 12 | Lemma ldv_xdot `{laws} `{DIV ≪ l} n m p (x: X n m) (y: X m p): y ≦ x -o (x⋅y). 13 | Proof. now rewrite ldv_spec. Qed. 14 | 15 | Lemma ldv_1x `{laws} `{DIV ≪ l} n m (x: X n m): 1 -o x ≡ x. 16 | Proof. apply from_below. intro y. now rewrite ldv_spec, dot1x. Qed. 17 | 18 | Lemma ldv_0x `{laws} `{DIV+BOT+TOP ≪ l} n m p (x: X n m): 0 -o x ≡ top' p m. 19 | Proof. apply from_below. intro y. rewrite ldv_spec, dot0x. split; intros _; lattice. Qed. 20 | 21 | Lemma ldv_xt `{laws} `{DIV+TOP ≪ l} n m p (x: X n m): x -o top ≡ top' m p. 22 | Proof. apply from_below. intro y. rewrite ldv_spec. split; intros _; lattice. Qed. 23 | 24 | Lemma str_ldv `{laws} `{STR+DIV ≪ l} n m (x: X n m): (x -o x)^* ≡ x -o x. 25 | Proof. apply antisym. apply str_ldv_. apply str_ext. Qed. 26 | 27 | Lemma ldv_rdv `{laws} `{DIV ≪ l} n m p q (x: X n m) y (z: X p q): x -o (y o- z) ≡ (x -o y) o- z. 28 | Proof. apply from_below. intro. now rewrite ldv_spec, 2rdv_spec, ldv_spec, dotA. Qed. 29 | 30 | Lemma ldv_unfold `{laws} `{BL+DIV+CNV ≪ l} n m p (x: X n m) (y: X n p): x -o y ≡ !(x° ⋅ !y). 31 | Proof. apply from_below. intro. now rewrite ldv_spec, neg_leq_iff', <-Schroeder_l. Qed. 32 | 33 | 34 | (** dual properties for right factors *) 35 | 36 | Lemma rdv_cancel `{laws} `{DIV ≪ l} n m p (x: X m n) (y: X p n): (y o- x)⋅x ≦ y. 37 | Proof. dual @ldv_cancel. Qed. 38 | 39 | Lemma rdv_dotx `{laws} `{DIV ≪ l} n m p q (x: X m n) (y: X p m) (z: X q n): z o- y⋅x ≡ z o- x o- y. 40 | Proof. dual @ldv_dotx. Qed. 41 | 42 | Lemma rdv_xdot `{laws} `{DIV ≪ l} n m p (x: X m n) (y: X p m): y ≦ y⋅x o- x. 43 | Proof. dual @ldv_xdot. Qed. 44 | 45 | Lemma leq_rdv `{laws} `{DIV ≪ l} n m (x y: X m n): x ≦ y <-> 1 ≦ y o- x. 46 | Proof. dual @leq_ldv. Qed. 47 | 48 | Lemma rdv_xx `{laws} `{DIV ≪ l} n m (x: X m n): 1 ≦ x o- x. 49 | Proof. dual @ldv_xx. Qed. 50 | 51 | Lemma rdv_1x `{laws} `{DIV ≪ l} n m (x: X m n): x o- 1 ≡ x. 52 | Proof. dual @ldv_1x. Qed. 53 | 54 | Lemma rdv_0x `{laws} `{DIV+BOT+TOP ≪ l} n m p (x: X m n): x o- 0 ≡ top' m p. 55 | Proof. dual @ldv_0x. Qed. 56 | 57 | Lemma rdv_xt `{laws} `{DIV+TOP ≪ l} n m p (x: X m n): top o- x ≡ top' p m. 58 | Proof. dual @ldv_xt. Qed. 59 | 60 | Lemma rdv_trans `{laws} `{DIV ≪ l} n m p q (x: X m n) (y: X p n) (z: X q n): 61 | (z o- y)⋅(y o- x) ≦ z o- x. 62 | Proof. dual @ldv_trans. Qed. 63 | 64 | Lemma str_rdv `{laws} `{STR+DIV ≪ l} n m (x: X m n): (x o- x)^* ≡ x o- x. 65 | Proof. dual @str_ldv. Qed. 66 | 67 | Lemma rdv_unfold `{laws} `{BL+DIV+CNV ≪ l} n m p (x: X m n) (y: X p n): y o- x ≡ !(!y⋅x°). 68 | Proof. dual @ldv_unfold. Qed. 69 | -------------------------------------------------------------------------------- /theories/glang.v: -------------------------------------------------------------------------------- 1 | (** * glang: the KAT model of guarded string languages *) 2 | 3 | (** The model of guarded string languages is the model of traces, when 4 | states are the atoms of a Boolean lattice, we prove here that this 5 | it is a model of Kleene algebra with tests (KAT), where the Boolean 6 | subalgebra is just the free one: the set of Boolean expressions. 7 | 8 | Like for traces, we provide both untyped and typed models. *) 9 | 10 | Require Export traces. 11 | Require Import kat lsyntax ordinal comparisons boolean. 12 | Set Implicit Arguments. 13 | 14 | Section s. 15 | 16 | (** * Untyped model *) 17 | 18 | (** We consider the free Boolean lattice over a set of [pred] 19 | predicates, whose atoms are just functions [a: ord pred -> bool] 20 | assigning a truth value to each variable. *) 21 | 22 | Variable pred: nat. 23 | Notation Sigma := positive. 24 | 25 | (** to avoid extensionality problems, we call "atom" an element of 26 | [ord (pow2 pred)], relying on the bijection between [ord pred -> 27 | bool] and that set when needed *) 28 | 29 | Notation Atom := (ord (pow2 pred)). 30 | 31 | (** Boolean expressions over [pred] variables are injected into 32 | traces as follows: take all traces reduced to a single atom 33 | (i.e., state) such that the Boolean expression evaluates to [true] 34 | under the corresponding assignation of variables *) 35 | Definition glang_inj (n: traces_unit) (x: expr_ops (ord pred) BL): 36 | traces Atom := 37 | fun w => 38 | match w with 39 | | tnil a => is_true (eval (set.mem a) x) 40 | | _ => False 41 | end. 42 | 43 | (** packing this injection together with the Kleene algebra of traces 44 | and the Boolean algebra of expressions *) 45 | Canonical Structure glang_kat_ops := kat.mk_ops _ _ glang_inj. 46 | 47 | (** This model satisfies KAT laws *) 48 | Global Instance glang_kat_laws: kat.laws glang_kat_ops. 49 | Proof. 50 | constructor. apply lower_laws. intro. apply expr_laws. 51 | assert (inj_leq: forall n, Proper (leq ==> leq) (@glang_inj n)). 52 | intros n e f H [a|]. 2: reflexivity. 53 | apply (fn_leq _ _ (H _ lower_lattice_laws _)). 54 | constructor; try discriminate. 55 | apply inj_leq. 56 | apply op_leq_weq_1. 57 | intros _ x y [a|]. 2: compute; tauto. simpl. 58 | setoid_rewrite Bool.orb_true_iff. reflexivity. 59 | intros _ [a|]. 2: reflexivity. simpl. intuition discriminate. 60 | intros ? [a|]. 2: reflexivity. simpl. now intuition. 61 | intros ? x y [a|]. simpl. setoid_rewrite Bool.andb_true_iff. split. 62 | intros (Hx&Hy). repeat exists (tnil a); try split; trivial. constructor. 63 | intros [[b|] Hu [[c|] Hv H]]; try elim Hu; try elim Hv. 64 | inversion H. intuition congruence. 65 | intros. simpl. split. intros []. 66 | intros [[b|] Hu [[c|] Hv H]]; try elim Hu; try elim Hv. inversion H. 67 | Qed. 68 | 69 | 70 | (** * Typed model *) 71 | 72 | (** the typed model is obtained in a straighforward way from the typed 73 | traces model: Boolean expressions can be injected as in the untyped 74 | case since there are no typing constraints on the generated traces 75 | (they are reduced to a single state). *) 76 | 77 | Variables src tgt: Sigma -> positive. 78 | 79 | Program Definition tglang_inj n (x: expr_ops (ord pred) BL): ttraces Atom src tgt n n := 80 | glang_inj traces_tt x. 81 | Next Obligation. intros [a|???] []. constructor. Qed. 82 | 83 | Canonical Structure tglang_kat_ops := kat.mk_ops _ _ tglang_inj. 84 | 85 | (* TODO: comment factoriser les deux preuves? *) 86 | Global Instance tglang_kat_laws: kat.laws tglang_kat_ops. 87 | Proof. 88 | constructor. apply lower_laws. intro. apply expr_laws. 89 | assert (inj_leq: forall n, Proper (leq ==> leq) (@tglang_inj n)). 90 | intros n e f H [a|]. 2: reflexivity. 91 | apply (fn_leq _ _ (H _ lower_lattice_laws _)). 92 | constructor; try discriminate. 93 | apply inj_leq. 94 | apply op_leq_weq_1. 95 | intros _ x y [a|]. 2: compute; tauto. simpl. 96 | setoid_rewrite Bool.orb_true_iff. tauto. 97 | intros _ [a|]. 2: reflexivity. simpl. intuition discriminate. 98 | intros ? [a|]. 2: reflexivity. simpl. now intuition. 99 | intros ? x y [a|]. simpl. setoid_rewrite Bool.andb_true_iff. split. 100 | intros (Hx&Hy). repeat exists (tnil a); try split; trivial. constructor. 101 | intros [[b|] Hu [[c|] Hv H]]; try elim Hu; try elim Hv. 102 | inversion H. intuition congruence. 103 | intros. simpl. split. intros []. 104 | intros [[b|] Hu [[c|] Hv H]]; try elim Hu; try elim Hv. inversion H. 105 | Qed. 106 | 107 | End s. 108 | -------------------------------------------------------------------------------- /theories/gregex.v: -------------------------------------------------------------------------------- 1 | (** * gregex: generalised typed regular expressions, for KAT *) 2 | 3 | (** we define a typed syntax for KAT expressions: 4 | - typed because we have to prove KAT completeness at the typed level 5 | - generalised w.r.t. regular expressions since it has to embeds 6 | Boolean expressions, for tests *) 7 | 8 | Require Import lsyntax glang kat boolean atoms sups. 9 | Set Implicit Arguments. 10 | 11 | 12 | (** * Generalised regular expressions *) 13 | 14 | Section s. 15 | 16 | (** [I] is the set of objects of the category (or types, or indices) *) 17 | Notation I := positive. 18 | (** [Sigma] is the set of (Kleene) variables, those interpreted as relations, for instance *) 19 | Notation Sigma := positive. 20 | (** [pred] is the number of predicate variables (elementary tests), so 21 | that tests are just expressions with variables in [ord pred] *) 22 | Variable pred: nat. 23 | (** [src] and [tgt] assign a type to each Kleene variable *) 24 | Variables src tgt: Sigma -> I. 25 | (** Note that we do not type elementary tests: we shall actually prove 26 | a specific untyping theorem about KAT which makes this possible *) 27 | 28 | (** generalised regular expressions are just typed regular 29 | expressions, with an additional constructor, [g_prd], for embedding 30 | Boolean expressions *) 31 | Inductive gregex: I -> I -> Set := 32 | | g_zer: forall {n m}, gregex n m 33 | | g_prd: forall {n} (a: expr (ord pred)), gregex n n 34 | | g_var: forall (i: Sigma), gregex (src i) (tgt i) 35 | | g_pls: forall n m (e f: gregex n m), gregex n m 36 | | g_dot: forall n m p (e: gregex n m) (f: gregex m p), gregex n p 37 | | g_itr: forall n (e: gregex n n), gregex n n. 38 | 39 | (** [1] is derived, as the injection of the [top] expression *) 40 | Definition g_one {n} := @g_prd n e_top. 41 | 42 | (** Also note that [g_itr] is chosen as primitive, rather than [g_str] *) 43 | Definition g_str n (e: gregex n n) := g_pls g_one (g_itr e). 44 | 45 | 46 | 47 | (** * Interpretation into an arbitrary Kleene algebra with tests *) 48 | 49 | Section e. 50 | 51 | (** to interpret an expressions, we need: 52 | - a KAT [X], 53 | - an interpretation [fo] of syntactic types ([I]) 54 | - a properly typed interpretation [fs] of each Kleene variable 55 | - an interpretation [fp] of each predicate variable into the tests of X, at each type n 56 | (consider for instance, the expression [p]⋅a*[q], with [a: X n m, p: tst n, q: tst m], 57 | which can be represented by the term [@g_prd 1 (e_var 1) ⋅ g_var 1 ⋅ @g_prd 2 (e_var 1)], 58 | with the environments [fo(1)=n], [fo(2)=m], [fs(1)=1], [fp(1)(1)=p], [fp(2)(1)=q]). *) 59 | Context {X: kat.ops}. 60 | Variable fo: I -> ob X. 61 | Variable fp: forall n, ord pred -> tst (fo n). 62 | Variable fs: forall i, X (fo (src i)) (fo (tgt i)). 63 | 64 | Fixpoint eval n m (e: gregex n m): X (fo n) (fo m) := 65 | match e with 66 | | g_zer => 0 67 | | @g_prd n p => [lsyntax.eval (fp n) p] 68 | | g_pls e f => eval e + eval f 69 | | g_dot e f => eval e ⋅ eval f 70 | | g_itr e => (eval e)^+ 71 | | g_var i => fs i 72 | end. 73 | 74 | End e. 75 | 76 | (** * generalised regular expressions form a model of KAT *) 77 | 78 | (** (in)equalitiy on [gregex] is defined as a smallest fixed-point, impredicatevely *) 79 | Definition g_leq n m (x y: gregex n m) := 80 | forall X (L: kat.laws X) fo fp fa, @eval X fo fp fa n m x ≦ @eval X fo fp fa n m y. 81 | Definition g_weq n m (x y: gregex n m) := 82 | forall X (L: kat.laws X) fo fp fa, @eval X fo fp fa n m x ≡ @eval X fo fp fa n m y. 83 | 84 | (** packing all operations using canonical structures *) 85 | Canonical Structure gregex_lattice_ops n m := {| 86 | car := gregex n m; 87 | leq := @g_leq n m; 88 | weq := @g_weq n m; 89 | cup := @g_pls n m; 90 | bot := @g_zer n m; 91 | cap := assert_false (@g_pls n m); 92 | top := assert_false (@g_zer n m); 93 | neg := assert_false id 94 | |}. 95 | 96 | Canonical Structure gregex_monoid_ops := {| 97 | ob := I; 98 | mor := gregex_lattice_ops; 99 | dot := g_dot; 100 | one := @g_one; 101 | itr := g_itr; 102 | str := g_str; 103 | cnv n m := assert_false (fun _ => bot); 104 | ldv n m p := assert_false (fun _ _ => bot); 105 | rdv n m p := assert_false (fun _ _ => bot) 106 | |}. 107 | 108 | Canonical Structure gregex_kat_ops := 109 | kat.mk_ops gregex_monoid_ops (fun n => expr_ops _ BL) (@g_prd). 110 | 111 | (** lattice laws *) 112 | Global Instance gregex_lattice_laws n m: lattice.laws BKA (gregex_lattice_ops n m). 113 | Proof. 114 | constructor; try right; try discriminate. constructor. 115 | intros x X L fo fa fs. reflexivity. 116 | intros x y z H H' X L fo fa fs. transitivity (eval fo fa fs y); auto. 117 | intros x y. split. 118 | intro H. split; intros X L fo fa fs. now apply weq_leq, H. now apply weq_geq, H. 119 | intros [H H'] X L fo fa fs. apply antisym; auto. 120 | intros Hl x y z. split. 121 | intro H. split; intros X L fo fa fs; specialize (H X L fo fa fs); simpl in H; hlattice. 122 | intros [H H'] X L fo fa fs. simpl. apply cup_spec; auto. 123 | intros x X L fo fa fs. apply leq_bx. 124 | Qed. 125 | 126 | (** kleene algebra laws *) 127 | Global Instance gregex_monoid_laws: monoid.laws BKA gregex_monoid_ops. 128 | Proof. 129 | constructor; (try discriminate); repeat right; repeat intro; simpl. 130 | apply gregex_lattice_laws. 131 | apply dotA. 132 | rewrite inj_top. apply dot1x. 133 | rewrite inj_top. apply dotx1. 134 | apply dot_leq; auto. 135 | now rewrite dotplsx. 136 | now rewrite dotxpls. 137 | now rewrite dot0x. 138 | now rewrite dotx0. 139 | lattice. 140 | rewrite inj_top, <-str_itr. apply str_cons. 141 | rewrite inj_top, <-str_itr. apply str_ind_l. now refine (H0 _ _ _ _ _). 142 | rewrite inj_top, <-str_itr. apply str_ind_r. now refine (H0 _ _ _ _ _). 143 | rewrite inj_top, <-str_itr. apply itr_str_l. 144 | Qed. 145 | 146 | (** KAT laws *) 147 | Global Instance gregex_kat_laws: kat.laws gregex_kat_ops. 148 | Proof. 149 | constructor. apply gregex_monoid_laws. intro. apply lower_lattice_laws. 150 | constructor; try discriminate; repeat intro. 151 | apply inj_leq, H, tst_BL. 152 | apply inj_weq, H, tst_BL. 153 | apply inj_cup. 154 | apply inj_bot. 155 | reflexivity. 156 | repeat intro. apply inj_cap. 157 | Qed. 158 | 159 | (** additional properties of the injection ([g_prd]) *) 160 | Definition inj_cup := @inj_cup _ gregex_kat_laws. 161 | Definition inj_bot := @inj_bot _ gregex_kat_laws. 162 | Definition inj_cap := @inj_cap _ gregex_kat_laws. 163 | Definition inj_top := @inj_top _ gregex_kat_laws. 164 | Definition inj_weq := @inj_weq _ gregex_kat_laws. 165 | Definition inj_leq := @inj_leq _ gregex_kat_laws. 166 | 167 | Lemma inj_sup n I J (f: I -> expr_ BL): @g_prd n (sup f J) ≡ \sup_(i\in J) g_prd (f i). 168 | Proof. apply f_sup_weq. apply inj_bot. apply inj_cup. Qed. 169 | 170 | 171 | (** * Interpretation in the guarded strings model *) 172 | 173 | (** atoms are functions from predicate variables to [bool] *) 174 | Notation Atom := (ord (pow2 pred)). 175 | (** guarded string languages, typed according to the [src] and [tgt] functions *) 176 | Notation glang n m := (tglang_kat_ops pred src tgt n m). 177 | 178 | (** injection of atoms *) 179 | Notation g_atom n a := (@g_prd n (atom a)). 180 | 181 | (** (guarded string) language of a generalised regular expression. 182 | unlike for regular expressions, we define it inductively *) 183 | Definition lang: forall n m, gregex_kat_ops n m -> glang n m := 184 | eval id (fun _ => @e_var _) ttsingle. 185 | 186 | (** this interpretation function is a KA morphism, by definition *) 187 | 188 | Global Instance lang_leq n m: Proper (leq ==> leq) (@lang n m). 189 | Proof. intros e f H. apply H. apply tglang_kat_laws. Qed. 190 | Global Instance lang_weq n m: Proper (weq ==> weq) (@lang n m) := op_leq_weq_1. 191 | 192 | Lemma lang_0 n m: @lang n m 0 = 0. 193 | Proof. reflexivity. Qed. 194 | 195 | Lemma lang_1 n: @lang n n 1 ≡ 1. 196 | Proof. intros [|]; simpl; intuition. Qed. 197 | 198 | Lemma lang_pls n m (e f: gregex n m): lang (e+f) = lang e + lang f. 199 | Proof. reflexivity. Qed. 200 | 201 | Lemma lang_dot n m p (e: gregex n m) (f: gregex m p): lang (e⋅f) = lang e ⋅ lang f. 202 | Proof. reflexivity. Qed. 203 | 204 | Lemma lang_itr n (e: gregex n n): lang (e^+) = (lang e)^+. 205 | Proof. reflexivity. Qed. 206 | 207 | Lemma lang_sup n m I J (f: I -> _): @lang n m (sup f J) = \sup_(i\in J) lang (f i). 208 | Proof. apply f_sup_eq; now f_equal. Qed. 209 | 210 | 211 | (** languages of atoms *) 212 | 213 | Lemma lang_atom n a: lang (g_atom n a) ≡ tatom n a. 214 | Proof. 215 | (* TODO: voir si on peut faire mieux *) 216 | intros [b|]. 2: intros; compute; intuition discriminate. 217 | simpl. setoid_rewrite eval_var. 218 | split. intros H. now apply eval_atom in H as <-. 219 | intro E. injection E. clear E. intros <-. 220 | unfold atom. rewrite eval_inf. 221 | rewrite is_true_inf. intros i _. 222 | case_eq (set.mem a i); simpl; intros ->; reflexivity. 223 | Qed. 224 | 225 | End s. 226 | Arguments g_var {pred src tgt} i. 227 | -------------------------------------------------------------------------------- /theories/kat.v: -------------------------------------------------------------------------------- 1 | (** kat: Kleene algebra with tests *) 2 | 3 | (** We define here the class of Kleene algebra with tests, as a two 4 | sorted structure *) 5 | 6 | Require Export kleene. 7 | Set Implicit Arguments. 8 | 9 | (** * KAT operations *) 10 | 11 | (** A Kleene algebra with tests is composed of a Kleene algebra 12 | ([kar], i.e., [(X,dot,pls,one,zer,str)]), a Boolean algebra of 13 | tests ([tst], i.e., [(T,cap,cup,top,bot,neg)]), and an injection 14 | from tests to Kleene elements. 15 | 16 | Since we work with typed structures, the Kleene algebra is a 17 | category, and we actually have a family of Boolean algebras, for 18 | each square homset ([X n n]). *) 19 | Class ops := mk_ops { 20 | kar: monoid.ops; 21 | tst: ob kar -> lattice.ops; 22 | inj: forall {n}, tst n -> kar n n 23 | }. 24 | Coercion kar: ops >-> monoid.ops. 25 | (** we use [[p]] to denote the injection of the test [p] into the Kleene algebra *) 26 | Notation " [ p ] " := (inj p): ra_terms. 27 | 28 | (* -- failed attempts to declare [inj] as a coercion -- *) 29 | (* SubClass car' {X} n := @car (@tst X n). *) 30 | (* SubClass car'' {X} n := @car (@mor (@kar X) n n). *) 31 | (* Definition inj' X n: @car' X n -> @car'' X n := @inj X n. *) 32 | (* Coercion inj' : car' >-> car''. *) 33 | (* Print Coercion Paths car' car. *) 34 | (* Goal forall `{X: ops} n m (a: X n m) (p: tst n) (q: tst m), p⋅a*q ≡ a. *) 35 | 36 | 37 | (** * KAT laws *) 38 | 39 | (** The Kleene algebra should be a Kleene algebra (with bottom 40 | element), the Boolean algebras should be a Boolean lattice, and the 41 | injection should be a morphism of idempotent semirings, i.e, map 42 | [(leq,weq,cap,cup,top,bot)] into [(leq,weq,dot,pls,one,zer)] *) 43 | 44 | (* TOTHINK: voir si on laisse les deux instances ::, 45 | qui ne sont utiles que dans l'abstrait si les structures 46 | concrètes sont déclarées incrémentalement 47 | voir aussi s'il ne vaut pas mieux poser ces deux instances en 48 | paramètres phantomes. 49 | TODO: inliner [morphism]? 50 | TODO: relacher les contraintes sur les niveaux 51 | *) 52 | Class laws (X: ops) := { 53 | kar_BKA:: monoid.laws BKA kar; 54 | tst_BL:: forall n, lattice.laws BL (tst n); 55 | mor_inj: forall n, morphism BSL (@inj X n); 56 | inj_top: forall n, [top] ≡ one n; 57 | inj_cap: forall n (p q: tst n), [p ⊓ q] ≡ [p] ⋅ [q] 58 | }. 59 | 60 | 61 | (** * Basic properties of KAT *) 62 | 63 | Section s. 64 | Context `{L: laws}. 65 | Variable n: ob X. 66 | 67 | Global Instance inj_leq: Proper (leq ==> leq) (@inj X n). 68 | Proof. apply mor_inj. Qed. 69 | 70 | Global Instance inj_weq: Proper (weq ==> weq) (@inj X n). 71 | Proof. apply mor_inj. Qed. 72 | 73 | Lemma inj_bot: [bot] ≡ zer n n. 74 | Proof. now apply mor_inj. Qed. 75 | 76 | Lemma inj_cup (p q: tst n): [p ⊔ q] ≡ [p] + [q]. 77 | Proof. now apply mor_inj. Qed. 78 | 79 | Lemma str_inj (p: tst n): [p]^* ≡ 1. 80 | Proof. apply antisym. now rewrite leq_xt, inj_top, str1. apply str_refl. Qed. 81 | 82 | End s. 83 | 84 | 85 | (** * dual KAT, for duality reasoning *) 86 | 87 | Definition dual (X: ops) := {| 88 | kar := dual kar; 89 | tst := tst; 90 | inj := @inj X |}. 91 | 92 | Lemma dual_laws X (L: laws X): laws (dual X). 93 | Proof. 94 | constructor; try apply L. 95 | apply dual_laws, kar_BKA. 96 | intros. simpl in *. 97 | rewrite capC. apply inj_cap. 98 | Qed. 99 | 100 | Lemma dualize {P: ops -> Prop} (L: forall X, laws X -> P X) {X} {H: laws X}: P (dual X). 101 | Proof. eapply L. now apply dual_laws. Qed. 102 | 103 | Ltac dual x := apply (dualize x). 104 | -------------------------------------------------------------------------------- /theories/kat_untyping.v: -------------------------------------------------------------------------------- 1 | (** * kat_untyping: untyping theorem for KAT *) 2 | 3 | (** We prove a strong untyping theorem for KAT: 4 | - types can be erased (as in the untyping theorem in [untyping]) 5 | - predicate variables of distinct types can be merged 6 | 7 | The proofs are quite simple since we can perform them at the level 8 | of guarded string languages: unlike for KA, we proved typed 9 | completeness of KAT w.r.t. these models. *) 10 | 11 | Require Import kat gregex ugregex ordinal positives glang. 12 | Set Implicit Arguments. 13 | 14 | Section s. 15 | Variable Pred: nat. 16 | Notation Atom := (ord (pow2 Pred)). 17 | Notation Sigma := positive. 18 | Variables src tgt: Sigma -> positive. 19 | Notation pred := (ord Pred). 20 | Notation gregex := (gregex_kat_ops Pred src tgt). 21 | Notation ugregex := (ugregex_monoid_ops Pred ugregex_tt ugregex_tt). 22 | Notation glang := (@gregex.lang Pred src tgt). 23 | Notation uglang := (@ugregex.lang Pred). 24 | Notation typed := (@typed' Atom src tgt). 25 | 26 | (** type-erasing function on extended regular expressions *) 27 | 28 | Fixpoint gerase n m (e: gregex n m): ugregex := 29 | match e with 30 | | g_zer _ _ _ => 0 31 | | g_prd _ _ p => u_prd p 32 | | g_pls e f => gerase e + gerase f 33 | | g_dot e f => gerase e ⋅ gerase f 34 | | g_itr e => (gerase e)^+ 35 | | g_var i => u_var _ i 36 | end. 37 | 38 | (** charaterisation of the guarded string language of erased epressions *) 39 | 40 | Lemma uglang_gerase n m (e: gregex n m): 41 | uglang (gerase e) ≡ eval (fun _ => traces_tt) (fun _ => @lsyntax.e_var _) tsingle e. 42 | Proof. 43 | induction e; simpl gerase. 44 | apply lang_0. 45 | simpl. rewrite lsyntax.eval_var. reflexivity. 46 | reflexivity. 47 | now apply cup_weq. 48 | now apply dot_weq. 49 | now apply itr_weq. 50 | Qed. 51 | 52 | Corollary gerase_weq n m: Proper (weq ==> weq) (@gerase n m). 53 | Proof. intros ? ? H. simpl. unfold u_weq. rewrite 2uglang_gerase. apply (H _ _ _). Qed. 54 | 55 | 56 | (** the a priori untyped guarded string language of a typed gregex is necessarily typed *) 57 | 58 | Lemma typed_uglang_gerase n m (e: gregex n m): typed n m (uglang (gerase e)). 59 | Proof. 60 | induction e. 61 | intros [|] H. discriminate. destruct H. 62 | apply typed'_inj. 63 | apply typed'_single. 64 | revert IHe1 IHe2. apply typed'_cup. 65 | revert IHe1 IHe2. apply typed'_dot. 66 | revert IHe. apply typed'_itr. 67 | Qed. 68 | 69 | 70 | (** we can thus recover the typed language out of the untyped one *) 71 | 72 | Notation restrict := (restrict src tgt). 73 | 74 | Theorem untype_glang n m (e: gregex n m): glang e ≡ restrict n m (uglang (gerase e)). 75 | Proof. 76 | symmetry. induction e. 77 | setoid_rewrite lang_0. apply restrict_0. 78 | setoid_rewrite restrict_inj. simpl. unfold ttraces_weq. simpl. now rewrite lsyntax.eval_var. 79 | apply restrict_single. 80 | etransitivity. 2: apply cup_weq; eassumption. apply restrict_pls. 81 | etransitivity. 2: apply dot_weq; eassumption. apply restrict_dot; apply typed_uglang_gerase. 82 | etransitivity. 2: apply itr_weq; eassumption. apply restrict_itr; apply typed_uglang_gerase. 83 | Qed. 84 | 85 | End s. 86 | -------------------------------------------------------------------------------- /theories/kleene.v: -------------------------------------------------------------------------------- 1 | (** kleene: simple facts about Kleene star *) 2 | (** and strict iteration *) 3 | 4 | Require Export monoid. 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | 8 | (** * properties of Kleene star *) 9 | 10 | (** additional induction schemes *) 11 | Lemma str_ind_r' `{laws} `{STR ≪ l} n m (x: X n n) (y z: X m n): y ≦ z -> z⋅x ≦ z -> y⋅x^* ≦ z. 12 | Proof. dual @str_ind_l'. Qed. 13 | 14 | Lemma str_ind_r1 `{laws} `{STR ≪ l} n (x z: X n n): 1 ≦ z -> z ⋅ x ≦ z -> x ^* ≦ z. 15 | Proof. dual @str_ind_l1. Qed. 16 | 17 | Lemma str_unfold_r `{laws} `{KA ≪ l} n (x: X n n): x^* ≡ 1 + x^* ⋅ x. 18 | Proof. dual @str_unfold_l. Qed. 19 | 20 | (** bisimulation rules *) 21 | Lemma str_move_l `{laws} `{STR ≪ l} n m (x: X n m) y z: 22 | x ⋅ y ≦ z ⋅ x -> x ⋅ y^* ≦ z^* ⋅ x. 23 | Proof. 24 | intro E. apply str_ind_r'. now rewrite <-str_refl, dot1x. 25 | rewrite <-str_snoc at 2. now rewrite <-dotA, E, dotA. 26 | Qed. 27 | 28 | Lemma str_move_r `{laws} `{STR ≪ l} n m (x: X m n) y z: 29 | y ⋅ x ≦ x ⋅ z -> y^* ⋅ x ≦ x ⋅ z^*. 30 | Proof. dual @str_move_l. Qed. 31 | 32 | Lemma str_move `{laws} `{STR ≪ l} n m (x: X n m) y z: 33 | x ⋅ y ≡ z ⋅ x -> x ⋅ y^* ≡ z^* ⋅ x. 34 | Proof. 35 | intro. apply antisym. 36 | apply str_move_l. now apply weq_leq. 37 | apply str_move_r. now apply weq_geq. 38 | Qed. 39 | 40 | Lemma str_dot `{laws} `{STR ≪ l} n m (x: X n m) y: x ⋅ (y ⋅ x)^* ≡ (x ⋅ y)^* ⋅ x. 41 | Proof. apply str_move, dotA. Qed. 42 | 43 | (** [str] is uniquely determined *) 44 | Lemma str_unique `{laws} `{STR ≪ l} n (a x: X n n): 45 | 1 ≦x -> a⋅x ≦ x -> (forall y: X n n, a⋅y ≦y -> x⋅y ≦y) -> a^* ≡ x. 46 | Proof. 47 | intros H1 H2 H3. apply antisym. now apply str_ind_l1. 48 | rewrite <-(dotx1 x), (str_refl a). apply H3. apply str_cons. 49 | Qed. 50 | 51 | Lemma str_unique' `{laws} `{KA ≪ l} n (a x: X n n): 52 | 1+a⋅x ≦ x -> (forall y: X n n, a⋅y ≦y -> x⋅y ≦y) -> a^* ≡ x. 53 | Proof. rewrite cup_spec. intros []. now apply str_unique. Qed. 54 | 55 | (** value of [str] on constants *) 56 | Lemma str1 `{laws} `{STR ≪ l} n: 1^* ≡ one n. 57 | Proof. apply str_unique. reflexivity. now rewrite dotx1. trivial. Qed. 58 | 59 | Lemma str0 `{laws} `{STR+BOT ≪ l} n: 0^* ≡ one n. 60 | Proof. apply str_unique. reflexivity. rewrite dot0x. lattice. now intros; rewrite dot1x. Qed. 61 | 62 | Lemma strtop `{laws} `{STR+TOP ≪ l} n: top^* ≡ @top (mor n n). 63 | Proof. apply leq_tx_iff. apply str_ext. Qed. 64 | 65 | (** transitivity of starred elements *) 66 | Lemma str_trans `{laws} `{STR ≪ l} n (x: X n n): x^* ⋅ x^* ≡ x^*. 67 | Proof. 68 | apply antisym. apply str_ind_l; apply str_cons. 69 | rewrite <-str_refl at 2. now rewrite dot1x. 70 | Qed. 71 | 72 | (** [str] is involutive *) 73 | Lemma str_invol `{laws} `{STR ≪ l} n (x: X n n): x^*^* ≡ x^*. 74 | Proof. apply antisym. apply str_ind_l1. apply str_refl. now rewrite str_trans. apply str_ext. Qed. 75 | 76 | (** (de)nesting rule *) 77 | Lemma str_pls `{laws} `{KA ≪ l} n (x y: X n n): (x+y)^* ≡ x^*⋅(y⋅x^*)^*. 78 | Proof. 79 | apply str_unique. 80 | rewrite <-2str_refl. now rewrite dotx1. 81 | rewrite dotplsx. apply leq_cupx. 82 | now rewrite dotA, str_cons. 83 | rewrite <-(str_refl x) at 3. now rewrite dot1x, dotA, str_cons. 84 | intros z Hz. rewrite dotplsx in Hz. apply cup_spec in Hz as [Hxz Hyz]. rewrite <-dotA. 85 | apply str_ind_l'. 2: assumption. 86 | apply str_ind_l. rewrite <- Hyz at 2. rewrite <-dotA. apply dot_leq. reflexivity. 87 | now apply str_ind_l. 88 | Qed. 89 | 90 | Lemma str_pls' `{laws} `{KA ≪ l} n (x y: X n n): (x+y)^* ≡ (x^*⋅y)^*⋅x^*. 91 | Proof. rewrite str_pls. apply str_dot. Qed. 92 | 93 | Lemma str_pls_str `{laws} `{KA ≪ l} n (x y: X n n): (x+y)^* ≡ (x^* + y^* )^* . 94 | Proof. 95 | symmetry. rewrite str_pls, str_invol, <-str_pls. 96 | rewrite cupC. now rewrite str_pls, str_invol, <-str_pls, cupC. 97 | Qed. 98 | 99 | (** links with reflexive closure and reflexive elements *) 100 | Lemma str_pls1x `{laws} `{KA ≪ l} n (x: X n n): (1+x)^* ≡ x^*. 101 | Proof. now rewrite str_pls, str1, dot1x, dotx1. Qed. 102 | 103 | Lemma str_weq1 `{laws} `{KA ≪ l} n (x y: X n n): 1+x ≡ 1+y -> x^* ≡ y^*. 104 | Proof. rewrite <-(str_pls1x x), <-(str_pls1x y). apply str_weq. Qed. 105 | 106 | Lemma str_dot_refl `{laws} `{KA ≪ l} n (x y: X n n): 1 ≦x -> 1 ≦y -> (x⋅y)^* ≡ (x+y)^*. 107 | Proof. 108 | intros Hx Hy. apply antisym. 109 | - apply str_ind_l1. apply str_refl. 110 | rewrite <-2str_cons at 2. rewrite dotA. repeat apply dot_leq; lattice. 111 | - apply str_ind_l1. apply str_refl. 112 | rewrite <-str_cons at 2. apply dot_leq. 2: reflexivity. 113 | apply leq_cupx. now rewrite <-Hy, dotx1. now rewrite <-Hx, dot1x. 114 | Qed. 115 | 116 | 117 | (** * counterparts for strict iteration *) 118 | 119 | Lemma itr_ind_l `{laws} `{STR ≪ l} n m (x: X n n) (y z: X n m): x⋅y ≦ z -> x⋅z ≦ z -> x^+⋅y ≦ z. 120 | Proof. intros xy xz. rewrite itr_str_r, <-dotA, xy. now apply str_ind_l. Qed. 121 | 122 | Lemma itr_ind_l1 `{laws} `{STR ≪ l} n (x z: X n n): x ≦ z -> x⋅z ≦ z -> x^+ ≦ z. 123 | Proof. intros xz xz'. rewrite <-dotx1. apply itr_ind_l. now rewrite dotx1. assumption. Qed. 124 | 125 | Lemma itr_ind_r `{laws} `{STR ≪ l} n m (x: X n n) (y z: X m n): y⋅x ≦ z -> z⋅x ≦ z -> y⋅x^+ ≦ z. 126 | Proof. dual @itr_ind_l. Qed. 127 | 128 | #[export] Instance itr_leq `{laws} `{STR ≪ l} n: Proper (leq ==> leq) (itr n). 129 | Proof. intros x y E. now rewrite 2itr_str_l, E. Qed. 130 | 131 | #[export] Instance itr_weq `{laws} `{STR ≪ l} n: Proper (weq ==> weq) (itr n) := op_leq_weq_1. 132 | 133 | Lemma itr1 `{laws} `{STR ≪ l} n: 1^+ ≡ one n. 134 | Proof. now rewrite itr_str_l, str1, dot1x. Qed. 135 | 136 | Lemma itr0 `{laws} `{STR+BOT ≪ l} n: 0^+ ≡ zer n n. 137 | Proof. now rewrite itr_str_l, str0, dotx1. Qed. 138 | 139 | Lemma itr_ext `{laws} `{STR ≪ l} n (x: X n n): x ≦ x^+. 140 | Proof. now rewrite itr_str_l, <-str_refl, dotx1. Qed. 141 | 142 | Lemma itrtop `{laws} `{STR+TOP ≪ l} n: top^+ ≡ @top (mor n n). 143 | Proof. apply leq_tx_iff. apply itr_ext. Qed. 144 | 145 | Lemma itr_cons `{laws} `{STR ≪ l} n (x: X n n): x⋅x^+ ≦ x^+. 146 | Proof. rewrite itr_str_l. now rewrite str_cons at 1. Qed. 147 | 148 | Lemma itr_snoc `{laws} `{STR ≪ l} n (x: X n n): x^+⋅x ≦ x^+. 149 | Proof. dual @itr_cons. Qed. 150 | 151 | Lemma itr_pls_itr `{laws} `{KA ≪ l} n (x y: X n n): (x+y)^+ ≡ (x^+ + y^+)^+. 152 | Proof. 153 | apply antisym. apply itr_leq. now rewrite <-2itr_ext. 154 | apply itr_ind_l1. apply leq_cupx; apply itr_leq; lattice. 155 | rewrite dotplsx. apply leq_cupx; apply itr_ind_l; rewrite <-itr_cons at 2; apply dot_leq; lattice. 156 | Qed. 157 | 158 | Lemma itr_trans `{laws} `{STR ≪ l} n (x: X n n): x^+ ⋅ x^+ ≦ x^+. 159 | Proof. apply itr_ind_l; apply itr_cons. Qed. 160 | 161 | Lemma itr_invol `{laws} `{STR ≪ l} n (x: X n n): x^+^+ ≡ x^+. 162 | Proof. apply antisym. apply itr_ind_l1. reflexivity. apply itr_trans. apply itr_ext. Qed. 163 | 164 | Lemma itr_move `{laws} `{STR ≪ l} n m (x: X n m) y z: 165 | x ⋅ y ≡ z ⋅ x -> x ⋅ y^+ ≡ z^+ ⋅ x. 166 | Proof. 167 | intro E. rewrite itr_str_l, dotA, E, <-dotA, str_move by eassumption. 168 | now rewrite dotA, <-itr_str_l. 169 | Qed. 170 | 171 | Lemma itr_dot `{laws} `{STR ≪ l} n m (x: X n m) y: x⋅(y⋅x)^+ ≡ (x⋅y)^+⋅x. 172 | Proof. apply itr_move, dotA. Qed. 173 | 174 | 175 | (** this lemma is used for KAT completeness *) 176 | Lemma itr_aea `{laws} `{STR ≪ l} n (a e: X n n): a⋅a ≡a -> (a⋅e)^+⋅a ≡ (a⋅e⋅a)^+. 177 | Proof. 178 | intro Ha. rewrite (itr_str_l (a⋅e⋅a)), <-dotA, str_dot, (dotA a a), Ha. 179 | now rewrite dotA, <-itr_str_l. 180 | Qed. 181 | 182 | 183 | (** * converse and iteration commute *) 184 | 185 | Lemma cnvstr `{laws} `{CNV+STR ≪ l} n (x: X n n): x^*° ≡ x°^*. 186 | Proof. apply antisym. apply cnvstr_. cnv_switch. now rewrite cnvstr_, cnv_invol. Qed. 187 | 188 | Lemma cnvitr `{laws} `{CNV+STR ≪ l} n (x: X n n): x^+° ≡ x°^+. 189 | Proof. now rewrite itr_str_l, itr_str_r, cnvdot, cnvstr. Qed. 190 | -------------------------------------------------------------------------------- /theories/lang.v: -------------------------------------------------------------------------------- 1 | (** * lang: the (flat) model of languages of finite words *) 2 | 3 | From Stdlib Require Import List. 4 | Require Export prop. 5 | Require Import monoid. 6 | 7 | (** singleton type for the objects of this flat structure *) 8 | CoInductive lang_unit := lang_tt. 9 | 10 | Section l. 11 | 12 | Variable X: Type. 13 | 14 | (** a language on [X] is a predicate on finite words with letters in [X] *) 15 | Definition lang := list X -> Prop. 16 | Implicit Types x y z: lang. 17 | Implicit Types n m p q: lang_unit. 18 | Notation tt := lang_tt. 19 | 20 | (** * Languages as a lattice *) 21 | 22 | (** lattice operations and laws are obtained for free, by pointwise 23 | lifting of the [Prop] lattice *) 24 | 25 | Canonical Structure lang_lattice_ops := 26 | lattice.mk_ops lang leq weq cup cap neg bot top. 27 | 28 | Global Instance lang_lattice_laws: 29 | lattice.laws (BDL+STR+DIV) lang_lattice_ops := lower_lattice_laws (H:=pw_laws _). 30 | 31 | (** * Languages a residuated Kleene lattice *) 32 | 33 | (** ** language operations *) 34 | 35 | (** language concatenation *) 36 | Definition lang_dot n m p x y: lang := fun w => exists2 u, x u & exists2 v, y v & w=u++v. 37 | 38 | (** languages left and right residuals *) 39 | Definition lang_ldv n m p x y: lang := fun w => forall u, x u -> y (u++w). 40 | Definition lang_rdv n m p x y: lang := fun w => forall u, x u -> y (w++u). 41 | 42 | (** language reduced to the empty word *) 43 | Definition lang_one n: lang := eq nil. 44 | 45 | (** language of reversed words *) 46 | Definition lang_cnv n m x: lang := fun w => x (rev w). 47 | 48 | (** finite iterations of a language (with a slight generalisation: [y⋅x^n]) *) 49 | Fixpoint iter i y x: lang := 50 | match i with O => y | S i => lang_dot tt tt tt x (iter i y x) end. 51 | 52 | (** strict iteration: union of finite iterations, starting with [x] *) 53 | Definition lang_itr n x: lang := fun w => exists i, iter i x x w. 54 | 55 | (** Kleene star: union of finite iterations, starting with [1] *) 56 | Definition lang_str n x: lang := fun w => exists i, iter i (lang_one n) x w. 57 | 58 | (** packing all operations in a canonical structure *) 59 | Canonical Structure lang_ops := 60 | mk_ops lang_unit _ lang_dot lang_one lang_itr lang_str lang_cnv lang_ldv lang_rdv. 61 | 62 | (** shorthand for [lang], when a morphism is expected *) 63 | Notation lang' := (lang_ops tt tt). 64 | 65 | 66 | (** ** languages form a residuated Kleene lattice *) 67 | 68 | (** auxiliary lemmas, to establish that languages form a residuated Kleene lattice *) 69 | Lemma lang_dotA n m p q x y z: 70 | lang_dot n m q x (lang_dot m p q y z) ≡ lang_dot n p q (lang_dot n m p x y) z. 71 | Proof. 72 | intro w. split. 73 | intros [u Hu [v [u' Hu' [v' Hv' ->]] ->]]. repeat eexists; eauto. now rewrite app_assoc. 74 | intros [u [u' Hu' [v' Hv' ->]] [v Hv ->]]. repeat eexists; eauto. now rewrite app_assoc. 75 | Qed. 76 | 77 | Lemma lang_dotx1 x: lang_dot tt tt tt x (lang_one tt) ≡ x. 78 | Proof. 79 | intro w. split. 80 | intros [u Hu [v <- ->]]. now rewrite app_nil_r. 81 | intro Hw. exists w; trivial. exists nil. reflexivity. now rewrite app_nil_r. 82 | Qed. 83 | 84 | Lemma lang_dot_leq n m p: Proper (leq ==> leq ==> leq) (lang_dot n m p). 85 | Proof. 86 | intros x y H x' y' H' w [u Hu [v Hv Hw]]. 87 | exists u. apply H, Hu. exists v. apply H', Hv. assumption. 88 | Qed. 89 | 90 | Lemma lang_iter_S i x: iter i x x ≡ iter (S i) (lang_one tt) x. 91 | Proof. 92 | induction i; simpl iter. symmetry. apply lang_dotx1. 93 | now apply (op_leq_weq_2 (Hf:=@lang_dot_leq _ _ _)). 94 | Qed. 95 | 96 | (** languages form a residuated Kleene lattice 97 | (we do not have an allegory, since the converse operation does not 98 | satisfy the law [x ≦x⋅x°⋅x]) *) 99 | Global Instance lang_laws: laws (BDL+STR+DIV) lang_ops. 100 | Proof. 101 | constructor; (try (intro; discriminate)); (try now left); repeat right; intros. 102 | apply lower_lattice_laws. 103 | apply lang_dotA. 104 | intro w. split. 105 | now intros [u <- [v Hv ->]]. 106 | intro Hw. exists nil. reflexivity. now exists w. 107 | apply lang_dotx1. 108 | intros w Hw. now exists O. 109 | intros w [u Hu [v [i Hi] ->]]. exists (S i). repeat eexists; eauto. 110 | intros w [u [i Hu] [v Hv ->]]. revert u Hu. induction i. 111 | now intros u <-. 112 | intros u [u' Hu' [u'' Hu'' ->]]. apply H0. rewrite <-app_assoc. eexists; eauto. 113 | intro w. split. 114 | intros [i H']. apply lang_iter_S in H' as [? ? [? ? ?]]. repeat eexists; eauto. 115 | intros [? ? [? [i H'] ?]]. exists i. apply lang_iter_S. repeat eexists; eauto. 116 | split; intros E w. intros [u xu [v xv ->]]. now apply E. 117 | intros Hw u Hu. apply E. repeat eexists; eauto. 118 | split; intros E w. intros [u xu [v xv ->]]. now apply E. 119 | intros Hw u Hu. apply E. repeat eexists; eauto. 120 | Qed. 121 | 122 | (** empty word property for concatenated languages *) 123 | Lemma lang_dot_nil (L L': lang'): (L⋅L')%ra nil <-> L nil /\ L' nil. 124 | Proof. 125 | split. 2:firstorder. intros [h H [k K E]]. 126 | apply eq_sym, List.app_eq_nil in E. intuition congruence. 127 | Qed. 128 | 129 | (** concatenation of singleton languages *) 130 | Lemma eq_app_dot u v: eq (u++v) ≡ (eq u: lang') ⋅ (eq v: lang'). 131 | Proof. split. intros <-. repeat eexists; eauto. now intros [? <- [? <- <-]]. Qed. 132 | 133 | 134 | (** * Language derivatives *) 135 | 136 | Definition lang_deriv a (L: lang'): lang' := fun w => L (a::w). 137 | 138 | Lemma lang_deriv_0 a: lang_deriv a 0 ≡ 0. 139 | Proof. firstorder. Qed. 140 | 141 | Lemma lang_deriv_1 a: lang_deriv a 1 ≡ 0. 142 | Proof. compute. intuition discriminate. Qed. 143 | 144 | Lemma lang_deriv_pls a (H K: lang'): 145 | lang_deriv a (H+K) ≡ lang_deriv a H + lang_deriv a K. 146 | Proof. intro. now apply cup_weq. Qed. 147 | 148 | Lemma lang_deriv_dot_1 a (H K: lang'): H nil -> 149 | lang_deriv a (H⋅K) ≡ lang_deriv a H ⋅ K + lang_deriv a K. 150 | Proof. 151 | intros Hnil w; simpl; unfold lang_deriv, lang_dot. 152 | split. 153 | intros [[|b u] Hu [v Kv E]]; simpl in E. 154 | right. now rewrite E. 155 | injection E; intros -> <-; clear E. left. repeat eexists; eauto. 156 | intros [[u Hu [v Kv ->]]|Ka]; repeat eexists; eauto. 157 | Qed. 158 | 159 | Lemma lang_deriv_dot_2 a (H K: lang'): ~ (H nil) -> 160 | lang_deriv a (H⋅K) ≡ lang_deriv a H ⋅ K. 161 | Proof. 162 | intros Hnil w; simpl; unfold lang_deriv, lang_dot. 163 | split. 164 | intros [[|b u] Hu [v Kv E]]; simpl in E. 165 | tauto. 166 | injection E; intros -> <-; clear E. repeat eexists; eauto. 167 | intros [u Hu [v Kv ->]]; repeat eexists; eauto. 168 | Qed. 169 | 170 | Lemma lang_deriv_str a (H: lang'): 171 | lang_deriv a (H^*) ≡ lang_deriv a H ⋅ H^*. 172 | Proof. 173 | intro w. split. 174 | intros [n Hn]. induction n in a, w, Hn; simpl in Hn. 175 | discriminate. 176 | destruct Hn as [[|b v] Hv [u Hu Hw]]; simpl in Hw. 177 | rewrite <- Hw in Hu. apply IHn, Hu. 178 | injection Hw; intros -> ->; clear Hw. repeat eexists; eauto. 179 | intros [u Hu [v [n Hv] ->]]. exists (S n). repeat eexists; eauto. 180 | Qed. 181 | 182 | End l. 183 | 184 | Arguments lang_deriv {X}. 185 | Notation lang' X := ((lang_ops X) lang_tt lang_tt). 186 | 187 | Ltac fold_lang := ra_fold lang_ops lang_tt. 188 | -------------------------------------------------------------------------------- /theories/level.v: -------------------------------------------------------------------------------- 1 | (** * level: tuples of Booleans identifying a point in the algebraic hierarchy *) 2 | 3 | Require Import common. 4 | 5 | (** a level specifies which relation algebra operations are considered 6 | 7 | the interpretation in the model of binary relations is given on the 8 | right-hand side. *) 9 | Record level := mk_level { 10 | has_cup: bool; (** set theoretic union *) 11 | has_bot: bool; (** empty relation *) 12 | has_cap: bool; (** set theoretic intersection *) 13 | has_top: bool; (** full relation *) 14 | has_str: bool; (** reflexive transitive closure *) 15 | has_cnv: bool; (** converse, or transpose *) 16 | has_neg: bool; (** Boolean negation *) 17 | has_div: bool (** residuals, or factors *) 18 | }. 19 | Declare Scope level_scope. 20 | Bind Scope level_scope with level. 21 | Delimit Scope level_scope with level. 22 | 23 | (** dual level, for symmetry arguments related to lattices *) 24 | Definition dual l := mk_level 25 | (has_cap l) 26 | (has_top l) 27 | (has_cup l) 28 | (has_bot l) 29 | (has_str l) 30 | (has_cnv l) 31 | (has_neg l) 32 | (has_div l). 33 | 34 | (** * Level constraints *) 35 | 36 | (** [lower k k'], or [k ≪ k'], denotes the fact that there are less 37 | operations/axioms at level [k] than at level [k'] *) 38 | Class lower (k k': level) := mk_lower: 39 | let 'mk_level a b c d e f g h := k in 40 | let 'mk_level a' b' c' d' e' f' g' h' := k' in 41 | is_true (a<< 53 | (has_cup h -> has_cup k) /\ 54 | (has_bot h -> has_bot k) /\ 55 | (has_cap h -> has_cap k) /\ 56 | (has_top h -> has_top k) /\ 57 | (has_str h -> has_str k) /\ 58 | (has_cnv h -> has_cnv k) /\ 59 | (has_neg h -> has_neg k) /\ 60 | (has_div h -> has_div k). 61 | Proof. 62 | destruct h; destruct k. unfold lower. 63 | rewrite !landb_spec, !le_bool_spec. reflexivity. 64 | Qed. 65 | 66 | (** [≪] is a preorder *) 67 | #[export] Instance lower_refl: Reflexive lower. 68 | Proof. intro. setoid_rewrite lower_spec. tauto. Qed. 69 | 70 | #[export] Instance lower_trans: Transitive lower. 71 | Proof. intros h k l. setoid_rewrite lower_spec. tauto. Qed. 72 | 73 | (** * Merging levels *) 74 | 75 | (** merging two levels: taking the union of their supported operations *) 76 | Definition merge h k := mk_level 77 | (has_cup h ||| has_cup k) 78 | (has_bot h ||| has_bot k) 79 | (has_cap h ||| has_cap k) 80 | (has_top h ||| has_top k) 81 | (has_str h ||| has_str k) 82 | (has_cnv h ||| has_cnv k) 83 | (has_neg h ||| has_neg k) 84 | (has_div h ||| has_div k). 85 | Infix "+" := merge: level_scope. 86 | Arguments merge _ _: simpl never. 87 | 88 | (** [merge] is a supremum for the [≪] preorder *) 89 | Lemma merge_spec h k l: h+k ≪ l <-> h ≪ l /\ k ≪ l. 90 | Proof. setoid_rewrite lower_spec. setoid_rewrite lorb_spec. tauto. Qed. 91 | 92 | Lemma lower_xmerge h k l: l ≪ h \/ l ≪ k -> l ≪ (h + k). 93 | Proof. 94 | assert (C:= merge_spec h k (h+k)). 95 | intros [E|E]; (eapply lower_trans; [eassumption|]); apply C, lower_refl. 96 | Qed. 97 | 98 | Lemma lower_mergex h k l: h ≪ l -> k ≪ l -> h+k ≪ l. 99 | Proof. rewrite merge_spec. tauto. Qed. 100 | 101 | #[export] Instance merge_lower: Proper (lower ==> lower ==> lower) merge. 102 | Proof. intros h k H h' k' H'. apply lower_mergex; apply lower_xmerge; auto. Qed. 103 | 104 | (** * Tactics for level constraints resolution *) 105 | 106 | (** simple but efficient tactic, this is the one used by default, we 107 | give it as a hint for maximally inserted arguments (typeclasses 108 | resolution) *) 109 | Ltac solve_lower := solve 110 | [ exact eq_refl (* trivial constraint (on closed levels) *) 111 | | eassumption (* context assumption *) 112 | | repeat 113 | match goal with 114 | | H: ?h ≪ ?l , H': ?k ≪ ?l |- _ ≪ ?l => 115 | (* merge assumptions about [l] *) 116 | apply (lower_mergex h k l H) in H'; clear H 117 | | H: ?k ≪ ?l |- ?h ≪ _ => 118 | (* use assumptions by transitivity *) 119 | apply (lower_trans h k l eq_refl H) 120 | end ] || fail "could not prove this entailment". 121 | #[export] Hint Extern 0 (_ ≪ _) => solve_lower: typeclass_instances. 122 | 123 | (** heavier and more complete tactic, which we use in a selfdom way *) 124 | Ltac solve_lower' := solve [ 125 | (repeat 126 | match goal with 127 | H: _ + _ ≪ _ |- _ => apply merge_spec in H as [? ?] 128 | end); 129 | (repeat apply lower_mergex); 130 | auto 100 using lower_xmerge, lower_refl ] || fail "could not prove this entailment". 131 | 132 | (** tactic used to discriminate unsatisfiable level constraint *) 133 | Ltac discriminate_levels := solve [ 134 | intros; repeat discriminate || 135 | match goal with 136 | | H: _ + _ ≪ _ |- _ => apply merge_spec in H as [? ?] 137 | end ]. 138 | 139 | (** * Concrete levels *) 140 | Section levels. 141 | Notation "1" := true. 142 | Notation "0" := false. 143 | (** atoms *) 144 | Definition MIN := mk_level 0 0 0 0 0 0 0 0. 145 | Definition CUP := mk_level 1 0 0 0 0 0 0 0. 146 | Definition BOT := mk_level 0 1 0 0 0 0 0 0. 147 | Definition CAP := mk_level 0 0 1 0 0 0 0 0. 148 | Definition TOP := mk_level 0 0 0 1 0 0 0 0. 149 | Definition STR := mk_level 0 0 0 0 1 0 0 0. 150 | Definition CNV := mk_level 0 0 0 0 0 1 0 0. 151 | Definition NEG := mk_level 0 0 0 0 0 0 1 0. 152 | Definition DIV := mk_level 0 0 0 0 0 0 0 1. 153 | Local Open Scope level_scope. 154 | (** points of particular interest (i.e., corresponding to standard 155 | mathematical structures) *) 156 | Definition SL := CUP. 157 | Definition DL := Eval compute in CUP+CAP. 158 | Definition BSL := Eval compute in SL+BOT. 159 | Definition BDL := Eval compute in DL+BOT+TOP. 160 | Definition BL := Eval compute in BDL+NEG. 161 | Definition KA := Eval compute in SL+STR. 162 | Definition AA := Eval compute in DL+STR. 163 | Definition AL := Eval compute in CAP+CNV. 164 | Definition DAL := Eval compute in DL+CNV. 165 | Definition BKA := Eval compute in KA+BOT. 166 | Definition CKA := Eval compute in KA+CNV. 167 | End levels. 168 | 169 | (* sanity checks for the [solve_lower] tactic *) 170 | (* 171 | Goal forall l, CUP ≪ l -> AL ≪ l -> CNV+CUP ≪ l. 172 | intros. solve_lower || fail "bad". Abort. 173 | Goal forall l, KA ≪ l -> AL ≪ l -> CNV+CUP ≪ l. 174 | intros. solve_lower || fail "bad". Abort. 175 | Goal forall l, CAP ≪ l -> AL ≪ l -> CNV+CUP ≪ l. 176 | intros. Fail solve_lower. Abort. 177 | *) 178 | -------------------------------------------------------------------------------- /theories/lset.v: -------------------------------------------------------------------------------- 1 | (** * lset: finite sets represented as lists *) 2 | 3 | (** This module is used quite intensively, as finite sets are 4 | pervasives (free variables, summations, partial derivatives...): 5 | 6 | We implement finite sets as simple lists, without any additional 7 | structure: this allows for very simple operations and 8 | specifications, without the need for keeping well-formedness 9 | hypotheses around. 10 | 11 | When a bit of efficiency is required, we use sorted listed without 12 | duplicates as a special case (but without ensuring that these lists 13 | are sorted: we managed to avoid such a need in our proofs). 14 | 15 | We declare these finite sets a sup-semilattice with bottom element, 16 | allowing us to use the lattice tactics and theorems in a 17 | transparent way. *) 18 | 19 | Require Import lattice comparisons. 20 | From Stdlib Require Export List. Export ListNotations. 21 | 22 | Set Implicit Arguments. 23 | 24 | (** * semi-lattice of finite sets as simple lists *) 25 | 26 | (** two lists are equal when they contain the same elements, 27 | independently of their position or multiplicity *) 28 | 29 | Universe lset. 30 | 31 | Canonical Structure lset_ops (A:Type@{lset}) := lattice.mk_ops (list A) 32 | (fun h k => forall a, In a h -> In a k) 33 | (fun h k => forall a, In a h <-> In a k) 34 | (@app A) (@app A) (assert_false id) (@nil A) (@nil A). 35 | 36 | (** the fact that this makes a semi-lattice is almost trivial *) 37 | #[export] Instance lset_laws (A:Type@{lset}) : lattice.laws BSL (lset_ops A). 38 | Proof. 39 | constructor; simpl; try discriminate. 40 | firstorder. 41 | firstorder. 42 | setoid_rewrite in_app_iff. firstorder. 43 | firstorder. 44 | Qed. 45 | 46 | (** the [map] function on lists is actually a monotone function over the 47 | represented sets *) 48 | #[export] Instance map_leq A B (f: A -> B): Proper (leq ==> leq) (map f). 49 | Proof. 50 | intro h. induction h as [|a h IH]; intros k H. apply leq_bx. 51 | intros i [<-|I]. apply in_map. apply H. now left. 52 | apply IH. 2: assumption. intros ? ?. apply H. now right. 53 | Qed. 54 | #[export] Instance map_weq A B (f: A -> B): Proper (weq ==> weq) (map f) := op_leq_weq_1. 55 | 56 | (** [map] is extensional *) 57 | #[export] Instance map_compat A B: Proper (pwr eq ==> eq ==> eq) (@map A B). 58 | Proof. intros f g H h k <-. apply map_ext, H. Qed. 59 | 60 | (** belonging to a singleton *) 61 | Lemma in_singleton A (x y: A): In x [y] <-> y=x. 62 | Proof. simpl. tauto. Qed. 63 | 64 | (** the following tactic replaces all occurrences of [cons] with 65 | degenerated concatenations, so that the [lattice] can subsequently 66 | handle them *) 67 | 68 | Ltac fold_cons := 69 | repeat match goal with 70 | | |- context[@cons ?A ?x ?q] => (constr_eq q (@nil A); fail 1) || change (x::q) with ([x]++q) 71 | | H: context[!cons ?A ?x ?q] |- _ => (constr_eq q (@nil A); fail 1) || change (x::q) with ([x]++q) in H 72 | end. 73 | 74 | 75 | 76 | (** * sorted lists without duplicates *) 77 | 78 | (** when the elements come with a [cmpType] structure, one can perform 79 | sorted lists operations *) 80 | 81 | Section m. 82 | Context {A: cmpType}. 83 | 84 | (** sorted merge of sorted lists *) 85 | Fixpoint union (l1: list A) := 86 | match l1 with 87 | | nil => fun l2 => l2 88 | | h1::t1 => 89 | let fix union' l2 := 90 | match l2 with 91 | | nil => l1 92 | | h2::t2 => 93 | match cmp h1 h2 with 94 | | Eq => h1::union t1 t2 95 | | Lt => h1::union t1 l2 96 | | Gt => h2::union' t2 97 | end 98 | end 99 | in union' 100 | end. 101 | 102 | (** sorted insertion in a sorted list *) 103 | Fixpoint insert (i: A) l := 104 | match l with 105 | | nil => i::nil 106 | | j::q => 107 | match cmp i j with 108 | | Eq => l 109 | | Lt => i::l 110 | | Gt => j::insert i q 111 | end 112 | end. 113 | 114 | (** weak specification: [union] actually performs an union *) 115 | Lemma union_app: forall h k, union h k ≡ h ++ k. 116 | Proof. 117 | induction h as [|x h IHh]; simpl union. reflexivity. 118 | induction k as [|y k IHk]. lattice. case cmp_spec. 119 | intros ->. fold_cons. rewrite IHh. lattice. 120 | intros _. fold_cons. rewrite IHh. lattice. 121 | intros _. fold_cons. rewrite IHk. lattice. 122 | Qed. 123 | 124 | (** and [insert] actually performs an insertion *) 125 | Lemma insert_union: forall i l, insert i l = union [i] l. 126 | Proof. 127 | induction l; simpl. reflexivity. 128 | case cmp_spec. congruence. reflexivity. now rewrite IHl. 129 | Qed. 130 | 131 | Lemma insert_app: forall i l, insert i l ≡ [i] ++ l. 132 | Proof. intros. rewrite insert_union. apply union_app. Qed. 133 | 134 | End m. 135 | 136 | Module Fix. 137 | 138 | Canonical Structure lset_ops A := lattice.mk_ops (list A) 139 | (fun h k => forall a, In a h -> In a k) 140 | (fun h k => forall a, In a h <-> In a k) 141 | (@app A) (@app A) (assert_false id) (@nil A) (@nil A). 142 | 143 | End Fix. 144 | -------------------------------------------------------------------------------- /theories/lsyntax.v: -------------------------------------------------------------------------------- 1 | (** * lsyntax: syntactic model for flat structures (lattice operations) *) 2 | 3 | Require Export positives. 4 | Require Import comparisons lattice lset sups. 5 | Set Implicit Arguments. 6 | 7 | (** * Free syntactic model *) 8 | 9 | Section s. 10 | Variable A: Set. 11 | (* [A = ord n] in KAT proofs 12 | [A = positive] in reification, (and possibly in computations in the future) *) 13 | 14 | (** Boolean lattice expressions over a set [A] of variables *) 15 | Inductive expr := 16 | | e_bot 17 | | e_top 18 | | e_cup (e f: expr) 19 | | e_cap (e f: expr) 20 | | e_neg (e: expr) 21 | | e_var (a: A). 22 | 23 | (** level of an expression: the set of operations that appear in that expression *) 24 | Fixpoint e_level e := 25 | match e with 26 | | e_bot => BOT 27 | | e_top => TOP 28 | | e_cup x y => CUP + e_level x + e_level y 29 | | e_cap x y => CAP + e_level x + e_level y 30 | | e_neg x => BL + e_level x 31 | (* negation is ill-defined without the other Boolean operations, 32 | whence the [BL] rather than [NEG] *) 33 | | e_var _ => MIN 34 | end%level. 35 | 36 | Section e. 37 | Context {X: ops}. 38 | Variable f: A -> X. 39 | 40 | (** interpretation of an expression into an arbitray Boolean lattice 41 | structure, given an assignation [f] of the variables *) 42 | Fixpoint eval e: X := 43 | match e with 44 | | e_bot => bot 45 | | e_top => top 46 | | e_cup x y => eval x ⊔ eval y 47 | | e_cap x y => eval x ⊓ eval y 48 | | e_neg x => ! eval x 49 | | e_var a => f a 50 | end. 51 | End e. 52 | 53 | 54 | Section l. 55 | Variable l: level. 56 | 57 | (** * (In)equality of syntactic expressions. 58 | 59 | Rather than defining (in)equality of syntactic expressions as 60 | inductive predicates, we exploit the standard impredicative 61 | encoding of such predicates: two expressions are equal (resp., 62 | lower or equal) iff they are equal (resp., lower or equal) under 63 | any interpretation. 64 | 65 | These definitions are parametrised by the level [l] at which one 66 | wants to interpret the expressions: this allows us to capture once 67 | and for all the equational theories of each flat structure. *) 68 | 69 | Definition e_leq (x y: expr) := forall X (L: laws l X) (f: A -> X), eval f x ≦ eval f y. 70 | Definition e_weq (x y: expr) := forall X (L: laws l X) (f: A -> X), eval f x ≡ eval f y. 71 | 72 | (** by packing syntactic expressions and the above predicates into a 73 | canonical structure, we get all notations for free *) 74 | Canonical Structure expr_ops := {| 75 | car := expr; 76 | leq := e_leq; 77 | weq := e_weq; 78 | cup := e_cup; 79 | cap := e_cap; 80 | neg := e_neg; 81 | bot := e_bot; 82 | top := e_top 83 | |}. 84 | 85 | (** we easily show that we get a model so that we immediately benefit 86 | from all lemmas about flat structures *) 87 | 88 | Global Instance expr_laws: laws l expr_ops. 89 | Proof. 90 | constructor; try right. constructor. 91 | intros x X L f. reflexivity. 92 | intros x y z H H' X L f. transitivity (eval f y); auto. 93 | intros x y. split. 94 | intro H. split; intros X L f. now apply weq_leq, H. now apply weq_geq, H. 95 | intros [H H'] X L f. apply antisym; auto. 96 | intros Hl x y z. split. 97 | intro H. split; intros X L f; specialize (H X L f); simpl in H; hlattice. 98 | intros [H H'] X L f. simpl. apply cup_spec; auto. 99 | intros Hl x y z. split. 100 | intro H. split; intros X L f; specialize (H X L f); simpl in H; hlattice. 101 | intros [H H'] X L f. simpl. apply cap_spec; auto. 102 | intros x X L f. apply leq_bx. 103 | intros x X L f. apply leq_xt. 104 | intros Hl x y z X L f. apply cupcap_. 105 | intros Hl x X L f. apply capneg. 106 | intros Hl x X L f. apply cupneg. 107 | Qed. 108 | 109 | 110 | (** the interpretation function is an homomorphism, so that it 111 | preserves all finite sups and infs *) 112 | Lemma eval_sup I (J: list I) (f: I -> expr) (X: lattice.ops) (g: A -> X): 113 | eval g (sup (X:=expr_ops) f J) = \sup_(i\in J) eval g (f i). 114 | Proof. apply f_sup_eq; now f_equal. Qed. 115 | 116 | Lemma eval_inf I (J: list I) (f: I -> expr) (X: lattice.ops) (g: A -> X): 117 | eval g (sup (X:=dual expr_ops) f J) = \inf_(i\in J) eval g (f i). 118 | Proof. apply (f_sup_eq (Y:=dual X)); now f_equal. Qed. 119 | 120 | (** [e_var] is a unit for the underlying monad *) 121 | Lemma eval_var (e: expr_ops): eval e_var e = e. 122 | Proof. induction e; simpl; congruence. Qed. 123 | 124 | End l. 125 | 126 | End s. 127 | Arguments e_var [A] a. 128 | Arguments e_bot {A}. 129 | Arguments e_top {A}. 130 | 131 | Declare Scope last_scope. 132 | Bind Scope last_scope with expr. 133 | Delimit Scope last_scope with last. 134 | 135 | (** additional notations, to specify explicitly at which level 136 | expressions are considered, or to work directly with the 137 | bare constructors (by opposition with the encapsulated ones, 138 | through lattice.ops)*) 139 | Notation expr_ l := (car (expr_ops _ l)). 140 | Notation "x <==_[ l ] y" := (@leq (expr_ops _ l) x%last y%last) (at level 79): ra_scope. 141 | Notation "x ==_[ l ] y" := (@weq (expr_ops _ l) x%last y%last) (at level 79): ra_scope. 142 | 143 | Infix "⊔" := e_cup: last_scope. 144 | Infix "⊓" := e_cap: last_scope. 145 | Notation "! x" := (e_neg x): last_scope. 146 | 147 | 148 | (** * Comparing expressions *) 149 | 150 | (** we get a [cmpType] on expressions if the set of variable is such 151 | (currently used in ugregex_dec) *) 152 | 153 | Section expr_cmp. 154 | Context {A: cmpType}. 155 | Fixpoint expr_compare (x y: expr A) := 156 | match x,y with 157 | | e_bot, e_bot 158 | | e_top, e_top => Eq 159 | | e_var a, e_var b => cmp a b 160 | | e_cup x x', e_cup y y' 161 | | e_cap x x', e_cap y y' => lex (expr_compare x y) (expr_compare x' y') 162 | | e_neg x, e_neg y => expr_compare x y 163 | | e_bot, _ => Lt 164 | | _, e_bot => Gt 165 | | e_top, _ => Lt 166 | | _, e_top => Gt 167 | | e_var _, _ => Lt 168 | | _, e_var _ => Gt 169 | | e_cup _ _, _ => Lt 170 | | _, e_cup _ _ => Gt 171 | | e_cap _ _, _ => Lt 172 | | _, e_cap _ _ => Gt 173 | end. 174 | 175 | Lemma expr_compare_spec: forall x y, compare_spec (x=y) (expr_compare x y). 176 | Proof. 177 | induction x; destruct y; try (constructor; congruence). 178 | - eapply lex_spec; eauto. intuition congruence. 179 | - eapply lex_spec; eauto. intuition congruence. 180 | - simpl; case IHx; constructor; congruence. 181 | - simpl; case cmp_spec; constructor; congruence. 182 | Qed. 183 | 184 | Canonical Structure cmp_expr := mk_simple_cmp _ expr_compare_spec. 185 | 186 | (** variables appearing in an expression ([A] needs to be a [cmpType] 187 | so that the resulting list is without duplicates) *) 188 | Fixpoint vars (e: expr A): list A := 189 | match e with 190 | | e_bot 191 | | e_top => [] 192 | | e_cup x y 193 | | e_cap x y => union (vars x) (vars y) 194 | | e_neg x => vars x 195 | | e_var x => [x] 196 | end. 197 | End expr_cmp. 198 | -------------------------------------------------------------------------------- /theories/matrix_ext.v: -------------------------------------------------------------------------------- 1 | (** * matrix_ext: additional properties of matrices *) 2 | 3 | Require Import kleene normalisation ordinal sups. 4 | Require Export matrix. 5 | Set Implicit Arguments. 6 | 7 | 8 | (** * [mx_scal] is an homomorphism *) 9 | 10 | #[export] Instance mx_scal_leq `{lattice.laws}: Proper (leq ==> leq) (@mx_scal X). 11 | Proof. intros ? ? H'. apply H'. Qed. 12 | #[export] Instance mx_scal_weq `{lattice.laws}: Proper (weq ==> weq) (@mx_scal X) := op_leq_weq_1. 13 | 14 | Lemma mx_scal_zer `{lattice.laws}: mx_scal bot ≡ bot. 15 | Proof. reflexivity. Qed. 16 | 17 | Lemma mx_scal_one `{laws} n: mx_scal 1 ≡ one n. 18 | Proof. reflexivity. Qed. 19 | 20 | Lemma mx_scal_pls `{lattice.laws} (M N: mx X 1 1): 21 | mx_scal (M ⊔ N) ≡ mx_scal M ⊔ mx_scal N. 22 | Proof. reflexivity. Qed. 23 | 24 | Lemma mx_scal_dot `{laws} `{BOT+CUP ≪ l} u (M N: mx (X u u) 1 1): 25 | mx_scal (M ⋅ N) ≡ mx_scal M ⋅ mx_scal N. 26 | Proof. apply cupxb. Qed. 27 | 28 | Lemma mx_scal_str `{laws} `{BKA ≪ l} u (M: mx (X u u) 1 1): 29 | mx_scal (M^*) ≡ (mx_scal M)^*. 30 | Proof. 31 | apply str_weq. unfold mx_scal, sub00_mx, tsub_mx, lsub_mx. simpl. 32 | setoid_rewrite ord0_unique. apply cupxb. 33 | Qed. 34 | 35 | (** * [scal_mx] preserves inclusions/equalities *) 36 | 37 | #[export] Instance scal_mx_leq `{lattice.laws}: Proper (leq ==> leq) (@scal_mx X). 38 | Proof. now repeat intro. Qed. 39 | #[export] Instance scal_mx_weq `{lattice.laws}: Proper (weq ==> weq) (@scal_mx X) := op_leq_weq_1. 40 | 41 | (** * extracting components of block matrices *) 42 | 43 | Lemma mx_tsub_col `{lattice.laws} n1 n2 m M1 M2: 44 | tsub_mx (@col_mx X n1 n2 m M1 M2) ≡ M1. 45 | Proof. intros i j. unfold tsub_mx, col_mx. now rewrite split_lshift. Qed. 46 | Lemma mx_bsub_col `{lattice.laws} n1 n2 m M1 M2: 47 | bsub_mx (@col_mx X n1 n2 m M1 M2) ≡ M2. 48 | Proof. intros i j. unfold bsub_mx, col_mx. now rewrite split_rshift. Qed. 49 | Lemma mx_lsub_row `{lattice.laws} n m1 m2 M1 M2: 50 | lsub_mx (@row_mx X n m1 m2 M1 M2) ≡ M1. 51 | Proof. intros i j. unfold lsub_mx, row_mx. now rewrite split_lshift. Qed. 52 | Lemma mx_rsub_row `{lattice.laws} n m1 m2 M1 M2: 53 | rsub_mx (@row_mx X n m1 m2 M1 M2) ≡ M2. 54 | Proof. intros i j. unfold rsub_mx, row_mx. now rewrite split_rshift. Qed. 55 | 56 | Lemma mx_sub00_blk `{lattice.laws} n1 n2 m1 m2 a b c d: 57 | sub00_mx (@blk_mx X n1 n2 m1 m2 a b c d) ≡ a. 58 | Proof. setoid_rewrite mx_tsub_col. apply mx_lsub_row. Qed. 59 | Lemma mx_sub01_blk `{lattice.laws} n1 n2 m1 m2 a b c d: 60 | sub01_mx (@blk_mx X n1 n2 m1 m2 a b c d) ≡ b. 61 | Proof. setoid_rewrite mx_tsub_col. apply mx_rsub_row. Qed. 62 | Lemma mx_sub10_blk `{lattice.laws} n1 n2 m1 m2 a b c d: 63 | sub10_mx (@blk_mx X n1 n2 m1 m2 a b c d) ≡ c. 64 | Proof. setoid_rewrite mx_bsub_col. apply mx_lsub_row. Qed. 65 | Lemma mx_sub11_blk `{lattice.laws} n1 n2 m1 m2 a b c d: 66 | sub11_mx (@blk_mx X n1 n2 m1 m2 a b c d) ≡ d. 67 | Proof. setoid_rewrite mx_bsub_col. apply mx_rsub_row. Qed. 68 | 69 | 70 | (** sub-matrices of the empty matrix are empty *) 71 | Lemma blk_mx_0 `{laws} u n1 n2 m1 m2 a b c d: @blk_mx (X u u) n1 n2 m1 m2 a b c d ≡ 0 -> 72 | a ≡0 /\ b ≡0 /\ c ≡0 /\ d ≡0. 73 | Proof. 74 | intro Z. split; [|split; [|split]]. 75 | rewrite <-(mx_sub00_blk a b c d). intros ? ?. apply Z. 76 | rewrite <-(mx_sub01_blk a b c d). intros ? ?. apply Z. 77 | rewrite <-(mx_sub10_blk a b c d). intros ? ?. apply Z. 78 | rewrite <-(mx_sub11_blk a b c d). intros ? ?. apply Z. 79 | Qed. 80 | 81 | 82 | (** * Kleene star of a block matrix *) 83 | Section h. 84 | Context `{L:laws} `{Hl:BKA ≪ l} (u: ob X). 85 | 86 | Instance mx_bka_laws: laws BKA (mx_ops X u) := mx_laws (L:=lower_laws) _. 87 | 88 | Lemma mx_str_blk' n m (M: mx (X u u) (n+m) (n+m)): 89 | M^* ≡ mx_str_build X u n m (mx_str _ _ _) (mx_str _ _ _) M. 90 | Proof. 91 | apply str_unique'. 92 | apply mx_str_build_unfold_l; apply mx_str_unfold_l. 93 | apply mx_str_build_ind_l; intros ? ? ?; apply mx_str_ind_l. 94 | Qed. 95 | 96 | (** general result *) 97 | Lemma mx_str_blk n1 n2 98 | (a: mx (X u u) n1 n1) (b: mx (X u u) n1 n2) 99 | (c: mx (X u u) n2 n1) (d: mx (X u u) n2 n2): 100 | let e := d^* in 101 | let f := (a+(b⋅e)⋅c)^* in 102 | (blk_mx a b c d)^* ≡ blk_mx f (f⋅(b⋅e)) ((e⋅c)⋅f) (e+(e⋅c⋅f)⋅(b⋅e)). 103 | Proof. 104 | intros e f. rewrite mx_str_blk'. unfold mx_str_build. 105 | ra_fold (mx_ops X). now rewrite mx_sub00_blk, mx_sub01_blk, mx_sub10_blk, mx_sub11_blk. 106 | Qed. 107 | 108 | (** specialisation to trigonal block matrices *) 109 | Lemma mx_str_trigonal n1 n2 110 | (a: mx (X u u) n1 n1) (b: mx (X u u) n1 n2) 111 | (d: mx (X u u) n2 n2): 112 | (blk_mx a b 0 d)^* ≡ blk_mx (a^*) (a^*⋅(b⋅d^*)) 0 (d^*). 113 | Proof. rewrite mx_str_blk. apply blk_mx_weq; ra. Qed. 114 | 115 | (** and to diagonal block matrices *) 116 | Lemma mx_str_diagonal n1 n2 117 | (a: mx (X u u) n1 n1) (d: mx (X u u) n2 n2): 118 | (blk_mx a 0 0 d)^* ≡ blk_mx (a^*) 0 0 (d^*). 119 | Proof. rewrite mx_str_trigonal. apply blk_mx_weq; trivial; ra. Qed. 120 | 121 | 122 | Lemma mx_str_1 (M: mx (X u u) 1 1): M^* ≡ scal_mx ((mx_scal M)^*). 123 | Proof. 124 | intros i j. setoid_rewrite ord0_unique. simpl. 125 | unfold mx_str_build, blk_mx, col_mx, row_mx, ordinal.split; simpl. 126 | unfold mx_scal, scal_mx, mx_dot, sub00_mx, tsub_mx, lsub_mx; simpl. 127 | setoid_rewrite ord0_unique. ra. 128 | Qed. 129 | 130 | (** * induction schemes for proving properties of the Kleene star of a matrix *) 131 | (** (used to show that epsilon and derivatives commute with matrix star in [rmx]) *) 132 | 133 | Lemma mx_str_ind (P: forall n, mx (X u u) n n -> mx (X u u) n n -> Prop): 134 | (forall n, Proper (weq ==> weq ==> iff) (P n)) -> 135 | (forall M, P O M M) -> 136 | (forall M, P _ M (scal_mx ((mx_scal M)^*))) -> 137 | (forall n m, 138 | (forall M, P n M (M^*)) -> 139 | (forall M, P m M (M^*)) -> 140 | forall M, P _ M (mx_str_build _ _ n m (fun M => M^*) (fun M => M^*) M)) -> 141 | forall n M, P n M (M^*). 142 | Proof. 143 | intros HP HO H1 Hplus n M. induction n as [|n IHn]. 144 | apply HO. 145 | change (M^*) with (mx_str _ _ _ M). unfold mx_str, mx_str_build. ra_fold (mx_ops X). 146 | setoid_rewrite <-mx_str_1. 147 | revert M; refine (Hplus (S O) n _ _); intro M. 148 | rewrite mx_str_1. apply H1. 149 | apply IHn. 150 | Qed. 151 | 152 | Lemma mx_str_ind' (P: forall n, mx (X u u) n n -> mx (X u u) n n -> Prop): 153 | (forall n, Proper (weq ==> weq ==> iff) (P n)) -> 154 | (forall M, P O M M) -> 155 | (forall M, P _ M (scal_mx ((mx_scal M)^*))) -> 156 | (forall n m a b c d, 157 | let e := d^* in 158 | let be := b⋅e in 159 | let ec := e⋅c in 160 | let f := (a+be⋅c)^* in 161 | let fbe := f⋅be in 162 | let ecf := ec⋅f in 163 | P m d e -> 164 | P n (a+be⋅c) f -> 165 | P _ (blk_mx a b c d) (blk_mx f fbe ecf (e+ecf⋅be))) -> 166 | forall n M, P n M (M^*). 167 | Proof. 168 | intros HP HO H1 Hplus. apply (mx_str_ind P HP HO H1). 169 | intros n m Hn Hm M. rewrite (to_blk_mx M) at 1. now apply Hplus. 170 | Qed. 171 | 172 | End h. 173 | 174 | 175 | (** * pointwise extension of a funcion to matrices *) 176 | 177 | Definition mx_map X Y (f: X -> Y) n m (M: mx X n m): mx Y n m := fun i j => f (M i j). 178 | 179 | #[export] Instance mx_map_leq {X Y: lattice.ops} {f: X -> Y} 180 | {Hf: Proper (leq ==> leq) f} n m: Proper (leq ==> leq) (@mx_map _ _ f n m). 181 | Proof. intros M N H i j. apply Hf, H. Qed. 182 | 183 | #[export] Instance mx_map_weq {X Y: lattice.ops} {f: X -> Y} 184 | {Hf: Proper (weq ==> weq) f} n m: Proper (weq ==> weq) (@mx_map _ _ f n m). 185 | Proof. intros M N H i j. apply Hf, H. Qed. 186 | 187 | Lemma mx_map_blk {X Y l} {HY: lattice.laws l Y} (f: X -> Y) n1 n2 m1 m2 a b c d: 188 | mx_map f (@blk_mx _ n1 n2 m1 m2 a b c d) ≡ 189 | blk_mx (mx_map f a) (mx_map f b) (mx_map f c) (mx_map f d). 190 | Proof. 191 | intros i j. unfold mx_map, blk_mx, col_mx, row_mx. 192 | case split; case split; reflexivity. 193 | Qed. 194 | 195 | Lemma mx_map_scal {X Y} (f: X -> Y) x: mx_map f (scal_mx x) = scal_mx (f x). 196 | Proof. reflexivity. Qed. 197 | 198 | Lemma scal_mx_map {X} {Y: lattice.ops} (f: X -> Y) M: f (mx_scal M) = mx_scal (mx_map f M). 199 | Proof. reflexivity. Qed. 200 | 201 | (** * `functional' matrices, with exactly one [z] per line, and [0] everywhere else *) 202 | 203 | Definition mx_fun {X: lattice.ops} n m f z: mx X n m := 204 | fun x y => if eqb_ord y (f x) then z else bot. 205 | 206 | Lemma mx_dot_fun `{laws} `{BSL ≪ l} u n m f z p (M: mx (X u u) m p) i j: 207 | (mx_fun (n:=n) f z ⋅ M) i j ≡ z ⋅ M (f i) j. 208 | Proof. 209 | simpl. unfold mx_dot. apply antisym. 210 | apply leq_supx. intros j' _. unfold mx_fun. case eqb_ord_spec. 211 | intros ->. ra. 212 | intros _. ra. 213 | rewrite <- (leq_xsup _ _ (f i)). 2: apply in_seq. 214 | unfold mx_fun. now rewrite eqb_refl. 215 | Qed. 216 | 217 | Lemma mx_dot_kfun1 `{laws} `{BSL ≪ l} u n m i p (M: mx (X u u) m p): 218 | (mx_fun (n:=n) (fun _ => i) 1 ⋅ M) ≡ fun _ j => M i j. 219 | Proof. intros j k. rewrite mx_dot_fun. apply dot1x. Qed. 220 | 221 | Lemma mx_map_fun {X Y: lattice.ops} {l} {HY: lattice.laws l Y} n m f z g: 222 | g bot ≡ bot -> mx_map g (@mx_fun X n m f z) ≡ @mx_fun Y n m f (g z). 223 | Proof. intros Hg i j. unfold mx_map, mx_fun. now case eqb_ord. Qed. 224 | 225 | -------------------------------------------------------------------------------- /theories/move.v: -------------------------------------------------------------------------------- 1 | (** * move: simple tactics allowing to move subterms inside products 2 | (by exploiting commutation hypotheses from the context) *) 3 | 4 | Require Import kat normalisation rewriting kat_tac. 5 | 6 | Local Infix " ;" := (dot _ _ _) (left associativity, at level 40): ra_terms. 7 | 8 | Lemma rmov_x_str `{L: monoid.laws} `{Hl: STR ≪ l} {n} (x e: X n n): 9 | x;e ≡ e;x -> x;e^* ≡ e^*;x. 10 | Proof. apply str_move. Qed. 11 | 12 | Lemma rmov_x_itr `{L: monoid.laws} `{Hl: STR ≪ l} {n} (x e: X n n): 13 | x;e ≡ e;x -> x;e^+ ≡ e^+;x. 14 | Proof. apply itr_move. Qed. 15 | 16 | Lemma rmov_x_pls `{L: monoid.laws} `{Hl: CUP ≪ l} {n m} x y (e f: X n m): 17 | x;e ≡ e;y -> x;f ≡ f;y -> x;(e+f) ≡ (e+f);y. 18 | Proof. intros. ra_normalise. now apply cup_weq. Qed. 19 | 20 | Lemma rmov_x_dot `{L: monoid.laws} {n m p} x y z (e: X n m) (f: X m p): 21 | x;e ≡ e;y -> y;f ≡ f;z -> x;(e;f) ≡ (e;f);z. 22 | Proof. intros He Hf. rewrite dotA, He, <-dotA, Hf. apply dotA. Qed. 23 | 24 | Lemma rmov_x_1 `{L: monoid.laws} {n} (x: X n n): x;1 ≡ 1;x. 25 | Proof. ra. Qed. 26 | 27 | Lemma rmov_x_0 `{L: monoid.laws} `{Hl:BOT ≪ l} {n m p q} (x: X n m) (y: X p q): x;0 ≡ 0;y. 28 | Proof. ra. Qed. 29 | 30 | Lemma rmov_x_cap `{L: laws} {n} (x: X n n) a b: 31 | x;[a] ≡ [a];x -> x;[b] ≡ [b];x -> x;[a ⊓ b] ≡ [a ⊓ b];x. 32 | Proof. hkat. Qed. 33 | 34 | Lemma rmov_x_cup `{L: laws} {n} (x: X n n) a b: 35 | x;[a] ≡ [a];x -> x;[b] ≡ [b];x -> x;[a ⊔ b] ≡ [a ⊔ b];x. 36 | Proof. hkat. Qed. 37 | 38 | Lemma rmov_x_neg `{L: laws} {n} (x: X n n) a: 39 | x;[a] ≡ [a];x -> x;[!a] ≡ [!a];x. 40 | Proof. hkat. Qed. 41 | 42 | Lemma rmov_inj `{L: laws} {n} (a b: tst n): [a]⋅[b] ≡ [b]⋅[a]. 43 | Proof. kat. Qed. 44 | 45 | Ltac solve_rmov := 46 | first 47 | [ eassumption 48 | | symmetry; eassumption 49 | | eapply rmov_x_dot 50 | | apply rmov_x_pls 51 | | apply rmov_x_str 52 | | apply rmov_x_itr 53 | | apply rmov_x_cap 54 | | apply rmov_x_cup 55 | | apply rmov_x_neg 56 | | apply rmov_inj 57 | | apply rmov_x_1 58 | | apply rmov_x_0 ]; solve_rmov. 59 | 60 | Ltac rmov1 x := 61 | rewrite ?dotA; 62 | (* rewrite ?(dotA _ _ x); *) 63 | match goal with 64 | | |- context [@dot ?X ?n ?n ?m x ?e] => 65 | let H := fresh "H" in 66 | let y := fresh "y" in 67 | evar (y: car (X m m)); 68 | assert (H: x;e ≡ e;y) by (subst y; solve_rmov); 69 | rewrite H; subst y; clear H 70 | | |- context [@dot ?X _ ?n ?m (?f;x) ?e] => 71 | let H := fresh "H" in 72 | let y := fresh "y" in 73 | evar (y: car (X m m)); 74 | assert (H: x;e ≡ e;y) by (subst y; solve_rmov); 75 | rewrite <-(dotA f x e), H; subst y; clear H 76 | end. 77 | 78 | Ltac lmov1 x := 79 | rewrite <-?dotA; 80 | (* rewrite <-?(dotA x); *) 81 | match goal with 82 | | |- context [@dot ?X ?m ?n ?n ?e x] => 83 | let H := fresh "H" in 84 | let y := fresh "y" in 85 | evar (y: car (X m m)); 86 | assert (H: y;e ≡ e;x) by (subst y; solve_rmov); 87 | rewrite <-H; subst y; clear H 88 | | |- context [@dot ?X ?m _ _ ?e (x;?f)] => 89 | let H := fresh "H" in 90 | let y := fresh "y" in 91 | evar (y: car (X m m)); 92 | assert (H: y;e ≡ e;x) by (subst y; solve_rmov); 93 | rewrite (dotA e x f), <-H; subst y; clear H 94 | end. 95 | 96 | (* test 97 | Goal forall `{laws} n (p q q' r r': X n n) (a b: tst n), 98 | r;[a] ≡ [a];r -> 99 | r;p ≡ p;r -> 100 | r;q ≡ q;r' -> 101 | p;[a];r;p^*;(q;q') ≡ 0. 102 | Proof. 103 | intros. 104 | rmov1 r. 105 | rmov1 r. 106 | lmov1 r'. 107 | lmov1 r. 108 | lmov1 r. 109 | lmov1 r. 110 | Abort. 111 | *) 112 | -------------------------------------------------------------------------------- /theories/nfa.v: -------------------------------------------------------------------------------- 1 | (** * nfa: Non-deterministic Finite Automata *) 2 | 3 | Require Import positives comparisons. 4 | Require Import kleene regex rmx sums matrix_ext prop normalisation. 5 | Require dfa. 6 | Set Implicit Arguments. 7 | Unset Printing Implicit Defensive. 8 | 9 | (** * Matricial (non deterministic) finite automata *) 10 | 11 | (** transitions are labelled with regular expressions *) 12 | Record t := mk { 13 | n: nat; 14 | u: rmx 1 n; 15 | M: rmx n n; 16 | v: rmx n 1 17 | }. 18 | Notation "x ^u" := (u x) (at level 2, left associativity, format "x ^u"). 19 | Notation "x ^M" := (M x) (at level 2, left associativity, format "x ^M"). 20 | Notation "x ^v" := (v x) (at level 2, left associativity, format "x ^v"). 21 | 22 | (** formal evaluation of matricial automata into regular expressions *) 23 | Definition eval A := mx_scal (A^u ⋅ A^M^* ⋅ A^v). 24 | Arguments eval !_ /. 25 | 26 | (** two important classes of automata: 27 | - NFA, for which transitions are labelled by sums of letters, and 28 | - NFA with epsilon-transitions, where the sums may also include [1] *) 29 | 30 | Definition is_nfa e := is_01_mx e^u /\ is_pure_mx e^M /\ is_01_mx e^v. 31 | Definition is_enfa e := is_01_mx e^u /\ is_simple_mx e^M /\ is_01_mx e^v. 32 | 33 | (** characterisation of epsilon for automata with a pure transition matrix *) 34 | Lemma epsilon_eval n u (M: rmx n n) v: is_pure_mx M -> 35 | (epsilon (mx_scal (u⋅M^*⋅v)) <-> epsilon (mx_scal (u⋅v))). 36 | Proof. 37 | intro HM. rewrite 2epsilon_iff_reflexive_eps. 38 | rewrite 2(scal_mx_map (fun e => eps e)). 39 | rewrite 3epsilon_mx_dot, epsilon_mx_str, (epsilon_mx_pure HM). 40 | now rewrite str0, dotx1. 41 | Qed. 42 | 43 | (** characterisation of derivatives for NFA *) 44 | Lemma deriv_eval a n u (M: rmx n n) v: is_01_mx u -> is_pure_mx M -> is_01_mx v -> 45 | deriv a (mx_scal (u⋅M^*⋅v)) ≡ mx_scal (u⋅epsilon_mx (deriv_mx a M)⋅M^*⋅v). 46 | (* NB: we use epsilon_mx because [deriv_mx a M] is not necessarily a 01 matrix, 47 | even if it is equal to such a matrix *) 48 | Proof. 49 | intros Hu HM Hv. 50 | rewrite (scal_mx_map (deriv a)). apply mx_scal_weq. 51 | rewrite 2deriv_mx_dot, deriv_mx_str_strict. 2: apply epsilon_mx_pure; assumption. 52 | rewrite <-expand_01_mx by assumption. 53 | rewrite (deriv_01_mx _ Hu), (deriv_01_mx _ Hv), epsilon_deriv_pure_mx by assumption. 54 | ra. 55 | Qed. 56 | 57 | (** * Language of a NFA *) 58 | (** (operationally, not through evaluation into regular expressions) *) 59 | Fixpoint lang n (M: rmx n n) v u w: Prop := 60 | match w with 61 | | nil => epsilon (mx_scal (u ⋅ v)) 62 | | cons a w => lang M v (u ⋅ epsilon_mx (deriv_mx a M)) w 63 | end. 64 | (* NB: like above, we have to use [epsilon_mx] because [u ⋅ deriv_mx a M] is 65 | only equal to a 01-matrix *) 66 | 67 | (** the language of the NFA is that obtained by evaluation into regular expressions *) 68 | Theorem eval_lang n u M v (H: is_nfa (@mk n u M v)): 69 | regex.lang (mx_scal (u ⋅ M^* ⋅ v)) ≡ lang M v u. 70 | Proof. 71 | unfold regex.lang. intro w. revert u H. induction w; intros u H. 72 | unfold derivs. now rewrite epsilon_eval by apply H. 73 | unfold derivs. setoid_rewrite <- IHw. 74 | clear IHw. revert w. apply lang_weq, deriv_eval; apply H. 75 | split. 2: apply H. apply is_01_mx_dot. apply H. apply is_01_mx_epsilon. 76 | Qed. 77 | 78 | 79 | (** additional bureaucratic lemmas *) 80 | #[export] Instance lang_leq n (M: rmx n n) v: Proper (leq ==> leq) (lang M v). 81 | Proof. 82 | intros u u' H w. revert u u' H; induction w; intros u u' H; unfold lang; fold lang. 83 | apply epsilon_leq. (* TODO: this line should not be needed *) 84 | now rewrite H. 85 | apply IHw. now rewrite H. 86 | Qed. 87 | 88 | #[export] Instance lang_weq n (M: rmx n n) v: Proper (weq ==> weq) (lang M v) := op_leq_weq_1. 89 | 90 | #[export] Instance lang_weq' n (M: rmx n n) v: Proper (weq ==> eq ==> iff) (lang M v). 91 | Proof. intros ? ? H ? ? <-. now apply lang_weq. Qed. 92 | 93 | Lemma lang_empty n (u: rmx 1 n) M v: u ≡0 -> lang M v u ≡ bot. 94 | Proof. 95 | intros Hu w. revert Hu. induction w; intro Hu. simpl; fold_regex. 96 | rewrite Hu, dot0x. intuition discriminate. 97 | simpl. rewrite <-IHw by assumption. now rewrite Hu, dot0x. 98 | Qed. 99 | 100 | 101 | (** * Injection of DFA into NFA *) 102 | Module dfa. 103 | 104 | (** injection into NFA *) 105 | Definition to_nfa (A: dfa.t): t := mk 106 | (mx_fun (fun _ => dfa.u A) 1) 107 | (\sum_(a\in dfa.vars A) mx_fun (fun x => dfa.M A x a) (var a)) 108 | (fun i _ => ofbool (dfa.v A i)). 109 | 110 | (** injected DFA are indeed NFA *) 111 | Lemma is_nfa_nfa A: is_nfa (to_nfa A). 112 | Proof. 113 | split. intros ? ?. simpl. unfold mx_fun. case eqb_ord; constructor. 114 | split. intros ? ?. simpl. rewrite mx_sup. apply is_pure_sup. 115 | intros. unfold mx_fun. case eqb_ord; constructor. 116 | intros ? ?. apply is_01_ofbool. 117 | Qed. 118 | 119 | 120 | (** evaluation at a given state, into regular expressions *) 121 | Notation "A @ i" := (eval (to_nfa (dfa.reroot A i))) (at level 1). 122 | 123 | 124 | (** the language of a DFA coincides with that of the underlying NFA *) 125 | Theorem nfa_lang A i: dfa.lang A i ≡ 126 | lang ((to_nfa A)^M) ((to_nfa A)^v) (mx_fun (fun _ => i) 1). 127 | Proof. 128 | intro w. revert i. induction w; intro i; simpl. 129 | - rewrite epsilon_iff_reflexive_eps. rewrite (scal_mx_map (fun e => eps e)). 130 | change (mx_dot regex_ops regex_tt) with (@dot (mx_ops regex_ops regex_tt)). 131 | rewrite (mx_dot_kfun1 (X:=regex_ops)). 132 | unfold mx_map, mx_scal. rewrite <-epsilon_iff_reflexive_eps. case dfa.v; reflexivity. 133 | - rewrite IHw. clear IHw. 134 | change (mx_dot regex_ops regex_tt) with (@dot (mx_ops regex_ops regex_tt)). 135 | rewrite (mx_dot_kfun1 (X:=regex_ops)). unfold mx_fun, epsilon_mx, mx_map. 136 | setoid_rewrite mx_sup. setoid_rewrite deriv_sup. setoid_rewrite epsilon_sup. split. 137 | + intros [Ha H]. eapply lang_leq. 2: apply H. clear w H. 138 | intros _ j. rewrite <-(leq_xsup _ _ a Ha). 139 | case eqb_ord. 2: apply leq_bx. 140 | simpl. now rewrite eqb_refl. 141 | + intros H. split. case (List.in_dec (cmp_dec _) a (dfa.vars A)) as [Ha|Ha]. assumption. 142 | apply lang_empty in H. elim H. clear H. 143 | intros o j. apply sup_b. intros b Hb. case eqb_ord. 2: reflexivity. 144 | simpl. case eqb_spec; simpl. 2: reflexivity. 145 | intros <-. elim (Ha Hb). 146 | eapply lang_leq. 2: apply H. clear w H. 147 | intros _ j. apply leq_supx. intros b _. 148 | case eqb_spec. 2: intros; ra. 149 | intros ->. simpl. case eqb_spec; simpl. 2: intro; lattice. 150 | intros <-. now rewrite eqb_refl. 151 | Qed. 152 | 153 | (** the language of the DFA is that obtained by evaluation into regular expressions *) 154 | Corollary eval_lang A i: regex.lang A@i ≡ dfa.lang A i. 155 | Proof. setoid_rewrite eval_lang. 2: apply is_nfa_nfa. now rewrite nfa_lang. Qed. 156 | 157 | End dfa. 158 | 159 | Coercion dfa.to_nfa: dfa.t >-> t. 160 | -------------------------------------------------------------------------------- /theories/pair.v: -------------------------------------------------------------------------------- 1 | (** * pair: encoding pairs of ordinals as ordinals *) 2 | (** more precisely, [ord n * ord m] into [ord (n*m)] *) 3 | 4 | From Stdlib Require Import Psatz PeanoNat Compare_dec Euclid. 5 | Require Import ordinal. 6 | 7 | Set Asymmetric Patterns. 8 | Set Implicit Arguments. 9 | Local Open Scope ltb_scope. 10 | 11 | (** equivalence between our Boolean strict order on [nat], 12 | and the standard one from the standard library *) 13 | Lemma ltb_lt x y: ltb x y = true <-> lt x y. 14 | Proof. 15 | revert y. induction x; destruct y; simpl. 16 | split. discriminate. inversion 1. 17 | split. lia. trivial. 18 | split. discriminate. inversion 1. 19 | rewrite IHx. lia. 20 | Qed. 21 | 22 | (** auxiliary lemma *) 23 | Lemma mk_lt n m x y: x y y*n+x < n*m. 24 | Proof. setoid_rewrite ltb_lt. nia. Qed. 25 | 26 | (** since [x] is bounded by [n], we encode the pair [(x,y)] as [y*n+x] *) 27 | Definition mk n m (x: ord n) (y: ord m): ord (n*m). 28 | destruct x as [x Hx]; destruct y as [y Hy]. 29 | apply Ord with (y*n+x). 30 | now apply mk_lt. 31 | Defined. 32 | 33 | Lemma ord_nm_lt_O_n {n m} (x: ord (n*m)): lt 0 n. 34 | Proof. destruct n. elim (ord_0_empty x). lia. Qed. 35 | 36 | (** first projection, by modulo *) 37 | Definition pi1 {n m} (p: ord (n*m)): ord n := 38 | let '(divex _ x Hx _) := eucl_dev n (ord_nm_lt_O_n p) p in (Ord x (proj2 (ltb_lt _ _) Hx)). 39 | 40 | (** second projection, by division *) 41 | Definition pi2 {n m} (p: ord (n*m)): ord m. 42 | destruct (eucl_dev n (ord_nm_lt_O_n p) p) as [y x Hx Hy]. 43 | apply Ord with y. 44 | unfold gt in *. 45 | destruct p as [p Hp]. simpl in Hy. rewrite Hy in Hp. clear p Hy. 46 | destruct (le_lt_dec m y) as [Hy|Hy]. 2: now apply ltb_lt. exfalso. 47 | apply ltb_lt in Hp. abstract nia. 48 | Defined. 49 | 50 | Lemma euclid_unique n: lt 0 n -> 51 | forall x y x' y', lt x n -> lt x' n -> y*n+x = y'*n+x' -> y=y' /\ x=x'. 52 | Proof. 53 | intros Hn x y x' y' Hx Hx' H. rewrite Nat.mul_comm, (Nat.mul_comm y') in H. split. 54 | erewrite Nat.div_unique. 3: eassumption. 2: assumption. 55 | rewrite H. eapply Nat.div_unique. 2: symmetry; eassumption. assumption. 56 | erewrite Nat.mod_unique. 3: eassumption. 2: assumption. 57 | rewrite H. eapply Nat.mod_unique. 2: symmetry; eassumption. assumption. 58 | Qed. 59 | 60 | (** projections behave as expected *) 61 | Lemma pi1mk n m: forall x y, pi1 (@mk n m x y) = x. 62 | Proof. 63 | intros [x Hx] [y Hy]. unfold pi1, mk. case eucl_dev. 64 | intros y' x' Hx' H. apply eq_ord. apply euclid_unique in H as [_ ?]; auto. 65 | nia. now apply ltb_lt. 66 | Qed. 67 | 68 | Lemma pi2mk n m: forall x y, pi2 (@mk n m x y) = y. 69 | Proof. 70 | intros [x Hx] [y Hy]. unfold pi2, mk. case eucl_dev. 71 | intros y' x' Hx' H. apply eq_ord. simpl. apply euclid_unique in H as [? _]; auto. 72 | nia. now apply ltb_lt. 73 | Qed. 74 | 75 | (** surjective pairing *) 76 | Lemma mkpi12 n m: forall p, @mk n m (pi1 p) (pi2 p) = p. 77 | Proof. 78 | intros [p Hp]. unfold pi1, pi2, mk. case eucl_dev. simpl. intros y x Hx Hy. 79 | apply eq_ord. simpl. now rewrite Hy. 80 | Qed. 81 | -------------------------------------------------------------------------------- /theories/positives.v: -------------------------------------------------------------------------------- 1 | (** * positives: basic facts about binary positive numbers *) 2 | 3 | Require Export BinNums. 4 | Require Import comparisons. 5 | 6 | (** positives as a [cmpType] *) 7 | 8 | Fixpoint eqb_pos i j := 9 | match i,j with 10 | | xH,xH => true 11 | | xI i,xI j | xO i, xO j => eqb_pos i j 12 | | _,_ => false 13 | end. 14 | 15 | Lemma eqb_pos_spec: forall i j, reflect (i=j) (eqb_pos i j). 16 | Proof. induction i; intros [j|j|]; simpl; (try case IHi); constructor; congruence. Qed. 17 | 18 | Fixpoint pos_compare i j := 19 | match i,j with 20 | | xH, xH => Eq 21 | | xO i, xO j | xI i, xI j => pos_compare i j 22 | | xH, _ => Lt 23 | | _, xH => Gt 24 | | xO _, _ => Lt 25 | | _,_ => Gt 26 | end. 27 | 28 | Lemma pos_compare_spec: forall i j, compare_spec (i=j) (pos_compare i j). 29 | Proof. induction i; destruct j; simpl; try case IHi; try constructor; congruence. Qed. 30 | 31 | Canonical Structure cmp_pos := mk_cmp _ eqb_pos_spec _ pos_compare_spec. 32 | 33 | 34 | (** positive maps (for making environments) *) 35 | (** we redefine such trees here rather than importing them from the standard library: 36 | since we do not need any proof about them, this avoids us a heavy Require Import *) 37 | Section e. 38 | Variable A: Type. 39 | Inductive sigma := sigma_empty | N(l: sigma)(o: option A)(r: sigma). 40 | Fixpoint sigma_get default m i := 41 | match m with 42 | | N l o r => 43 | match i with 44 | | xH => match o with None => default | Some a => a end 45 | | xO i => sigma_get default l i 46 | | xI i => sigma_get default r i 47 | end 48 | | _ => default 49 | end. 50 | Fixpoint sigma_add i v m := 51 | match m with 52 | | sigma_empty => 53 | match i with 54 | | xH => N sigma_empty (Some v) sigma_empty 55 | | xO i => N (sigma_add i v sigma_empty) None sigma_empty 56 | | xI i => N sigma_empty None (sigma_add i v sigma_empty) 57 | end 58 | | N l o r => 59 | match i with 60 | | xH => N l (Some v) r 61 | | xO i => N (sigma_add i v l) o r 62 | | xI i => N l o (sigma_add i v r) 63 | end 64 | end. 65 | End e. 66 | 67 | -------------------------------------------------------------------------------- /theories/powerfix.v: -------------------------------------------------------------------------------- 1 | (** * powerfix: bounded fixpoint operator *) 2 | 3 | (** we define a fixpoint operator which recursively unfolds an 4 | open-recursive function with recursive depth at most [2^n], for 5 | arbitrary [n]. This allows us to define arbitrary recursive 6 | functions, without needing to prove their termination. The operator 7 | is defined in a computationally efficient way. (We already used 8 | such a trick in ATBR ; it's simplified here thanks to the 9 | introduction of eta in Coq v8.4 *) 10 | 11 | Require Import common. 12 | Set Implicit Arguments. 13 | 14 | Section powerfix. 15 | 16 | Variables A B: Type. 17 | Notation Fun := (A -> B). 18 | 19 | (** the three following functions "iterate" their [f] argument lazily: 20 | iteration stops whenever [f] no longer makes recursive calls. 21 | - [powerfix' n f k] iterates [f] at most [(2^n-1)] times and then yields to [k] 22 | - [powerfix n f k] iterates [f] at most [(2^n)] times and then yields to [k] 23 | - [linearfix n f k] iterates [f] at most [n] times and then yields to [k] 24 | *) 25 | Fixpoint powerfix' n (f: Fun -> Fun) (k: Fun): Fun := 26 | fun a => match n with O => k a | S n => f (powerfix' n f (powerfix' n f k)) a end. 27 | Definition powerfix n f k a := f (powerfix' n f k) a. 28 | 29 | Fixpoint linearfix n (f: Fun -> Fun) (k: Fun): Fun := 30 | fun a => match n with O => k a | S n => f (linearfix n f k) a end. 31 | 32 | (** simple lemmas about [2^n] *) 33 | Lemma pow2_S n: pow2 n = S (pred (pow2 n)). 34 | Proof. induction n. reflexivity. simpl. now rewrite IHn. Qed. 35 | 36 | Lemma pred_pow2_Sn n: pred (pow2 (S n)) = S (double (pred (pow2 n))). 37 | Proof. simpl. now rewrite pow2_S. Qed. 38 | 39 | (** characterisation of [powerfix] with [linearfix] *) 40 | Section linear_carac. 41 | 42 | Variable f: Fun -> Fun. 43 | 44 | Lemma linearfix_S: forall n k, 45 | f (linearfix n f k) = linearfix n f (f k). 46 | Proof. induction n; intros k; simpl. reflexivity. now rewrite IHn. Qed. 47 | 48 | Lemma linearfix_double: forall n k, 49 | linearfix n f (linearfix n f k) = linearfix (double n) f k. 50 | Proof. 51 | induction n; intros k. reflexivity. simpl linearfix. 52 | now rewrite <-IHn, <-linearfix_S. 53 | Qed. 54 | 55 | Lemma powerfix'_linearfix: forall n k, 56 | powerfix' n f k = linearfix (pred (pow2 n)) f k. 57 | Proof. 58 | induction n; intros. reflexivity. 59 | rewrite pred_pow2_Sn. simpl. 60 | now rewrite <-linearfix_double, 2IHn. 61 | Qed. 62 | 63 | Theorem powerfix_linearfix: forall n k, 64 | powerfix n f k = linearfix (pow2 n) f k. 65 | Proof. intros. unfold powerfix. now rewrite powerfix'_linearfix, pow2_S. Qed. 66 | 67 | End linear_carac. 68 | 69 | (** [powerfix_invariant] gives an induction principle for [powerfix], 70 | that does not care about the number of iterations -- in particular, 71 | the trivial "emptyfix" function : ([fun f k a => k a]) satisfies 72 | the same induction principle, so that this can only be used to 73 | reason about partial correctness. *) 74 | Section invariant. 75 | Variable P: Fun -> Prop. 76 | 77 | Lemma powerfix_invariant: forall n f g, 78 | (forall k, P k -> P (f k)) -> P g -> P (powerfix n f g). 79 | Proof. 80 | intros n f g Hf Hg. apply Hf. 81 | revert g Hg. induction n; intros g Hg; simpl; auto. 82 | Qed. 83 | 84 | End invariant. 85 | 86 | End powerfix. 87 | -------------------------------------------------------------------------------- /theories/prop.v: -------------------------------------------------------------------------------- 1 | (** * prop: Propositions ([Prop]) as a bounded distributive lattice *) 2 | 3 | Require Import lattice. 4 | 5 | (** lattice operations *) 6 | 7 | Canonical Structure Prop_lattice_ops: lattice.ops := {| 8 | leq := impl; 9 | weq := iff; 10 | cup := or; 11 | cap := and; 12 | neg := not; 13 | bot := False; 14 | top := True 15 | |}. 16 | 17 | (** bounded distributive lattice laws 18 | (we could get a Boolean lattice by assuming excluded middle) *) 19 | 20 | #[export] Instance Prop_lattice_laws: lattice.laws (BDL+STR+CNV+DIV) Prop_lattice_ops. 21 | Proof. 22 | constructor; (try apply Build_PreOrder); simpl; 23 | repeat intro; try discriminate; tauto. 24 | Qed. 25 | 26 | (** we could also equip Prop with a flat monoid structure, but this is 27 | not useful in practice *) 28 | (* 29 | Require Import monoid. 30 | 31 | CoInductive Prop_unit := Prop_tt. 32 | 33 | Canonical Structure Prop_ops: monoid.ops := {| 34 | ob := Prop_unit; 35 | mor n m := Prop_lattice_ops; 36 | dot n m p := and; 37 | one n := True; 38 | str n x := True; 39 | cnv n m x := x; 40 | ldv n m p := impl; 41 | rdv n m p := impl 42 | |}. 43 | 44 | Notation Prop' := (Prop_ops Prop_tt Prop_tt). 45 | 46 | Instance Prop_laws: laws (BDL+STR+CNV+DIV) Prop_ops. 47 | Proof. 48 | constructor; [intros; apply Prop_lattice_laws |..]; 49 | (try now left); repeat right; simpl; try tauto. 50 | Qed. 51 | *) 52 | -------------------------------------------------------------------------------- /theories/rel.v: -------------------------------------------------------------------------------- 1 | (** * rel: the main model of heterogeneous binary relations *) 2 | 3 | From Stdlib Require Bool. 4 | Require Export boolean prop. 5 | Require Import kat. 6 | 7 | Set Printing Universes. 8 | 9 | (** We fix a type universe U and show that heterogeneous relations 10 | between types in this universe form a kleene algebra. *) 11 | 12 | Universe U. 13 | Definition hrel (n m: Type@{U}) := n -> m -> Prop. 14 | Identity Coercion fun_of_hrel : hrel >-> Funclass. 15 | 16 | (** * Relations as a (bounded, distributive) lattice *) 17 | 18 | (** lattice operations and laws are obtained for free, by two 19 | successive pointwise liftings of the [Prop] lattice *) 20 | 21 | Canonical Structure hrel_lattice_ops n m := 22 | lattice.mk_ops (hrel n m) leq weq cup cap neg bot top. 23 | 24 | Global Instance hrel_lattice_laws n m: 25 | lattice.laws (BDL+STR+CNV+DIV) (hrel_lattice_ops n m) := pw_laws _. 26 | 27 | (** * Relations as a residuated Kleene allegory *) 28 | 29 | Section RepOps. 30 | Implicit Types n m p : Type@{U}. 31 | 32 | (** relational composition *) 33 | Definition hrel_dot n m p (x: hrel n m) (y: hrel m p): hrel n p := 34 | fun i j => exists2 k, x i k & y k j. 35 | 36 | (** converse (or transpose) *) 37 | Definition hrel_cnv n m (x: hrel n m): hrel m n := 38 | fun i j => x j i. 39 | 40 | (** left / right divisions *) 41 | Definition hrel_ldv n m p (x: hrel n m) (y: hrel n p): hrel m p := 42 | fun i j => forall k, x k i -> y k j. 43 | 44 | Definition hrel_rdv n m p (x: hrel m n) (y: hrel p n): hrel p m := 45 | fun j i => forall k, x i k -> y j k. 46 | 47 | Section i. 48 | Variable n: Type@{U}. 49 | Variable x: hrel n n. 50 | (** finite iterations of a relation *) 51 | Fixpoint iter u := match u with O => @eq _ | S u => hrel_dot _ _ _ x (iter u) end. 52 | (** Kleene star (reflexive transitive closure) *) 53 | Definition hrel_str: hrel n n := fun i j => exists u, iter u i j. 54 | (** strict iteration (transitive closure) *) 55 | Definition hrel_itr: hrel n n := hrel_dot n n n x hrel_str. 56 | End i. 57 | 58 | End RepOps. 59 | 60 | (** packing all operations into a monoid; note that the unit on [n] is 61 | just the equality on [n], i.e., the identity relation on [n] *) 62 | 63 | (** We need to eta-expand @eq here. This generates the universe 64 | constraint [U <= Coq.Init.Logic.8] (where the latter is the universe of 65 | the type argument to [eq]). Without the eta-expansion, the definition 66 | would yield the constraint [U = Coq.Init.Logig.8], which is too strong 67 | and leads to universe inconsistencies later on. *) 68 | 69 | Canonical Structure hrel_monoid_ops := 70 | monoid.mk_ops Type@{U} hrel_lattice_ops hrel_dot (fun n => @eq n) hrel_itr hrel_str hrel_cnv hrel_ldv hrel_rdv. 71 | 72 | (** binary relations form a residuated Kleene allegory *) 73 | #[export] Instance hrel_monoid_laws: monoid.laws (BDL+STR+CNV+DIV) hrel_monoid_ops. 74 | Proof. 75 | assert (dot_leq: forall n m p : Type@{U}, 76 | Proper (leq ==> leq ==> leq) (hrel_dot n m p)). 77 | intros n m p x y H x' y' H' i k [j Hij Hjk]. exists j. apply H, Hij. apply H', Hjk. 78 | constructor; (try now left); intros. 79 | apply hrel_lattice_laws. 80 | intros i j. firstorder. 81 | intros i j. firstorder congruence. 82 | intros i j. firstorder. 83 | intros i j. reflexivity. 84 | intros x y E i j. apply E. 85 | intros i j E. exists O. exact E. 86 | intros i k [j Hij [u Hjk]]. exists (S u). firstorder. 87 | assert (E: forall i, (iter n x i: hrel n n) ⋅ z ≦ z). 88 | induction i. simpl. firstorder now subst. 89 | rewrite <-H0 at 2. transitivity (x⋅((iter n x i: hrel n n)⋅z)). 90 | simpl. firstorder congruence. now apply dot_leq. 91 | intros i j [? [? ?] ?]. eapply E. repeat eexists; eauto. 92 | reflexivity. 93 | intros i k [[j Hij Hjk] Hik]. exists j; trivial. split; firstorder. 94 | split. intros E i j [k Hik Hkj]. apply E in Hkj. now apply Hkj. 95 | intros E i j Hij k Hki. apply E. firstorder. 96 | split. intros E i j [k Hik Hkj]. apply E in Hik. now apply Hik. 97 | intros E i j Hij k Hki. apply E. firstorder. 98 | Qed. 99 | 100 | 101 | (** * Relations as a Kleene algebra with tests *) 102 | 103 | 104 | (** "decidable" sets or predicates: Boolean functions 105 | 106 | Similar to [hrel_monoid_ops] we need to eta-expand the definition of 107 | dset to avoid forcing [U = pw] and obtain [U <= pw] instead *) 108 | 109 | Definition dset: ob hrel_monoid_ops -> lattice.ops := fun Y => pw_ops bool_lattice_ops Y. 110 | 111 | (** injection of decidable predicates into relations, as sub-identities *) 112 | Definition hrel_inj n (x: dset n): hrel n n := fun i j => i=j /\ x i. 113 | 114 | (** packing relations and decidable sets as a Kleene algebra with tests *) 115 | Canonical Structure hrel_kat_ops := 116 | kat.mk_ops hrel_monoid_ops dset hrel_inj. 117 | 118 | 119 | (** We need to impose the constraint [U < pw] before proving this 120 | lemma since otherwise we have [U = pw] afterwards. This leads to a 121 | universe inconsistency when trying load ugregex_dec, kat_completeness 122 | (as exported by kat_tac) and rel at the same time. *) 123 | 124 | Constraint U < pw. 125 | #[export] Instance hrel_kat_laws: kat.laws hrel_kat_ops. 126 | Proof. 127 | constructor. apply lower_laws. intro. apply (pw_laws (H:=lower_lattice_laws)). 128 | assert (inj_leq: forall n, Proper (leq ==> leq) (@hrel_inj n)). 129 | intros n e f H i j [E H']. split. assumption. revert H'. apply mm_bool_Prop, H. 130 | constructor; try discriminate. 131 | apply inj_leq. 132 | apply op_leq_weq_1. 133 | intros _ x y i j. split. 134 | intros [E H']. setoid_rewrite Bool.orb_true_iff in H'. 135 | destruct H'; [left|right]; split; assumption. 136 | intros [[E H']|[E H']]; split; trivial; setoid_rewrite Bool.orb_true_iff; now auto. 137 | intros _ i j. compute. intuition discriminate. 138 | intros ? i j. compute. tauto. 139 | intros ? p q i j. split. 140 | intros [E H']. setoid_rewrite Bool.andb_true_iff in H'. exists i; split; tauto. 141 | intros [k [ik Hi] [kj Hk]]. subst. split; trivial. setoid_rewrite Bool.andb_true_iff; now split. 142 | Qed. 143 | 144 | 145 | (** * Functional relations *) 146 | 147 | Definition frel {A B: Set} (f: A -> B): hrel A B := fun x y => y = f x. 148 | 149 | Lemma frel_comp {A B C: Set} (f: A -> B) (g: B -> C): frel f ⋅ frel g ≡ frel (fun x => g (f x)). 150 | Proof. 151 | apply antisym. intros x z [y -> ->]. reflexivity. 152 | simpl. intros x z ->. eexists; reflexivity. 153 | Qed. 154 | 155 | #[export] Instance frel_weq {A B}: Proper (pwr eq ==> weq) (@frel A B). 156 | Proof. unfold frel; split; intros ->; simpl. apply H. apply eq_sym, H. Qed. 157 | 158 | Ltac fold_hrel := ra_fold hrel_monoid_ops. 159 | Tactic Notation "fold_hrel" "in" hyp_list(H) := ra_fold hrel_monoid_ops in H. 160 | Tactic Notation "fold_hrel" "in" "*" := ra_fold hrel_monoid_ops in *. 161 | -------------------------------------------------------------------------------- /theories/rewriting.v: -------------------------------------------------------------------------------- 1 | (** * rewriting: additional rewriting support *) 2 | 3 | Require Import monoid. 4 | 5 | 6 | (** * rewriting modulo associativity of [dot] *) 7 | 8 | (** We notice that to rewrite modulo A, it suffices to normalise 9 | associativity, and to use an extended lemma: for instance, if one 10 | wants to rewrite using a closed hypothesis 11 | 12 | [H: a_1⋅...⋅a_n ≡ c] 13 | 14 | in a goal including a subterm like [d⋅e*a_1⋅...⋅a_n⋅f], then one 15 | can simply rewrite using 16 | 17 | [(ext_weq_n H): forall x, x⋅a_1⋅...⋅a_n ≡ x⋅c] 18 | 19 | where ext_weq_n is the appropriate lemma (see rewriting.v). 20 | 21 | Such a lemma could be generated by hand, but it's a bit heavy, so 22 | that we simply hardwire it for n=2,3,4 23 | 24 | This trick generalises to "open" equations, like 25 | 26 | [H: forall x y, P x y -> forall z, y⋅(x+z)⋅y ≡ y] 27 | 28 | where one wants to rewrite using 29 | [(fun x y Hxy z => ext_weq_3 (H x y Hxy z))] 30 | 31 | The ML plugin [mrewrite] generates such abstractions in the 32 | appropriate way, taking care efficiently of the order in which one 33 | wants to rewrite, and whether we have an equation or an 34 | inequation. (Doing so in Ltac is both painful and inefficient.) 35 | 36 | Of course the method is incomplete (e.g., if [y] has to be 37 | instantiated by a product), but it seems enough for most common 38 | situations. The advantage over using the AAC_tactics library is 39 | that it's much faster since reification is "syntactic", and that 40 | it works for typed structures and heterogeneous terms, which are 41 | not supported in AAC_tactics. 42 | *) 43 | 44 | Lemma ext_leq_2 `{laws} {n m p} (x: X n m) (y: X m p) v: x⋅y ≦ v -> 45 | forall o (u: X o n), u⋅x⋅y ≦ u⋅v. 46 | Proof. intros E ? ?. now rewrite <-E, !dotA. Qed. 47 | 48 | Lemma ext_leq_3 `{laws} {n m p q} (x: X n m) (y: X m p) (z: X p q) v: x⋅y⋅z ≦ v -> 49 | forall o (u: X o n), u⋅x⋅y⋅z ≦ u⋅v. 50 | Proof. intros E ? ?. now rewrite <-E, !dotA. Qed. 51 | 52 | Lemma ext_leq_4 `{laws} {n m p q r} (x: X n m) (y: X m p) (z: X p q) (t: X q r) v: x⋅y⋅z⋅t ≦ v -> 53 | forall o (u: X o n), u⋅x⋅y⋅z⋅t ≦ u⋅v. 54 | Proof. intros E ? ?. now rewrite <-E, !dotA. Qed. 55 | 56 | 57 | Lemma ext_weq_2 `{laws} {n m p} (x: X n m) (y: X m p) v: x⋅y ≡ v -> 58 | forall o (u: X o n), u⋅x⋅y ≡ u⋅v. 59 | Proof. intros E ? ?. now rewrite <-E, !dotA. Qed. 60 | 61 | Lemma ext_weq_3 `{laws} {n m p q} (x: X n m) (y: X m p) (z: X p q) v: x⋅y⋅z ≡ v -> 62 | forall o (u: X o n), u⋅x⋅y⋅z ≡ u⋅v. 63 | Proof. intros E ? ?. now rewrite <-E, !dotA. Qed. 64 | 65 | Lemma ext_weq_4 `{laws} {n m p q r} (x: X n m) (y: X m p) (z: X p q) (t: X q r) v: x⋅y⋅z⋅t ≡ v -> 66 | forall o (u: X o n), u⋅x⋅y⋅z⋅t ≡ u⋅v. 67 | Proof. intros E ? ?. now rewrite <-E, !dotA. Qed. 68 | 69 | 70 | Lemma ext_leq_2' `{laws} {n m p} (x: X n m) (y: X m p) v: v ≦ x⋅y -> 71 | forall o (u: X o n), u⋅v ≦ u⋅x⋅y. 72 | Proof. intros E ? ?. now rewrite E, !dotA. Qed. 73 | 74 | Lemma ext_leq_3' `{laws} {n m p q} (x: X n m) (y: X m p) (z: X p q) v: v ≦ x⋅y⋅z -> 75 | forall o (u: X o n), u⋅v ≦ u⋅x⋅y⋅z. 76 | Proof. intros E ? ?. now rewrite E, !dotA. Qed. 77 | 78 | Lemma ext_leq_4' `{laws} {n m p q r} (x: X n m) (y: X m p) (z: X p q) (t: X q r) v: v ≦ x⋅y⋅z⋅t -> 79 | forall o (u: X o n), u⋅v ≦ u⋅x⋅y⋅z⋅t. 80 | Proof. intros E ? ?. now rewrite E, !dotA. Qed. 81 | 82 | 83 | Lemma ext_weq_2' `{laws} {n m p} (x: X n m) (y: X m p) v: v ≡ x⋅y -> 84 | forall o (u: X o n), u⋅v ≡ u⋅x⋅y. 85 | Proof. intros E ? ?. now rewrite E, !dotA. Qed. 86 | 87 | Lemma ext_weq_3' `{laws} {n m p q} (x: X n m) (y: X m p) (z: X p q) v: v ≡ x⋅y⋅z -> 88 | forall o (u: X o n), u⋅v ≡ u⋅x⋅y⋅z. 89 | Proof. intros E ? ?. now rewrite E, !dotA. Qed. 90 | 91 | Lemma ext_weq_4' `{laws} {n m p q r} (x: X n m) (y: X m p) (z: X p q) (t: X q r) v: v ≡ x⋅y⋅z⋅t -> 92 | forall o (u: X o n), u⋅v ≡ u⋅x⋅y⋅z⋅t. 93 | Proof. intros E ? ?. now rewrite E, !dotA. Qed. 94 | 95 | 96 | Declare ML Module "coq-relation-algebra.mrewrite". 97 | 98 | (** User-end rewriting tactics *) 99 | 100 | Tactic Notation "mrewrite" constr(H) := 101 | rewrite ?dotA; (rewrite H || ra_extend (fun H => rewrite H) ->H); [rewrite ?dotA|..]. 102 | Tactic Notation "mrewrite" "<-" constr(H) := 103 | rewrite ?dotA; (rewrite <-H || ra_extend (fun H => rewrite <-H) <-H); [rewrite ?dotA|..]. 104 | Tactic Notation "mrewrite" constr(H) "in" hyp(H') := 105 | rewrite ?dotA in H'; (rewrite H in H' || ra_extend (fun H => rewrite H in H') ->H); rewrite ?dotA in H'. 106 | Tactic Notation "mrewrite" "<-" constr(H) "in" hyp(H') := 107 | rewrite ?dotA in H'; (rewrite <-H in H' || ra_extend (fun H => rewrite <-H in H') <-H); rewrite ?dotA in H'. 108 | -------------------------------------------------------------------------------- /theories/rewriting_aac.v: -------------------------------------------------------------------------------- 1 | (** * rewriting_aac: bridge with AAC_tactics *) 2 | 3 | Require Import monoid. 4 | 5 | From AAC_tactics 6 | Require Export AAC. 7 | 8 | Section lattice. 9 | Context `{lattice.laws}. 10 | 11 | Global Instance aac_cupA `{CUP ≪ l} : Associative weq cup := cupA. 12 | Global Instance aac_cupC `{CUP ≪ l} : Commutative weq cup := cupC. 13 | Global Instance aac_cupI `{CUP ≪ l} : Idempotent weq cup := cupI. 14 | Global Instance aac_cupU `{BOT+CUP ≪ l} : Unit weq cup bot := Build_Unit _ _ _ cupbx cupxb. 15 | 16 | Global Instance aac_capA `{CAP ≪ l} : Associative weq cap := capA. 17 | Global Instance aac_capC `{CAP ≪ l} : Commutative weq cap := capC. 18 | Global Instance aac_capI `{CAP ≪ l} : Idempotent weq cap := capI. 19 | Global Instance aac_capU `{TOP+CAP ≪ l} : Unit weq cap top := Build_Unit _ _ _ captx capxt. 20 | 21 | Global Instance aac_lift_leq_weq : AAC_lift leq weq. 22 | Proof. constructor; eauto with typeclass_instances. Qed. 23 | 24 | End lattice. 25 | 26 | Section monoid. 27 | Context `{monoid.laws} {n: ob X}. 28 | Global Instance aac_dotA: Associative weq (dot n n n) := (@dotA _ _ _ n n n n). 29 | Global Instance aac_dotU: Unit weq (dot n n n) (one n). 30 | Proof. constructor; intro. apply dot1x. apply dotx1. Qed. 31 | End monoid. 32 | 33 | (* 34 | (* tests *) 35 | Require Import kleene. 36 | Goal forall `{laws} `{BKA ≪ l} n (a b c: X n n), a+b ≡ c -> (forall x: X n n, x⋅x ≡ x) -> 37 | a⋅b+b+1⋅a+(b+0)^* ≡ a⋅b⋅c⋅b⋅c⋅a+0. 38 | Proof. 39 | intros. aac_normalise. 40 | aac_rewrite H1. 41 | aac_rewrite H2 in_right. 42 | Abort. 43 | 44 | Require Import rel. 45 | Goal forall (a b c: hrel nat nat), a+b ≡ c -> (forall x: hrel nat nat, x⋅x ≡ x) -> 46 | a⋅b+b+1⋅a+(b+0)^* ≡ a⋅b⋅c⋅b⋅c⋅a+0. 47 | Proof. 48 | intros. 49 | aac_rewrite H. 50 | aac_rewrite H0 in_right. 51 | aac_normalise. 52 | (* TOFIX: can we prevent the unfoldings? *) 53 | ra_fold hrel_monoid_ops nat. 54 | (* TOFIX: incomplete folding *) 55 | Abort. 56 | *) 57 | -------------------------------------------------------------------------------- /theories/sums.v: -------------------------------------------------------------------------------- 1 | (** * sums: finite sums, a la ssreflect *) 2 | 3 | (** this tiny module extends [sups] to the setting of monoids (it is 4 | a separate module just to avoid [sups] to depend on [monoid]) *) 5 | 6 | Require Import monoid. 7 | Require Export sups. 8 | 9 | (** in the setting of monoids, we prefer the "sum" notation *) 10 | 11 | Notation "\sum_ ( i \in l ) f" := (@sup (mor _ _) _ (fun i => f) l) 12 | (at level 41, f at level 41, i, l at level 50, 13 | format "'[' \sum_ ( i \in l ) '/ ' f ']'"): ra_terms. 14 | 15 | Notation "\sum_ ( i < n ) f" := (\sum_(i \in seq n) f) 16 | (at level 41, f at level 41, i, n at level 50, 17 | format "'[' \sum_ ( i < n ) '/ ' f ']'"): ra_terms. 18 | 19 | (** [dot] distributes over sums *) 20 | Lemma dotxsum `{laws} `{BSL ≪ l} I J n m p (f: I -> X m n) (x: X p m): 21 | x ⋅ (\sum_(i\in J) f i) ≡ \sum_(i\in J) (x ⋅ f i). 22 | Proof. apply f_sup_weq. apply dotx0. intros; apply dotxpls. Qed. 23 | 24 | Lemma dotsumx `{laws} `{BSL ≪ l} I J n m p (f: I -> X n m) (x: X m p): 25 | (\sum_(i\in J) f i) ⋅ x ≡ \sum_(i\in J) (f i ⋅ x). 26 | Proof. dual @dotxsum. Qed. 27 | 28 | (** converse commutes with sums *) 29 | Lemma cnvsum `{laws} `{BSL+CNV ≪ l} I J n m (f: I -> X n m): 30 | (\sum_(i\in J) f i)° ≡ \sum_(i \in J) (f i)°. 31 | Proof. apply f_sup_weq. apply cnv0. apply cnvpls. Qed. 32 | -------------------------------------------------------------------------------- /theories/sups.v: -------------------------------------------------------------------------------- 1 | (** * sups: finite joins (or supremums), a la ssreflect *) 2 | 3 | (** We define a few operations for manipulating finite supremums or 4 | intersections. We basically follow the scheme proposed for "bigops" 5 | in ssreflect, but we simplify it as much as possible since we do 6 | not need the whole machinery. The two main simplifications are: 7 | - the fact that we restrict ourselves to the associative, 8 | commutative, and idempotent operation [cup] of lattices 9 | (intersections being obtained by working in the dual lattices) 10 | - the fact that we do not include a "selection" operator *) 11 | 12 | Require Import lset lattice. 13 | Require Export ordinal. 14 | 15 | Section s. 16 | Context `{L:laws} `{Hl:BSL ≪ l}. 17 | 18 | Universe S. 19 | 20 | Section i. 21 | 22 | Context {I: Type@{S}}. 23 | 24 | (** * Supremums *) 25 | 26 | (** the unique operator which we define is the following one, 27 | which intuitively corresponds to [fold_right cup (map f J) bot], 28 | we redefine it to get a better behaviour with [simpl] *) 29 | 30 | (** sup f [j1;...;jn] = f j1 ⊔ ... ⊔ f jn *) 31 | Fixpoint sup (f: I -> X) J := 32 | match J with 33 | | nil => bot 34 | | cons i J => f i ⊔ sup f J 35 | end. 36 | 37 | (** sup specification *) 38 | Lemma sup_spec f J x: sup f J ≦ x <-> forall i, In i J -> f i ≦ x. 39 | Proof. 40 | induction J; simpl. split. tauto. intro. lattice. 41 | rewrite cup_spec, IHJ. clear IHJ. intuition. now subst. 42 | Qed. 43 | 44 | (** ** basic facts about [sup] *) 45 | Lemma sup_app f h k: sup f (h++k) ≡ sup f h ⊔ sup f k. 46 | Proof. induction h; simpl. lattice. rewrite IHh. hlattice. Qed. 47 | 48 | Lemma sup_singleton f i: sup f (i::nil) ≡ f i. 49 | Proof. simpl. lattice. Qed. 50 | 51 | Lemma leq_supx f J x: (forall i, In i J -> f i ≦ x) -> sup f J ≦ x. 52 | Proof. apply sup_spec. Qed. 53 | 54 | Lemma leq_xsup f J i: In i J -> f i ≦ sup f J. 55 | Proof. now apply sup_spec. Qed. 56 | 57 | Lemma leq_xsup' f J i x: In i J -> x ≦ f i -> x ≦ sup f J. 58 | Proof. intros ? E. rewrite E. now apply leq_xsup. Qed. 59 | 60 | (** [sup] is monotone, w.r.t, both the function [f] and the set [J] *) 61 | Global Instance sup_leq: Proper (pwr leq ==> leq ==> leq) sup. 62 | Proof. 63 | intros f f' Hf J J' HJ. induction J. apply leq_bx. 64 | simpl. apply leq_cupx. rewrite Hf. apply leq_xsup. apply HJ. now left. 65 | apply IHJ. intros j ?. apply HJ. now right. 66 | Qed. 67 | 68 | Global Instance sup_weq: Proper (pwr weq ==> weq ==> weq) sup. 69 | Proof. simpl. setoid_rewrite weq_spec. split; apply sup_leq; firstorder. Qed. 70 | 71 | Lemma supcup f g J: sup (fun i => f i ⊔ g i) J ≡ sup f J ⊔ sup g J. 72 | Proof. induction J; simpl. lattice. rewrite IHJ. lattice. Qed. 73 | 74 | (** refined monotonicity result: the functions have to be pointwise 75 | comparable only on the elements of [J] *) 76 | Lemma sup_leq' J J' (f f': I -> X): 77 | J ≦J' -> (forall i, In i J -> f i ≦ f' i) -> sup f J ≦ sup f' J'. 78 | Proof. 79 | induction J; intros HJ Hf. apply leq_bx. 80 | simpl. apply leq_cupx. 81 | rewrite Hf. apply leq_xsup. apply HJ. now left. now left. 82 | apply IHJ. rewrite <- HJ. clear; firstorder. clear -Hf; firstorder. 83 | Qed. 84 | 85 | Lemma sup_weq' J J' (f f': I -> X): 86 | J ≡J' -> (forall i, In i J -> f i ≡ f' i) -> sup f J ≡ sup f' J'. 87 | Proof. setoid_rewrite weq_spec. split; apply sup_leq'; firstorder. Qed. 88 | 89 | (** the sup of empty elements is still empty *) 90 | Lemma sup_b J (f: I -> X) (Hf: forall i, In i J -> f i ≡ bot): sup f J ≡ bot. 91 | Proof. 92 | apply antisym. 2: apply leq_bx. 93 | apply leq_supx. intros. now rewrite Hf. 94 | Qed. 95 | 96 | End i. 97 | 98 | (** ** swapping and reindexing indices *) 99 | 100 | Theorem sup_swap I J (f: I -> J -> X) I' J': 101 | sup (fun i => sup (fun j => f i j) J') I' ≡ 102 | sup (fun j => sup (fun i => f i j) I') J'. 103 | Proof. 104 | induction I'; simpl. apply antisym. apply leq_bx. apply leq_supx; trivial. 105 | now rewrite IHI', supcup. 106 | Qed. 107 | 108 | Lemma sup_map I J (f: J -> X) (m: I -> J) I': 109 | sup f (map m I') = sup (fun i => f (m i)) I'. 110 | Proof. induction I'; simpl; congruence. Qed. 111 | 112 | End s. 113 | 114 | (** ** notations *) 115 | 116 | (** we use "\sup_(i\in l) f" in the general case *) 117 | Notation "\sup_ ( i \in l ) f" := (sup (fun i => f) l) 118 | (at level 41, f at level 41, i, l at level 50, 119 | format "'[' \sup_ ( i \in l ) '/ ' f ']'"): ra_terms. 120 | 121 | (** and "\sup_(i Y): 135 | (f bot ≡ bot) -> 136 | (forall x y, f (x ⊔ y) ≡ f x ⊔ f y) -> 137 | forall I J (g: I -> X), f (sup g J) ≡ \sup_(i\in J) f (g i). 138 | Proof. 139 | intros Hbot Hcup I J g. induction J. apply Hbot. 140 | simpl. rewrite Hcup. now apply cup_weq. 141 | Qed. 142 | 143 | Lemma f_sup_eq {X Y: ops} (f: X -> Y): 144 | (f bot = bot) -> 145 | (forall x y, f (x ⊔ y) = f x ⊔ f y) -> 146 | forall I J (g: I -> X), f (sup g J) = \sup_(i\in J) f (g i). 147 | Proof. 148 | intros Hbot Hcup I J g. induction J. apply Hbot. 149 | simpl. rewrite Hcup. congruence. 150 | Qed. 151 | 152 | (** same thing, to prove that a predicate is preserved under supremums *) 153 | 154 | Lemma P_sup {X: ops} {P: X -> Prop} I J (f: I -> X): 155 | P bot -> 156 | (forall x y, P x -> P y -> P (x ⊔ y)) -> 157 | (forall i, In i J -> P (f i)) -> 158 | P (sup f J). 159 | Proof. 160 | intros Hbot Hcup. 161 | induction J; intro H; simpl. apply Hbot. 162 | apply Hcup. apply H; now left. apply IHJ. intros. apply H. now right. 163 | Qed. 164 | 165 | 166 | 167 | (** cutting a supremum over ordinals of size [n+m] *) 168 | Lemma sup_cut `{L:laws} `{BSL ≪ l} n m f: 169 | \sup_(i X) A (J: A -> list I) h: 174 | sup f (sup J h) ≡ sup (fun a => sup f (J a)) h. 175 | Proof. induction h. reflexivity. simpl. now rewrite sup_app, IHh. Qed. 176 | 177 | (** belonging to a finite union *) 178 | Lemma in_sup A I J (f: I -> list A) a: In a (sup f J) <-> exists i, In i J /\ In a (f i). 179 | Proof. 180 | induction J; simpl. firstorder. 181 | rewrite in_app_iff, IHJ. clear. firstorder congruence. 182 | Qed. 183 | 184 | (** link between [map] and [sup] *) 185 | Lemma map_sup A I J (f: I -> A): map f J = \sup_(i\in J) [f i]. 186 | Proof. induction J; simpl; congruence. Qed. 187 | 188 | 189 | (** distribution of meets over supremums *) 190 | Lemma capxsup `{laws} `{BSL+CAP ≪ l} I J (f: I -> X) (x: X): 191 | x ⊓ (\sup_(i\in J) f i) ≡ \sup_(i\in J) (x ⊓ f i). 192 | Proof. apply f_sup_weq. apply capxb. intros; apply capcup. Qed. 193 | 194 | Lemma capsupx `{laws} `{BSL+CAP ≪ l} I J (f: I -> X) (x: X): 195 | (\sup_(i\in J) f i) ⊓ x ≡ \sup_(i\in J) (f i ⊓ x). 196 | Proof. rewrite capC, capxsup. now setoid_rewrite capC at 1. Qed. 197 | 198 | 199 | (** * Infimum (or intersections) *) 200 | 201 | (** obtained for free, by duality *) 202 | 203 | Notation inf f l := (@sup (dual _) _ f l). 204 | 205 | Notation "\inf_ ( i \in l ) f" := (inf (fun i => f) l) 206 | (at level 41, f at level 41, i, l at level 50, 207 | format "'[' \inf_ ( i \in l ) '/ ' f ']'"): ra_terms. 208 | 209 | Notation "\inf_ ( i < n ) f" := (\inf_(i \in seq n) f) 210 | (at level 41, f at level 41, i, n at level 50, 211 | format "'[' \inf_ ( i < n ) '/ ' f ']'"): ra_terms. 212 | 213 | Section inf. 214 | Context `{laws} `{CAP+TOP ≪ l} {I: Type}. 215 | 216 | Global Instance inf_leq: 217 | Proper (pwr (@leq X) ==> leq --> @leq X) (@sup (dual X) I). 218 | Proof. intros ? ? ? ? ?. now dual @sup_leq. Qed. 219 | 220 | Lemma inf_spec (f: I -> X) J (x: X): 221 | x ≦ \inf_(i\in J) f i <-> forall i, In i J -> x ≦ f i. 222 | Proof. dual @sup_spec. Qed. 223 | 224 | Lemma inf_singleton (f: I -> X) i: inf f (i::nil) ≡ f i. 225 | Proof. dual @sup_singleton. Qed. 226 | 227 | Lemma leq_xinf (f: I -> X) J x: (forall i, In i J -> x ≦ f i) -> x ≦ inf f J. 228 | Proof. dual @leq_supx. Qed. 229 | 230 | Lemma leq_infx (f: I -> X) J i: In i J -> @leq X (inf f J) (f i). 231 | Proof. dual @leq_xsup. Qed. 232 | 233 | Lemma leq_infx' (f: I -> X) J i x: In i J -> f i ≦ x -> @leq X (inf f J) x. 234 | Proof. dual @leq_xsup'. Qed. 235 | 236 | End inf. 237 | 238 | -------------------------------------------------------------------------------- /theories/ugregex.v: -------------------------------------------------------------------------------- 1 | (** * ugregex: untyped generalised regular expressions *) 2 | 3 | (** we define here the syntax for untyped generalised regular expressions 4 | which we will actually use in computations *) 5 | 6 | Require Import kat lsyntax positives sups glang comparisons boolean. 7 | Set Implicit Arguments. 8 | 9 | Section l. 10 | Variable Pred: nat. 11 | Notation Sigma := positive. 12 | Notation Atom := (ord (pow2 Pred)). 13 | Notation uglang := (traces_monoid_ops Atom traces_tt traces_tt). 14 | 15 | (** * Syntax *) 16 | 17 | (** we declare strict iteration as primitive for efficiency reasons: 18 | Kleene star is derived from strict iteration in a linear way, 19 | while deriving strict iteration out of Kleene star requires duplication. *) 20 | Inductive ugregex := 21 | | u_var(i: Sigma) 22 | | u_prd(p: expr (ord Pred)) 23 | | u_pls(e f: ugregex) 24 | | u_dot(e f: ugregex) 25 | | u_itr(e: ugregex). 26 | 27 | (** [zer] and [one] are also derived operations *) 28 | Definition u_zer := u_prd e_bot. 29 | Definition u_one := u_prd e_top. 30 | Definition u_str e := u_pls u_one (u_itr e). 31 | 32 | 33 | (** * Language *) 34 | 35 | (** we define the untyped guarded string language of an expression 36 | algebraically (by induction on the expression) ; below we 37 | characterise it coalgebraically *) 38 | 39 | Fixpoint lang (e: ugregex): uglang := 40 | match e with 41 | | u_var a => tsingle a 42 | | u_prd p => tinj (fun i => eval (set.mem i) p) 43 | | u_pls e f => lang e + lang f 44 | | u_dot e f => lang e ⋅ lang f 45 | | u_itr e => (lang e)^+ 46 | end. 47 | 48 | (** we get a KA structure, by interpretation into languages *) 49 | 50 | Definition u_leq e f := lang e ≦ lang f. 51 | Definition u_weq e f := lang e ≡ lang f. 52 | 53 | Canonical Structure ugregex_lattice_ops := 54 | lattice.mk_ops _ u_leq u_weq u_pls u_pls id u_zer u_zer. 55 | 56 | CoInductive ugregex_unit := ugregex_tt. 57 | 58 | Canonical Structure ugregex_monoid_ops := 59 | monoid.mk_ops ugregex_unit _ 60 | (fun _ _ _ => u_dot) (fun _ => u_one) (fun _ => u_itr) (fun _ => u_str) 61 | (fun _ _ _ => u_zer) (fun _ _ _ _ _ => u_zer) (fun _ _ _ _ _ => u_zer). 62 | 63 | (* Canonical Structure ugregex_kat_ops := *) 64 | (* kat.mk_ops ugregex_monoid_ops (fun _ => lsyntax.expr_ops _ BL) (fun _ => u_prd). *) 65 | 66 | Notation tt := ugregex_tt. 67 | Notation ugregex' := (ugregex_monoid_ops tt tt). 68 | 69 | Global Instance ugregex_monoid_laws: monoid.laws BKA ugregex_monoid_ops. 70 | Proof. 71 | apply (laws_of_faithful_functor (f:=fun _ _: ugregex_unit => lang)). 72 | constructor; simpl ob. intros ? ?. constructor. 73 | now intros ? ? ?. 74 | now intros ? ? ?. 75 | now intros _ ? ?. 76 | discriminate. 77 | intros _ [a|]; simpl; intuition discriminate. 78 | discriminate. 79 | discriminate. 80 | reflexivity. 81 | intros ? [a|]; simpl; intuition. 82 | reflexivity. 83 | intros _ ? x. rewrite str_itr. simpl (lang _). apply cup_weq. 2: reflexivity. 84 | intros [|]; simpl. intuition. tauto. 85 | discriminate. 86 | discriminate. 87 | discriminate. 88 | now intros ? ? ?. 89 | now intros ? ? ?. 90 | Qed. 91 | 92 | Global Instance ugregex_lattice_laws: lattice.laws BKA ugregex_lattice_ops. 93 | Proof. apply (@lattice_laws _ _ ugregex_monoid_laws tt tt). Qed. 94 | 95 | (** Note that [ugregex] actually comes with a KAT structure, but we do not need it *) 96 | (* Global Instance ugregex_kat_laws: kat.laws ugregex_kat_ops. *) 97 | 98 | (** folding expressions *) 99 | Ltac fold_ugregex := ra_fold ugregex_monoid_ops tt. 100 | 101 | 102 | 103 | (** * Coalgebraic characterisation of the language recognised by an expression *) 104 | 105 | (** epsilon (optimised since it's quite simple) *) 106 | 107 | Fixpoint epsilon_pred a (e: expr_ops (ord Pred) BL) := 108 | match e with 109 | | e_bot => false 110 | | e_top => true 111 | | e_var i => a i 112 | | e_cup e f => epsilon_pred a e ||| epsilon_pred a f 113 | | e_cap e f => epsilon_pred a e &&& epsilon_pred a f 114 | | e_neg e => negb (epsilon_pred a e) 115 | end. 116 | 117 | Fixpoint epsilon a (e: ugregex) := 118 | match e with 119 | | u_var _ => false 120 | | u_prd p => epsilon_pred a p 121 | | u_pls e f => epsilon a e ||| epsilon a f 122 | | u_dot e f => epsilon a e &&& epsilon a f 123 | | u_itr e => epsilon a e 124 | end. 125 | 126 | (** derivatives (specification, unoptimised) *) 127 | 128 | Fixpoint deriv a i (e: ugregex'): ugregex' := 129 | match e with 130 | | u_prd _ => 0 131 | | u_var j => ofbool (eqb_pos i j) 132 | | u_pls e f => deriv a i e + deriv a i f 133 | | u_dot e f => deriv a i e ⋅ f + ofbool (epsilon (set.mem a) e) ⋅ deriv a i f 134 | | u_itr e => deriv a i e ⋅ (e: ugregex')^* 135 | end. 136 | 137 | (** corresponding coalgebraic notion of language *) 138 | 139 | Fixpoint lang' (e: ugregex') (w: trace Atom) := 140 | match w with 141 | | tnil a => is_true (epsilon (set.mem a) e) 142 | | tcons a i w => lang' (deriv a i e) w 143 | end. 144 | 145 | (** characterisation of [epsilon] through languages *) 146 | 147 | Lemma epsilon_iff_lang_nil a e: epsilon (set.mem a) e <-> (lang e) (tnil a). 148 | Proof. 149 | induction e; simpl. 150 | intuition discriminate. 151 | apply eq_bool_iff. simpl epsilon. induction p; simpl. 152 | reflexivity. 153 | reflexivity. 154 | rewrite <-Bool.orb_lazy_alt. congruence. 155 | rewrite <-Bool.andb_lazy_alt. congruence. 156 | congruence. 157 | reflexivity. 158 | setoid_rewrite Bool.orb_true_iff. now apply cup_weq. 159 | setoid_rewrite Bool.andb_true_iff. setoid_rewrite traces_dot_nil. now apply cap_weq. 160 | split. exists O. simpl. tauto. 161 | intros [i Hi]. rewrite IHe. clear IHe. induction i. assumption. 162 | apply IHi. setoid_rewrite traces_dot_nil in Hi. apply Hi. 163 | Qed. 164 | 165 | Lemma lang_0: lang u_zer ≡ 0. 166 | Proof. intros [?|???]; simpl; intuition discriminate. Qed. 167 | 168 | Lemma lang_1: lang u_one ≡ 1. 169 | Proof. intros [a|???]; simpl. intuition. reflexivity. Qed. 170 | 171 | Lemma lang_ofbool b: lang (ofbool b: ugregex') ≡ ofbool b. 172 | Proof. case b. apply lang_1. apply lang_0. Qed. 173 | 174 | Global Instance lang_leq: Proper (leq ==> leq) lang. 175 | Proof. now intros ? ?. Qed. 176 | Global Instance lang_weq: Proper (weq ==> weq) lang. 177 | Proof. now intros ? ?. Qed. 178 | 179 | Lemma lang_sup J: lang (sup id J) ≡ sup lang J. 180 | Proof. apply f_sup_weq. apply lang_0. reflexivity. Qed. 181 | 182 | Lemma deriv_sup a i J: deriv a i (sup id J) = sup (deriv a i) J. 183 | Proof. apply f_sup_eq; now f_equal. Qed. 184 | 185 | (** characterisation of derivatives through languages *) 186 | 187 | Lemma deriv_traces a i e: lang (deriv a i e) ≡ traces_deriv a i (lang e). 188 | Proof. 189 | symmetry. induction e; simpl deriv. simpl lang. 190 | rewrite lang_ofbool. apply traces_deriv_single. 191 | rewrite lang_0. apply traces_deriv_inj. 192 | setoid_rewrite traces_deriv_pls. now apply cup_weq. 193 | generalize (epsilon_iff_lang_nil a e1). case epsilon; intro He1. 194 | fold_ugregex. setoid_rewrite dot1x. simpl lang. 195 | setoid_rewrite traces_deriv_dot_1. now rewrite IHe1, IHe2. 196 | now rewrite <-He1. 197 | fold_ugregex. setoid_rewrite dot0x. rewrite cupxb. simpl lang. 198 | setoid_rewrite traces_deriv_dot_2. now rewrite IHe1. 199 | rewrite <-He1. discriminate. 200 | simpl lang. 201 | setoid_rewrite traces_deriv_itr. now rewrite IHe, str_itr, <-inj_top. 202 | Qed. 203 | 204 | (** the two definitions of languages (algebraic and coalgebraic) coincide, 205 | by unicity of the coalgebra morphism from expressions to languages *) 206 | 207 | Theorem lang_lang' e: lang e ≡ lang' e. 208 | Proof. 209 | symmetry. intro w. revert e. induction w as [a|a i w IH]; simpl lang'; intro e. 210 | - apply epsilon_iff_lang_nil. 211 | - rewrite IH. apply deriv_traces. 212 | Qed. 213 | 214 | (** as a consequence, [lang'] preserves equality *) 215 | Corollary lang'_weq: Proper (weq ==> weq) lang'. 216 | Proof. intros ? ? H. apply lang_weq in H. now rewrite 2 lang_lang' in H. Qed. 217 | 218 | 219 | (** * Comparing expressions *) 220 | 221 | Fixpoint ugregex_compare (x y: ugregex) := 222 | match x,y with 223 | | u_prd a, u_prd b 224 | | u_var a, u_var b => cmp a b 225 | | u_pls x x', u_pls y y' 226 | | u_dot x x', u_dot y y' => lex (ugregex_compare x y) (ugregex_compare x' y') 227 | | u_itr x, u_itr y => ugregex_compare x y 228 | | u_var _, _ => Lt 229 | | _, u_var _ => Gt 230 | | u_prd _, _ => Lt 231 | | _, u_prd _ => Gt 232 | | u_itr _ , _ => Lt 233 | | _, u_itr _ => Gt 234 | | u_pls _ _ , _ => Lt 235 | | _, u_pls _ _ => Gt 236 | end. 237 | 238 | 239 | Lemma ugregex_compare_spec x y: compare_spec (x=y) (ugregex_compare x y). 240 | Proof. 241 | revert y; induction x; destruct y; try (constructor; congruence); simpl. 242 | case cmp_spec; constructor; congruence. 243 | case cmp_spec; constructor; congruence. 244 | eapply lex_spec; eauto. intuition congruence. 245 | eapply lex_spec; eauto. intuition congruence. 246 | case IHx; constructor; congruence. 247 | Qed. 248 | 249 | Canonical Structure ugregex_cmp := mk_simple_cmp _ ugregex_compare_spec. 250 | 251 | End l. 252 | --------------------------------------------------------------------------------