├── .github └── workflows │ └── docker-action.yml ├── .gitignore ├── LICENSE ├── Makefile ├── Makefile.coq.local ├── README.md ├── TODO.txt ├── _CoqProject ├── coq-atbr.opam ├── dune-project ├── meta.yml ├── resources ├── config.js ├── coqdoc.css ├── coqdocjs.css ├── coqdocjs.js ├── footer.html ├── header.html ├── index.html └── index.md ├── src ├── dune ├── reification.mlg ├── reification_plugin.mlpack └── reify.ml └── theories ├── ATBR.v ├── ATBR_Matrices.v ├── BoolView.v ├── ChurchRosser.v ├── ChurchRosser_Points_vs_Algebraic.v ├── Classes.v ├── Common.v ├── Converse.v ├── DKA_CheckLabels.v ├── DKA_Construction.v ├── DKA_DFA_Equiv.v ├── DKA_DFA_Language.v ├── DKA_Definitions.v ├── DKA_Determinisation.v ├── DKA_Epsilon.v ├── DKA_Merge.v ├── DKA_StateSetSets.v ├── DecideKleeneAlgebra.v ├── DisjointSets.v ├── Examples.v ├── Force.v ├── Functors.v ├── Graph.v ├── KleeneAlgebra.v ├── Model_Languages.v ├── Model_MinPlus.v ├── Model_RegExp.v ├── Model_Relations.v ├── Model_StdRelations.v ├── Monoid.v ├── MxFunctors.v ├── MxGraph.v ├── MxKleeneAlgebra.v ├── MxSemiLattice.v ├── MxSemiRing.v ├── MyFMapProperties.v ├── MyFSetProperties.v ├── MyFSets.v ├── Numbers.v ├── Reification.v ├── SemiLattice.v ├── SemiRing.v ├── StrictKleeneAlgebra.v ├── StrictStarForm.v ├── Utils_WF.v └── dune /.github/workflows/docker-action.yml: -------------------------------------------------------------------------------- 1 | name: Docker CI 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | paths-ignore: 8 | - 'resources/**' 9 | pull_request: 10 | branches: 11 | - '**' 12 | paths-ignore: 13 | - 'resources/**' 14 | 15 | jobs: 16 | build: 17 | # the OS must be GNU/Linux to be able to use the docker-coq-action 18 | runs-on: ubuntu-latest 19 | strategy: 20 | matrix: 21 | image: 22 | - 'coqorg/coq:dev' 23 | fail-fast: false 24 | steps: 25 | - uses: actions/checkout@v3 26 | - uses: coq-community/docker-coq-action@v1 27 | with: 28 | opam_file: 'coq-atbr.opam' 29 | custom_image: ${{ matrix.image }} 30 | 31 | 32 | # See also: 33 | # https://github.com/coq-community/docker-coq-action#readme 34 | # https://github.com/erikmd/docker-coq-github-action-demo 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # build output 2 | _build 3 | docs 4 | *.aux 5 | *.vo 6 | *.glob 7 | *.d 8 | *.vos 9 | *.vok 10 | .lia.cache 11 | 12 | # make-related output 13 | Makefile.coq 14 | Makefile.coq.conf 15 | 16 | # reification plugin 17 | *.cmi 18 | *.cmx 19 | *.cmxs 20 | *.o 21 | *.a 22 | *.cmxa 23 | *.cmt 24 | src/reification.ml 25 | src/.merlin 26 | src/META.coq-atbr 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The ATBR library is free software: you can redistribute it and/or 2 | modify it under the terms of the GNU Lesser General Public License as 3 | published by the Free Software Foundation, either version 3 of the 4 | License, or (at your option) any later version. 5 | 6 | This library is distributed in the hope that it will be useful, but 7 | WITHOUT ANY WARRANTY; without even the implied warranty of 8 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 9 | Lesser General Public License for more details. 10 | 11 | GNU LESSER GENERAL PUBLIC LICENSE 12 | Version 3, 29 June 2007 13 | 14 | Copyright (C) 2007 Free Software Foundation, Inc. 15 | Everyone is permitted to copy and distribute verbatim copies 16 | of this license document, but changing it is not allowed. 17 | 18 | 19 | This version of the GNU Lesser General Public License incorporates 20 | the terms and conditions of version 3 of the GNU General Public 21 | License, supplemented by the additional permissions listed below. 22 | 23 | 0. Additional Definitions. 24 | 25 | As used herein, "this License" refers to version 3 of the GNU Lesser 26 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 27 | General Public License. 28 | 29 | "The Library" refers to a covered work governed by this License, 30 | other than an Application or a Combined Work as defined below. 31 | 32 | An "Application" is any work that makes use of an interface provided 33 | by the Library, but which is not otherwise based on the Library. 34 | Defining a subclass of a class defined by the Library is deemed a mode 35 | of using an interface provided by the Library. 36 | 37 | A "Combined Work" is a work produced by combining or linking an 38 | Application with the Library. The particular version of the Library 39 | with which the Combined Work was made is also called the "Linked 40 | Version". 41 | 42 | The "Minimal Corresponding Source" for a Combined Work means the 43 | Corresponding Source for the Combined Work, excluding any source code 44 | for portions of the Combined Work that, considered in isolation, are 45 | based on the Application, and not on the Linked Version. 46 | 47 | The "Corresponding Application Code" for a Combined Work means the 48 | object code and/or source code for the Application, including any data 49 | and utility programs needed for reproducing the Combined Work from the 50 | Application, but excluding the System Libraries of the Combined Work. 51 | 52 | 1. Exception to Section 3 of the GNU GPL. 53 | 54 | You may convey a covered work under sections 3 and 4 of this License 55 | without being bound by section 3 of the GNU GPL. 56 | 57 | 2. Conveying Modified Versions. 58 | 59 | If you modify a copy of the Library, and, in your modifications, a 60 | facility refers to a function or data to be supplied by an Application 61 | that uses the facility (other than as an argument passed when the 62 | facility is invoked), then you may convey a copy of the modified 63 | version: 64 | 65 | a) under this License, provided that you make a good faith effort to 66 | ensure that, in the event an Application does not supply the 67 | function or data, the facility still operates, and performs 68 | whatever part of its purpose remains meaningful, or 69 | 70 | b) under the GNU GPL, with none of the additional permissions of 71 | this License applicable to that copy. 72 | 73 | 3. Object Code Incorporating Material from Library Header Files. 74 | 75 | The object code form of an Application may incorporate material from 76 | a header file that is part of the Library. You may convey such object 77 | code under terms of your choice, provided that, if the incorporated 78 | material is not limited to numerical parameters, data structure 79 | layouts and accessors, or small macros, inline functions and templates 80 | (ten or fewer lines in length), you do both of the following: 81 | 82 | a) Give prominent notice with each copy of the object code that the 83 | Library is used in it and that the Library and its use are 84 | covered by this License. 85 | 86 | b) Accompany the object code with a copy of the GNU GPL and this license 87 | document. 88 | 89 | 4. Combined Works. 90 | 91 | You may convey a Combined Work under terms of your choice that, 92 | taken together, effectively do not restrict modification of the 93 | portions of the Library contained in the Combined Work and reverse 94 | engineering for debugging such modifications, if you also do each of 95 | the following: 96 | 97 | a) Give prominent notice with each copy of the Combined Work that 98 | the Library is used in it and that the Library and its use are 99 | covered by this License. 100 | 101 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 102 | document. 103 | 104 | c) For a Combined Work that displays copyright notices during 105 | execution, include the copyright notice for the Library among 106 | these notices, as well as a reference directing the user to the 107 | copies of the GNU GPL and this license document. 108 | 109 | d) Do one of the following: 110 | 111 | 0) Convey the Minimal Corresponding Source under the terms of this 112 | License, and the Corresponding Application Code in a form 113 | suitable for, and under terms that permit, the user to 114 | recombine or relink the Application with a modified version of 115 | the Linked Version to produce a modified Combined Work, in the 116 | manner specified by section 6 of the GNU GPL for conveying 117 | Corresponding Source. 118 | 119 | 1) Use a suitable shared library mechanism for linking with the 120 | Library. A suitable mechanism is one that (a) uses at run time 121 | a copy of the Library already present on the user's computer 122 | system, and (b) will operate properly with a modified version 123 | of the Library that is interface-compatible with the Linked 124 | Version. 125 | 126 | e) Provide Installation Information, but only if you would otherwise 127 | be required to provide such information under section 6 of the 128 | GNU GPL, and only to the extent that such information is 129 | necessary to install and execute a modified version of the 130 | Combined Work produced by recombining or relinking the 131 | Application with a modified version of the Linked Version. (If 132 | you use option 4d0, the Installation Information must accompany 133 | the Minimal Corresponding Source and Corresponding Application 134 | Code. If you use option 4d1, you must provide the Installation 135 | Information in the manner specified by section 6 of the GNU GPL 136 | for conveying Corresponding Source.) 137 | 138 | 5. Combined Libraries. 139 | 140 | You may place library facilities that are a work based on the 141 | Library side by side in a single library together with other library 142 | facilities that are not Applications and are not covered by this 143 | License, and convey such a combined library under terms of your 144 | choice, if you do both of the following: 145 | 146 | a) Accompany the combined library with a copy of the same work based 147 | on the Library, uncombined with any other library facilities, 148 | conveyed under the terms of this License. 149 | 150 | b) Give prominent notice with the combined library that part of it 151 | is a work based on the Library, and explaining where to find the 152 | accompanying uncombined form of the same work. 153 | 154 | 6. Revised Versions of the GNU Lesser General Public License. 155 | 156 | The Free Software Foundation may publish revised and/or new versions 157 | of the GNU Lesser General Public License from time to time. Such new 158 | versions will be similar in spirit to the present version, but may 159 | differ in detail to address new problems or concerns. 160 | 161 | Each version is given a distinguishing version number. If the 162 | Library as you received it specifies that a certain numbered version 163 | of the GNU Lesser General Public License "or any later version" 164 | applies to it, you have the option of following the terms and 165 | conditions either of that published version or of any later version 166 | published by the Free Software Foundation. If the Library as you 167 | received it does not specify a version number of the GNU Lesser 168 | General Public License, you may choose any version of the GNU Lesser 169 | General Public License ever published by the Free Software Foundation. 170 | 171 | If the Library as you received it specifies that a proxy can decide 172 | whether future versions of the GNU Lesser General Public License shall 173 | apply, that proxy's public statement of acceptance of any version is 174 | permanent authorization for you to choose that version for the 175 | Library. 176 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: Makefile.coq 2 | @+$(MAKE) -f Makefile.coq all 3 | 4 | clean: Makefile.coq 5 | @+$(MAKE) -f Makefile.coq cleanall 6 | @rm -f Makefile.coq Makefile.coq.conf 7 | 8 | Makefile.coq: _CoqProject 9 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 10 | 11 | force _CoqProject Makefile: ; 12 | 13 | %: Makefile.coq force 14 | @+$(MAKE) -f Makefile.coq $@ 15 | 16 | .PHONY: all clean force 17 | -------------------------------------------------------------------------------- /Makefile.coq.local: -------------------------------------------------------------------------------- 1 | GLOBFILES = $(VFILES:.v=.glob) 2 | CSSFILES = resources/coqdoc.css resources/coqdocjs.css 3 | JSFILES = resources/config.js resources/coqdocjs.js 4 | HTMLFILES = resources/header.html resources/footer.html 5 | COQDOCDIR = docs/coqdoc 6 | 7 | COQDOCHTMLFLAGS = --toc --toc-depth 2 --index indexpage --html \ 8 | --interpolate --no-lib-name --parse-comments \ 9 | --with-header resources/header.html --with-footer resources/footer.html 10 | 11 | coqdoc: $(GLOBFILES) $(VFILES) $(CSSFILES) $(JSFILES) $(HTMLFILES) 12 | $(SHOW)'COQDOC -d $(COQDOCDIR)' 13 | $(HIDE)mkdir -p $(COQDOCDIR) 14 | $(HIDE)$(COQDOC) $(COQDOCHTMLFLAGS) $(COQDOCLIBS) -d $(COQDOCDIR) $(VFILES) 15 | $(SHOW)'COPY resources' 16 | $(HIDE)cp $(CSSFILES) $(JSFILES) $(COQDOCDIR) 17 | .PHONY: coqdoc 18 | 19 | resources/index.html: resources/index.md 20 | pandoc -s -o $@ $< 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 5 | # ATBR 6 | 7 | [![Docker CI][docker-action-shield]][docker-action-link] 8 | [![Contributing][contributing-shield]][contributing-link] 9 | [![Code of Conduct][conduct-shield]][conduct-link] 10 | [![Zulip][zulip-shield]][zulip-link] 11 | [![coqdoc][coqdoc-shield]][coqdoc-link] 12 | [![DOI][doi-shield]][doi-link] 13 | 14 | [docker-action-shield]: https://github.com/coq-community/atbr/workflows/Docker%20CI/badge.svg?branch=master 15 | [docker-action-link]: https://github.com/coq-community/atbr/actions?query=workflow:"Docker%20CI" 16 | 17 | [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg 18 | [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md 19 | 20 | [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg 21 | [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md 22 | 23 | [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg 24 | [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users 25 | 26 | [coqdoc-shield]: https://img.shields.io/badge/docs-coqdoc-blue.svg 27 | [coqdoc-link]: https://coq-community.org/atbr 28 | 29 | [doi-shield]: https://zenodo.org/badge/DOI/10.2168/LMCS-8(1:16)2012.svg 30 | [doi-link]: https://doi.org/10.2168/LMCS-8(1:16)2012 31 | 32 | This library provides algebraic tools for working with binary relations. 33 | The main tactic provided is a reflexive tactic for solving (in)equations 34 | in an arbitrary Kleene algebra. The decision procedure goes through 35 | standard finite automata constructions. 36 | 37 | Note that the initial authors consider this library to be superseded 38 | by the Relation Algebra library, which is based on derivatives 39 | rather than automata: https://github.com/damien-pous/relation-algebra 40 | 41 | ## Meta 42 | 43 | - Author(s): 44 | - Thomas Braibant (initial) 45 | - Damien Pous (initial) 46 | - Coq-community maintainer(s): 47 | - Tej Chajed ([**@tchajed**](https://github.com/tchajed)) 48 | - License: [GNU Lesser General Public License v3.0 or later](LICENSE) 49 | - Compatible Coq versions: master (use the corresponding branch or release for other Coq versions) 50 | - Compatible OCaml versions: 4.09.0 or later 51 | - Additional dependencies: none 52 | - Coq namespace: `ATBR` 53 | - Related publication(s): 54 | - [Deciding Kleene Algebras in Coq](https://arxiv.org/abs/1105.4537) doi:[10.2168/LMCS-8(1:16)2012](https://doi.org/10.2168/LMCS-8(1:16)2012) 55 | 56 | ## Building and installation instructions 57 | 58 | The easiest way to install the latest released version of ATBR 59 | is via [OPAM](https://opam.ocaml.org/doc/Install.html): 60 | 61 | ```shell 62 | opam repo add coq-released https://coq.inria.fr/opam/released 63 | opam install coq-atbr 64 | ``` 65 | 66 | To instead build and install manually, do: 67 | 68 | ``` shell 69 | git clone https://github.com/coq-community/atbr.git 70 | cd atbr 71 | make # or make -j 72 | make install 73 | ``` 74 | 75 | 76 | ## Documentation 77 | 78 | The development and underlying theory of the library is described in the paper 79 | [Deciding Kleene Algebras in Coq][paper], Logical Methods in Computer Science, 80 | Volume 8, Issue 1, 2012. 81 | 82 | Below are succinct descriptions of each file and tactic. See also the 83 | [coqdoc presentation][coqdoc] of the Coq source files from the latest release. 84 | 85 | ### Library files 86 | 87 | | Filename | Description 88 | | -------- | ----------- 89 | | ATBR | Export all relevant modules, except those related to matrices 90 | | ATBR_Matrices | Export all relevant modules, including those related to matrices 91 | 92 | 93 | #### Algebraic hierarchy 94 | 95 | | Filename | Description 96 | | -------- | ----------- 97 | | Classes | Definitions of algebraic classes of the development 98 | | Graph | Lemmas and hints about the base class (carrier with equality) 99 | | Monoid | Monoids, free monoids, finite iterations over a monoid, various tactics 100 | | SemiLattice | Semilattices, tactics: normalise, reflexivity, rewrite 101 | | SemiRing | Idempotent semirings, tactics: normalise, reflexivity, rewrite 102 | | KleeneAlgebra | Kleene algebras, basic properties 103 | | Converse | Structures with converse (semirings and Kleene Algebras) 104 | | Functors | Functors between the various algebraic structures 105 | | StrictKleeneAlgebra | Class of Strict Kleene algebras (without 0), and extension of the decision procedure 106 | 107 | #### Models 108 | 109 | | Filename | Description 110 | | -------- | ----------- 111 | | Model_Relations | Kleene Algebra of (heterogeneous) binary relations 112 | | Model_StdRelations | Kleene Algebra of standard (homogeneous) binary relations 113 | | Model_Languages | Kleene Algebra of languages 114 | | Model_RegExp | Kleene Algebra of regular expressions (syntactic free model), typed reification 115 | | Model_MinMax | (min,+) Kleene Algebra (matrices on this algebra give weighted graphs) 116 | 117 | #### Matrices 118 | 119 | | Filename | Description 120 | | -------- | ----------- 121 | | MxGraph | Matrices without operations; blocks definitions 122 | | MxSemiLattice | Semilattices of matrices 123 | | MxSemiRing | Semiring of matrices 124 | | MxKleeneAlgebra | Kleene algebra of matrices (definition of the star operation) 125 | | MxFunctors | Extension of functors to matrices 126 | 127 | 128 | #### Decision procedure for KA 129 | 130 | | Filename | Description 131 | | -------- | ----------- 132 | | DKA_Definitions | Base definitions for the decision procedure for KA (automata types, notations, ...) 133 | | DKA_StateSetSets | Properties about sets of sets 134 | | DKA_CheckLabels | Algorithm to check whether two regex have the same set of labels 135 | | DKA_Construction | Construction algorithm, and proof of correctness 136 | | DKA_Epsilon | Removal of epsilon transitions, proof of correctness 137 | | DKA_Determinisation | Determinisation algorithm, proof of correctness 138 | | DKA_Merge | Union of DFAs, proof of correctness 139 | | DKA_DFA_Language | Language recognised by a DFA, equivalence with the evaluation of the DFA 140 | | DKA_DFA_Equiv | Equivalence check for DFAs, proof of correctness 141 | | DecideKleeneAlgebra | Kozen's initiality proof, kleene_reflexivity tactic 142 | 143 | #### Other tools 144 | 145 | | Filename | Description 146 | | -------- | ----------- 147 | | StrictStarForm | Conversion of regular expressions into strict star form, kleene_ssf tactic 148 | | Equivalence | Tactic for solving equivalences by transitivity 149 | 150 | #### Examples 151 | 152 | | Filename | Description 153 | | -------- | ----------- 154 | | Examples | Small tutorial file, that goes through our set of tactics 155 | | ChurchRosser | Simple usages of kleene_reflexivity to prove commutation properties 156 | | ChurchRosser_Points | Comparison between a standard CR proof and algebraic ones 157 | 158 | #### Misc. 159 | 160 | | Filename | Description 161 | | -------- | ----------- 162 | | Common | Shared simple tactics and definitions 163 | | BoolView | View mechanism for Boolean computations 164 | | Numbers | NUM interface, to abstract over the representation of numbers, sets, and maps 165 | | Utils_WF | Utilities about well-founded relations; partial fixpoint operators (powerfix) 166 | | DisjointSets | Efficient implementation of a disjoint sets data structure 167 | | Force | Functional memoisation (in case one needs efficient matrix computations) 168 | | Reification | Reified syntax for the various algebraic structures 169 | 170 | #### Finite sets and maps 171 | 172 | | Filename | Description 173 | | -------- | ----------- 174 | | MyFSets | Efficient ordered datatypes constructions (for FSets functors) 175 | | MyFSetProperties | Handler for FSet properties 176 | | MyFMapProperties | Handler for FMap properties 177 | 178 | #### OCaml modules 179 | 180 | | Filename | Description 181 | | -------- | ----------- 182 | | `reification.ml` | reification for the reflexive tactics 183 | 184 | ### Tactics 185 | 186 | #### Reflexive tactics 187 | 188 | | Tactic | Description 189 | | ------ | ----------- 190 | | `semiring_reflexivity` | solve an (in)equation on the idempotent semiring (*,+,1,0) 191 | | `semiring_normalize` | simplify an (in)equation on the idempotent semiring (*,+,1,0) 192 | | `semiring_clean` | simplify 0 and 1 193 | | `semiring_cleanassoc` | simplify 0 and 1, normalize the parentheses 194 | | `kleene_reflexivity` | solve an (in)equation in Kleene Algebras 195 | | `ckleene_reflexivity` | solve an (in)equation in Kleene Algebras with converse 196 | | `skleene_reflexivity` | solve an (in)equation in Strict Kleene Algebras (without 0) 197 | | `kleene_clean_zero` | remove zeros in a KA expression 198 | | `kleene_ssf` | put KA expressions into strict star form 199 | 200 | #### Rewriting tactics 201 | 202 | | Tactic | Description 203 | | ------ | ----------- 204 | | `ac_rewrite H` | rewrite a closed equality modulo (AC) of (+) 205 | | `monoid_rewrite H` | rewrite a closed equality modulo (A) of (*) 206 | 207 | #### Other tactics 208 | 209 | | Tactic | Description 210 | | ------ | ----------- 211 | | `converse_down` | push converses down to terms leaves 212 | | `switch` | add converses to the goal and push them down to terms leaves 213 | 214 | ## Acknowledgements 215 | 216 | The initial authors would like to thank Guilhem Moulin and Sebastien Briais, 217 | who participated to a preliminary version of this project. They are also grateful 218 | to Assia Mahboubi, Matthieu Sozeau, Bruno Barras, and Hugo Herbelin for highly 219 | stimulating discussions, as well as numerous hints for solving various problems. 220 | 221 | [paper]: https://arxiv.org/abs/1105.4537 222 | [coqdoc]: https://coq-community.github.io/atbr/docs/latest/coqdoc/toc.html 223 | 224 | -------------------------------------------------------------------------------- /TODO.txt: -------------------------------------------------------------------------------- 1 | Here is a list of things we intend to do at some point; 2 | suggestions are welcome. 3 | 4 | - Non idempotent semirings: 5 | we considered only idempotent (non-commutative) semirings in this 6 | development. This is because we wanted to work with binary relations. 7 | It should be easy, however, to isolate the idempotence hypothesis, 8 | so as to provide tools for non necessarily idempotents semirings. 9 | This would fill the gap with existing Coq tactics (ring), that handle 10 | the commutative case. 11 | 12 | - Matrix library: 13 | we need to clean up this part of the code, and to add some 14 | documentation, in order to release it as a library for working 15 | with matrices in a non-commutative setting. Some lemmas and 16 | functions will be renamed. 17 | 18 | - Compilation time / Loading time: 19 | our library is really slow to compile (about 6 minutes), and slow 20 | to load (about 8 seconds), for at least two reasons: 21 | 1/ our intensive use of FSets modules and functors, that are really 22 | slow to instantiate and load in the current version of Coq; 23 | 2/ our intensive use of typeclasses. 24 | Depending on the evolutions of Coq, we might be able to improve this 25 | situation. 26 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -generate-meta-for-package coq-atbr 2 | -Q theories ATBR 3 | -I src 4 | 5 | -arg -w -arg -variable-collision 6 | -arg -w -arg -projection-no-head-constant 7 | -arg -w -arg -undo-batch-mode 8 | -arg -w -arg -undeclared-scope 9 | -arg -w -arg -ambiguous-paths 10 | 11 | src/reify.ml 12 | src/reification.mlg 13 | src/reification_plugin.mlpack 14 | 15 | theories/Common.v 16 | theories/BoolView.v 17 | theories/MyFSets.v 18 | theories/MyFSetProperties.v 19 | theories/MyFMapProperties.v 20 | theories/Numbers.v 21 | theories/Utils_WF.v 22 | theories/Force.v 23 | theories/DisjointSets.v 24 | theories/Classes.v 25 | theories/Reification.v 26 | theories/Functors.v 27 | theories/Graph.v 28 | theories/SemiLattice.v 29 | theories/Monoid.v 30 | theories/SemiRing.v 31 | theories/KleeneAlgebra.v 32 | theories/Converse.v 33 | theories/Model_Relations.v 34 | theories/Model_StdRelations.v 35 | theories/Model_Languages.v 36 | theories/Model_RegExp.v 37 | theories/Model_MinPlus.v 38 | theories/StrictStarForm.v 39 | theories/MxGraph.v 40 | theories/MxSemiLattice.v 41 | theories/MxSemiRing.v 42 | theories/MxKleeneAlgebra.v 43 | theories/MxFunctors.v 44 | theories/DKA_Definitions.v 45 | theories/DKA_StateSetSets.v 46 | theories/DKA_CheckLabels.v 47 | theories/DKA_Construction.v 48 | theories/DKA_Epsilon.v 49 | theories/DKA_Determinisation.v 50 | theories/DKA_Merge.v 51 | theories/DKA_DFA_Language.v 52 | theories/DKA_DFA_Equiv.v 53 | theories/DecideKleeneAlgebra.v 54 | theories/StrictKleeneAlgebra.v 55 | theories/ATBR.v 56 | theories/ATBR_Matrices.v 57 | theories/Examples.v 58 | theories/ChurchRosser.v 59 | theories/ChurchRosser_Points_vs_Algebraic.v 60 | -------------------------------------------------------------------------------- /coq-atbr.opam: -------------------------------------------------------------------------------- 1 | # This file was generated from `meta.yml`, please do not edit manually. 2 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 3 | 4 | opam-version: "2.0" 5 | maintainer: "palmskog@gmail.com" 6 | version: "dev" 7 | 8 | homepage: "https://github.com/coq-community/atbr" 9 | dev-repo: "git+https://github.com/coq-community/atbr.git" 10 | bug-reports: "https://github.com/coq-community/atbr/issues" 11 | doc: "https://coq-community.github.io/atbr/" 12 | license: "LGPL-3.0-or-later" 13 | 14 | synopsis: "Coq library and tactic for deciding Kleene algebras" 15 | description: """ 16 | This library provides algebraic tools for working with binary relations. 17 | The main tactic provided is a reflexive tactic for solving (in)equations 18 | in an arbitrary Kleene algebra. The decision procedure goes through 19 | standard finite automata constructions. 20 | 21 | Note that the initial authors consider this library to be superseded 22 | by the Relation Algebra library, which is based on derivatives 23 | rather than automata: https://github.com/damien-pous/relation-algebra""" 24 | 25 | build: [make "-j%{jobs}%"] 26 | install: [make "install"] 27 | depends: [ 28 | "ocaml" {>= "4.09.0"} 29 | "coq" {= "dev"} 30 | ] 31 | 32 | tags: [ 33 | "category:Miscellaneous/Coq Extensions" 34 | "category:Computer Science/Decision Procedures and Certified Algorithms/Decision procedures" 35 | "keyword:Kleene algebra" 36 | "keyword:finite automata" 37 | "keyword:semiring" 38 | "keyword:matrices" 39 | "keyword:decision procedure" 40 | "keyword:reflexive tactic" 41 | "logpath:ATBR" 42 | ] 43 | authors: [ 44 | "Thomas Braibant" 45 | "Damien Pous" 46 | ] 47 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (using coq 0.3) 3 | (name atbr) 4 | -------------------------------------------------------------------------------- /meta.yml: -------------------------------------------------------------------------------- 1 | --- 2 | fullname: ATBR 3 | shortname: atbr 4 | organization: coq-community 5 | community: true 6 | action: true 7 | coqdoc: true 8 | doi: 10.2168/LMCS-8(1:16)2012 9 | plugin: true 10 | 11 | synopsis: Coq library and tactic for deciding Kleene algebras 12 | 13 | description: |- 14 | This library provides algebraic tools for working with binary relations. 15 | The main tactic provided is a reflexive tactic for solving (in)equations 16 | in an arbitrary Kleene algebra. The decision procedure goes through 17 | standard finite automata constructions. 18 | 19 | Note that the initial authors consider this library to be superseded 20 | by the Relation Algebra library, which is based on derivatives 21 | rather than automata: https://github.com/damien-pous/relation-algebra 22 | 23 | publications: 24 | - pub_url: https://arxiv.org/abs/1105.4537 25 | pub_title: Deciding Kleene Algebras in Coq 26 | pub_doi: 10.2168/LMCS-8(1:16)2012 27 | 28 | authors: 29 | - name: Thomas Braibant 30 | initial: true 31 | - name: Damien Pous 32 | initial: true 33 | 34 | maintainers: 35 | - name: Tej Chajed 36 | nickname: tchajed 37 | 38 | opam-file-maintainer: palmskog@gmail.com 39 | 40 | opam-file-version: dev 41 | 42 | license: 43 | fullname: GNU Lesser General Public License v3.0 or later 44 | identifier: LGPL-3.0-or-later 45 | 46 | supported_coq_versions: 47 | text: master (use the corresponding branch or release for other Coq versions) 48 | opam: '{= "dev"}' 49 | 50 | supported_ocaml_versions: 51 | text: 4.09.0 or later 52 | opam: '{>= "4.09.0"}' 53 | 54 | tested_coq_opam_versions: 55 | - version: 'dev' 56 | 57 | namespace: ATBR 58 | 59 | keywords: 60 | - name: Kleene algebra 61 | - name: finite automata 62 | - name: semiring 63 | - name: matrices 64 | - name: decision procedure 65 | - name: reflexive tactic 66 | 67 | categories: 68 | - name: Miscellaneous/Coq Extensions 69 | - name: Computer Science/Decision Procedures and Certified Algorithms/Decision procedures 70 | 71 | documentation: | 72 | ## Documentation 73 | 74 | The development and underlying theory of the library is described in the paper 75 | [Deciding Kleene Algebras in Coq][paper], Logical Methods in Computer Science, 76 | Volume 8, Issue 1, 2012. 77 | 78 | Below are succinct descriptions of each file and tactic. See also the 79 | [coqdoc presentation][coqdoc] of the Coq source files from the latest release. 80 | 81 | ### Library files 82 | 83 | | Filename | Description 84 | | -------- | ----------- 85 | | ATBR | Export all relevant modules, except those related to matrices 86 | | ATBR_Matrices | Export all relevant modules, including those related to matrices 87 | 88 | 89 | #### Algebraic hierarchy 90 | 91 | | Filename | Description 92 | | -------- | ----------- 93 | | Classes | Definitions of algebraic classes of the development 94 | | Graph | Lemmas and hints about the base class (carrier with equality) 95 | | Monoid | Monoids, free monoids, finite iterations over a monoid, various tactics 96 | | SemiLattice | Semilattices, tactics: normalise, reflexivity, rewrite 97 | | SemiRing | Idempotent semirings, tactics: normalise, reflexivity, rewrite 98 | | KleeneAlgebra | Kleene algebras, basic properties 99 | | Converse | Structures with converse (semirings and Kleene Algebras) 100 | | Functors | Functors between the various algebraic structures 101 | | StrictKleeneAlgebra | Class of Strict Kleene algebras (without 0), and extension of the decision procedure 102 | 103 | #### Models 104 | 105 | | Filename | Description 106 | | -------- | ----------- 107 | | Model_Relations | Kleene Algebra of (heterogeneous) binary relations 108 | | Model_StdRelations | Kleene Algebra of standard (homogeneous) binary relations 109 | | Model_Languages | Kleene Algebra of languages 110 | | Model_RegExp | Kleene Algebra of regular expressions (syntactic free model), typed reification 111 | | Model_MinMax | (min,+) Kleene Algebra (matrices on this algebra give weighted graphs) 112 | 113 | #### Matrices 114 | 115 | | Filename | Description 116 | | -------- | ----------- 117 | | MxGraph | Matrices without operations; blocks definitions 118 | | MxSemiLattice | Semilattices of matrices 119 | | MxSemiRing | Semiring of matrices 120 | | MxKleeneAlgebra | Kleene algebra of matrices (definition of the star operation) 121 | | MxFunctors | Extension of functors to matrices 122 | 123 | 124 | #### Decision procedure for KA 125 | 126 | | Filename | Description 127 | | -------- | ----------- 128 | | DKA_Definitions | Base definitions for the decision procedure for KA (automata types, notations, ...) 129 | | DKA_StateSetSets | Properties about sets of sets 130 | | DKA_CheckLabels | Algorithm to check whether two regex have the same set of labels 131 | | DKA_Construction | Construction algorithm, and proof of correctness 132 | | DKA_Epsilon | Removal of epsilon transitions, proof of correctness 133 | | DKA_Determinisation | Determinisation algorithm, proof of correctness 134 | | DKA_Merge | Union of DFAs, proof of correctness 135 | | DKA_DFA_Language | Language recognised by a DFA, equivalence with the evaluation of the DFA 136 | | DKA_DFA_Equiv | Equivalence check for DFAs, proof of correctness 137 | | DecideKleeneAlgebra | Kozen's initiality proof, kleene_reflexivity tactic 138 | 139 | #### Other tools 140 | 141 | | Filename | Description 142 | | -------- | ----------- 143 | | StrictStarForm | Conversion of regular expressions into strict star form, kleene_ssf tactic 144 | | Equivalence | Tactic for solving equivalences by transitivity 145 | 146 | #### Examples 147 | 148 | | Filename | Description 149 | | -------- | ----------- 150 | | Examples | Small tutorial file, that goes through our set of tactics 151 | | ChurchRosser | Simple usages of kleene_reflexivity to prove commutation properties 152 | | ChurchRosser_Points | Comparison between a standard CR proof and algebraic ones 153 | 154 | #### Misc. 155 | 156 | | Filename | Description 157 | | -------- | ----------- 158 | | Common | Shared simple tactics and definitions 159 | | BoolView | View mechanism for Boolean computations 160 | | Numbers | NUM interface, to abstract over the representation of numbers, sets, and maps 161 | | Utils_WF | Utilities about well-founded relations; partial fixpoint operators (powerfix) 162 | | DisjointSets | Efficient implementation of a disjoint sets data structure 163 | | Force | Functional memoisation (in case one needs efficient matrix computations) 164 | | Reification | Reified syntax for the various algebraic structures 165 | 166 | #### Finite sets and maps 167 | 168 | | Filename | Description 169 | | -------- | ----------- 170 | | MyFSets | Efficient ordered datatypes constructions (for FSets functors) 171 | | MyFSetProperties | Handler for FSet properties 172 | | MyFMapProperties | Handler for FMap properties 173 | 174 | #### OCaml modules 175 | 176 | | Filename | Description 177 | | -------- | ----------- 178 | | `reification.ml` | reification for the reflexive tactics 179 | 180 | ### Tactics 181 | 182 | #### Reflexive tactics 183 | 184 | | Tactic | Description 185 | | ------ | ----------- 186 | | `semiring_reflexivity` | solve an (in)equation on the idempotent semiring (*,+,1,0) 187 | | `semiring_normalize` | simplify an (in)equation on the idempotent semiring (*,+,1,0) 188 | | `semiring_clean` | simplify 0 and 1 189 | | `semiring_cleanassoc` | simplify 0 and 1, normalize the parentheses 190 | | `kleene_reflexivity` | solve an (in)equation in Kleene Algebras 191 | | `ckleene_reflexivity` | solve an (in)equation in Kleene Algebras with converse 192 | | `skleene_reflexivity` | solve an (in)equation in Strict Kleene Algebras (without 0) 193 | | `kleene_clean_zero` | remove zeros in a KA expression 194 | | `kleene_ssf` | put KA expressions into strict star form 195 | 196 | #### Rewriting tactics 197 | 198 | | Tactic | Description 199 | | ------ | ----------- 200 | | `ac_rewrite H` | rewrite a closed equality modulo (AC) of (+) 201 | | `monoid_rewrite H` | rewrite a closed equality modulo (A) of (*) 202 | 203 | #### Other tactics 204 | 205 | | Tactic | Description 206 | | ------ | ----------- 207 | | `converse_down` | push converses down to terms leaves 208 | | `switch` | add converses to the goal and push them down to terms leaves 209 | 210 | ## Acknowledgements 211 | 212 | The initial authors would like to thank Guilhem Moulin and Sebastien Briais, 213 | who participated to a preliminary version of this project. They are also grateful 214 | to Assia Mahboubi, Matthieu Sozeau, Bruno Barras, and Hugo Herbelin for highly 215 | stimulating discussions, as well as numerous hints for solving various problems. 216 | 217 | [paper]: https://arxiv.org/abs/1105.4537 218 | [coqdoc]: https://coq-community.github.io/atbr/docs/latest/coqdoc/toc.html 219 | --- 220 | -------------------------------------------------------------------------------- /resources/config.js: -------------------------------------------------------------------------------- 1 | var coqdocjs = coqdocjs || {}; 2 | 3 | coqdocjs.repl = { 4 | "forall": "∀", 5 | "exists": "∃", 6 | "~": "¬", 7 | "/\\": "∧", 8 | "\\/": "∨", 9 | "->": "→", 10 | "<-": "←", 11 | "<->": "↔", 12 | "=>": "⇒", 13 | "<>": "≠", 14 | "<=": "≤", 15 | ">=": "≥", 16 | "el": "∈", 17 | "nel": "∉", 18 | "<<=": "⊆", 19 | "|-": "⊢", 20 | ">>": "»", 21 | "<<": "⊆", 22 | "++": "⧺", 23 | "===": "≡", 24 | "=/=": "≢", 25 | "=~=": "≅", 26 | "==>": "⟹", 27 | "<==": "⟸", 28 | "False": "⊥", 29 | "True": "⊤", 30 | ":=": "≔", 31 | "-|": "⊣", 32 | "*": "×", 33 | "::": "∷", 34 | "lhd": "⊲", 35 | "rhd": "⊳", 36 | "nat": "ℕ", 37 | "alpha": "α", 38 | "beta": "β", 39 | "gamma": "γ", 40 | "delta": "δ", 41 | "epsilon": "ε", 42 | "eta": "η", 43 | "iota": "ι", 44 | "kappa": "κ", 45 | "lambda": "λ", 46 | "mu": "μ", 47 | "nu": "ν", 48 | "omega": "ω", 49 | "phi": "ϕ", 50 | "pi": "π", 51 | "psi": "ψ", 52 | "rho": "ρ", 53 | "sigma": "σ", 54 | "tau": "τ", 55 | "theta": "θ", 56 | "xi": "ξ", 57 | "zeta": "ζ", 58 | "Delta": "Δ", 59 | "Gamma": "Γ", 60 | "Pi": "Π", 61 | "Sigma": "Σ", 62 | "Omega": "Ω", 63 | "Xi": "Ξ" 64 | }; 65 | 66 | coqdocjs.subscr = { 67 | "0" : "₀", 68 | "1" : "₁", 69 | "2" : "₂", 70 | "3" : "₃", 71 | "4" : "₄", 72 | "5" : "₅", 73 | "6" : "₆", 74 | "7" : "₇", 75 | "8" : "₈", 76 | "9" : "₉", 77 | }; 78 | 79 | coqdocjs.replInText = ["==>","<=>", "=>", "->", "<-", ":="]; 80 | -------------------------------------------------------------------------------- /resources/coqdoc.css: -------------------------------------------------------------------------------- 1 | @import url(https://fonts.googleapis.com/css?family=Open+Sans:400,700); 2 | 3 | body{ 4 | font-family: 'Open Sans', sans-serif; 5 | font-size: 14px; 6 | color: #2D2D2D 7 | } 8 | 9 | a { 10 | text-decoration: none; 11 | border-radius: 3px; 12 | padding-left: 3px; 13 | padding-right: 3px; 14 | margin-left: -3px; 15 | margin-right: -3px; 16 | color: inherit; 17 | font-weight: bold; 18 | } 19 | 20 | #main .code a, #main .inlinecode a, #toc a { 21 | font-weight: inherit; 22 | } 23 | 24 | a[href]:hover, [clickable]:hover{ 25 | background-color: rgba(0,0,0,0.1); 26 | cursor: pointer; 27 | } 28 | 29 | h, h1, h2, h3, h4, h5 { 30 | line-height: 1; 31 | color: black; 32 | text-rendering: optimizeLegibility; 33 | font-weight: normal; 34 | letter-spacing: 0.1em; 35 | text-align: left; 36 | } 37 | 38 | div + br { 39 | display: none; 40 | } 41 | 42 | div:empty{ display: none;} 43 | 44 | #main h1 { 45 | font-size: 2em; 46 | } 47 | 48 | #main h2 { 49 | font-size: 1.667rem; 50 | } 51 | 52 | #main h3 { 53 | font-size: 1.333em; 54 | } 55 | 56 | #main h4, #main h5, #main h6 { 57 | font-size: 1em; 58 | } 59 | 60 | #toc h2 { 61 | padding-bottom: 0; 62 | } 63 | 64 | #main .doc { 65 | margin: 0; 66 | text-align: justify; 67 | } 68 | 69 | .inlinecode, .code, #main pre { 70 | font-family: monospace; 71 | } 72 | 73 | .code > br:first-child { 74 | display: none; 75 | } 76 | 77 | .doc + .code{ 78 | margin-top:0.5em; 79 | } 80 | 81 | .block{ 82 | display: block; 83 | margin-top: 5px; 84 | margin-bottom: 5px; 85 | padding: 10px; 86 | text-align: center; 87 | } 88 | 89 | .block img{ 90 | margin: 15px; 91 | } 92 | 93 | table.infrule { 94 | border: 0px; 95 | margin-left: 50px; 96 | margin-top: 10px; 97 | margin-bottom: 10px; 98 | } 99 | 100 | td.infrule { 101 | font-family: "Droid Sans Mono", "DejaVu Sans Mono", monospace; 102 | text-align: center; 103 | padding: 0; 104 | line-height: 1; 105 | } 106 | 107 | tr.infrulemiddle hr { 108 | margin: 1px 0 1px 0; 109 | } 110 | 111 | .infrulenamecol { 112 | color: rgb(60%,60%,60%); 113 | padding-left: 1em; 114 | padding-bottom: 0.1em 115 | } 116 | 117 | .id[type="constructor"], .id[type="projection"], .id[type="method"], 118 | .id[title="constructor"], .id[title="projection"], .id[title="method"] { 119 | color: #A30E16; 120 | } 121 | 122 | .id[type="var"], .id[type="variable"], 123 | .id[title="var"], .id[title="variable"] { 124 | color: inherit; 125 | } 126 | 127 | .id[type="definition"], .id[type="record"], .id[type="class"], .id[type="instance"], .id[type="inductive"], .id[type="library"], 128 | .id[title="definition"], .id[title="record"], .id[title="class"], .id[title="instance"], .id[title="inductive"], .id[title="library"] { 129 | color: #A6650F; 130 | } 131 | 132 | .id[type="lemma"], 133 | .id[title="lemma"]{ 134 | color: #188B0C; 135 | } 136 | 137 | .id[type="keyword"], .id[type="notation"], .id[type="abbreviation"], 138 | .id[title="keyword"], .id[title="notation"], .id[title="abbreviation"]{ 139 | color : #2874AE; 140 | } 141 | 142 | .comment { 143 | color: #808080; 144 | } 145 | 146 | /* TOC */ 147 | 148 | #toc h2{ 149 | letter-spacing: 0; 150 | font-size: 1.333em; 151 | } 152 | 153 | /* Index */ 154 | 155 | #index { 156 | margin: 0; 157 | padding: 0; 158 | width: 100%; 159 | } 160 | 161 | #index #frontispiece { 162 | margin: 1em auto; 163 | padding: 1em; 164 | width: 60%; 165 | } 166 | 167 | .booktitle { font-size : 140% } 168 | .authors { font-size : 90%; 169 | line-height: 115%; } 170 | .moreauthors { font-size : 60% } 171 | 172 | #index #entrance { 173 | text-align: center; 174 | } 175 | 176 | #index #entrance .spacer { 177 | margin: 0 30px 0 30px; 178 | } 179 | 180 | ul.doclist { 181 | margin-top: 0em; 182 | margin-bottom: 0em; 183 | } 184 | 185 | #toc > * { 186 | clear: both; 187 | } 188 | 189 | #toc > a { 190 | display: block; 191 | float: left; 192 | margin-top: 1em; 193 | } 194 | 195 | #toc a h2{ 196 | display: inline; 197 | } 198 | -------------------------------------------------------------------------------- /resources/coqdocjs.css: -------------------------------------------------------------------------------- 1 | /* replace unicode */ 2 | 3 | .id[repl] .hidden { 4 | font-size: 0; 5 | } 6 | 7 | .id[repl]:before{ 8 | content: attr(repl); 9 | } 10 | 11 | /* folding proofs */ 12 | 13 | @keyframes show-proof { 14 | 0% { 15 | max-height: 1.2em; 16 | opacity: 1; 17 | } 18 | 99% { 19 | max-height: 1000em; 20 | } 21 | 100%{ 22 | } 23 | } 24 | 25 | @keyframes hide-proof { 26 | from { 27 | visibility: visible; 28 | max-height: 10em; 29 | opacity: 1; 30 | } 31 | to { 32 | max-height: 1.2em; 33 | } 34 | } 35 | 36 | .proof { 37 | cursor: pointer; 38 | } 39 | .proof * { 40 | cursor: pointer; 41 | } 42 | 43 | .proof { 44 | overflow: hidden; 45 | position: relative; 46 | transition: opacity 1s; 47 | display: inline-block; 48 | } 49 | 50 | .proof[show="false"] { 51 | max-height: 1.2em; 52 | visibility: visible; 53 | opacity: 0.3; 54 | } 55 | 56 | .proof[show="false"][animate] { 57 | animation-name: hide-proof; 58 | animation-duration: 0.25s; 59 | } 60 | 61 | .proof[show="true"] { 62 | animation-name: show-proof; 63 | animation-duration: 10s; 64 | } 65 | 66 | .proof[show="true"]:before { 67 | content: "\25BC"; /* arrow down */ 68 | } 69 | .proof[show="false"]:before { 70 | content: "\25B6"; /* arrow right */ 71 | } 72 | 73 | .proof[show="false"]:hover { 74 | visibility: visible; 75 | opacity: 0.5; 76 | } 77 | 78 | #toggle-proofs[proof-status="no-proofs"] { 79 | display: none; 80 | } 81 | 82 | #toggle-proofs[proof-status="some-hidden"]:before { 83 | content: "Show Proofs"; 84 | } 85 | 86 | #toggle-proofs[proof-status="all-shown"]:before { 87 | content: "Hide Proofs"; 88 | } 89 | 90 | 91 | /* page layout */ 92 | 93 | html, body { 94 | height: 100%; 95 | margin:0; 96 | padding:0; 97 | } 98 | 99 | @media only screen { /* no div with internal scrolling to allow printing of whole content */ 100 | body { 101 | display: flex; 102 | flex-direction: column 103 | } 104 | 105 | #content { 106 | flex: 1; 107 | overflow: auto; 108 | display: flex; 109 | flex-direction: column; 110 | } 111 | } 112 | 113 | #content:focus { 114 | outline: none; /* prevent glow in OS X */ 115 | } 116 | 117 | #main { 118 | display: block; 119 | padding: 16px; 120 | padding-top: 1em; 121 | padding-bottom: 2em; 122 | margin-left: auto; 123 | margin-right: auto; 124 | max-width: 60em; 125 | flex: 1 0 auto; 126 | } 127 | 128 | .libtitle { 129 | display: none; 130 | } 131 | 132 | /* header */ 133 | #header { 134 | width:100%; 135 | padding: 0; 136 | margin: 0; 137 | display: flex; 138 | align-items: center; 139 | background-color: rgb(21,57,105); 140 | color: white; 141 | font-weight: bold; 142 | overflow: hidden; 143 | } 144 | 145 | 146 | .button { 147 | cursor: pointer; 148 | } 149 | 150 | #header * { 151 | text-decoration: none; 152 | vertical-align: middle; 153 | margin-left: 15px; 154 | margin-right: 15px; 155 | } 156 | 157 | #header > .right, #header > .left { 158 | display: flex; 159 | flex: 1; 160 | align-items: center; 161 | } 162 | #header > .left { 163 | text-align: left; 164 | } 165 | #header > .right { 166 | flex-direction: row-reverse; 167 | } 168 | 169 | #header a, #header .button { 170 | color: white; 171 | box-sizing: border-box; 172 | } 173 | 174 | #header a { 175 | border-radius: 0; 176 | padding: 0.2em; 177 | } 178 | 179 | #header .button { 180 | background-color: rgb(63, 103, 156); 181 | border-radius: 1em; 182 | padding-left: 0.5em; 183 | padding-right: 0.5em; 184 | margin: 0.2em; 185 | } 186 | 187 | #header a:hover, #header .button:hover { 188 | background-color: rgb(181, 213, 255); 189 | color: black; 190 | } 191 | 192 | #header h1 { padding: 0; 193 | margin: 0;} 194 | 195 | /* footer */ 196 | #footer { 197 | text-align: center; 198 | opacity: 0.5; 199 | font-size: 75%; 200 | } 201 | 202 | /* hyperlinks */ 203 | 204 | @keyframes highlight { 205 | 50%{ 206 | background-color: black; 207 | } 208 | } 209 | 210 | :target * { 211 | animation-name: highlight; 212 | animation-duration: 1s; 213 | } 214 | 215 | a[name]:empty { 216 | float: right; 217 | } 218 | 219 | /* Proviola */ 220 | 221 | div.code { 222 | width: auto; 223 | float: none; 224 | } 225 | 226 | div.goal { 227 | position: fixed; 228 | left: 75%; 229 | width: 25%; 230 | top: 3em; 231 | } 232 | 233 | div.doc { 234 | clear: both; 235 | } 236 | 237 | span.command:hover { 238 | background-color: inherit; 239 | } 240 | -------------------------------------------------------------------------------- /resources/coqdocjs.js: -------------------------------------------------------------------------------- 1 | var coqdocjs = coqdocjs || {}; 2 | (function(){ 3 | 4 | function replace(s){ 5 | var m; 6 | if (m = s.match(/^(.+)'/)) { 7 | return replace(m[1])+"'"; 8 | } else if (m = s.match(/^([A-Za-z]+)_?(\d+)$/)) { 9 | return replace(m[1])+m[2].replace(/\d/g, function(d){ 10 | if (coqdocjs.subscr.hasOwnProperty(d)) { 11 | return coqdocjs.subscr[d]; 12 | } else { 13 | return d; 14 | } 15 | }); 16 | } else if (coqdocjs.repl.hasOwnProperty(s)){ 17 | return coqdocjs.repl[s] 18 | } else { 19 | return s; 20 | } 21 | } 22 | 23 | function toArray(nl){ 24 | return Array.prototype.slice.call(nl); 25 | } 26 | 27 | function replInTextNodes() { 28 | // Get all the nodes up front. 29 | var nodes = Array.from(document.querySelectorAll(".code, .inlinecode")) 30 | .flatMap(elem => Array.from(elem.childNodes) 31 | .filter(e => e.nodeType == Node.TEXT_NODE) 32 | ); 33 | 34 | // Create a replacement template node to clone from. 35 | var replacementTemplate = document.createElement("span"); 36 | replacementTemplate.setAttribute("class", "id"); 37 | replacementTemplate.setAttribute("type", "keyword"); 38 | 39 | // Do the replacements. 40 | coqdocjs.replInText.forEach(function(toReplace){ 41 | var replacement = replacementTemplate.cloneNode(true); 42 | replacement.appendChild(document.createTextNode(toReplace)); 43 | 44 | nodes.forEach(node => { 45 | var fragments = node.textContent.split(toReplace); 46 | node.textContent = fragments[fragments.length-1]; 47 | for (var k = 0; k < fragments.length - 1; ++k) { 48 | fragments[k] && node.parentNode.insertBefore(document.createTextNode(fragments[k]),node); 49 | node.parentNode.insertBefore(replacement.cloneNode(true), node); 50 | } 51 | }); 52 | }); 53 | } 54 | 55 | function replNodes() { 56 | toArray(document.getElementsByClassName("id")).forEach(function(node){ 57 | if (["var", "variable", "keyword", "notation", "definition", "inductive"].indexOf(node.getAttribute("type"))>=0){ 58 | var text = node.textContent; 59 | var replText = replace(text); 60 | if(text != replText) { 61 | node.setAttribute("repl", replText); 62 | node.setAttribute("title", text); 63 | var hidden = document.createElement("span"); 64 | hidden.setAttribute("class", "hidden"); 65 | while (node.firstChild) { 66 | hidden.appendChild(node.firstChild); 67 | } 68 | node.appendChild(hidden); 69 | } 70 | } 71 | }); 72 | } 73 | 74 | function isVernacStart(l, t){ 75 | t = t.trim(); 76 | for(var s of l){ 77 | if (t == s || t.startsWith(s+" ") || t.startsWith(s+".")){ 78 | return true; 79 | } 80 | } 81 | return false; 82 | } 83 | 84 | function isProofStart(n){ 85 | return isVernacStart(["Proof"], n.textContent) || 86 | (isVernacStart(["Next"], n.textContent) && isVernacStart(["Obligation"], n.nextSibling.nextSibling.textContent)); 87 | } 88 | 89 | function isProofEnd(s){ 90 | return isVernacStart(["Qed", "Admitted", "Defined", "Abort"], s); 91 | } 92 | 93 | function proofStatus(){ 94 | var proofs = toArray(document.getElementsByClassName("proof")); 95 | if(proofs.length) { 96 | for(var proof of proofs) { 97 | if (proof.getAttribute("show") === "false") { 98 | return "some-hidden"; 99 | } 100 | } 101 | return "all-shown"; 102 | } 103 | else { 104 | return "no-proofs"; 105 | } 106 | } 107 | 108 | function updateView(){ 109 | document.getElementById("toggle-proofs").setAttribute("proof-status", proofStatus()); 110 | } 111 | 112 | function foldProofs() { 113 | var hasCommands = true; 114 | var nodes = document.getElementsByClassName("command"); 115 | if(nodes.length == 0) { 116 | hasCommands = false; 117 | console.log("no command tags found") 118 | nodes = document.getElementsByClassName("id"); 119 | } 120 | toArray(nodes).forEach(function(node){ 121 | if(isProofStart(node)) { 122 | var proof = document.createElement("span"); 123 | proof.setAttribute("class", "proof"); 124 | 125 | node.parentNode.insertBefore(proof, node); 126 | if(proof.previousSibling.nodeType === Node.TEXT_NODE) 127 | proof.appendChild(proof.previousSibling); 128 | while(node && !isProofEnd(node.textContent)) { 129 | proof.appendChild(node); 130 | node = proof.nextSibling; 131 | } 132 | if (proof.nextSibling) proof.appendChild(proof.nextSibling); // the Qed 133 | if (!hasCommands && proof.nextSibling) proof.appendChild(proof.nextSibling); // the dot after the Qed 134 | 135 | proof.addEventListener("click", function(proof){return function(e){ 136 | if (e.target.parentNode.tagName.toLowerCase() === "a") 137 | return; 138 | proof.setAttribute("show", proof.getAttribute("show") === "true" ? "false" : "true"); 139 | proof.setAttribute("animate", ""); 140 | updateView(); 141 | };}(proof)); 142 | proof.setAttribute("show", "false"); 143 | } 144 | }); 145 | } 146 | 147 | function toggleProofs(){ 148 | var someProofsHidden = proofStatus() === "some-hidden"; 149 | toArray(document.getElementsByClassName("proof")).forEach(function(proof){ 150 | proof.setAttribute("show", someProofsHidden); 151 | proof.setAttribute("animate", ""); 152 | }); 153 | updateView(); 154 | } 155 | 156 | function repairDom(){ 157 | // pull whitespace out of command 158 | toArray(document.getElementsByClassName("command")).forEach(function(node){ 159 | while(node.firstChild && node.firstChild.textContent.trim() == ""){ 160 | console.log("try move"); 161 | node.parentNode.insertBefore(node.firstChild, node); 162 | } 163 | }); 164 | toArray(document.getElementsByClassName("id")).forEach(function(node){ 165 | node.setAttribute("type", node.getAttribute("title")); 166 | }); 167 | toArray(document.getElementsByClassName("idref")).forEach(function(ref){ 168 | toArray(ref.childNodes).forEach(function(child){ 169 | if (["var", "variable"].indexOf(child.getAttribute("type")) > -1) 170 | ref.removeAttribute("href"); 171 | }); 172 | }); 173 | 174 | } 175 | 176 | function fixTitle(){ 177 | var url = "/" + window.location.pathname; 178 | var basename = url.substring(url.lastIndexOf('/')+1, url.lastIndexOf('.')); 179 | if (basename === "toc") {document.title = "Table of Contents";} 180 | else if (basename === "indexpage") {document.title = "Index";} 181 | else {document.title = basename;} 182 | } 183 | 184 | function postprocess(){ 185 | repairDom(); 186 | replInTextNodes() 187 | replNodes(); 188 | foldProofs(); 189 | document.getElementById("toggle-proofs").addEventListener("click", toggleProofs); 190 | updateView(); 191 | } 192 | 193 | fixTitle(); 194 | document.addEventListener('DOMContentLoaded', postprocess); 195 | 196 | coqdocjs.toggleProofs = toggleProofs; 197 | })(); 198 | -------------------------------------------------------------------------------- /resources/footer.html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /resources/header.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 26 |
27 |
28 | -------------------------------------------------------------------------------- /resources/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | ATBR 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 19 |
20 | View the project on GitHub 21 |
22 |

About

23 |

Welcome to the ATBR project website! This project is part of coq-community.

24 |

This library provides algebraic tools for working with binary relations. The main tactic provided is a reflexive tactic for solving (in)equations in an arbitrary Kleene algebra. The decision procedure goes through standard finite automata constructions.

25 |

Note that the initial authors consider this library to be superseded by the Relation Algebra library, which is based on derivatives rather than automata: https://github.com/damien-pous/relation-algebra

26 |

This is an open source project, licensed under the GNU Lesser General Public License v3.0 or later.

27 |

Get the code

28 |

The current stable release of ATBR can be downloaded from GitHub.

29 |

Documentation

30 |

The coqdoc presentations of releases can be browsed online:

31 | 35 |

Other related publications, if any, are listed below.

36 | 39 |

Help and contact

40 |
    41 |
  • Report issues on GitHub
    • 42 |
  • Chat with us on Gitter
    • 43 |
  • Discuss with us on Coq's Discourse forum
    • 44 |
45 |

Authors and contributors

46 |
    47 |
  • Thomas Braibant
    • 48 |
  • Damien Pous
    • 49 |
50 | 51 | 52 | -------------------------------------------------------------------------------- /resources/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | # This file was generated from `meta.yml`, please do not edit manually. 3 | # Follow the instructions on https://github.com/coq-community/templates to regenerate. 4 | title: ATBR 5 | lang: en 6 | header-includes: 7 | - | 8 | 9 | 10 | 11 | 12 | 13 | --- 14 | 15 |
16 | View the project on GitHub 17 |
18 | 19 | ## About 20 | 21 | Welcome to the ATBR project website! This project is part of [coq-community](https://github.com/coq-community/manifesto). 22 | 23 | This library provides algebraic tools for working with binary relations. 24 | The main tactic provided is a reflexive tactic for solving (in)equations 25 | in an arbitrary Kleene algebra. The decision procedure goes through 26 | standard finite automata constructions. 27 | 28 | Note that the initial authors consider this library to be superseded 29 | by the Relation Algebra library, which is based on derivatives 30 | rather than automata: https://github.com/damien-pous/relation-algebra 31 | 32 | This is an open source project, licensed under the GNU Lesser General Public License v3.0 or later. 33 | 34 | ## Get the code 35 | 36 | The current stable release of ATBR can be [downloaded from GitHub](https://github.com/coq-community/atbr/releases). 37 | 38 | ## Documentation 39 | 40 | 41 | Related publications, if any, are listed below. 42 | 43 | - [Deciding Kleene Algebras in Coq](https://arxiv.org/abs/1105.4537) doi:[10.2168/LMCS-8(1:16)2012](https://doi.org/10.2168/LMCS-8(1:16)2012) 44 | 45 | ## Help and contact 46 | 47 | - Report issues on [GitHub](https://github.com/coq-community/atbr/issues) 48 | - Chat with us on [Zulip](https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users) 49 | - Discuss with us on Coq's [Discourse](https://coq.discourse.group) forum 50 | 51 | ## Authors and contributors 52 | 53 | - Thomas Braibant (initial) 54 | - Damien Pous (initial) 55 | 56 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name reification_plugin) 3 | (public_name coq-atbr.plugin) 4 | (synopsis "ATBR Plugin") 5 | (flags :standard -w -3-27) 6 | (libraries coq-core.plugins.ltac)) 7 | 8 | (coq.pp (modules reification)) 9 | -------------------------------------------------------------------------------- /src/reification.mlg: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Generic reification, for the classes from [Classes.v] to the inductives from [Reification.v] *) 10 | 11 | DECLARE PLUGIN "coq-atbr.plugin" 12 | 13 | { 14 | 15 | open Ltac_plugin 16 | open Reify 17 | 18 | } 19 | 20 | (* tactic grammar entries *) 21 | TACTIC EXTEND _kleene_reify_ | [ "kleene_reify" ] -> { reify_goal Reify.Reification.KA.ops } END 22 | TACTIC EXTEND _semiring_reify_ | [ "semiring_reify" ] -> { reify_goal Reify.Reification.Semiring.ops } END 23 | -------------------------------------------------------------------------------- /src/reification_plugin.mlpack: -------------------------------------------------------------------------------- 1 | Reify 2 | Reification 3 | -------------------------------------------------------------------------------- /theories/ATBR.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Import this file to gain access to all algebraic structures and tools. 10 | To work with matrices, import file Matrices.v *) 11 | 12 | From ATBR Require Export Common. 13 | From ATBR Require Export Classes. 14 | From ATBR Require Export Graph. 15 | From ATBR Require Export Monoid. 16 | From ATBR Require Export SemiLattice. 17 | From ATBR Require Export SemiRing. 18 | From ATBR Require Export KleeneAlgebra. 19 | From ATBR Require Export Converse. 20 | From ATBR Require Export DecideKleeneAlgebra. 21 | -------------------------------------------------------------------------------- /theories/ATBR_Matrices.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Import this file to gain access to all algebraic structures and 10 | tools, including those about matrices *) 11 | 12 | From ATBR Require Export ATBR. 13 | From ATBR Require Export MxGraph MxSemiLattice MxSemiRing MxKleeneAlgebra. 14 | -------------------------------------------------------------------------------- /theories/BoolView.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** This file builds some machinery to deal with reflection and 10 | views. 11 | 12 | Through the development, we define several efficient comparison 13 | functions that produce results in [bool] or [comparison]. For 14 | example, [eq_nat_bool] efficiently computes the equality on [nat], 15 | but is not easy to manipulate. 16 | 17 | We provide some tools to deal with these kind of functions: 18 | 19 | - [*_analyse] tactics: using a "view" mechanism, we associate to 20 | boolean or comparison functions the relation they describe. The 21 | [*_analyse] tactics will perform case destructions. 22 | 23 | - [*_prop] tactics: Through the development, we declare several 24 | lemmas as hints for autorewrite libraries, in order to transform, 25 | e.g., [eq_nat_bool x y = true] into [x = y]. 26 | 27 | - [bool_simpl] tactic: Through the development, we declare several 28 | simplification lemmas, in order to transform, e.g., [eq_nat_bool x x] 29 | into [true] 30 | 31 | *) 32 | 33 | From ATBR Require Import Common. 34 | From Coq Require Export Bool. 35 | From Coq Require Import Equality Program Sumbool Peano. 36 | 37 | #[local] Ltac Tauto.intuition_solver ::= auto with exfalso lia. 38 | 39 | (***********) 40 | (* analyse *) 41 | (***********) 42 | 43 | Class Type_View {A} (f : A) := { 44 | type_view_ty : Type; 45 | type_view : type_view_ty 46 | }. 47 | 48 | (* TOTHINK: a-t'on vraiment besoin de passer par les instances, puisqu'on a toujours le lemme dans la main !? *) 49 | Ltac type_view f := 50 | Tactics.on_call f 51 | ltac:(fun c => 52 | match c with 53 | | context args[f] => 54 | let ind_app := context args [type_view (f:=f)] in 55 | let t := type of ind_app in 56 | destruct ind_app 57 | end). 58 | 59 | Inductive compare_spec {A} eq lt (x y : A) : comparison -> Prop := 60 | | compare_spec_lt : lt x y -> compare_spec eq lt x y Lt 61 | | compare_spec_eq : eq x y -> compare_spec eq lt x y Eq 62 | | compare_spec_gt : lt y x -> compare_spec eq lt x y Gt. 63 | 64 | (** computationally efficient equality and comparison of natural numbers *) 65 | Fixpoint eq_nat_bool a b := 66 | match (a,b) with 67 | | (S n, S p) => eq_nat_bool n p 68 | | (O , O) => true 69 | | _ => false 70 | end. 71 | 72 | Fixpoint le_lt_bool a b := 73 | match (a,b) with 74 | | (O , _) => true 75 | | (S n, S p) => le_lt_bool n p 76 | | _ => false 77 | end. 78 | 79 | Lemma eq_nat_spec: forall a b, reflect (a=b) (eq_nat_bool a b). 80 | Proof. 81 | induction a; intros [|b]; simpl; try constructor; auto. 82 | case (IHa ( b)); intros H; subst; constructor; auto. 83 | Qed. 84 | 85 | Lemma le_nat_spec : forall a b, reflect (le a b) (le_lt_bool a b). 86 | Proof. 87 | induction a; intros [|b]; simpl; try constructor; auto with arith. 88 | case (IHa ( b)); intros H; subst; constructor; auto with arith. 89 | Qed. 90 | 91 | #[global] Instance eq_nat_view : Type_View eq_nat_bool := { type_view := eq_nat_spec }. 92 | #[global] Instance le_nat_view : Type_View le_lt_bool := { type_view := le_nat_spec }. 93 | 94 | Ltac nat_analyse := 95 | repeat ( 96 | try (type_view eq_nat_bool; try subst; try lia_false); 97 | try (type_view le_lt_bool; try subst; try lia_false) 98 | ). 99 | 100 | 101 | (** same thing for positive numbers *) 102 | Fixpoint eq_pos_bool x y := 103 | match x,y with 104 | | xH, xH => true 105 | | xO a, xO b => eq_pos_bool a b 106 | | xI a, xI b => eq_pos_bool a b 107 | | _, _ => false 108 | end. 109 | 110 | Lemma eq_pos_spec : forall n m, reflect (n=m) (eq_pos_bool n m). 111 | Proof. 112 | induction n; intros [m|m|]; simpl; try constructor; try congruence. 113 | case (IHn m); intro; subst; constructor; congruence. 114 | case (IHn m); intro; subst; constructor; congruence. 115 | Qed. 116 | 117 | #[global] Instance eq_pos_view : Type_View eq_pos_bool := { type_view := eq_pos_spec }. 118 | 119 | Ltac pos_analyse := repeat type_view eq_pos_bool. 120 | 121 | 122 | (** same thing for booleans *) 123 | Definition eq_bool_bool := Bool.eqb. 124 | 125 | Lemma eq_bool_spec : forall a b, reflect (a=b) (eq_bool_bool a b). 126 | Proof. 127 | intros [|] [|]; simpl; constructor; firstorder. 128 | congruence. 129 | Qed. 130 | 131 | #[global] Instance eq_bool_view : Type_View eq_bool_bool := { type_view := eq_bool_spec }. 132 | 133 | Ltac bool_analyse := repeat type_view eq_bool_bool. 134 | 135 | 136 | 137 | (************) 138 | (* nat_prop *) 139 | (************) 140 | 141 | Lemma eq_nat_bool_true : forall x y, eq_nat_bool x y = true <-> x = y. 142 | Proof. intros. nat_analyse; intuition discriminate. Qed. 143 | Lemma eq_nat_bool_false : forall x y, eq_nat_bool x y = false <-> x <> y. 144 | Proof. intros. nat_analyse; intuition discriminate. Qed. 145 | Lemma le_lt_bool_true : forall x y, le_lt_bool x y = true <-> x <= y. 146 | Proof. intros. nat_analyse; intuition. Qed. 147 | Lemma le_lt_bool_false : forall x y, le_lt_bool x y = false <-> y < x. 148 | Proof. intros. nat_analyse; intuition. lia. Qed. 149 | 150 | #[global] Hint Rewrite eq_nat_bool_true eq_nat_bool_false le_lt_bool_true le_lt_bool_false : nat_prop. 151 | Ltac nat_prop := autorewrite with nat_prop in *. 152 | 153 | 154 | 155 | (**************) 156 | (* bool_simpl *) 157 | (**************) 158 | 159 | (** * [bool_simpl] is a tactic that simplifies boolean operations in the context and in the goal 160 | The database bool_simpl should be enriched with lemmas such as [forall x, eqb x x = true], 161 | which is done in Numbers.v 162 | *) 163 | #[global] Hint Rewrite 164 | orb_false_r (** b || false -> b *) 165 | orb_false_l (** false || b -> b *) 166 | orb_true_r (** b || true -> true *) 167 | orb_true_l (** true || b -> true *) 168 | andb_false_r (** b && false -> false *) 169 | andb_false_l (** false && b -> false *) 170 | andb_true_r (** b && true -> b *) 171 | andb_true_l (** true && b -> b *) 172 | negb_orb (** negb (b || c) -> negb b && negb c *) 173 | negb_andb (** negb (b && c) -> negb b || negb c *) 174 | negb_involutive (** negb (negb b) -> b *) 175 | : bool_simpl. 176 | 177 | #[global] Hint Rewrite <- andb_lazy_alt : bool_simpl. (** a &&& b -> a && b *) 178 | #[global] Hint Rewrite <- orb_lazy_alt : bool_simpl. (** a ||| b -> a || b *) 179 | 180 | Ltac bool_simpl := autorewrite with bool_simpl in *. 181 | 182 | Lemma eq_nat_bool_refl: forall x, eq_nat_bool x x = true. 183 | Proof. intro. nat_prop. reflexivity. Qed. 184 | Lemma le_lt_bool_refl: forall x, le_lt_bool x x = true. 185 | Proof. intro. nat_prop. auto with arith. Qed. 186 | 187 | #[global] Hint Rewrite eq_nat_bool_refl le_lt_bool_refl: bool_simpl. 188 | 189 | 190 | 191 | (*******************) 192 | (* bool_connectors *) 193 | (*******************) 194 | 195 | (** * [bool_connectors ] takes hypothesis like [((x && y) || negb z) = true] and transforms them into 196 | [? : (x = true /\ y = true) \/ (~ z = true)]. *) 197 | 198 | Lemma andb_false_iff : forall b1 b2:bool, b1 && b2 = false <-> (b1 = false \/ b2 = false). 199 | Proof. intros [|] [|]; firstorder. Qed. 200 | Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> (b1 = true /\ b2 = true). 201 | Proof. intros [|] [|]; firstorder. Qed. 202 | 203 | Lemma orb_false_iff : forall b1 b2:bool, b1 || b2 = false <-> (b1 = false /\ b2 = false). 204 | Proof. intros [|] [|]; firstorder. Qed. 205 | Lemma orb_true_iff : forall b1 b2:bool, b1 || b2 = true <-> (b1 = true \/ b2 = true). 206 | Proof. intros [|] [|]; firstorder. Qed. 207 | 208 | Lemma negb_true : forall b, negb b = true <-> b = false. 209 | Proof. intros [|]; firstorder. Qed. 210 | Lemma negb_false : forall b, negb b = false <-> b = true. 211 | Proof. intros [|]; firstorder. Qed. 212 | Lemma eq_not_negb : forall b c, b = c <-> ~ (b = negb c). 213 | Proof. intros [|] [|]; firstorder; simpl; try congruence. Qed. 214 | 215 | #[global] Hint Rewrite andb_false_iff andb_true_iff orb_false_iff orb_true_iff negb_true negb_false : bool_connectors. 216 | 217 | Ltac bool_connectors := autorewrite with bool_connectors in *. 218 | 219 | Lemma bool_prop_iff : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true). 220 | Proof. intros [|] [|]; firstorder. Qed. 221 | 222 | 223 | (*************) 224 | (* decompose *) 225 | (*************) 226 | 227 | (** [completer tac] simplfies the layout of the hypothesis, and try to 228 | saturate the context with hypothesis. It is adapted from A. Chlipala 229 | *) 230 | 231 | 232 | Ltac notHyp P := 233 | match goal with 234 | [ _ : P |- _ ] => fail 1 235 | | _ => match P with 236 | | ?P1 /\ ?P2 => first [notHyp P1 | notHyp P2 | fail 2] 237 | | _ => idtac 238 | end 239 | end. 240 | 241 | Ltac extend pf := 242 | let t := type of pf in notHyp t; generalize pf; intro. 243 | 244 | Ltac completer tac:= 245 | repeat match goal with 246 | | H : False |- _ => apply False_ind; exact H 247 | | H : ?P \/ ?Q |- _ => destruct H as [?|?] 248 | | [ |- _ /\ _ ] => constructor 249 | | [ |- _ <-> _ ] => constructor 250 | | [ |- _ -> _] => intro 251 | | [H : _ /\ _ |- _] => destruct H 252 | | [H : ?P -> ?Q, H' : ?P |- _] => generalize (H H'); clear H; intro H 253 | | [ |- forall x, _] => intro 254 | | [H : forall x, ?P x -> _ , H' : ?P ?X |- _ ]=> extend (H X H') 255 | | [H : exists x, _ |- _ ] => destruct H 256 | | [H : ?x = ?y |- _ ] => subst H 257 | | _ => tac 258 | end. 259 | 260 | -------------------------------------------------------------------------------- /theories/ChurchRosser.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Short mechanised proofs of the Church-Rosser Theorems mentioned by Georg Struth in 10 | # 11 | Calculating Church-Rosser Proofs in Kleene Algebra#. 12 | *) 13 | 14 | From ATBR Require Import ATBR. 15 | 16 | Set Implicit Arguments. 17 | Unset Strict Implicit. 18 | 19 | Section Props1. 20 | 21 | Context `{KA: KleeneAlgebra}. 22 | 23 | Theorem SemiConfluence_is_WeakConfluence A: 24 | forall (a b : X A A), b * a# <== a# * b# <-> b# * a# <== a# * b#. 25 | Proof. 26 | intros a b; split. 27 | apply wsemicomm_iter_left. 28 | intro H. rewrite <- H. kleene_reflexivity. 29 | Qed. 30 | 31 | Theorem SemiConfluence_is_ChurchRosser A: 32 | forall (a b : X A A), b * a# <== a# * b# <-> (a+b)# <== a# * b#. 33 | Proof. 34 | intros a b; split; intro H. 35 | star_left_induction. 36 | semiring_normalize. 37 | rewrite H. kleene_reflexivity. 38 | 39 | rewrite <- H. kleene_reflexivity. 40 | Qed. 41 | 42 | Theorem WeakConfluence_is_ChurchRosser A: 43 | forall (a b : X A A), b# * a# <== a# * b# <-> (a+b)# <== a# * b#. 44 | Proof. 45 | intros a b; split; intro H. 46 | star_left_induction. 47 | semiring_normalize. 48 | rewrite (a_leq_star_a b) at 2. 49 | rewrite H. kleene_reflexivity. 50 | 51 | rewrite <- H. kleene_reflexivity. 52 | Qed. 53 | 54 | 55 | Theorem BubbleSort A: 56 | forall (a b : X A A), b * a <== a * b -> (a+b)# <== a# * b#. 57 | Proof. 58 | intros a b; intro H. 59 | star_left_induction. 60 | semiring_normalize. 61 | apply semicomm_iter_left, semicomm_iter_right in H. 62 | rewrite (a_leq_star_a b) at 2. 63 | rewrite H. kleene_reflexivity. 64 | Qed. 65 | 66 | Notation "a ^+" := (a * a#) (at level 15). 67 | 68 | 69 | Theorem WeakConfluence_is_ChurchRosser_plus A: 70 | forall (a b : X A A), b^+ * a# <== a# * b^+ + a^+ * b# <-> (a+b)^+ <== a# * b^+ + a^+ * b#. 71 | Proof. 72 | intros a b; split; intro H. 73 | star_right_induction. 74 | rewrite (a_leq_star_a a) at 5. 75 | rewrite <- (star_make_right b) at 2. 76 | semiring_normalize. 77 | monoid_rewrite H. 78 | unfold leq. kleene_reflexivity. 79 | 80 | rewrite <- H. kleene_reflexivity. 81 | Qed. 82 | 83 | 84 | Lemma star_plus_one A: forall (a: X A A), a# == (a+1)#. 85 | Proof. intros. kleene_reflexivity. Qed. 86 | 87 | Lemma star_plus_star A: forall (a b: X A A), (a+b)# == (a#+b#)#. 88 | Proof. intros. kleene_reflexivity. Qed. 89 | 90 | Theorem Hindley_Rosen A: forall (a b : X A A), 91 | b*a <== a#*(b+1) -> b#*a# <== a#*b#. 92 | Proof. 93 | intros. 94 | do 2 rewrite (star_plus_one b) at 1. 95 | apply semicomm_iter_left. 96 | rewrite <- (star_idem a) at 2. 97 | apply semicomm_iter_right. 98 | semiring_normalize. 99 | rewrite H. kleene_reflexivity. 100 | Qed. 101 | 102 | Theorem Hindley_Rosen_union A: forall (a b c : X A A), 103 | c#*a# <== a#*c# -> 104 | c#*b# <== b#*c# -> 105 | c#*(a+b)# <== (a+b)#*c#. 106 | Proof. 107 | intros a b c Ha Hb. 108 | do 2 rewrite (star_plus_star a b) at 1. 109 | apply semicomm_iter_right. 110 | semiring_normalize. auto with compat. 111 | Qed. 112 | 113 | End Props1. 114 | 115 | 116 | Section Props2. 117 | 118 | Context `{KA: ConverseKleeneAlgebra}. 119 | 120 | Theorem Hindley_Rosen_confluent_union A: forall (a b : X A A), 121 | a`#*a# <== a#*a`# -> 122 | b`#*b# <== b#*b`# -> 123 | a`#*b# <== b#*a`# -> 124 | (a+b)`#*(a+b)# <== (a+b)#*(a+b)`#. 125 | Proof. 126 | intros a b Ha Hb Hab. 127 | do 2 rewrite conv_plus at 1. 128 | do 2 rewrite (star_plus_star (b`) (a`)) at 1. 129 | apply semicomm_iter_left. semiring_normalize. 130 | rewrite 2 Hindley_Rosen_union; trivial with algebra. 131 | switch. assumption. 132 | Qed. 133 | 134 | End Props2. 135 | 136 | -------------------------------------------------------------------------------- /theories/ChurchRosser_Points_vs_Algebraic.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE.txt for more details) *) 5 | (* *) 6 | (* Copyright 2009: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** This file illustrates why it might be easier to work with binary 10 | relations in an algebraic setting, through a very simple 11 | Church-Rosser proof. The corresponding .v file is #here#. *) 13 | 14 | From ATBR Require Import ATBR. 15 | From Coq Require Import Relations. 16 | 17 | (** * Standard proof: binary relations relate points to points *) 18 | Section CR_points. 19 | 20 | Variable P: Set. 21 | Variables R S: relation P. 22 | 23 | (** notations for reflexive transitive closure and relations union *) 24 | Notation "R #" := (clos_refl_trans_1n _ R). 25 | Notation "R + S" := (union _ R S). 26 | 27 | Definition WeakConfluence := 28 | forall p r q, R p r -> S# r q -> exists2 s, S# p s & R# s q. 29 | 30 | Definition ChurchRosser := 31 | forall p q, (R+S)# p q -> exists2 s, S# p s & R# s q. 32 | 33 | 34 | (** naive proof *) 35 | Theorem WeakConfluence_is_ChurchRosser0: 36 | WeakConfluence -> ChurchRosser. 37 | Proof. 38 | intros H p q Hpq. induction Hpq as [p | p q q' Hpq Hqq' IH]. 39 | exists p. constructor. constructor. 40 | destruct Hpq as [Hpq|Hpq]. 41 | destruct IH as [s' Hqs' Hs'q']. 42 | destruct (H p q s' Hpq Hqs') as [s Hps Hss']. 43 | exists s. assumption. 44 | apply trans_rt1n. 45 | apply rt_trans with s'; apply rt1n_trans; assumption. 46 | 47 | destruct IH as [s Hqs Hsq']. 48 | exists s. 49 | apply Relation_Operators.rt1n_trans with q; assumption. 50 | assumption. 51 | Qed. 52 | 53 | 54 | (** slightly more automatised proof *) 55 | Theorem WeakConfluence_is_ChurchRosser0': 56 | WeakConfluence -> ChurchRosser. 57 | Proof. 58 | intros H p q Hpq. induction Hpq as [p | p q q' Hpq Hqq' IH]. 59 | eexists; constructor. 60 | destruct Hpq as [Hpq|Hpq]. 61 | destruct IH as [s' Hqs' Hs'q']. 62 | destruct (H p q s' Hpq Hqs'). 63 | eauto 6 using trans_rt1n, rt_trans, rt1n_trans. 64 | 65 | destruct IH as [s Hqs Hsq']. 66 | eauto using Relation_Operators.rt1n_trans. 67 | Qed. 68 | 69 | End CR_points. 70 | 71 | 72 | 73 | (** * Algebraic proof, using standard properties of binary relations *) 74 | Section CR_algebra. 75 | 76 | (** we move to the algebraic setting *) 77 | Context `{KA: KleeneAlgebra}. 78 | 79 | Variable A: T. 80 | Variables R S: X A A. 81 | 82 | 83 | (** same proof, without points ; 84 | '<==' corresponds to relations inclusion *) 85 | Theorem WeakConfluence_is_ChurchRosser1: 86 | R * S# <== S# * R# -> (R+S)# <== S# * R#. 87 | Proof. 88 | intro H. 89 | star_left_induction. 90 | rewrite dot_distr_left. 91 | repeat apply plus_destruct_leq. 92 | do 2 rewrite <- one_leq_star_a. 93 | rewrite dot_neutral_left. reflexivity. 94 | rewrite dot_assoc. rewrite H. 95 | rewrite <- dot_assoc. rewrite (star_trans R). reflexivity. 96 | rewrite dot_assoc. rewrite a_star_a_leq_star_a. reflexivity. 97 | Qed. 98 | 99 | 100 | (** with high-level tactics, some administrative step can be handled automatically *) 101 | Theorem WeakConfluence_is_ChurchRosser2: 102 | R * S# <== S# * R# -> (R+S)# <== S# * R#. 103 | Proof. 104 | intro H. 105 | star_left_induction. 106 | semiring_normalize. 107 | repeat apply plus_destruct_leq. 108 | do 2 rewrite <- one_leq_star_a. semiring_reflexivity. 109 | rewrite H. monoid_rewrite (star_trans R). reflexivity. 110 | rewrite a_star_a_leq_star_a. reflexivity. 111 | Qed. 112 | 113 | 114 | (** even better, with our tactic for Kleene algebras *) 115 | Theorem WeakConfluence_is_ChurchRosser3: 116 | R * S# <== S# * R# -> (R+S)# <== S# * R#. 117 | Proof. 118 | intro H. 119 | star_left_induction. 120 | semiring_normalize. 121 | rewrite H. 122 | kleene_reflexivity. 123 | Qed. 124 | 125 | End CR_algebra. 126 | -------------------------------------------------------------------------------- /theories/Classes.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** This module defines all classes of our algebraic hierarchy *) 10 | 11 | From ATBR Require Import Common. 12 | 13 | (** * Graph : base class of the hierarchy 14 | 15 | a multigraph with indexed equalities on vertices. *) 16 | 17 | (* RMK: we do not separate operators (equal) from axioms 18 | (equal_equivalence) for this base class. This is to be able to add 19 | reflexivity as a trivial hint, and symmetry as an immediate 20 | one. This might change in the future, if the semantics of hints for 21 | lemmas with maximally inserted implicit arguments changes. 22 | *) 23 | 24 | Class Graph := { 25 | T: Type; 26 | X: T -> T -> Type; 27 | equal: forall A B, relation (X A B); 28 | equal_:: forall A B, Equivalence (equal A B) 29 | }. 30 | 31 | (*Arguments equal : simpl never.*) 32 | 33 | Set Implicit Arguments. 34 | 35 | Bind Scope A_scope with X. 36 | 37 | Section Ops. 38 | (** * Operations 39 | 40 | All operations are parametrised by the [Graph] base-class 41 | 42 | *) 43 | Context (G: Graph). 44 | 45 | Class Monoid_Ops := { 46 | dot: forall A B C, X A B -> X B C -> X A C; 47 | one: forall A, X A A 48 | }. 49 | 50 | Class SemiLattice_Ops := { 51 | plus: forall A B, X A B -> X A B -> X A B; 52 | zero: forall A B, X A B; 53 | leq: forall A B: T, relation (X A B) := fun A B x y => equal A B (plus A B x y) y 54 | }. 55 | 56 | Class Star_Op := { 57 | star: forall A, X A A -> X A A 58 | }. 59 | 60 | Class Converse_Op := { 61 | conv: forall A B, X A B -> X B A 62 | }. 63 | 64 | End Ops. 65 | 66 | (** Notations for operations *) 67 | Notation "x == y" := (equal _ _ x y) (at level 70): A_scope. 68 | Notation "x <== y" := (leq _ _ x y) (at level 70): A_scope. 69 | Notation "x * y" := (dot _ _ _ x y) (at level 40, left associativity): A_scope. 70 | Notation "x + y" := (plus _ _ x y) (at level 50, left associativity): A_scope. 71 | Notation "x #" := (star _ x) (at level 15, left associativity): A_scope. 72 | Notation "x `" := (conv _ _ x) (at level 15, left associativity): A_scope. 73 | Notation "1" := (one _): A_scope. 74 | Notation "0" := (zero _ _): A_scope. 75 | 76 | Open Scope A_scope. 77 | Delimit Scope A_scope with A. 78 | 79 | 80 | (* Unset Implicit Arguments. *) 81 | Unset Strict Implicit. 82 | 83 | 84 | Section Structures. 85 | (** * Structures 86 | 87 | All structures are parametrised by both the [Graph] base-class and the corresponding operations. 88 | *) 89 | 90 | Context {G: Graph}. 91 | Context {Mo: Monoid_Ops G} {SLo: SemiLattice_Ops G} {Ko: Star_Op G} {Co: Converse_Op G}. 92 | 93 | Class Monoid := { 94 | dot_compat:: forall A B C, Proper (equal A B ==> equal B C ==> equal A C) (dot A B C); 95 | dot_assoc: forall A B C D (x: X A B) y (z: X C D), x*(y*z) == (x*y)*z; 96 | dot_neutral_left: forall A B (x: X A B), 1*x == x; 97 | dot_neutral_right: forall A B (x: X B A), x*1 == x 98 | }. 99 | 100 | Class SemiLattice := { 101 | plus_compat:: forall A B, Proper (equal A B ==> equal A B ==> equal A B) (plus A B); 102 | plus_neutral_left: forall A B (x: X A B), 0+x == x; 103 | plus_idem: forall A B (x: X A B), x+x == x; 104 | plus_assoc: forall A B (x y z: X A B), x+(y+z) == (x+y)+z; 105 | plus_com: forall A B (x y: X A B), x+y == y+x 106 | }. 107 | 108 | Class IdemSemiRing := { 109 | ISR_Monoid :: Monoid; 110 | ISR_SemiLattice :: SemiLattice; 111 | dot_ann_left: forall A B C (x: X B C), zero A B * x == 0; 112 | dot_ann_right: forall A B C (x: X C B), x * zero B A == 0; 113 | dot_distr_left: forall A B C (x y: X A B) (z: X B C), (x+y)*z == x*z + y*z; 114 | dot_distr_right: forall A B C (x y: X B A) (z: X C B), z*(x+y) == z*x + z*y 115 | }. 116 | 117 | Class KleeneAlgebra := { 118 | KA_ISR :: IdemSemiRing; 119 | star_make_left: forall A (a:X A A), 1 + a#*a == a#; 120 | star_destruct_left: forall A B (a: X A A) (c: X A B), a*c <== c -> a#*c <== c; 121 | star_destruct_right: forall A B (a: X A A) (c: X B A), c*a <== c -> c*a# <== c 122 | }. 123 | 124 | (** Once we add the converse operation, we no longer need some 125 | axioms from Monoid/SemiRing/KA. This is why we do not use direct 126 | inheritance *) 127 | (* TODO: introduce an intermediate ConverseMonoid class *) 128 | 129 | Class ConverseIdemSemiRing := { 130 | CISR_SL :: SemiLattice; 131 | dot_compat_c: forall A B C, Proper (equal A B ==> equal B C ==> equal A C) (dot A B C); 132 | dot_assoc_c: forall A B C D (x: X A B) y (z: X C D), x*(y*z) == (x*y)*z; 133 | dot_neutral_left_c: forall A B (x: X A B), 1*x == x; 134 | 135 | conv_compat:: forall A B, Proper (equal A B ==> equal B A) (conv A B); 136 | conv_invol: forall A B (x: X A B), x`` == x; 137 | conv_dot: forall A B C (x: X A B) (y: X B C), (x*y)` == y`*x`; 138 | conv_plus: forall A B (x y: X A B), (x+y)` == y`+x`; 139 | dot_ann_left_c: forall A B C (x: X B C), zero A B * x == 0; 140 | dot_distr_left_c: forall A B C (x y: X A B) (z: X B C), (x+y)*z == x*z + y*z 141 | }. 142 | 143 | Class ConverseKleeneAlgebra := { 144 | CKA_CISR :: ConverseIdemSemiRing; 145 | star_make_left_c: forall A (a:X A A), 1 + a#*a == a#; 146 | star_destruct_left_c: forall A B (a: X A A) (c: X A B), a*c <== c -> a#*c <== c 147 | }. 148 | 149 | End Structures. 150 | 151 | (** we want to keep the graph explicit, for better readability, (but 152 | we still want the graph to be maximally implicit in projections 153 | like [dot_assoc]. *) 154 | Arguments Monoid G {Mo}. 155 | Arguments SemiLattice G {SLo}. 156 | Arguments IdemSemiRing G {Mo SLo}, G Mo SLo. 157 | Arguments ConverseIdemSemiRing G {Mo} {SLo} {Co}. 158 | Arguments KleeneAlgebra G {Mo} {SLo} {Ko}. 159 | Arguments ConverseIdemSemiRing G {Mo} {SLo} {Co}. 160 | Arguments ConverseKleeneAlgebra G {Mo} {SLo} {Ko} {Co}. 161 | 162 | 163 | 164 | (** * Dual structures 165 | 166 | These structures are obtained by reversing all arrows; they make it 167 | possible to factorise several proofs, by symmetry. 168 | *) 169 | 170 | Module Dual. Section Protect. 171 | 172 | #[local] Transparent equal. 173 | 174 | Context (G: Graph). 175 | Context {Mo: Monoid_Ops G} {SLo: SemiLattice_Ops G} {Ko: Star_Op G} {Co: Converse_Op G}. 176 | 177 | Instance Graph: Graph := { 178 | T := T; 179 | X A B := X B A; 180 | equal A B := equal B A; 181 | equal_ A B := equal_ B A 182 | }. 183 | 184 | Instance Monoid_Ops: Monoid_Ops Graph := { 185 | dot A B C x y := @dot _ Mo C B A y x; 186 | one := @one _ Mo 187 | }. 188 | 189 | Instance SemiLattice_Ops: SemiLattice_Ops Graph := { 190 | plus A B := @plus _ SLo B A; 191 | zero A B := @zero _ SLo B A 192 | }. 193 | 194 | Instance Star_Op: Star_Op Graph := { 195 | star := @star _ Ko 196 | }. 197 | 198 | Instance Converse_Op: Converse_Op Graph := { 199 | conv A B := @conv _ Co B A 200 | }. 201 | 202 | Program Instance Monoid {M: Monoid G}: Monoid Graph := { 203 | dot_neutral_left := @dot_neutral_right _ _ M; 204 | dot_neutral_right := @dot_neutral_left _ _ M; 205 | dot_compat A B C x x' Hx y y' Hy := @dot_compat _ _ M C B A _ _ Hy _ _ Hx 206 | }. 207 | Obligation 1. 208 | intros. symmetry. simpl. apply dot_assoc. 209 | Defined. 210 | 211 | Instance SemiLattice {SL: SemiLattice G}: SemiLattice Graph := { 212 | plus_com A B := @plus_com _ _ SL B A; 213 | plus_idem A B := @plus_idem _ _ SL B A; 214 | plus_assoc A B := @plus_assoc _ _ SL B A; 215 | plus_compat A B := @plus_compat _ _ SL B A; 216 | plus_neutral_left A B := @plus_neutral_left _ _ SL B A 217 | }. 218 | 219 | Instance IdemSemiRing {ISR: IdemSemiRing G}: IdemSemiRing Graph. 220 | Proof. 221 | intros. 222 | constructor. 223 | exact Monoid. 224 | exact SemiLattice. 225 | exact (@dot_ann_right _ _ _ ISR). 226 | exact (@dot_ann_left _ _ _ ISR). 227 | exact (@dot_distr_right _ _ _ ISR). 228 | exact (@dot_distr_left _ _ _ ISR). 229 | Defined. 230 | 231 | End Protect. End Dual. 232 | -------------------------------------------------------------------------------- /theories/Common.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** This small module is imported in all our files, it exports useful 10 | modules and defines some basic utilities and tactics *) 11 | 12 | From Coq Require Export Arith. 13 | From Coq Require Export Lia. 14 | From Coq Require Export BinNums BinPos PArith.Pnat. 15 | From Coq Require Export Program.Equality. 16 | From Coq Require Export Setoid Morphisms. 17 | 18 | Set Implicit Arguments. 19 | 20 | Bind Scope nat_scope with nat. 21 | 22 | (** Functional composition *) 23 | Definition comp A B C (f: A -> B) (g: B -> C) := fun x => g (f x). 24 | Notation "f >> g" := (comp f g) (at level 50). 25 | 26 | (** This lemma is useful when applied in hypotyheses ([apply apply in H] makes it possible to specialize 27 | an hypothesis [H] by generating the corresponding subgoals) *) 28 | Definition apply X x Y (f: X -> Y) := f x. 29 | 30 | (** Tactics to resolve a goal by using a contradiction in the hypotheses, using either [lia] or [tauto] *) 31 | Ltac lia_false := exfalso; lia. 32 | Ltac tauto_false := exfalso; tauto. 33 | 34 | (** This destructor sometimes works better that the standard [destruct] *) 35 | Ltac idestruct H := 36 | let H' := fresh in generalize H; intro H'; destruct H'. 37 | 38 | (** For debugging *) 39 | Ltac print_goal := match goal with |- ?x => idtac x end. 40 | 41 | (** This tactic allows one to infere maximally implicit arguments that failed to be inferred and were 42 | replaced by sub-goals *) 43 | Ltac ti_auto := eauto with typeclass_instances. 44 | 45 | 46 | (** The following databases are used all along the library: 47 | - contains most "compatibility with equality" and "monotonicity" lemmas: Morphisms with respects to 48 | [Classes.equal] and [Classes.leq] ; it is useful to solve simple goals like [x <== y |- x*f x <== y*f y], 49 | and to obtain new morphisms. These morphism are always called [f_compat] and [f_incr], where [f] is the 50 | name of the compatible or monotone function. 51 | - contains simple algebraic lemmas like [0 <== x], [1 <== x#], 52 | and [x <== z -> y <== z -> x+y <== z], 53 | that seem to be appropriate for [(e)auto] proof search. 54 | - is a rewriting database, to be used with the [rsimpl] tactic. It contains lemmas like [1*x == x] 55 | [0# == 1] and provides a simple way to normalise the goal "in depth", using the setoid infrastructure. 56 | This is not really efficient, however. 57 | - contains hints to use [lia] when proof search failed ; this basically allows us to avoid 58 | using [lia] in trivial cases. 59 | *) 60 | Create HintDb compat discriminated. 61 | Create HintDb algebra discriminated. 62 | 63 | Ltac rsimpl := simpl; autorewrite with simpl using ti_auto. 64 | 65 | #[global] Hint Extern 9 (@eq nat ?x ?y) => abstract lia: lia. 66 | #[global] Hint Extern 9 (Peano.le ?x ?y) => abstract lia: lia. 67 | #[global] Hint Extern 9 (Peano.lt ?x ?y) => abstract lia: lia. 68 | 69 | (** Tactic to use when apply does not smartly unify *) 70 | Ltac rapply H := first 71 | [ refine H 72 | | refine (H _) 73 | | refine (H _ _) 74 | | refine (H _ _ _) 75 | | refine (H _ _ _ _) 76 | | refine (H _ _ _ _ _) 77 | | refine (H _ _ _ _ _ _) 78 | | refine (H _ _ _ _ _ _ _) 79 | | refine (H _ _ _ _ _ _ _ _) 80 | | refine (H _ _ _ _ _ _ _ _ _) 81 | | refine (H _ _ _ _ _ _ _ _ _ _) 82 | | refine (H _ _ _ _ _ _ _ _ _ _ _) 83 | | refine (H _ _ _ _ _ _ _ _ _ _ _ _) 84 | | fail 1 "extend rapply" 85 | ]. 86 | -------------------------------------------------------------------------------- /theories/Converse.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Properties and tactics about algebraic structures with converse. 10 | 11 | In particular, 12 | - [converse_down] pushes converses down to leaves 13 | - [switch] add converses on both sides of an (in)equation, and pushes converses down to leaves 14 | *) 15 | 16 | From ATBR Require Import Common. 17 | From ATBR Require Import Classes. 18 | From ATBR Require Import Graph. 19 | From ATBR Require Import SemiLattice. 20 | From ATBR Require Import SemiRing. 21 | 22 | Set Implicit Arguments. 23 | Unset Strict Implicit. 24 | 25 | 26 | Section ISR. 27 | 28 | Context `{CISR: ConverseIdemSemiRing}. 29 | 30 | Lemma conv_compat' A B (x y: X A B): x` == y` -> x == y. 31 | Proof. 32 | intro H. 33 | rewrite <- (conv_invol x). 34 | rewrite <- (conv_invol y). 35 | apply conv_compat; exact H. 36 | Qed. 37 | 38 | Hint Rewrite conv_dot conv_plus conv_invol: converse_down. 39 | 40 | Ltac switch := 41 | match goal with 42 | | |- _ ` == _ ` => apply conv_compat 43 | | |- _ == _ => apply conv_compat' 44 | end; autorewrite with converse_down. 45 | 46 | Existing Instance dot_compat_c. 47 | Lemma conv_one A: one A` == 1. 48 | Proof. 49 | rewrite <- (dot_neutral_left_c ((one A)`)). 50 | switch. apply dot_neutral_left_c. 51 | Qed. 52 | Hint Rewrite conv_one: converse_down. 53 | 54 | Lemma conv_zero A B: zero B A` == 0. 55 | Proof. 56 | transitivity ((dot B A A 0 (0`))`). 57 | switch. 58 | symmetry. apply dot_ann_left_c. 59 | autorewrite with converse_down. apply dot_ann_left_c. 60 | Qed. 61 | Hint Rewrite conv_zero: converse_down. 62 | 63 | Instance CISR_ISR: IdemSemiRing G. 64 | Proof. 65 | intros. constructor. constructor. 66 | apply dot_compat_c. 67 | apply dot_assoc_c. 68 | apply dot_neutral_left_c. 69 | intros. switch. apply dot_neutral_left_c. 70 | apply CISR_SL. 71 | apply dot_ann_left_c. 72 | intros. switch. apply dot_ann_left_c. 73 | apply dot_distr_left_c. 74 | intros. switch. apply dot_distr_left_c. 75 | Qed. 76 | 77 | #[global] Instance conv_incr A B: 78 | Proper ((leq A B) ==> (leq B A)) (conv A B). 79 | Proof. 80 | unfold leq. 81 | intros x y H. 82 | rewrite <- H at 2. rewrite conv_plus. apply plus_com. 83 | Qed. 84 | 85 | Lemma conv_incr' A B (x y: X A B): x` <== y` -> x <== y. 86 | Proof. 87 | intro H. 88 | rewrite <- (conv_invol x). 89 | rewrite <- (conv_invol y). 90 | apply conv_incr; exact H. 91 | Qed. 92 | 93 | End ISR. 94 | 95 | (** the push converses down to leaves *) 96 | Ltac converse_down := 97 | repeat ( 98 | rewrite conv_invol || 99 | rewrite conv_dot || 100 | rewrite conv_plus 101 | ); 102 | repeat ( 103 | rewrite conv_one || 104 | rewrite conv_zero 105 | ). 106 | 107 | (** add converses on both sides, and push converses down to leaves *) 108 | Ltac switch := 109 | match goal with 110 | | |- _ ` == _ ` => apply conv_compat 111 | | |- _ == _ => apply conv_compat' 112 | | |- _ ` <== _ ` => apply conv_incr 113 | | |- _ <== _ => apply conv_incr' 114 | end; converse_down. 115 | 116 | 117 | Section KA. 118 | 119 | Context `{KA: ConverseKleeneAlgebra}. 120 | 121 | Existing Instance CISR_ISR. 122 | 123 | Lemma star_destruct_left_old' A B (a: X A A) (b c: X A B): b+a*c <== c -> a#*b <== c. 124 | Proof. 125 | intro H; transitivity (a#*c). 126 | rewrite <- H; semiring_reflexivity. 127 | apply star_destruct_left_c. 128 | rewrite <- H at -1; auto with algebra. 129 | Qed. 130 | 131 | Lemma conv_star A (a: X A A): a# ` == a` #. 132 | Proof. 133 | apply leq_antisym. 134 | 135 | switch. 136 | rewrite <- (dot_neutral_right (a#)). 137 | apply star_destruct_left_old'. 138 | switch. 139 | rewrite <- star_make_left_c at 2. semiring_reflexivity. 140 | 141 | rewrite <- (dot_neutral_right (a`#)). 142 | apply star_destruct_left_old'. 143 | switch. 144 | rewrite <- star_make_left_c at 2. semiring_reflexivity. 145 | Qed. 146 | 147 | #[global] Instance CKA_KA: KleeneAlgebra G. 148 | Proof. 149 | constructor. apply CISR_ISR. 150 | apply star_make_left_c. 151 | apply star_destruct_left_c. 152 | intros. switch. rewrite conv_star. 153 | apply star_destruct_left_c. switch. assumption. 154 | Qed. 155 | 156 | End KA. 157 | 158 | (** override, to take [conv_star] into account *) 159 | Ltac converse_down ::= 160 | repeat ( 161 | rewrite conv_invol || 162 | rewrite conv_star || 163 | rewrite conv_dot || 164 | rewrite conv_plus 165 | ); 166 | repeat ( 167 | rewrite conv_one || 168 | rewrite conv_zero 169 | ). 170 | -------------------------------------------------------------------------------- /theories/DKA_CheckLabels.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Reflexive algorithm to check that two regex have the same sets of variables. 10 | 11 | We also prove that equal regex necessarily have the same set of 12 | labels, and that the conversion into strict star form preserves 13 | this set. 14 | *) 15 | 16 | From ATBR Require Import Common. 17 | From ATBR Require Import Classes. 18 | From ATBR Require Import Graph. 19 | 20 | From ATBR Require Import DKA_Definitions. 21 | From ATBR Require Import StrictStarForm. 22 | 23 | Set Implicit Arguments. 24 | Unset Strict Implicit. 25 | 26 | Fixpoint collect e acc := 27 | match e with 28 | | RegExp.var i => NumSet.add i acc 29 | | RegExp.plus a b => collect a (collect b acc) 30 | | RegExp.dot a b => collect a (collect b acc) 31 | | RegExp.star a => collect a acc 32 | | _ => acc 33 | end. 34 | 35 | Definition same_labels a b : bool := 36 | NumSet.equal (collect a NumSet.empty) (collect b NumSet.empty). 37 | 38 | Infix " [=] " := NumSet.Equal (at level 80). 39 | 40 | Section protect. 41 | 42 | #[local] Instance collect_compat a: Proper (NumSet.Equal ==> NumSet.Equal) (collect a). 43 | Proof. 44 | induction a; simpl; intros ? ? H; rewrite H; reflexivity. 45 | Qed. 46 | Definition collect_compat' a x := @collect_compat a x. 47 | 48 | Lemma collect_incr_2: forall a i acc, 49 | NumSet.In i acc -> NumSet.In i (collect a acc). 50 | Proof. 51 | induction a; simpl; intros; auto. 52 | NumSetProps.setdec. 53 | Qed. 54 | 55 | Lemma collect_incr_1: forall a i acc acc', 56 | NumSet.In i (collect a acc') -> NumSet.In i (collect a acc) \/ NumSet.In i acc'. 57 | Proof. 58 | induction a; simpl; intros i acc acc' Hi; auto. 59 | eapply IHa1 in Hi as [Hi|Hi]. left. apply Hi. eapply IHa2 in Hi as [Hi|Hi]; auto. left. apply collect_incr_2, Hi. 60 | eapply IHa1 in Hi as [Hi|Hi]. left. apply Hi. eapply IHa2 in Hi as [Hi|Hi]; auto. left. apply collect_incr_2, Hi. 61 | NumSetProps.setdec. 62 | Qed. 63 | 64 | Lemma collect_com: forall a b acc, collect a (collect b acc) [=] collect b (collect a acc). 65 | Proof. 66 | induction a; simpl; intros; try reflexivity. 67 | rewrite IHa2, IHa1. reflexivity. 68 | rewrite IHa2, IHa1. reflexivity. 69 | apply IHa. 70 | revert acc. induction b; intro acc; simpl; try reflexivity. 71 | rewrite IHb1, IHb2. reflexivity. 72 | rewrite IHb1, IHb2. reflexivity. 73 | apply IHb. 74 | NumSetProps.setdec. 75 | Qed. 76 | 77 | Lemma collect_idem: forall a acc, collect a (collect a acc) [=] collect a acc. 78 | Proof. 79 | induction a; simpl; intro; try reflexivity. 80 | rewrite (collect_com a2 a1). rewrite IHa1, IHa2. reflexivity. 81 | rewrite (collect_com a2 a1). rewrite IHa1, IHa2. reflexivity. 82 | apply IHa. 83 | NumSetProps.setdec. 84 | Qed. 85 | 86 | Lemma NumSetEqual_refl: forall x, x [=] x. 87 | Proof. reflexivity. Qed. 88 | 89 | #[local] Hint Resolve collect_compat' collect_idem collect_com NumSetEqual_refl : core. 90 | 91 | Notation clean := RegExp.Clean.rewrite. 92 | 93 | Ltac contradict := 94 | match goal with 95 | | H: RegExp.equal ?x ?y , Hx: RegExp.is_zero (clean ?x) = _ , Hy: RegExp.is_zero (clean ?y) = _ |- _ => 96 | exfalso; apply RegExp.Clean.equal_rewrite_zero_equiv in H; rewrite H, Hy in Hx; discriminate Hx 97 | end. 98 | 99 | Lemma equal_collect: forall a b, a==b -> 100 | forall acc, collect (clean a) acc [=] collect (clean b) acc. 101 | Proof. 102 | intros a b H. induction H; intro acc; simpl in *; RegExp.destruct_tests; simpl in*; auto; try contradict. 103 | rewrite (collect_com (clean z)). rewrite collect_idem. reflexivity. 104 | rewrite 2 (collect_com (clean y)). rewrite collect_idem. auto. 105 | rewrite IHequal1, IHequal2. reflexivity. 106 | rewrite IHequal1, IHequal2. reflexivity. 107 | rewrite IHequal1. apply IHequal2. 108 | symmetry. apply IHequal. 109 | Qed. 110 | 111 | Theorem complete: forall a b, same_labels (clean a) (clean b) = false -> ~ a == b. 112 | Proof. 113 | intros a b H H'. assert (F := equal_collect H' NumSet.empty). apply NumSet.equal_1 in F. 114 | unfold same_labels in H. rewrite F in H. discriminate. 115 | Qed. 116 | 117 | 118 | (** Proof that rewriting a regex in strict star form preserves its set of labels *) 119 | 120 | Lemma collect_ssf_remove: forall a acc, collect (remove a) acc [=] collect a acc. 121 | Proof. 122 | induction a; simpl; intro acc; auto. 123 | case contains_one; simpl; auto. 124 | case contains_one; simpl; auto. 125 | unfold plus_but_one. RegExp.destruct_tests; simpl; auto. 126 | rewrite <- IHa1, IHa2. reflexivity. 127 | rewrite <- IHa2, IHa1. reflexivity. 128 | rewrite IHa1, IHa2. reflexivity. 129 | case contains_one; simpl; auto. 130 | unfold plus_but_one. RegExp.destruct_tests; simpl; auto. 131 | rewrite <- IHa1, IHa2. reflexivity. 132 | rewrite <- IHa2, IHa1. reflexivity. 133 | rewrite IHa1, IHa2. reflexivity. 134 | case contains_one; simpl; auto. 135 | unfold plus_but_one. RegExp.destruct_tests; simpl; auto. 136 | rewrite <- IHa1, IHa2. reflexivity. 137 | rewrite <- IHa2, IHa1. reflexivity. 138 | rewrite IHa1, IHa2. reflexivity. 139 | Qed. 140 | 141 | Lemma collect_ssf: forall a acc, collect (ssf a) acc [=] collect a acc. 142 | Proof. 143 | induction a; simpl; unfold dot', plus_but_one, star'; intro acc; auto; 144 | RegExp.destruct_tests; simpl; auto. 145 | rewrite <- IHa1, IHa2. reflexivity. 146 | rewrite <- IHa2, IHa1. reflexivity. 147 | rewrite IHa1, IHa2. reflexivity. 148 | rewrite IHa1, IHa2. reflexivity. 149 | rewrite <- IHa. rewrite <- collect_ssf_remove. rewrite (RegExp.Is_one O). reflexivity. 150 | rewrite collect_ssf_remove, IHa. reflexivity. 151 | Qed. 152 | 153 | Theorem same_labels_ssf: forall a b, same_labels a b = true -> same_labels (ssf a) (ssf b) = true. 154 | Proof. 155 | intros. unfold same_labels. rewrite 2 collect_ssf. assumption. 156 | Qed. 157 | 158 | End protect. 159 | -------------------------------------------------------------------------------- /theories/DecideKleeneAlgebra.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** This module aggregates all DKA_* modules, to obtain the decision 10 | procedure for Kleene algebras [kleene_reflexivity]. *) 11 | 12 | 13 | From ATBR Require Import Common. 14 | From ATBR Require Import Classes. 15 | From ATBR Require Import Graph. 16 | From ATBR Require Import Converse. 17 | From ATBR Require Import DKA_Definitions. 18 | From ATBR Require DKA_CheckLabels. 19 | From ATBR Require DKA_Construction. 20 | From ATBR Require DKA_Epsilon. 21 | From ATBR Require DKA_Determinisation. 22 | From ATBR Require DKA_Merge. 23 | From ATBR Require DKA_DFA_Equiv. 24 | From ATBR Require StrictStarForm. 25 | From ATBR Require Reification. 26 | 27 | From Coq Require Import List. 28 | 29 | Definition word := list positive. 30 | Inductive CounterExample: Set := 31 | | NotLeq: word -> CounterExample 32 | | NotGeq: word -> CounterExample 33 | | DifferentAtomSets: CounterExample. 34 | 35 | 36 | Definition X_to_DFA (a: regex) := 37 | let a' := StrictStarForm.ssf a in 38 | let A := DKA_Construction.X_to_eNFA a' in 39 | let A := DKA_Epsilon.eNFA_to_NFA A (DKA_Construction.well_founded (StrictStarForm.ssf_complete a)) in 40 | let A := DKA_Determinisation.NFA_to_DFA A in 41 | A. 42 | 43 | Definition translate_ce (ce: option (bool*word)) := 44 | match ce with 45 | | None => None 46 | | Some(b,w) => Some ((if b then NotLeq else NotGeq) (List.rev w)) 47 | end. 48 | 49 | Notation clean := RegExp.Clean.rewrite. 50 | 51 | Definition decide_kleene a b := 52 | let a := clean a in 53 | let b := clean b in 54 | if negb (DKA_CheckLabels.same_labels a b) then Some DifferentAtomSets 55 | else translate_ce (DKA_Merge.compare_DFAs DKA_DFA_Equiv.equiv (X_to_DFA a) (X_to_DFA b)). 56 | 57 | Lemma X_to_DFA_correct: forall a, DFA.eval (X_to_DFA a) == a. 58 | Proof. 59 | intro a. unfold X_to_DFA. 60 | rewrite DKA_Determinisation.correct by apply DKA_Epsilon.bounded, DKA_Construction.bounded. 61 | rewrite DKA_Epsilon.correct by apply DKA_Construction.bounded. 62 | rewrite DKA_Construction.correct. 63 | apply StrictStarForm.ssf_correct. 64 | Qed. 65 | 66 | Lemma X_to_DFA_bounded: forall a, DFA.bounded (X_to_DFA a). 67 | Proof. 68 | intro a. apply DKA_Determinisation.bounded, DKA_Epsilon.bounded, DKA_Construction.bounded. 69 | Qed. 70 | 71 | Lemma X_to_DFA_labels: forall a b, 72 | DKA_CheckLabels.same_labels (clean a) (clean b) = true -> 73 | DFA.max_label (X_to_DFA (clean a)) = DFA.max_label (X_to_DFA (clean b)). 74 | Proof. 75 | intros. unfold X_to_DFA. 76 | rewrite 2 DKA_Determinisation.preserve_max_label. 77 | rewrite 2 DKA_Epsilon.preserve_max_label. 78 | apply DKA_Construction.same_labels_max_label. 79 | apply DKA_CheckLabels.same_labels_ssf. 80 | assumption. 81 | Qed. 82 | 83 | 84 | Lemma translate_correct: forall ce, translate_ce ce = None <-> ce = None. 85 | Proof. intros [[b w]|]; simpl; intuition discriminate. Qed. 86 | 87 | 88 | Theorem Kozen94: forall a b, decide_kleene a b = None <-> a == b. 89 | Proof. 90 | unfold decide_kleene. intros a b. 91 | case_eq (DKA_CheckLabels.same_labels (clean a) (clean b)); simpl; intros Hm. 92 | 93 | rewrite translate_correct. 94 | rewrite DKA_Merge.correct; try apply X_to_DFA_bounded. 95 | setoid_rewrite X_to_DFA_correct. 96 | setoid_rewrite <- RegExp.Clean.correct. 97 | reflexivity. 98 | apply DKA_DFA_Equiv.correct. 99 | apply X_to_DFA_labels, Hm. 100 | 101 | split; intro H. 102 | discriminate H. 103 | exfalso. apply DKA_CheckLabels.complete in Hm. tauto. 104 | Qed. 105 | 106 | (* Print Assumptions Kozen94. *) 107 | 108 | Import RegExp.Untype. 109 | Import Reification. 110 | 111 | Corollary dk_erase_correct `{KA: KleeneAlgebra} {env: Env}: 112 | forall n m (a b: KA.X n m), decide_kleene (erase a) (erase b) = None -> KA.eval a == KA.eval b. 113 | Proof. intros. apply erase_faithful. apply Kozen94. assumption. Qed. 114 | 115 | 116 | Ltac display_counter_example e ce := 117 | let eval_word w := 118 | let rec build w := 119 | lazymatch w with 120 | | nil => fail 0 121 | | ?x::nil => constr:(Reification.unpack (@Reification.val _ e x)) 122 | | ?x::?q => let q := build q in constr:(q * Reification.unpack (@Reification.val _ e x)) 123 | end 124 | in 125 | let x := build w in 126 | let x := eval compute [e Reification.unpack Reification.tgt Reification.src 127 | Reification.sigma_get Reification.sigma_add Reification.sigma_empty 128 | FMapPositive.PositiveMap.find FMapPositive.PositiveMap.add 129 | FMapPositive.PositiveMap.empty Reification.val] in x 130 | in x 131 | in 132 | match ce with 133 | | DifferentAtomSets => fail 1 "Not a Kleene algebra theorem: different atom sets" 134 | | NotGeq ?w => 135 | (try let u := eval_word w in 136 | fail 2 "Not a Kleene Algebra theorem: " u "does not belong to the left-hand side"); 137 | fail 1 "Not a Kleene Algebra theorem: the empty word (1) does not belong to the left-hand side" 138 | | NotLeq ?w => 139 | (try let u := eval_word w in 140 | fail 2 "Not a Kleene Algebra theorem: " u "does not belong to the right-hand side"); 141 | fail 1 "Not a Kleene Algebra theorem: the empty word (1) does not belong to the right-hand side" 142 | end. 143 | 144 | 145 | (** the tactic for solving Kleene algebras equations *) 146 | Ltac kleene_reflexivity := 147 | let e := fresh "e" in 148 | unfold leq; 149 | kleene_reify; intros t e l r; 150 | apply dk_erase_correct; vm_compute; 151 | (reflexivity || lazymatch goal with |- Some ?w = None => display_counter_example e w end). 152 | 153 | (** extension to Kleene algebras with converse *) 154 | Ltac ckleene_reflexivity := converse_down; kleene_reflexivity. 155 | 156 | 157 | Ltac kleene_ssf := StrictStarForm.kleene_ssf. 158 | Ltac kleene_clean_zeros := Model_RegExp.kleene_clean_zeros. 159 | 160 | 161 | (*begintests 162 | Section test. 163 | 164 | Context `{KA: KleeneAlgebra}. 165 | 166 | Goal forall A B (a: X A B) (b: X B A), a*(b*a)# == (a*b)#*a. 167 | intros. 168 | Time kleene_reflexivity. 169 | Abort. 170 | 171 | Goal forall A (a b: X A A), (a+b)# == a#*(b*a#)#. 172 | intros. 173 | Time kleene_reflexivity. 174 | Abort. 175 | 176 | Goal forall A (a b: X A A), a*b# + a#*b# == a#*b#. 177 | intros. 178 | Time kleene_reflexivity. 179 | Abort. 180 | 181 | Goal forall A B (a c: X A B) (b: X B A), (a+c)*(b*a+b*c)# == (a*b+c*b)#*(a+c). 182 | intros. 183 | Time kleene_reflexivity. 184 | Abort. 185 | 186 | Goal forall A (a b: X A A), (a*b)# == (a+b)# . 187 | intros. 188 | try kleene_reflexivity. 189 | idtac. 190 | Abort. 191 | 192 | Goal forall A B (a: X A B) (b: X B A), a*(b*a) == (a*b)#*a . 193 | intros. 194 | try kleene_reflexivity. 195 | idtac. 196 | Abort. 197 | 198 | Goal forall A B (a: X A B) (b: X B A), a*b*a*b == a*b + a*b*a*b . 199 | intros. 200 | try kleene_reflexivity. 201 | idtac. 202 | Abort. 203 | 204 | Goal forall A B (a: X A B) (b: X B A), a*b <== a*b*a*b. 205 | intros. 206 | try kleene_reflexivity. 207 | idtac. 208 | Abort. 209 | 210 | Goal forall A B (a: X A B) (b: X B A) (c: X B B), a*c*(b*a)# == (a*b)#*a. 211 | intros. 212 | try kleene_reflexivity. 213 | idtac. 214 | Abort. 215 | 216 | Goal forall A B (a: X A B) (b: X B A) (c: X B B), a*c*(b*a)# == (a*b)#*a*(1+c*0). 217 | intros. 218 | try kleene_reflexivity. 219 | idtac. 220 | Abort. 221 | 222 | Goal forall A (a b: X A A), (a*0)#*b == b+0*a#+b*0#. 223 | intros. kleene_clean_zeros. 224 | Abort. 225 | 226 | Goal forall A (a b: X A A), (a*0)# <== b+0*a#+0#. 227 | intros. kleene_clean_zeros. 228 | Abort. 229 | 230 | Goal forall A (a b: X A A), ((1+b)*(1+a))# == (a+b)#. 231 | intros. kleene_ssf. 232 | Abort. 233 | 234 | End test. 235 | 236 | Section ctest. 237 | 238 | Context `{KA: ConverseKleeneAlgebra}. 239 | 240 | Goal forall A B (a: X A B) (b: X B A), a`*(a*b)`# == (b*a)#`*a`. 241 | intros. 242 | Time ckleene_reflexivity. 243 | Abort. 244 | 245 | End ctest. 246 | endtests*) 247 | -------------------------------------------------------------------------------- /theories/Examples.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** * Examples about uses of the ATBR library *) 10 | 11 | From ATBR Require Import ATBR. 12 | 13 | Set Implicit Arguments. 14 | Unset Strict Implicit. 15 | Unset Printing Implicit Defensive. 16 | 17 | 18 | (** ** Setting *) 19 | 20 | Section Setting. 21 | 22 | (** We assume a typed Kleene algebra (as described in [Classes]) *) 23 | Context `{KA: KleeneAlgebra}. 24 | 25 | (** printing * * *) 26 | (** This means we can write expressions like the following one, where 27 | - [a #] is the Kleene star of [a], 28 | - [a + b] is the sum of [a] and [b], 29 | - [a * b] is their product (or concatenation) 30 | - [1] is the neutral element for [*] 31 | - [0] is the neutral element for [+] 32 | - [==] is the equality associated to this algebraic structure 33 | - [<==] is the preorder associated to [+] ([x <== y] iff [x + y == y]) 34 | *) 35 | 36 | Check forall A (a b c: X A A), 1+a#*b+(c*0+a*b*c)# == 1. 37 | 38 | (** In the previous expression, A is a "type", it makes sense in 39 | situations like the following, where 40 | - R can be thought of as a relation from a set A to a set B, 41 | - S as a relation from set B to set A, 42 | - T as a relation from A to C 43 | 44 | (As shown below, these `types' can also be seen as matrix dimensions.) 45 | *) 46 | 47 | Check forall A B C (R: X A B) (S: X B A) (T: X A C), ((R*S)# + 1) * T == 0. 48 | 49 | End Setting. 50 | 51 | 52 | (** ** Decision tactics *) 53 | 54 | Section Tactics. 55 | 56 | (** The main tactic of this library is [kleene_reflexivity] from 57 | file DecideKleeneAlgebra.v. This is a reflexive tactic that 58 | through automata constructions in order to solve (in)equations 59 | that are valid in any Kleene algebras: *) 60 | 61 | Section DKA. 62 | Context `{KA: KleeneAlgebra}. 63 | 64 | Variables A B: T. 65 | Variables a b c: X A A. 66 | Variable d: X A B. 67 | Variable e: X B A. 68 | 69 | Lemma star_distr: (a+b)# == a#*(b*a#)#. 70 | kleene_reflexivity. 71 | Qed. 72 | 73 | Goal (d*e)#*d == d*(e*d)#. 74 | kleene_reflexivity. 75 | Qed. 76 | 77 | Goal a#*(b+a#*(1+c))# == (a+b+c)#. 78 | kleene_reflexivity. 79 | Qed. 80 | 81 | Goal a*b*c*a*b*c*a# <== a#*(b*c+a)#. 82 | kleene_reflexivity. 83 | Qed. 84 | 85 | (** Note that kleene_reflexivity cannot use hypotheses (Horn theory 86 | of KA is undecidable) *) 87 | 88 | Goal a*b <== c -> a*(b*a)# <== c#*a. 89 | intro H. 90 | try kleene_reflexivity. 91 | rewrite <- H. 92 | kleene_reflexivity. 93 | Qed. 94 | 95 | (** kleene_reflexivity is a decision procedure, which means it also produces a 96 | counter-example when the goal is false. It typically reports a single string 97 | that appears on one side but not the other. *) 98 | Goal b# <== a*b*c. 99 | Fail kleene_reflexivity. 100 | Abort. 101 | 102 | Goal a <== b. 103 | Fail kleene_reflexivity. 104 | Abort. 105 | 106 | Goal a*b# <== a*b*c. 107 | Fail kleene_reflexivity. 108 | Abort. 109 | 110 | Goal b#*a# == b#*1*a. 111 | Fail kleene_reflexivity. 112 | Abort. 113 | 114 | End DKA. 115 | 116 | 117 | (** We also implemented reflexive decision tactics for the 118 | intermediate structures (lighter, faster). They work as soon as 119 | we provide enough structure (e.g. an idempotent semi-ring 120 | [IdemSemiRing], or even a [Monoid] or a [SemiLattice]); they can 121 | of course be used to solve simple goals in richer settings, like 122 | Kleene Agebras. *) 123 | 124 | Section ISR. 125 | Context `{ISR: IdemSemiRing}. 126 | 127 | Variables A B: T. 128 | Variables a b c: X A A. 129 | Variable d: X A B. 130 | 131 | 132 | Goal (a+b)*(a+b) == a*a+a*b+b*a+b*b. 133 | semiring_reflexivity. 134 | Qed. 135 | 136 | Goal 0+b*a <== (a+b)*(1+a). 137 | semiring_reflexivity. 138 | Qed. 139 | 140 | Goal a*(b*1)*(c*d) == a*1*b*c*d. 141 | semiring_reflexivity. 142 | Qed. 143 | 144 | Goal a+(b+1)+(a+c) == 1+c+b+a+0. 145 | semiring_reflexivity. 146 | Qed. 147 | 148 | Goal a <== 1+c+b+a+0. 149 | semiring_reflexivity. 150 | Qed. 151 | 152 | (** On these simpler structures, we also have `normalisation' tactics: *) 153 | 154 | Goal a*1*(a+b)*d <== (a+b)*((a+(b+c))*d) + d*0. 155 | (** normalize expressions by expanding them *) 156 | semiring_normalize. 157 | (** just remove zeros and ones *) 158 | Restart. semiring_clean. 159 | (** remove zeros and ones and normalize parentheses *) 160 | Restart. semiring_cleanassoc. 161 | semiring_reflexivity. 162 | Qed. 163 | 164 | (** *** Rewriting tactics 165 | 166 | When rewriting terms, handling associativity and commutativity 167 | explicitly can be tedious. We implemented ad-hoc tactics for 168 | rewriting *closed* equations modulo A and/or AC; we plan to 169 | investigate this problem in a more systematic way. *) 170 | 171 | Goal c*d <== 0 -> a*b*c*d <== 0. 172 | intro H. 173 | (** parentheses do not match *) 174 | try rewrite H. 175 | monoid_rewrite H. 176 | semiring_reflexivity. 177 | Qed. 178 | 179 | Goal d <== c*d -> a*b*d <== a*b*c*d. 180 | intro H. 181 | (** parentheses do not match *) 182 | try rewrite <- H. 183 | monoid_rewrite <- H. 184 | semiring_reflexivity. 185 | Qed. 186 | 187 | Goal a+b+c <== c -> b+a+c+c <== c. 188 | intro H. 189 | ac_rewrite H. 190 | semiring_reflexivity. 191 | Qed. 192 | 193 | End ISR. 194 | End Tactics. 195 | 196 | 197 | (** ** Examples about matrices 198 | 199 | Our development makes an heavy use of matrices, so that we had to 200 | develop a bit of matrix theory, that could be reused in other 201 | contexts. We give some examples about how to work with matrices in 202 | our setting. *) 203 | 204 | 205 | From ATBR Require ATBR_Matrices. 206 | Section Matrices. 207 | 208 | Import ATBR_Matrices. 209 | 210 | (** Assume an underlying idempotent semi-ring *) 211 | Context `{ISR: IdemSemiRing}. 212 | 213 | (** Notations are overloaded, thanks to the typeclass mechanism. We 214 | introduce specific notations to avoid confusion betwen matrices [MX] and 215 | their underlying elements [X]. *) 216 | 217 | Variable A: T. 218 | (** type of matrices over (X A A) *) 219 | Notation MX := (@X (mx_Graph A)). 220 | (** type of elements *) 221 | Notation X := (@X G). 222 | 223 | (** Constant-to-a 2x2 matrix, with elements of type X A A *) 224 | Definition constant (a: X A A): MX 2 2 := box 2 2 (fun i j => a). 225 | 226 | (** To retrieve the elements of a matrix, we use "!" (a notation for the "get" operation) *) 227 | Goal forall a, !(constant a) O O == a. 228 | Proof. 229 | intros. reflexivity. 230 | Qed. 231 | 232 | (** Dummy lemma, notice overloading of notations for [*] *) 233 | Lemma square_constant a: constant a * constant a == constant (a*a). 234 | Proof. 235 | (** since the dimensions are known (and finite), the matricial product can be computed *) 236 | simpl. 237 | (** the [mx_intros] simple tactic introduces indices to prove a 238 | matricial equality; it is useful when considering vectors: only 239 | one dimension is introduced *) 240 | mx_intros i j Hi Hj. 241 | simpl. 242 | (* easy goal, on the underlying algebra *) 243 | semiring_reflexivity. 244 | Qed. 245 | 246 | (** Our tactics automatically work for matrices (matrices are just another idempotent semiring) *) 247 | Goal forall n m p (M: MX n m) (N: MX m p) (P: MX n p), 248 | M*1*N + P == P+M*N. 249 | Proof. 250 | intros. 251 | semiring_reflexivity. 252 | Qed. 253 | 254 | (** Block matrices manipulation *) 255 | Lemma square_triangular_blocks n m (M: MX n n) (N: MX n m) (P: MX m m): 256 | mx_blocks M N 0 P * mx_blocks M N 0 P == mx_blocks (M*M) (M*N+N*P) 0 (P*P). 257 | Proof. 258 | intros. 259 | rewrite mx_blocks_dot. 260 | apply mx_blocks_compat; semiring_reflexivity. 261 | Qed. 262 | 263 | (** (We will clean-up and document this library for matrices at some 264 | point, so that we do not give further details for now.) *) 265 | 266 | End Matrices. 267 | 268 | 269 | 270 | (** ** Using concrete structures 271 | 272 | To work with a concrete given struture, you need to show that it 273 | satisfies the corresponding axioms. Examples are given in files 274 | Model_*.v 275 | 276 | For example, it is shown in Model_Relations.v that 277 | (heterogeneous) binary relations form a Kleene algebra with 278 | converse. This file can easily be adapted to use other 279 | definitions. 280 | *) 281 | 282 | 283 | From ATBR Require Model_Relations. 284 | Section Concrete. 285 | 286 | Import Model_Relations. 287 | Import Load. 288 | (* the latter line is required in order to register binary relations 289 | to the typeclass mechanism *) 290 | 291 | (** Any theorem we proved in an abstract structure now applies to 292 | binary relations *) 293 | Variable A: Set. 294 | Variables R S: rel A A. 295 | Check (star_distr R S). 296 | 297 | (** tactics work out of the box when using our notations *) 298 | Goal R*S==R -> R*(S+R#) == R#*R. 299 | Proof. 300 | intro H. 301 | rewrite dot_distr_right, H. 302 | kleene_reflexivity. 303 | Qed. 304 | 305 | (* TOTHINK: also declare canonical structures for operations *) 306 | Canonical Structure rel_Monoid_Ops. 307 | Goal R*S==R -> rel_comp R (S+R#) == rel_comp (R#) R. 308 | Proof. 309 | intro H. 310 | rewrite dot_distr_right, H. 311 | fold_relAlg. 312 | kleene_reflexivity. 313 | Qed. 314 | 315 | End Concrete. 316 | 317 | 318 | (** Similarly, homogeneous relations (from the standard library) are 319 | declared in Model_StdRelations, so that one can use our tactics to 320 | reason about these. *) 321 | 322 | From Coq Require Relations. 323 | From ATBR Require Model_StdRelations. 324 | 325 | Section Concrete'. 326 | 327 | Import Relations. 328 | Import Model_StdRelations. 329 | Import Load. 330 | 331 | Variable A: Set. 332 | Variables R S: relation A. 333 | 334 | Lemma example: same_relation _ 335 | (clos_refl_trans _ (union _ R S)) 336 | (comp (clos_refl_trans _ R) (clos_refl_trans _ (comp S (clos_refl_trans _ R)))). 337 | Proof. 338 | intros. 339 | fold_relAlg A. 340 | kleene_reflexivity. 341 | Qed. 342 | Print Assumptions example. 343 | 344 | End Concrete'. 345 | -------------------------------------------------------------------------------- /theories/Force.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Memoisation function for matrices: we define an identity function 10 | that enforces evaluation *) 11 | 12 | From Coq Require Import List. 13 | From Coq Require Import Arith. 14 | 15 | Set Implicit Arguments. 16 | 17 | Section force. 18 | Variable T: Type. 19 | Variable f: nat -> T. 20 | 21 | Fixpoint force_rec acc i := 22 | match i with 23 | | O => acc 24 | | S i => force_rec (f i :: acc) i 25 | end. 26 | 27 | Fixpoint nth i l := 28 | match l,i with 29 | | nil, _ => f O (* absurd *) 30 | | a::_, O => a 31 | |_::q, S i => nth i q 32 | end. 33 | End force. 34 | 35 | Definition print T n f := @force_rec T f nil n. 36 | 37 | Definition id T n f := 38 | let l := @print T n f in 39 | fun i => nth f i l. 40 | 41 | Section correction. 42 | Variable T: Type. 43 | 44 | Lemma force_rec_rec: forall (f: nat -> T) i a, force_rec f a (S i) = f 0 :: force_rec (fun k => f (S k)) a i. 45 | Proof. 46 | induction i; intros a; simpl. 47 | reflexivity. 48 | apply IHi. 49 | Qed. 50 | 51 | Lemma nth_force_rec: forall n (f g: nat -> T) i a, i nth g i (force_rec f a n) = f i. 52 | Proof. 53 | induction n; intros f g i a H. 54 | inversion H. 55 | rewrite force_rec_rec. destruct i. 56 | reflexivity. 57 | refine (IHn _ _ _ _ _). auto with arith. 58 | Qed. 59 | 60 | Lemma nth_force_rec': forall n (f g: nat -> T) i, n<=i -> nth g i (force_rec f nil n) = g O. 61 | Proof. 62 | induction n; intros f g i H. case i; reflexivity. 63 | rewrite force_rec_rec. destruct i. inversion H. 64 | simpl. apply IHn. auto with arith. 65 | Qed. 66 | 67 | Lemma id_id: forall n (f: nat -> T) i, i id n f i = f i. 68 | Proof. 69 | intros. apply nth_force_rec. assumption. 70 | Qed. 71 | 72 | Lemma id_notid: forall n (f: nat -> T) i, n<=i -> id n f i = f O. 73 | Proof. 74 | intros. apply nth_force_rec'. assumption. 75 | Qed. 76 | 77 | End correction. 78 | 79 | Section force2. 80 | Variable T: Type. 81 | Variables n m: nat. 82 | Variable f: nat -> nat -> T. 83 | 84 | Definition id2 := id n (fun i => id m (f i)). 85 | Definition print2 := print n (fun i => print m (f i)). 86 | 87 | Lemma id2_id: forall i j, i j id2 i j = f i j. 88 | Proof. 89 | intros; unfold id2. 90 | rewrite id_id by assumption. 91 | apply id_id; assumption. 92 | Qed. 93 | End force2. 94 | 95 | (*begintests 96 | 97 | Let m i := mult i i - i. 98 | Eval compute in print 5 m. 99 | Time Eval vm_compute in let _ := print 100 (id 100 m) in true. 100 | 101 | Let n i j := mult i (j+1). 102 | Eval compute in print2 3 5 n. 103 | Eval compute in print2 3 5 (id2 3 5 n). 104 | 105 | endtests*) 106 | -------------------------------------------------------------------------------- /theories/Functors.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Functors and homomorphisms between algebraic structures *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Import SemiLattice. 14 | From ATBR Require Import KleeneAlgebra. 15 | 16 | Set Implicit Arguments. 17 | Unset Strict Implicit. 18 | 19 | Record functor (G1 G2: Graph) := { 20 | fT: @T G1 -> @T G2; 21 | fX:> forall A B, X A B -> X (fT A) (fT B) 22 | }. 23 | 24 | Section Defs. 25 | 26 | Context {G1: Graph} {G2: Graph}. 27 | 28 | Class graph_functor (F: functor G1 G2) := { 29 | functor_compat: forall A B, Proper (equal A B ==> equal _ _) (F A B) 30 | }. 31 | 32 | Definition faithful (F: functor G1 G2) := 33 | forall A B x y, F A B x == F A B y -> x == y. 34 | 35 | Definition full (F: functor G1 G2) := 36 | forall A B y, exists x, F A B x == y. 37 | 38 | Class monoid_functor {Mo1: Monoid_Ops G1} {Mo2: Monoid_Ops G2} (F: functor G1 G2) := { 39 | monoid_graph_functor :: graph_functor F; 40 | functor_dot : forall A B C x y, F A C (x*y) == F A B x * F B C y; 41 | functor_one : forall A, F A A 1 == 1 42 | }. 43 | 44 | Class semilattice_functor {SLo1: SemiLattice_Ops G1} {SL2: SemiLattice_Ops G2} (F: functor G1 G2) := { 45 | semilattice_graph_functor :: graph_functor F; 46 | functor_plus : forall A B x y, F A B (x+y) == F A B x + F A B y; 47 | functor_zero : forall A B, F A B 0 == 0 48 | }. 49 | 50 | Section SLfunct. 51 | 52 | Context {SLo1} {SL1: @SemiLattice G1 SLo1} {SLo2} {SL2: @SemiLattice G2 SLo2} {F: functor G1 G2} {HF: semilattice_functor F}. 53 | 54 | Lemma functor_incr: forall A B, Proper ((leq A B) ==> (leq _ _)) (F A B). 55 | Proof. 56 | intros. intros x y H. unfold leq. rewrite <- functor_plus. apply functor_compat. trivial. 57 | Qed. 58 | 59 | Lemma functor_sum: forall A B i k f, F A B (sum i k f) == sum i k (fun i => F A B (f i)). 60 | Proof. 61 | intros. revert i; induction k; intro i. 62 | apply functor_zero. 63 | simpl. rewrite functor_plus. apply plus_compat; auto. 64 | Qed. 65 | 66 | End SLfunct. 67 | 68 | Context 69 | {Mo1: Monoid_Ops G1} {Mo2: Monoid_Ops G2} 70 | {SLo1: SemiLattice_Ops G1} {SLo2: SemiLattice_Ops G2} 71 | {Ko1: Star_Op G1} {Ko2: Star_Op G2}. 72 | 73 | Class semiring_functor (F: functor G1 G2) := { 74 | semiring_monoid_functor :: monoid_functor F; 75 | semiring_semilattice_functor :: semilattice_functor F 76 | }. 77 | 78 | Lemma functor_star_leq {KA1: KleeneAlgebra G1} {KA2: KleeneAlgebra G2} 79 | {F: functor G1 G2} {HF: semiring_functor F}: 80 | forall A a, (F A A a)# <== F A A (a#). 81 | Proof. 82 | intros. 83 | apply star_destruct_left_one. 84 | rewrite <- functor_one. 85 | rewrite <- functor_dot. 86 | rewrite <- functor_plus. 87 | apply functor_incr. rewrite star_make_right. reflexivity. 88 | Qed. 89 | 90 | Class kleene_functor (F: functor G1 G2) := { 91 | kleene_semiring :: semiring_functor F; 92 | functor_star: forall A a, F A A (a#) == (F A A a) # 93 | }. 94 | 95 | End Defs. 96 | 97 | 98 | 99 | -------------------------------------------------------------------------------- /theories/Graph.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Basic properties, definitions and hints about the [Classes.Graph] base-class *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | 14 | Set Implicit Arguments. 15 | Unset Strict Implicit. 16 | Unset Printing Implicit Defensive. 17 | 18 | Section equal. 19 | 20 | Context {G: Graph}. 21 | Variables A B: T. 22 | 23 | (** projections, for auto, or to help in manual proofs *) 24 | Lemma equal_refl x: equal A B x x. 25 | Proof. intros; apply Equivalence_Reflexive. Qed. 26 | Lemma equal_sym x y: equal A B x y -> equal A B y x. 27 | Proof. intros; apply Equivalence_Symmetric; trivial. Qed. 28 | Lemma equal_trans x y z: equal A B x y -> equal A B y z -> equal A B x z. 29 | Proof. intros; eapply Equivalence_Transitive; eauto. Qed. 30 | 31 | (** Lemmas to solve automatically some index related goals (a la f_equal)*) 32 | Lemma equal_refl_f1 (f: nat -> X A B): 33 | forall i i', i = i' -> f i == f i'. 34 | Proof. intros; subst; reflexivity. Qed. 35 | Lemma equal_refl_f2 (f: nat -> nat -> X A B): 36 | forall i i' j j', i=i' -> j=j' -> f i j == f i' j'. 37 | Proof. intros; subst ; reflexivity. Qed. 38 | 39 | Lemma equal_refl_f1t Z (f: nat -> Z -> X A B): 40 | forall t i i', i = i' -> f i t == f i' t. 41 | Proof. intros; subst ; reflexivity. Qed. 42 | Lemma equal_refl_f2t Z (f: nat -> nat -> Z -> X A B): 43 | forall t i i' j j', i=i' -> j=j' -> f i j t == f i' j' t. 44 | Proof. intros; subst ; reflexivity. Qed. 45 | 46 | 47 | (** boolean test *) 48 | Definition xif (b: bool) (x y: X A B) := if b then x else y. 49 | 50 | #[global] Instance xif_compat: Proper (@eq bool ==> equal A B ==> equal A B ==> equal A B) xif. 51 | Proof. intros c b ->; repeat intro. destruct b; auto. Qed. 52 | 53 | Lemma xif_spec: forall b x y z, (b=true -> x==z) -> (b=false -> y==z) -> xif b x y == z. 54 | Proof. intros. destruct b; auto. Qed. 55 | 56 | Lemma xif_false: forall b x y, b=false -> xif b x y == y. 57 | Proof. intros ? ? ? ->; reflexivity. Qed. 58 | 59 | Lemma xif_true: forall b x y, b=true -> xif b x y == x. 60 | Proof. intros ? ? ? ->; reflexivity. Qed. 61 | 62 | Lemma xif_idem: forall b x, xif b x x == x. 63 | Proof. destruct b; reflexivity. Qed. 64 | 65 | Lemma xif_idem': forall b x y, x == y -> xif b x y == x. 66 | Proof. intros b x y H. rewrite H. apply xif_idem. Qed. 67 | 68 | Lemma xif_xif_and: forall b c x y, xif b (xif c x y) y == xif (b&&c) x y. 69 | Proof. destruct b; reflexivity. Qed. 70 | 71 | Lemma xif_xif_or: forall b c x y, xif b x (xif c x y) == xif (b||c) x y. 72 | Proof. destruct b; reflexivity. Qed. 73 | 74 | Lemma xif_negb: forall b x y, xif (negb b) x y == xif b y x. 75 | Proof. destruct b; reflexivity. Qed. 76 | 77 | End equal. 78 | 79 | 80 | Lemma fun_xif {G G': Graph} A B A' B' (f: @X G A B -> @X G' A' B') b x y: f (xif b x y) == xif b (f x) (f y). 81 | Proof. destruct b; reflexivity. Qed. 82 | 83 | 84 | 85 | Section leq. 86 | (** Basic properties of the underlying preorder *) 87 | Context `{SL: SemiLattice}. 88 | Variables A B: T. 89 | 90 | #[global] Instance leq_refl: Reflexive (leq A B). 91 | Proof. intro. apply plus_idem. Qed. 92 | 93 | #[global] Instance leq_trans: Transitive (leq A B). 94 | Proof. 95 | intros x y z E E'; unfold leq in *. 96 | rewrite <- E', plus_assoc, E; reflexivity. 97 | Qed. 98 | 99 | #[global] Instance equal_leq: subrelation (equal A B) (leq A B). 100 | Proof. 101 | intros x y E; unfold leq; rewrite E; apply plus_idem. 102 | Qed. 103 | 104 | #[global] Instance equal_geq: subrelation (equal A B) (Basics.flip (leq A B)). 105 | Proof. repeat intro; apply equal_leq; symmetry; auto. Qed. 106 | 107 | Definition leq_antisym: Antisymmetric _ _ (leq A B). 108 | intros x y H1 H2; unfold leq in *; rewrite <- H2, plus_com, H1; reflexivity. 109 | Qed. 110 | End leq. 111 | 112 | 113 | #[global] Hint Resolve equal_refl : core. 114 | #[global] Hint Immediate equal_sym : core. 115 | 116 | (* BUG : If we add [equal_refl_fit] as hints, they are added as eapply ...*) 117 | 118 | #[global] Hint Resolve equal_refl_f1 equal_refl_f2 : core. 119 | (* Hint Resolve @equal_refl_f1t @equal_refl_f2t *) 120 | 121 | #[global] Hint Extern 1 (equal ?A ?B (?f _ ?t) (?f _ ?t)) => apply @equal_refl_f1t : core. 122 | #[global] Hint Extern 2 (equal ?A ?B (?f _ _ ?t) (?f _ _ ?t)) => apply @equal_refl_f2t : core. 123 | 124 | #[global] Hint Extern 3 (_ == _) => apply @xif_compat : core. 125 | -------------------------------------------------------------------------------- /theories/KleeneAlgebra.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Simple properties about Kleene algebras *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Import Graph. 14 | From ATBR Require Import Monoid. 15 | From ATBR Require Import SemiLattice. 16 | From ATBR Require Import SemiRing. 17 | 18 | Set Implicit Arguments. 19 | Unset Strict Implicit. 20 | 21 | Section Props0. 22 | 23 | Context `{KA: KleeneAlgebra}. 24 | 25 | (** other induction schemes *) 26 | Lemma star_destruct_right_old A B: forall (a: X A A) (b c: X B A), b+c*a <== c -> b*a# <== c. 27 | Proof. 28 | intros; transitivity (c*a#). 29 | rewrite <- H; semiring_reflexivity. 30 | apply star_destruct_right. 31 | rewrite <- H at -1; auto with algebra. 32 | Qed. 33 | 34 | Lemma star_destruct_left_old A B: forall (a: X A A) (b c: X A B), b+a*c <== c -> a#*b <== c. 35 | Proof. 36 | intros; transitivity (a#*c). 37 | rewrite <- H; semiring_reflexivity. 38 | apply star_destruct_left. 39 | rewrite <- H at -1; auto with algebra. 40 | Qed. 41 | 42 | Lemma star_destruct_right_one A: forall (a c: X A A), 1+c*a <== c -> a# <== c. 43 | Proof. 44 | intros. rewrite <- (dot_neutral_left (a#)). 45 | apply star_destruct_right_old. assumption. 46 | Qed. 47 | 48 | Lemma star_destruct_left_one A: forall (a c: X A A), 1+a*c <== c -> a# <== c. 49 | Proof. 50 | intros. rewrite <- (dot_neutral_right (a#)). 51 | apply star_destruct_left_old. assumption. 52 | Qed. 53 | 54 | End Props0. 55 | 56 | (** simple tactics to run an induction without having to remember which scheme to use *) 57 | Ltac star_left_induction := 58 | first [ apply star_destruct_left | 59 | apply star_destruct_left_old | 60 | apply star_destruct_left_one ]. 61 | 62 | Ltac star_right_induction := 63 | first [ apply star_destruct_right | 64 | apply star_destruct_right_old | 65 | apply star_destruct_right_one ]. 66 | 67 | 68 | (** simple properties *) 69 | Section Props1. 70 | 71 | Context `{KA: KleeneAlgebra}. 72 | Variable A: T. 73 | 74 | #[global] Instance star_incr: 75 | Proper ((leq A A) ==> (leq A A)) (star A). 76 | Proof. 77 | intros a b H. 78 | star_right_induction. 79 | rewrite H. rewrite star_make_left. reflexivity. 80 | Qed. 81 | 82 | #[global] Instance star_compat: Proper ((equal A A) ==> (equal A A)) (star A). 83 | Proof. 84 | intros a b H. apply leq_antisym; apply star_incr; apply equal_leq; auto. 85 | Qed. 86 | 87 | Lemma one_leq_star_a (a: X A A): 1 <== a#. 88 | Proof. 89 | rewrite <- star_make_left; auto with algebra. 90 | Qed. 91 | 92 | Lemma a_leq_star_a (a: X A A): a <== a#. 93 | Proof. 94 | rewrite <- star_make_left. 95 | rewrite <- one_leq_star_a. 96 | semiring_reflexivity. 97 | Qed. 98 | 99 | Lemma star_mon_is_one (a: X A A): a <== 1 -> a# == 1. 100 | Proof. 101 | intro H. 102 | apply leq_antisym. 103 | star_left_induction. 104 | rewrite H; semiring_reflexivity. 105 | apply one_leq_star_a. 106 | Qed. 107 | 108 | Lemma star_one: (1#: X A A) == 1. 109 | Proof. 110 | apply star_mon_is_one; reflexivity. 111 | Qed. 112 | 113 | Lemma star_zero: (0#: X A A) == 1. 114 | Proof. 115 | apply star_mon_is_one; apply zero_inf. 116 | Qed. 117 | 118 | Lemma star_a_a_leq_star_a (a: X A A): a#*a <== a#. 119 | Proof. 120 | rewrite <- star_make_left at 2. 121 | semiring_reflexivity. 122 | Qed. 123 | 124 | Lemma a_star_a_leq_star_a_a (a: X A A): a*a# <== a#*a. 125 | Proof. 126 | star_right_induction. 127 | rewrite star_a_a_leq_star_a at 1. 128 | apply plus_destruct_leq; auto. 129 | rewrite <- one_leq_star_a. semiring_reflexivity. 130 | Qed. 131 | 132 | Lemma star_make_right (a:X A A): 1+a*a# == a#. 133 | Proof. 134 | apply leq_antisym. 135 | rewrite a_star_a_leq_star_a_a. 136 | apply plus_destruct_leq. 137 | apply one_leq_star_a. 138 | apply star_a_a_leq_star_a. 139 | 140 | star_right_induction. 141 | rewrite <- star_make_left at 2. 142 | semiring_reflexivity. 143 | Qed. 144 | 145 | End Props1. 146 | 147 | (** hints *) 148 | #[global] Hint Extern 1 (equal _ _ _ _) => apply star_compat : compat algebra. 149 | #[global] Hint Extern 0 (equal _ _ _ _) => apply star_make_left: algebra. 150 | #[global] Hint Extern 0 (equal _ _ _ _) => apply star_make_right: algebra. 151 | #[global] Hint Extern 0 (equal _ _ _ _) => apply star_one: algebra. 152 | #[global] Hint Extern 0 (equal _ _ _ _) => apply star_zero: algebra. 153 | #[global] Hint Extern 0 (leq _ _ _ _) => apply a_leq_star_a: algebra. 154 | #[global] Hint Extern 0 (leq _ _ _ _) => apply one_leq_star_a: algebra. 155 | 156 | #[global] Hint Rewrite @star_zero @star_one using ti_auto : simpl. 157 | #[global] Hint Rewrite @star_mon_is_one using ti_auto : simpl. 158 | 159 | 160 | (** dual Kleene algebra *) 161 | Module Dual. Section Protect. 162 | Existing Instance Classes.Dual.Monoid_Ops. 163 | Existing Instance Classes.Dual.SemiLattice_Ops. 164 | Existing Instance Classes.Dual.Star_Op. 165 | Instance KleeneAlgebra `{KA: KleeneAlgebra}: KleeneAlgebra (Dual.Graph G). 166 | Proof. 167 | constructor. 168 | apply (@Dual.IdemSemiRing G). eauto with typeclass_instances. 169 | exact (@star_make_right _ _ _ _ KA). 170 | exact (@star_destruct_right _ _ _ _ KA). 171 | exact (@star_destruct_left _ _ _ _ KA). 172 | Defined. 173 | 174 | End Protect. End Dual. 175 | 176 | 177 | (** more properties *) 178 | Section Props2. 179 | Context `{KA: KleeneAlgebra}. 180 | Variable A: T. 181 | 182 | Lemma star_trans (a: X A A): a#*a# == a#. 183 | Proof. 184 | apply leq_antisym. 185 | star_right_induction. 186 | rewrite star_a_a_leq_star_a. reflexivity. 187 | rewrite <- one_leq_star_a at 3. semiring_reflexivity. 188 | Qed. 189 | 190 | Lemma star_idem (a: X A A): a## == a#. 191 | Proof. 192 | apply leq_antisym. 193 | star_right_induction. 194 | rewrite star_trans. 195 | rewrite (one_leq_star_a a). auto with algebra. 196 | apply a_leq_star_a. 197 | Qed. 198 | 199 | Lemma a_star_a_leq_star_a: forall (a: X A A), a*a# <== a#. 200 | Proof. 201 | exact (star_a_a_leq_star_a (KA:=Dual.KleeneAlgebra) (A:=A)). 202 | Qed. 203 | 204 | Lemma star_distr (a b: X A A): (a + b)# == a# * (b*a#)#. 205 | Proof. 206 | apply leq_antisym. 207 | 208 | star_left_induction. 209 | 210 | semiring_normalize. 211 | ac_rewrite (star_make_right (b*a#)). 212 | rewrite <- (star_make_right a) at 4. 213 | semiring_reflexivity. 214 | 215 | rewrite <- (star_trans (a+b)). 216 | apply dot_incr. 217 | apply star_incr. auto with algebra. 218 | rewrite <- (star_idem (a+b)). apply star_incr. 219 | rewrite <- (a_star_a_leq_star_a (a+b)). 220 | apply dot_incr. auto with algebra. 221 | apply star_incr. auto with algebra. 222 | Qed. 223 | 224 | Lemma semicomm_iter_right B (a: X A A) (b: X B B) (c: X B A): c*a <== b*c -> c*a# <== b#*c. 225 | Proof. 226 | intro H. 227 | star_right_induction. 228 | monoid_rewrite H. 229 | rewrite <- star_make_left at 2. 230 | semiring_reflexivity. 231 | Qed. 232 | 233 | Lemma wsemicomm_iter_right (a b : X A A): a*b <== b#*a -> a*b# <== b#*a. 234 | Proof. 235 | intros H. 236 | rewrite <- star_idem at 2. 237 | apply semicomm_iter_right; assumption. 238 | Qed. 239 | 240 | End Props2. 241 | 242 | #[global] Hint Extern 1 (leq _ _ _ _) => apply star_incr: compat algebra. 243 | #[global] Hint Extern 0 (equal _ _ _ _) => apply star_idem: algebra. 244 | #[global] Hint Extern 0 (equal _ _ _ _) => apply star_trans: algebra. 245 | 246 | 247 | (** more properties, by duality *) 248 | Section Props3. 249 | Context `{KA: KleeneAlgebra}. 250 | 251 | Lemma semicomm_iter_left: forall A B (a: X A A) (b: X B B) (c: X A B), a*c <== c*b -> a#*c <== c*b#. 252 | Proof. 253 | exact (semicomm_iter_right (KA:=Dual.KleeneAlgebra)). 254 | Qed. 255 | 256 | Lemma wsemicomm_iter_left: forall A (b a : X A A), a*b <== b*a# -> a#*b <== b*a#. 257 | Proof. 258 | exact (wsemicomm_iter_right (KA:=Dual.KleeneAlgebra)). 259 | Qed. 260 | 261 | Lemma comm_iter_left A B (x : X A B) a b: a * x == x * b -> a# * x == x * b# . 262 | Proof. 263 | intro H. 264 | apply leq_antisym. 265 | apply semicomm_iter_left, equal_leq. trivial. 266 | apply semicomm_iter_right, equal_leq. auto. 267 | Qed. 268 | 269 | Lemma move_star A (a: X A A): a#*a == a*a#. 270 | Proof. apply comm_iter_left; reflexivity. Qed. 271 | 272 | Lemma move_star2 A B (a: X A B) (b: X B A): (a*b)#*a == a*(b*a)#. 273 | Proof. apply comm_iter_left. semiring_reflexivity. Qed. 274 | 275 | End Props3. 276 | 277 | Section Props4. 278 | Context `{KA: KleeneAlgebra}. 279 | 280 | Lemma comm_iter_right: forall B A (x : X A B) a b, x * a == b * x -> x * a# == b# * x . 281 | Proof. 282 | exact (comm_iter_left (KA:=Dual.KleeneAlgebra)). 283 | Qed. 284 | 285 | End Props4. 286 | -------------------------------------------------------------------------------- /theories/Model_Languages.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Languages form a model of Kleene algebras *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Import MxGraph. 14 | From ATBR Require Converse. 15 | From Coq Require Import List. 16 | 17 | Set Implicit Arguments. 18 | Unset Strict Implicit. 19 | 20 | Section Def. 21 | 22 | Context {A: Type}. 23 | 24 | (* a language is a predicate of words, i.e., list of letters *) 25 | Definition lang := list A -> Prop. 26 | Definition lang_equal (L L': lang): Prop := forall x, L x <-> L' x. 27 | Definition lang_union (L L': lang): lang := fun x => L x \/ L' x. 28 | Definition lang_Union I (L: I -> lang): lang := fun x => exists i, L i x. 29 | Definition lang_inter (L L': lang): lang := fun x => L x /\ L' x. 30 | Definition lang_comp (L L': lang): lang := fun x => exists2 u, L u & exists2 v, L' v & x=u++v. 31 | Definition lang_conv (L: lang): lang := fun x => L (rev x). 32 | Definition lang_id: lang := fun x => x=nil. 33 | Definition lang_empty: lang := fun x => False. 34 | Definition lang_top: lang := fun x => True. 35 | Fixpoint lang_iter (L: lang) n: lang := 36 | match n with 37 | | 0 => lang_id 38 | | S n => lang_comp (lang_iter L n) L 39 | end. 40 | Definition lang_star (L: lang): lang := fun x => exists n, lang_iter L n x. 41 | 42 | Program Instance lang_Graph: Graph := { 43 | T := unit; 44 | X A B := lang; 45 | equal A B := lang_equal 46 | }. 47 | Next Obligation. 48 | constructor; unfold lang_equal; repeat intro; firstorder. 49 | Qed. 50 | 51 | Instance lang_SemiLattice_Ops: SemiLattice_Ops lang_Graph := { 52 | plus A B := lang_union; 53 | zero A B := lang_empty 54 | }. 55 | 56 | Instance lang_Monoid_Ops: Monoid_Ops lang_Graph := { 57 | dot A B C := lang_comp; 58 | one A := lang_id 59 | }. 60 | 61 | Instance lang_Star_Op: Star_Op lang_Graph := { 62 | star A := lang_star 63 | }. 64 | 65 | Instance lang_Converse_Op: Converse_Op lang_Graph := { 66 | conv A B := lang_conv 67 | }. 68 | 69 | Transparent equal. 70 | 71 | Instance lang_SemiLattice: SemiLattice lang_Graph. 72 | Proof. 73 | constructor; compute; firstorder. 74 | Qed. 75 | 76 | Instance lang_ConverseSemiRing: ConverseIdemSemiRing lang_Graph. 77 | Proof. 78 | constructor; (exact lang_SemiLattice || (try solve [intros; compute; firstorder])). 79 | 80 | intros ? ? ? ? L M N x. simpl. unfold lang_comp. 81 | split; intros [u Hu [v Hv ->]]. 82 | destruct Hv as [v' Hv [w Hw ->]]. repeat eexists; eauto. apply app_assoc. 83 | destruct Hu as [v' Hv' [w Hw ->]]. repeat eexists; eauto. symmetry. apply app_assoc. 84 | 85 | intros ? ? L x. simpl. unfold lang_comp. 86 | split; intro H. 87 | destruct H as [u -> [v Hv ->]]. assumption. 88 | exists nil; eauto. reflexivity. 89 | 90 | intros ? ? L x. unfold conv, lang_Converse_Op, lang_conv. rewrite rev_involutive. reflexivity. 91 | 92 | intros ? ? ? L M x. simpl. unfold conv, lang_Converse_Op, lang_conv, lang_comp. 93 | split; intros [u Hu [v Hv H]]. 94 | assert (Hx: x=rev v++rev u). rewrite <- distr_rev, <- H, rev_involutive. reflexivity. 95 | rewrite Hx. repeat eexists; rewrite rev_involutive; assumption. 96 | rewrite H, distr_rev. eauto. 97 | Qed. 98 | 99 | Definition lang_IdemSemiRing: IdemSemiRing lang_Graph := Converse.CISR_ISR. 100 | 101 | Notation LX := (@X lang_Graph tt tt). 102 | 103 | Lemma lang_leq n m: forall (a b: @X (lang_Graph) n m), a<==b <-> forall x, a x -> b x. 104 | Proof. compute. firstorder. Qed. 105 | 106 | Lemma lang_Union_spec I (L: I -> LX): forall L': LX, (lang_Union L: LX) <== L' <-> forall i, L i <== L'. 107 | Proof. 108 | intros. split; intro H. 109 | intro j. rewrite <- H. apply <- lang_leq. intros w Hw. exists j; assumption. 110 | apply <- lang_leq. intros w [j Hw]. setoid_rewrite lang_leq in H. eauto. 111 | Qed. 112 | 113 | Lemma leq_lang_Union I (L: I -> LX): forall i, L i <== lang_Union L. 114 | Proof. 115 | intros. apply -> (lang_Union_spec L). apply plus_idem. 116 | Qed. 117 | 118 | Instance lang_ConverseKleeneAlgebra: ConverseKleeneAlgebra lang_Graph. 119 | Proof. 120 | constructor; 121 | first [ 122 | exact lang_ConverseSemiRing | 123 | intros 124 | ]. 125 | intros p; split; intro H. 126 | destruct H as [H|[u [n Hu] [v Hv H]]]. 127 | exists O; trivial. 128 | exists (S n). exists u; trivial. exists v; trivial. 129 | destruct H as [[|n] H]. 130 | left; trivial. 131 | right. destruct H as [u Hu [v Hv H]]. exists u; trivial. exists n; trivial. exists v; trivial. 132 | 133 | apply <- lang_leq. intros w [u [n Hu] [v Hv ->]]. 134 | revert u Hu v Hv. induction n; intros u Hu v Hv. 135 | rewrite Hu. trivial. 136 | destruct Hu as [x Hx [y Hy ->]]. 137 | rewrite <- app_assoc. apply IHn; trivial. 138 | apply -> lang_leq; eauto. repeat eexists; trivial. 139 | Qed. 140 | 141 | Definition lang_KleeneAlgebra: KleeneAlgebra lang_Graph := Converse.CKA_KA. 142 | 143 | End Def. 144 | 145 | 146 | (** Import this module to work with languages *) 147 | Module Load. 148 | 149 | #[global] Existing Instance lang_Graph. 150 | #[global] Existing Instance lang_SemiLattice_Ops. 151 | #[global] Existing Instance lang_Monoid_Ops. 152 | #[global] Existing Instance lang_Converse_Op. 153 | #[global] Existing Instance lang_SemiLattice. 154 | #[global] Existing Instance lang_Star_Op. 155 | #[global] Existing Instance lang_KleeneAlgebra. 156 | 157 | Canonical Structure lang_Graph. 158 | 159 | Transparent equal plus dot one zero star. 160 | 161 | Notation LX A := (@X (@lang_Graph A) tt tt). 162 | Notation LMX A n m := (@X (@mx_Graph (@lang_Graph A) tt) (n%nat) (m%nat)). 163 | 164 | Ltac fold_langAlg A := 165 | change (@lang_equal A) with (@equal (@lang_Graph A) tt tt); 166 | change (@lang_id A) with (@one (@lang_Graph A) (@lang_Monoid_Ops A) tt); 167 | change (@lang_comp A) with (@dot (@lang_Graph A) (@lang_Monoid_Ops A) tt tt tt); 168 | change (@lang_union A) with (@plus (@lang_Graph A) (@lang_SemiLattice_Ops A) tt tt); 169 | change (@lang_empty A) with (@zero (@lang_Graph A) (@lang_SemiLattice_Ops A) tt tt); 170 | change (@lang_star A) with (@star (@lang_Graph A) (@lang_Star_Op A) tt). 171 | 172 | End Load. 173 | 174 | -------------------------------------------------------------------------------- /theories/Model_MinPlus.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** (min,+) Kleene algebra 10 | 11 | By taking matrices over this model, we get weighted graphs. For 12 | example, given a matrix [R] coding for the cost for moving from one 13 | state to another one, [R# i j] gives the cost of the shortest path 14 | from i to j. *) 15 | 16 | From ATBR Require Import Common. 17 | From ATBR Require Import Classes. 18 | From ATBR Require Converse. 19 | 20 | Set Implicit Arguments. 21 | Unset Strict Implicit. 22 | 23 | Definition onat := option nat. 24 | Notation infty := None. 25 | 26 | Definition mp_union (x y: onat): onat := 27 | match x,y with 28 | | infty,_ => y 29 | | _,infty => x 30 | | Some x, Some y => Some (min x y) 31 | end. 32 | Definition mp_comp (x y: onat): onat := 33 | match x,y with 34 | | infty,_ => infty 35 | | _,infty => infty 36 | | Some x, Some y => Some (Peano.plus x y) 37 | end. 38 | 39 | Definition mp_conv (x: onat): onat := x. 40 | Definition mp_id: onat := Some O. 41 | Definition mp_empty: onat := infty. 42 | Definition mp_star (_: onat): onat := mp_id. 43 | 44 | Section protect. 45 | 46 | Program Instance mp_Graph: Graph := { 47 | T := unit; 48 | X A B := onat; 49 | equal A B := eq 50 | }. 51 | 52 | Instance mp_SemiLattice_Ops: SemiLattice_Ops mp_Graph := { 53 | plus A B := mp_union; 54 | zero A B := mp_empty 55 | }. 56 | 57 | Instance mp_Monoid_Ops: Monoid_Ops mp_Graph := { 58 | dot A B C := mp_comp; 59 | one A := mp_id 60 | }. 61 | 62 | Instance mp_Star_Op: Star_Op mp_Graph := { 63 | star A := mp_star 64 | }. 65 | 66 | Instance mp_Converse_Op: Converse_Op mp_Graph := { 67 | conv A B := mp_conv 68 | }. 69 | 70 | Transparent equal. 71 | 72 | Import Nat. 73 | Instance mp_SemiLattice: SemiLattice mp_Graph. 74 | Proof. 75 | constructor; simpl. 76 | eauto with typeclass_instances. 77 | reflexivity. 78 | destruct x; simpl; trivial. rewrite min_id. reflexivity. 79 | destruct x; trivial. destruct y; trivial. destruct z; trivial. simpl. rewrite min_assoc. reflexivity. 80 | destruct x; trivial. destruct y; trivial. simpl. rewrite min_comm. reflexivity. 81 | destruct y; reflexivity. 82 | Qed. 83 | 84 | Instance mp_ConverseSemiRing: ConverseIdemSemiRing mp_Graph. 85 | Proof. 86 | constructor; simpl; eauto with typeclass_instances. 87 | destruct x; trivial. destruct y; trivial. destruct z; trivial. simpl. 88 | rewrite Nat.add_assoc. reflexivity. 89 | destruct x; reflexivity. 90 | destruct x; trivial. destruct y; trivial. simpl. rewrite Nat.add_comm. reflexivity. 91 | destruct y; reflexivity. 92 | destruct x; trivial. destruct y; trivial. simpl. rewrite min_comm. reflexivity. 93 | destruct y; reflexivity. 94 | destruct x; trivial. destruct y; trivial; destruct z; trivial. simpl. 95 | rewrite Nat.add_min_distr_r. reflexivity. 96 | Qed. 97 | 98 | Definition mp_IdemSemiRing: IdemSemiRing mp_Graph := Converse.CISR_ISR. 99 | 100 | Instance mp_ConverseKleeneAlgebra: ConverseKleeneAlgebra mp_Graph. 101 | Proof. 102 | constructor; simpl; unfold mp_star, mp_id; eauto with typeclass_instances. 103 | destruct a; trivial. 104 | destruct c; trivial. intros _. simpl. rewrite min_idempotent. reflexivity. 105 | Qed. 106 | 107 | Definition mp_KleeneAlgebra: KleeneAlgebra mp_Graph := Converse.CKA_KA. 108 | 109 | End protect. 110 | 111 | 112 | (** Import this module to work in the (min,+) algebra *) 113 | Module Load. 114 | 115 | #[global] Existing Instance mp_Graph. 116 | #[global] Existing Instance mp_SemiLattice_Ops. 117 | #[global] Existing Instance mp_Monoid_Ops. 118 | #[global] Existing Instance mp_Converse_Op. 119 | #[global] Existing Instance mp_SemiLattice. 120 | #[global] Existing Instance mp_Star_Op. 121 | #[global] Existing Instance mp_KleeneAlgebra. 122 | 123 | Canonical Structure mp_Graph. 124 | 125 | Transparent equal plus dot one zero star. 126 | 127 | Ltac fold_mpAlg := 128 | unfold mp_star; 129 | change (@eq onat) with (@equal mp_Graph tt tt); 130 | change (Some O) with (@one mp_Graph mp_Monoid_Ops tt); 131 | change mp_id with (@one mp_Graph mp_Monoid_Ops tt); 132 | change mp_comp with (@dot mp_Graph mp_Monoid_Ops tt tt tt); 133 | change mp_union with (@plus mp_Graph mp_SemiLattice_Ops tt tt); 134 | change (@None nat) with (@zero mp_Graph mp_SemiLattice_Ops tt tt); 135 | change mp_empty with (@zero mp_Graph mp_SemiLattice_Ops tt tt). 136 | 137 | End Load. 138 | -------------------------------------------------------------------------------- /theories/Model_Relations.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Model of heterogeneous binary relations *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Converse. 14 | Set Implicit Arguments. 15 | Unset Strict Implicit. 16 | 17 | Section Def. 18 | 19 | Definition rel A B := A -> B -> Prop. 20 | Definition rel_equal A B (R S: rel A B) := forall x y, R x y <-> S x y. 21 | Definition rel_union A B (R S: rel A B): rel A B := fun x y => R x y \/ S x y. 22 | Definition rel_inter A B (R S: rel A B): rel A B := fun x y => R x y /\ S x y. 23 | Definition rel_comp A B C (R: rel A B) (S: rel B C): rel A C := fun x z => exists2 y, R x y & S y z. 24 | Definition rel_conv A B (R: rel A B): rel B A := fun x y => R y x. 25 | Definition rel_id A: rel A A := @eq A. 26 | Definition rel_empty A B: rel A B := fun x y => False. 27 | Definition rel_top A B: rel A B := fun x y => True. 28 | Fixpoint rel_iter A (R: rel A A) n: rel A A := 29 | match n with 30 | | 0 => @rel_id A 31 | | S n => rel_comp (rel_iter R n) R 32 | end. 33 | Definition rel_star A (R: rel A A): rel A A := fun x y => exists n, rel_iter R n x y. 34 | 35 | Program Instance rel_Graph: Graph := { 36 | T := Type; 37 | X := rel; 38 | equal := rel_equal 39 | }. 40 | Next Obligation. 41 | constructor; unfold rel_equal; repeat intro; intuition. 42 | apply H in H0; trivial. 43 | apply H in H0; trivial. 44 | apply H, H0 in H1; trivial. 45 | apply H0, H in H1; trivial. 46 | Qed. 47 | 48 | Instance rel_SemiLattice_Ops: SemiLattice_Ops rel_Graph := { 49 | plus := rel_union; 50 | zero := rel_empty 51 | }. 52 | 53 | Instance rel_Monoid_Ops: Monoid_Ops rel_Graph := { 54 | dot := rel_comp; 55 | one := rel_id 56 | }. 57 | 58 | Instance rel_Star_Op: Star_Op rel_Graph := { 59 | star := rel_star 60 | }. 61 | 62 | Instance rel_Converse_Op: Converse_Op rel_Graph := { 63 | conv := rel_conv 64 | }. 65 | 66 | Transparent equal. 67 | 68 | Instance rel_SemiLattice: SemiLattice rel_Graph. 69 | Proof. 70 | constructor; compute; firstorder. 71 | Qed. 72 | 73 | 74 | Ltac destruct_ex := repeat match goal with 75 | | H : ex _ |- _ => destruct H 76 | | H : ex2 _ _ |- _ => destruct H 77 | | H : ?A \/ ?B |- _ => destruct H 78 | | H : ?A , H' : (forall (x : ?A), _ ) |- _ => specialize (H' H); intuition 79 | end. 80 | 81 | Instance rel_ConverseSemiRing: ConverseIdemSemiRing rel_Graph. 82 | Proof. 83 | constructor; (exact rel_SemiLattice || intros; compute; firstorder). 84 | destruct_ex; eauto. 85 | destruct_ex; eauto. 86 | subst; auto. 87 | Qed. 88 | 89 | Definition rel_IdemSemiRing: IdemSemiRing rel_Graph := Converse.CISR_ISR. 90 | 91 | 92 | Lemma rel_leq A B: forall (a b: @X (rel_Graph) A B), a<==b <-> forall x y, a x y -> b x y. 93 | Proof. 94 | compute. firstorder. 95 | Qed. 96 | 97 | Instance rel_ConverseKleeneAlgebra: ConverseKleeneAlgebra rel_Graph. 98 | Proof. 99 | constructor; 100 | first [ 101 | exact rel_ConverseSemiRing | 102 | intros 103 | ]. 104 | intros p q; split; intro H. 105 | destruct H as [H|[r [n H1] H2]]. 106 | exists O; trivial. 107 | exists (S n). exists r; trivial. 108 | destruct H as [[|n] H]. 109 | left; trivial. 110 | right. destruct H as [r H1 H2]. exists r; trivial. exists n; trivial. 111 | 112 | apply <- rel_leq. intros x y [z [n Hn] H2]. 113 | revert z Hn H2. induction n; intros z Hn H2. 114 | compute in Hn. rewrite Hn. trivial. 115 | destruct Hn as [t H1 H3]. 116 | apply IHn in H1. trivial. 117 | apply -> rel_leq; eauto. exists z; trivial. 118 | Qed. 119 | 120 | Definition rel_KleeneAlgebra: KleeneAlgebra rel_Graph := Converse.CKA_KA. 121 | 122 | End Def. 123 | 124 | 125 | (** Import this module to work with binary relations *) 126 | Module Load. 127 | 128 | #[global] Existing Instance rel_Graph. 129 | #[global] Existing Instance rel_SemiLattice_Ops. 130 | #[global] Existing Instance rel_Monoid_Ops. 131 | #[global] Existing Instance rel_Converse_Op. 132 | #[global] Existing Instance rel_SemiLattice. 133 | #[global] Existing Instance rel_Star_Op. 134 | #[global] Existing Instance rel_KleeneAlgebra. 135 | 136 | Canonical Structure rel_Graph. 137 | 138 | Transparent equal plus dot one zero star. 139 | 140 | Ltac fold_relAlg := 141 | change rel_equal with (@equal rel_Graph); 142 | change rel_id with (@one rel_Graph rel_Monoid_Ops); 143 | change rel_comp with (@dot rel_Graph rel_Monoid_Ops); 144 | change rel_union with (@plus rel_Graph rel_SemiLattice_Ops); 145 | change rel_empty with (@zero rel_Graph rel_SemiLattice_Ops); 146 | change rel_star with (@star rel_Graph rel_Star_Op). 147 | 148 | End Load. 149 | 150 | -------------------------------------------------------------------------------- /theories/Model_StdRelations.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Model of homegeneous binary relations, from Coq standard library *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Converse. 14 | From Coq Require Import Relations. 15 | 16 | Set Implicit Arguments. 17 | Unset Strict Implicit. 18 | 19 | Section Def. 20 | 21 | Context {A: Type}. 22 | 23 | Definition comp (R S: relation A): relation A := 24 | fun i k => exists j, R i j /\ S j k. 25 | Definition empty: relation A := fun x y => False. 26 | 27 | Program Instance rel_Graph: Graph := { 28 | T := unit; 29 | X n m := relation A; 30 | equal n m := same_relation A 31 | }. 32 | Next Obligation. 33 | unfold same_relation, inclusion. 34 | constructor; firstorder. 35 | Qed. 36 | 37 | Instance rel_SemiLattice_Ops: SemiLattice_Ops rel_Graph := { 38 | plus n m := union A; 39 | zero n m := empty 40 | }. 41 | 42 | Instance rel_Monoid_Ops: Monoid_Ops rel_Graph := { 43 | dot n m p := comp; 44 | one n := @eq A 45 | }. 46 | 47 | Instance rel_Star_Op: Star_Op rel_Graph := { 48 | star n := clos_refl_trans A 49 | }. 50 | 51 | Instance rel_Converse_Op: Converse_Op rel_Graph := { 52 | conv n m := transp A 53 | }. 54 | 55 | Transparent equal. 56 | 57 | Instance rel_SemiLattice: SemiLattice rel_Graph. 58 | Proof. constructor; compute; firstorder. Qed. 59 | 60 | 61 | Ltac destruct_ex := 62 | repeat 63 | match goal with 64 | | H : ex _ |- _ => destruct H 65 | | H : ex2 _ _ |- _ => destruct H 66 | | H : ?A \/ ?B |- _ => destruct H 67 | | H : ?A , H' : (forall (x : ?A), _ ) |- _ => 68 | specialize (H' H); intuition 69 | end. 70 | 71 | Instance rel_ConverseSemiRing: ConverseIdemSemiRing rel_Graph. 72 | Proof. 73 | constructor; (exact rel_SemiLattice || intros; compute; firstorder). 74 | destruct_ex; eauto. 75 | destruct_ex; eauto. 76 | subst; auto. 77 | Qed. 78 | 79 | Definition rel_IdemSemiRing: IdemSemiRing rel_Graph := Converse.CISR_ISR. 80 | 81 | 82 | Lemma rel_leq n m: forall (a b: @X rel_Graph n m), 83 | a<==b <-> forall x y, a x y -> b x y. 84 | Proof. compute. firstorder. Qed. 85 | 86 | Instance rel_ConverseKleeneAlgebra: ConverseKleeneAlgebra rel_Graph. 87 | Proof. 88 | constructor; 89 | first [ 90 | exact rel_ConverseSemiRing | 91 | intros 92 | ]. 93 | split; compute; intros x y H. 94 | destruct H as [->|[j [? ?]]]. 95 | constructor 2. 96 | econstructor 3. 97 | eassumption. 98 | constructor; assumption. 99 | rewrite rtn1_trans_equiv in H. 100 | inversion_clear H; auto. 101 | right. eexists; split; eauto. rewrite rtn1_trans_equiv. assumption. 102 | 103 | rewrite rel_leq in *. 104 | intros x y [z [Hxz Hzy]]. 105 | compute in Hxz. rewrite rtn1_trans_equiv in Hxz. 106 | induction Hxz; trivial. 107 | apply IHHxz. apply H. eexists; eauto. 108 | Qed. 109 | 110 | Definition rel_KleeneAlgebra: KleeneAlgebra rel_Graph := Converse.CKA_KA. 111 | 112 | End Def. 113 | 114 | 115 | (** Import this module to work with homogeneous binary relations *) 116 | Module Load. 117 | 118 | #[global] Existing Instance rel_Graph. 119 | #[global] Existing Instance rel_SemiLattice_Ops. 120 | #[global] Existing Instance rel_Monoid_Ops. 121 | #[global] Existing Instance rel_Converse_Op. 122 | #[global] Existing Instance rel_SemiLattice. 123 | #[global] Existing Instance rel_Star_Op. 124 | #[global] Existing Instance rel_KleeneAlgebra. 125 | 126 | Canonical Structure rel_Graph. 127 | 128 | Transparent equal plus dot one zero star. 129 | 130 | Ltac fold_relAlg A := 131 | change (same_relation A) with (@equal (@rel_Graph A) tt tt); 132 | change (@eq A) with (@one (@rel_Graph A) rel_Monoid_Ops tt); 133 | change (@comp A) with (@dot (@rel_Graph A) rel_Monoid_Ops tt tt tt); 134 | change (union A) with (@plus (@rel_Graph A) rel_SemiLattice_Ops tt tt); 135 | change (@empty A) with (@zero (@rel_Graph A) rel_SemiLattice_Ops tt tt); 136 | change (clos_refl_trans A) with (@star (@rel_Graph A) rel_Star_Op tt). 137 | 138 | (*begintests 139 | From ATBR Require Import DecideKleeneAlgebra. 140 | Goal forall A (R S: relation A), same_relation _ 141 | (clos_refl_trans _ (union _ R S)) 142 | (comp (clos_refl_trans _ R) 143 | (clos_refl_trans _ (comp S (clos_refl_trans _ R)))). 144 | Proof. 145 | intros. 146 | fold_relAlg A. 147 | kleene_reflexivity. 148 | Qed. 149 | Print Assumptions Unnamed_thm. 150 | endtests*) 151 | 152 | End Load. 153 | 154 | -------------------------------------------------------------------------------- /theories/MxFunctors.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (* Extension of functors on base structures to functors on matrices *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Import Monoid. 14 | From ATBR Require Import SemiLattice. 15 | From ATBR Require Import SemiRing. 16 | From ATBR Require Import KleeneAlgebra. 17 | From ATBR Require Import MxGraph. 18 | From ATBR Require Import MxSemiLattice. 19 | From ATBR Require Import MxSemiRing. 20 | From ATBR Require Import MxKleeneAlgebra. 21 | 22 | From ATBR Require Import Functors. 23 | 24 | Set Implicit Arguments. 25 | Unset Strict Implicit. 26 | Unset Printing Implicit Defensive. 27 | 28 | Transparent equal. 29 | 30 | Section Defs. 31 | 32 | Context {G1: Graph} {G2: Graph} 33 | {SLo1: SemiLattice_Ops G1} {SLo2: SemiLattice_Ops G2} 34 | {Mo1: Monoid_Ops G1} {Mo2: Monoid_Ops G2} 35 | {So1: Star_Op G1} {So2: Star_Op G2}. 36 | 37 | Variable F: functor G1 G2. 38 | Variable A: @T G1. 39 | 40 | Notation MG1 := (@mx_Graph G1 A). 41 | Notation MG2 := (@mx_Graph G2 (fT F A)). 42 | 43 | Definition mxF: functor MG1 MG2 := 44 | @Build_functor MG1 MG2 45 | (fun n => n) 46 | (fun n m M => box n m (fun i j => F _ _ (!M i j))). 47 | 48 | #[global] Instance mxgraph_functor {HF: graph_functor F}: graph_functor mxF. 49 | Proof. 50 | constructor. repeat intro. simpl. apply functor_compat. auto. 51 | Qed. 52 | 53 | #[global] Instance mxsemilattice_functor {HF: semilattice_functor F}: semilattice_functor mxF. 54 | Proof. 55 | constructor. 56 | apply mxgraph_functor. 57 | repeat intro; simpl. apply functor_plus. 58 | repeat intro; simpl. apply functor_zero. 59 | Qed. 60 | 61 | #[global] Instance mxsemiring_functor {SL1: SemiLattice G1} {SL2: SemiLattice G2} 62 | {HF: semiring_functor F}: semiring_functor mxF. 63 | Proof. 64 | constructor. constructor. 65 | 66 | apply mxgraph_functor. 67 | 68 | repeat intro; simpl. 69 | rewrite functor_sum. apply sum_compat. intros. apply functor_dot. 70 | 71 | repeat intro; simpl. intros. BoolView.nat_analyse. 72 | apply functor_one. apply functor_zero. 73 | 74 | apply mxsemilattice_functor. 75 | Qed. 76 | 77 | Lemma functor_mx_blocks: 78 | forall x y n m a b c d, 79 | mxF _ _ (@mx_blocks _ A x y n m a b c d) == 80 | mx_blocks (mxF _ _ a) (mxF _ _ b) (mxF _ _ c) (mxF _ _ d). 81 | Proof. 82 | repeat intro; simpl. destruct_blocks; reflexivity. 83 | Qed. 84 | 85 | Lemma functor_mx_sub: 86 | forall n' m' x y n m M, 87 | mxF _ _ (@mx_sub _ A n' m' x y n m M) = 88 | mx_sub x y n m (mxF _ _ M). 89 | Proof. reflexivity. Qed. 90 | 91 | Lemma functor_mx_of_scal: 92 | forall a, 93 | mxF _ _ (mx_of_scal a) = 94 | mx_of_scal (F _ _ a). 95 | Proof. reflexivity. Qed. 96 | 97 | Lemma functor_mx_to_scal: 98 | forall M, 99 | F _ _ (mx_to_scal M) = 100 | mx_to_scal (mxF _ _ M). 101 | Proof. reflexivity. Qed. 102 | 103 | #[global] Instance mxkleene_functor {KA1: KleeneAlgebra G1} {KA2: KleeneAlgebra G2} 104 | {HF: kleene_functor F}: kleene_functor mxF. 105 | Proof. 106 | constructor. 107 | apply mxsemiring_functor. 108 | 109 | intro n. induction n; intro a. 110 | intros i j Hi; inversion Hi. 111 | 112 | unfold star, mx_Star_Op in *. 113 | unfold star_rec at 1. fold (star_rec (A:=A) (n:=n)). unfold star_build. 114 | 115 | change (S n) with (1+n)%nat. 116 | rewrite functor_mx_blocks. 117 | rewrite functor_plus. 118 | rewrite !functor_dot. 119 | rewrite !functor_mx_of_scal. 120 | rewrite functor_star. 121 | rewrite functor_mx_to_scal. 122 | rewrite functor_plus. 123 | rewrite functor_dot. 124 | do 4 rewrite functor_dot at 1. 125 | do 9 rewrite IHn at 1. reflexivity. 126 | Qed. 127 | 128 | End Defs. 129 | -------------------------------------------------------------------------------- /theories/MxSemiLattice.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Properties of matrices over a semilattice (in particular, they form a semilattice) *) 10 | 11 | From ATBR Require Import Common. 12 | From ATBR Require Import Classes. 13 | From ATBR Require Import Graph. 14 | From ATBR Require Import MxGraph. 15 | From ATBR Require Import SemiLattice. 16 | From ATBR Require Import BoolView. 17 | 18 | Set Implicit Arguments. 19 | Unset Strict Implicit. 20 | Unset Printing Implicit Defensive. 21 | 22 | Transparent equal. 23 | 24 | Section Defs. 25 | 26 | Context `{SL: SemiLattice}. 27 | Variable A: T. 28 | Notation MX n m := (MX_ A n m). 29 | Notation mx_equal n m := (mx_equal_ A n m) (only parsing). 30 | 31 | Definition mx_plus n m (M N: MX n m): MX n m := box n m (fun i j => !M i j + !N i j). 32 | Definition mx_zero n m: MX n m := box n m (fun _ _ => 0). 33 | 34 | #[global] Instance mx_SemiLattice_Ops: SemiLattice_Ops (mx_Graph A) := { 35 | plus := mx_plus; 36 | zero := mx_zero }. 37 | 38 | Definition mx_point n m i j (x: X A A) : MX n m := 39 | box n m (fun i' j' => xif (eq_nat_bool i i' && eq_nat_bool j j') x 0). 40 | 41 | #[global] Instance mx_SemiLattice: SemiLattice (mx_Graph A). 42 | Proof. constructor; repeat intro; simpl in *; auto with algebra. Qed. 43 | 44 | End Defs. 45 | 46 | Notation mx_leq_ A n m := (@leq (mx_Graph A) (mx_SemiLattice_Ops A) (n%nat) (m%nat)) (only parsing). 47 | Notation "M <== [ n , m ] N" := (mx_leq_ _ n m M N) (at level 80) : A_scope. 48 | 49 | Section Props. 50 | 51 | Context `{SL: SemiLattice}. 52 | Variable A: T. 53 | Notation MX n m := (MX_ A n m). 54 | Notation mx_equal n m := (mx_equal_ A n m) (only parsing). 55 | Notation mx_leq n m := (mx_leq_ A n m) (only parsing). 56 | 57 | Lemma mx_blocks_plus x y n m: 58 | forall M M' N N' P P' Q Q', 59 | mx_blocks M N P Q + mx_blocks M' N' P' Q' 60 | == 61 | @mx_blocks _ A x y n m (M+M') (N+N') (P+P') (Q+Q'). 62 | Proof. 63 | simpl. intros. destruct_blocks; reflexivity. 64 | Qed. 65 | 66 | Lemma mx_blocks_zero x y n m: 67 | 0 == @mx_blocks _ A x y n m 0 0 0 0. 68 | Proof. 69 | simpl. intros. destruct_blocks; reflexivity. 70 | Qed. 71 | 72 | #[global] Instance mx_blocks_incr x y n m: 73 | Proper ( 74 | mx_leq x y ==> 75 | mx_leq x m ==> 76 | mx_leq n y ==> 77 | mx_leq n m ==> 78 | mx_leq (x+n) (y+m)) 79 | (@mx_blocks _ A x y n m). 80 | Proof. 81 | unfold Proper, respectful, leq; intros. 82 | rewrite mx_blocks_plus. 83 | auto with compat. 84 | Qed. 85 | 86 | Lemma mx_sub_plus x y n m n' m': forall M N: MX n' m', 87 | mx_sub x y n m M + mx_sub x y n m N == mx_sub x y n m (M+N). 88 | Proof. reflexivity. Qed. 89 | 90 | Lemma mx_of_scal_plus: forall a b: X A A, 91 | mx_of_scal a + mx_of_scal b == mx_of_scal (a+b). 92 | Proof. reflexivity. Qed. 93 | 94 | Lemma mx_of_scal_zero: 0 == mx_of_scal (0: X A A). 95 | Proof. reflexivity. Qed. 96 | 97 | Lemma mx_to_scal_plus: forall a b: MX 1 1, 98 | mx_to_scal a + mx_to_scal b == mx_to_scal (a+b). 99 | Proof. reflexivity. Qed. 100 | 101 | Lemma mx_to_scal_zero: (0: X A A) == mx_to_scal 0. 102 | Proof. reflexivity. Qed. 103 | 104 | 105 | Lemma mx_blocks_sum low up n m p q 106 | (a : nat -> MX n p) 107 | (b : nat -> MX n q) 108 | (c : nat -> MX m p) 109 | (d : nat -> MX m q): 110 | sum low up (fun u => mx_blocks (a u) (b u) (c u) (d u)) == 111 | mx_blocks (sum low up a) (sum low up b)(sum low up c)(sum low up d) . 112 | Proof. 113 | intros. 114 | induction up. 115 | simpl. intros. destruct_blocks; reflexivity. 116 | setoid_rewrite sum_enter_right. rewrite IHup. setoid_rewrite mx_blocks_plus. auto with compat. 117 | Qed. 118 | 119 | Lemma mx_blocks_leq x y n m: forall (a a': MX x y) b b' c c' (d d': MX n m), 120 | mx_blocks a b c d <== mx_blocks a' b' c' d' -> 121 | a<==a' /\ b<==b' /\ c<==c' /\ d<==d'. 122 | Proof. 123 | unfold leq. intros. apply mx_blocks_equal. 124 | rewrite <- mx_blocks_plus. assumption. 125 | Qed. 126 | 127 | 128 | (* matrices with a single non-zero value *) 129 | 130 | Lemma mx_point_zero: forall n m i j, 0 == mx_point n m i j (0: X A A). 131 | Proof. 132 | repeat intro. simpl. nat_analyse; reflexivity. 133 | Qed. 134 | 135 | Lemma mx_point_plus: forall n m i j (a b: X A A), mx_point n m i j a + mx_point n m i j b == mx_point n m i j (a+b). 136 | Proof. 137 | repeat intro. simpl. nat_analyse; trivial with algebra. 138 | Qed. 139 | 140 | Lemma mx_point_scal: forall (a: X A A), mx_point 1 1 0 0 a == mx_of_scal a. 141 | Proof. 142 | intro. mx_intros i j Hi Hj. reflexivity. 143 | Qed. 144 | 145 | Lemma mx_point_blocks00 n m x y: forall i j (a: X A A), i j 146 | mx_point (n+x) (m+y) i j a == mx_blocks (mx_point n m i j a) 0 0 0. 147 | Proof. 148 | simpl; intros. destruct_blocks; nat_analyse; trivial. 149 | Qed. 150 | 151 | Lemma mx_point_blocks01 n m x y: forall i j (a: X A A), i m<=j -> 152 | mx_point (n+x) (m+y) i j a == mx_blocks 0 (mx_point n y i (j-m) a) 0 0. 153 | Proof. 154 | simpl; intros. destruct_blocks; nat_analyse; trivial. 155 | Qed. 156 | 157 | Lemma mx_point_blocks10 n m x y: forall i j (a: X A A), n<=i -> j 158 | mx_point (n+x) (m+y) i j a == mx_blocks 0 0 (mx_point x m (i-n) j a) 0. 159 | Proof. 160 | simpl; intros. destruct_blocks; nat_analyse; trivial. 161 | Qed. 162 | 163 | Lemma mx_point_blocks11 n m x y: forall i j (a: X A A), n<=i -> m<=j -> 164 | mx_point (n+x) (m+y) i j a == mx_blocks 0 0 0 (mx_point x y (i-n) (j-m) a). 165 | Proof. 166 | simpl; intros. destruct_blocks; nat_analyse; trivial. 167 | Qed. 168 | 169 | #[global] Instance mx_point_compat n m i j: 170 | Proper (equal A A ==> mx_equal n m) (mx_point n m i j). 171 | Proof. 172 | repeat intro. simpl. nat_analyse; trivial. 173 | Qed. 174 | 175 | End Props. 176 | 177 | #[global] Hint Extern 1 (mx_equal_ _ _ _ _ _) => apply mx_point_compat: compat algebra. 178 | 179 | -------------------------------------------------------------------------------- /theories/MyFMapProperties.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Handler for FMap properties, provides the [find_tac] tactic. *) 10 | 11 | From Coq Require Import FMaps. 12 | From ATBR Require Import Common. 13 | From ATBR Require Import BoolView. 14 | 15 | Module MyMapProps (X : FMapInterface.S). 16 | Include FMapFacts.Properties X. 17 | Include F. 18 | 19 | Import X. 20 | 21 | Lemma mapsto_in: forall T x (y: T) d, MapsTo x y d -> In x d. 22 | Proof. intros. exists y. assumption. Qed. 23 | 24 | Lemma in_add_1: forall T x (y: T) d, In x (add x y d). 25 | Proof. intros. exists y. apply add_1. apply E.eq_refl. Qed. 26 | 27 | Lemma in_add_2: forall T x y (z: T) d, In x d -> In x (add y z d). 28 | Proof. 29 | intros. destruct (E.eq_dec y x). 30 | exists z. auto with map. 31 | destruct H as [w ?]. exists w. auto with map. 32 | Qed. 33 | 34 | #[global] Hint Resolve mapsto_in in_add_1 in_add_2 : map. 35 | 36 | Inductive find_spec_ind A k s : option A -> Prop := 37 | | find_spec_1 : forall x, MapsTo k x s -> find_spec_ind A k s (Some x) 38 | | find_spec_2 : ~In k s -> find_spec_ind A k s (None). 39 | 40 | Lemma find_spec : forall A k s, find_spec_ind A k s (find k s). 41 | Proof. 42 | intros. case_eq (find k s); intros; constructor; auto with map. 43 | intros [x Hx]. apply find_1 in Hx. rewrite H in Hx. discriminate. 44 | Qed. 45 | 46 | #[global] Instance find_view : Type_View find := {type_view := find_spec}. 47 | 48 | (** * Destructor for find *) 49 | Ltac find_analyse := 50 | repeat type_view find. 51 | 52 | Ltac find_tac := 53 | repeat ( 54 | match goal with 55 | | |- ?x = ?x => reflexivity 56 | 57 | | H : @MapsTo _ ?s ?x1 ?eps, H' : @MapsTo _ ?s ?x2 ?eps |- _ => 58 | let H'' := fresh in 59 | assert (H'' : x1 = x2) by (eapply MapsTo_fun; eauto); clear H'; destruct H'' 60 | | H : @MapsTo _ ?s ?x (@add _ ?t ?y ?eps) |- _ => 61 | revert H; map_iff; intros [[? ?] | [? ?]] 62 | | H : @MapsTo _ ?x ?b (@map _ _ ?f ?m) |- _ => 63 | rewrite map_mapsto_iff in H; 64 | destruct H as [?x [?H ?H]] 65 | | H : ~(@In _ ?x (@map _ _ ?f ?m)) |- _ => rewrite map_in_iff in H 66 | | H : @In _ ?x (map ?f ?m) |- _ => rewrite map_in_iff in H 67 | | H : ~ (@In _ ?k (@add _ ?k ?y ?s)) |- _ => exfalso; apply H; clear H; map_iff; firstorder 68 | | H : ~ (@In _ ?k (@add _ ?k' ?y ?s)), H' : @MapsTo _ ?k ?x ?s |- _ => 69 | exfalso; apply H; clear H; map_iff; firstorder 70 | | H : ~ (@In _ ?k ?s), H' : @MapsTo _ ?k ?x ?s |- _ => 71 | exfalso; apply H; clear H; map_iff; firstorder 72 | | H : ~ (@In _ ?k (@add _ ?k' ?y ?s)) |- _ => revert H; rewrite add_in_iff; intro H 73 | | H : ?s = ?s |- _ => clear H 74 | | H : ?s <> ?s |- _ => elim H; reflexivity 75 | | H : ?s = ?t |- _ => subst 76 | end); trivial. 77 | 78 | End MyMapProps. 79 | -------------------------------------------------------------------------------- /theories/MyFSets.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** This file defines the finite sets and finite maps modules we need 10 | in this development. 11 | 12 | TODO: Coq standard library has evolved in v8.3, so that (parts of) 13 | this file might no longer be useful. *) 14 | 15 | From Coq Require Export FMaps FSets. 16 | From Coq Require Import List. 17 | From Coq Require Import NArith. 18 | 19 | (** Functors to perform "transparent sealing". *) 20 | Module FSetHide (X : FSetInterface.S). 21 | Include X. 22 | End FSetHide. 23 | 24 | Module FMapHide (X : FMapInterface.S). 25 | Include X. 26 | End FMapHide. 27 | 28 | 29 | (** Building efficient ordered types *) 30 | Module Type OrderedTypeAlt. 31 | Parameter t : Type. 32 | 33 | Parameter compare : t -> t -> comparison. 34 | Infix "?=" := compare (at level 70, no associativity). 35 | 36 | Parameter compare_sym : forall x y, (y?=x) = CompOpp (x?=y). 37 | Parameter compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. 38 | Parameter reflect : forall x y, x ?= y = Eq -> x = y. 39 | End OrderedTypeAlt. 40 | 41 | Module Nat_as_OTA <: OrderedTypeAlt. 42 | Definition t := nat. 43 | Fixpoint compare x y := 44 | match x,y with 45 | | O,O => Eq 46 | | O,_ => Lt 47 | | _,O => Gt 48 | | S x, S y => compare x y 49 | end. 50 | Lemma compare_sym: forall x y, compare y x = CompOpp (compare x y). 51 | Proof. induction x; intros y; destruct y; simpl; auto. Qed. 52 | Lemma compare_trans: forall c x y z, compare x y = c -> compare y z = c -> compare x z = c. 53 | Proof. 54 | intros c x. revert c. 55 | induction x; intros c y z; destruct y; simpl; intro H; auto; subst; try discriminate H; 56 | destruct z; simpl; intro H'; eauto; try discriminate H'. 57 | Qed. 58 | Lemma reflect: forall x y, compare x y = Eq -> x = y. 59 | Proof. induction x; intros y; destruct y; simpl; intro H; auto; discriminate. Qed. 60 | End Nat_as_OTA. 61 | 62 | 63 | Module Pos_as_OTA <: OrderedTypeAlt. 64 | Definition t := positive. 65 | Fixpoint compare x y := 66 | match x,y with 67 | | xH, xH => Eq 68 | | xH, _ => Lt 69 | | _, xH => Gt 70 | | xO a, xO b => compare a b 71 | | xI a, xI b => compare a b 72 | | xI a, xO b => Gt 73 | | xO a, xI b => Lt 74 | end. 75 | Lemma compare_sym: forall x y, compare y x = CompOpp (compare x y). 76 | Proof. induction x; intros y; destruct y; simpl; auto. Qed. 77 | Lemma compare_trans: forall c x y z, compare x y = c -> compare y z = c -> compare x z = c. 78 | Proof. 79 | intros c x. revert c. 80 | induction x; intros c y z; destruct y; simpl; intro H; auto; subst; try discriminate H; 81 | destruct z; simpl; intro H'; eauto; try discriminate H'. 82 | Qed. 83 | Lemma reflect: forall x y, compare x y = Eq -> x = y. 84 | Proof. 85 | induction x; intros y; destruct y; simpl; intro H; auto; try discriminate. 86 | apply IHx in H. subst. reflexivity. 87 | apply IHx in H. subst. reflexivity. 88 | Qed. 89 | End Pos_as_OTA. 90 | 91 | 92 | 93 | (** Lexicographically ordered lists as [OrderedTypeAlt] *) 94 | Module ListOrderedTypeAlt(O: OrderedTypeAlt) <: OrderedTypeAlt. 95 | Definition t := list O.t. 96 | Fixpoint compare (m n: t) := 97 | match m,n with 98 | | nil,nil => Eq 99 | | nil,_ => Lt 100 | | _,nil => Gt 101 | | x::m, y::n => 102 | match O.compare x y with 103 | | Eq => compare m n 104 | | r => r 105 | end 106 | end. 107 | Lemma compare_sym: forall x y, compare y x = CompOpp (compare x y). 108 | Proof. 109 | induction x; intros y; destruct y; simpl; auto. 110 | rewrite O.compare_sym. 111 | destruct (O.compare a t0); simpl; auto. 112 | Qed. 113 | Lemma compare_trans: forall c x y z, compare x y = c -> compare y z = c -> compare x z = c. 114 | Proof. 115 | intros c x. revert c. 116 | induction x; intros c y z; destruct y; simpl; intro H; auto; subst; try discriminate H; 117 | destruct z; simpl; intro H'; eauto; try discriminate H'. 118 | revert H'. 119 | case_eq (O.compare a t0); case_eq (O.compare t0 t1); intros Hat0 Ht01 H'; 120 | (discriminate H' || (try rewrite <- H')); 121 | try rewrite (O.compare_trans _ _ _ _ Ht01 Hat0); eauto. 122 | (* here we do not need the [reflect] lemma *) 123 | apply O.reflect in Ht01. subst. rewrite Hat0. trivial. 124 | apply O.reflect in Ht01. subst. rewrite Hat0. trivial. 125 | apply O.reflect in Hat0. subst. rewrite Ht01. trivial. 126 | apply O.reflect in Hat0. subst. rewrite Ht01. trivial. 127 | Qed. 128 | Lemma reflect: forall x y, compare x y = Eq -> x = y. 129 | Proof. 130 | induction x; intros y; destruct y; simpl; intro H; auto; try discriminate. 131 | revert H. 132 | case_eq (O.compare a t0); intros H' H; try discriminate. 133 | apply O.reflect in H'. apply IHx in H. congruence. 134 | Qed. 135 | End ListOrderedTypeAlt. 136 | 137 | Module PairOrderedTypeAlt(O U: OrderedTypeAlt) <: OrderedTypeAlt. 138 | Definition t := (O.t * U.t)%type. 139 | Definition compare (m n: t) := 140 | let '(mo,mu) := m in 141 | let '(no,nu) := n in 142 | match O.compare mo no with 143 | | Eq => U.compare mu nu 144 | | r => r 145 | end. 146 | Lemma compare_sym: forall x y, compare y x = CompOpp (compare x y). 147 | Proof. 148 | intros [x x'] [y y']; simpl. 149 | rewrite O.compare_sym, U.compare_sym. destruct (O.compare x y); reflexivity. 150 | Qed. 151 | Lemma compare_trans: forall c x y z, compare x y = c -> compare y z = c -> compare x z = c. 152 | intros c [x x'] [y y'] [z z']; simpl. 153 | case_eq (O.compare x y); case_eq (O.compare y z); intros xy yz; simpl; 154 | try rewrite (O.compare_trans _ _ _ _ yz xy); intros; subst; try discriminate; auto. 155 | eauto using U.compare_trans. 156 | apply O.reflect in yz; subst. rewrite xy. trivial. 157 | apply O.reflect in yz; subst. rewrite xy. trivial. 158 | apply O.reflect in xy; subst. rewrite yz. trivial. 159 | apply O.reflect in xy; subst. rewrite yz. trivial. 160 | Qed. 161 | Lemma reflect: forall x y, compare x y = Eq -> x = y. 162 | Proof. 163 | intros [x x'] [y y']. simpl. 164 | case_eq (O.compare x y); intro xy; try apply O.reflect in xy; 165 | case_eq (U.compare x' y'); intro xy'; try apply U.reflect in xy'; 166 | intro; try discriminate; subst; auto. 167 | Qed. 168 | End PairOrderedTypeAlt. 169 | 170 | 171 | 172 | 173 | (** Here is an efficient definition of [OrderedType_from_Alt] : an 174 | [abstract] is used in the definition of compare, to avoid useless reductions.*) 175 | 176 | Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. 177 | Import O. 178 | Definition t := t. 179 | 180 | Definition eq x y := (x?=y) = Eq. 181 | Definition lt x y := (x?=y) = Lt. 182 | 183 | Lemma eq_refl : forall x, eq x x. 184 | Proof. 185 | intro x. 186 | unfold eq. 187 | assert (H:=compare_sym x x). 188 | destruct (x ?= x); simpl in *; try discriminate; auto. 189 | Qed. 190 | 191 | Lemma eq_sym : forall x y, eq x y -> eq y x. 192 | Proof. 193 | unfold eq; intros. 194 | rewrite compare_sym. 195 | rewrite H; simpl; auto. 196 | Qed. 197 | 198 | Definition eq_trans := (compare_trans Eq). 199 | 200 | Definition lt_trans := (compare_trans Lt). 201 | 202 | Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. 203 | Proof. 204 | unfold eq, lt; intros. 205 | rewrite H; discriminate. 206 | Qed. 207 | 208 | Definition compare : forall x y, Compare lt eq x y. 209 | Proof. 210 | intros. 211 | case_eq (x ?= y); intros. 212 | apply EQ; trivial. 213 | apply LT; trivial. 214 | (* Here the abstract prevent useless reductions *) 215 | apply GT; abstract (red; rewrite compare_sym; rewrite H; trivial). 216 | Defined. 217 | 218 | Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. 219 | Proof. 220 | intros; unfold eq. 221 | case (x ?= y); [ left | right | right ]; auto; discriminate. 222 | Defined. 223 | 224 | End OrderedType_from_Alt. 225 | 226 | 227 | Module PairOrderedType(O U: OrderedTypeAlt) <: OrderedType. 228 | Module P := PairOrderedTypeAlt O U. 229 | Include OrderedType_from_Alt P. 230 | End PairOrderedType. 231 | 232 | 233 | 234 | Module Nat_as_OT := OrderedType_from_Alt Nat_as_OTA. 235 | Module Pos_as_OT := OrderedType_from_Alt Pos_as_OTA. 236 | 237 | -------------------------------------------------------------------------------- /theories/Reification.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | 10 | (** Inductives (syntax) and evaluation functions for reifying the various classes from [Classes] *) 11 | 12 | 13 | From ATBR Require Import Common Classes. 14 | From Coq Require Import FMapPositive. 15 | From Coq Require Import Eqdep. 16 | 17 | Set Implicit Arguments. 18 | Unset Strict Implicit. 19 | Set Asymmetric Patterns. 20 | 21 | (* generic environments *) 22 | Definition sigma := PositiveMap.t. 23 | Definition sigma_get A default (map: sigma A) (n: positive) : A := 24 | match PositiveMap.find n map with 25 | | None => default 26 | | Some x => x 27 | end. 28 | Definition sigma_add := @PositiveMap.add. 29 | Definition sigma_empty := @PositiveMap.empty. 30 | 31 | 32 | (* packaged typed values *) 33 | Record Pack {G: Graph} typ := pack { src_p: positive; tgt_p: positive; unpack: X (typ src_p) (typ tgt_p) }. 34 | 35 | (* Value environment *) 36 | Class Env {G: Graph} := env { typ: positive -> T; val: positive -> Pack typ }. 37 | 38 | (* acces to domain/codomain informations *) 39 | Definition src `{env: Env} i := typ (src_p (val i)). 40 | Definition tgt `{env: Env} i := typ (tgt_p (val i)). 41 | 42 | 43 | (* heterogeneous dependent equality over pairs of positives *) 44 | Section S. 45 | Context `{env: Env}. 46 | 47 | Definition eqd n m p q (x: X (typ n) (typ m)) (y: X (typ p) (typ q)) := 48 | eq_dep (prod positive positive) (fun i => X (typ (fst i)) (typ (snd i))) (n,m) x (p,q) y. 49 | 50 | Lemma pos_eq_dec: forall n m: positive, {n=m}+{n<>m}. 51 | Proof. decide equality. Qed. 52 | 53 | Lemma eqd_inj: forall n m x y, @eqd n m n m x y -> x = y. 54 | Proof. intros. apply Eqdep_dec.eq_dep_eq_dec in H; trivial. decide equality; apply pos_eq_dec. Qed. 55 | 56 | End S. 57 | Infix " [=] " := eqd (at level 70). 58 | 59 | Module Semiring. 60 | Section S. 61 | Context `{env: Env}. 62 | Inductive X: positive -> positive -> Type := 63 | | dot: forall A B C, X A B -> X B C -> X A C 64 | | one: forall A, X A A 65 | | plus: forall A B, X A B -> X A B -> X A B 66 | | zero: forall A B, X A B 67 | | var: forall i, X (src_p (val i)) (tgt_p (val i)). 68 | Context {Mo: Monoid_Ops G} {SLo: SemiLattice_Ops G}. 69 | Fixpoint eval n m (x: X n m): Classes.X (typ n) (typ m) := 70 | match x with 71 | | dot _ _ _ x y => eval x * eval y 72 | | one _ => 1 73 | | plus _ _ x y => eval x + eval y 74 | | zero _ _ => 0 75 | | var i => unpack (val i) 76 | end. 77 | End S. 78 | End Semiring. 79 | 80 | Module KA. 81 | Section S. 82 | Context `{env: Env}. 83 | Inductive X: positive -> positive -> Type := 84 | | dot: forall A B C, X A B -> X B C -> X A C 85 | | one: forall A, X A A 86 | | plus: forall A B, X A B -> X A B -> X A B 87 | | zero: forall A B, X A B 88 | | star: forall A, X A A -> X A A 89 | | var: forall i, X (src_p (val i)) (tgt_p (val i)). 90 | Context {Mo: Monoid_Ops G} {SLo: SemiLattice_Ops G} {Ko: Star_Op G}. 91 | Fixpoint eval n m (x: X n m): Classes.X (typ n) (typ m) := 92 | match x with 93 | | dot _ _ _ x y => eval x * eval y 94 | | one _ => 1 95 | | plus _ _ x y => eval x + eval y 96 | | zero _ _ => 0 97 | | star _ x => eval x # 98 | | var i => unpack (val i) 99 | end. 100 | End S. 101 | End KA. 102 | 103 | Declare ML Module "reification_plugin:coq-atbr.plugin". 104 | -------------------------------------------------------------------------------- /theories/StrictKleeneAlgebra.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Class of "Strict Kleene Algebras" : those without a zero; 10 | extension of the [kleene_reflexivity] tactic to these structures, 11 | using a faithful embedding. *) 12 | 13 | From ATBR Require Import Common. 14 | From ATBR Require Import Classes. 15 | From ATBR Require Import DecideKleeneAlgebra. 16 | Set Implicit Arguments. 17 | Unset Printing Implicit Defensive. 18 | 19 | Bind Scope SA_scope with X. 20 | 21 | (** Strict Kleene Algebras operations *) 22 | Class SKA_Ops (G: Graph) := { 23 | dot: forall A B C, X A B -> X B C -> X A C; 24 | one: forall A, X A A; 25 | plus: forall A B, X A B -> X A B -> X A B; 26 | star: forall A, X A A -> X A A; 27 | leq: forall A B: T, relation (X A B) := fun A B x y => equal A B (plus A B x y) y 28 | }. 29 | 30 | 31 | Notation "x == y" := (equal _ _ x y) (at level 70): SA_scope. 32 | Notation "x <== y" := (leq _ _ x y) (at level 70): SA_scope. 33 | Notation "x * y" := (dot _ _ _ x y) (at level 40, left associativity): SA_scope. 34 | Notation "x + y" := (plus _ _ x y) (at level 50, left associativity): SA_scope. 35 | Notation "x #" := (star _ x) (at level 15, left associativity): SA_scope. 36 | Notation "1" := (one _): SA_scope. 37 | 38 | Close Scope A_scope. 39 | Open Scope SA_scope. 40 | Delimit Scope SA_scope with SA. 41 | 42 | (** Strict Kleene Algebras axioms *) 43 | Class StrictKleeneAlgebra {G: Graph} {Ops: SKA_Ops G} := { 44 | dot_compat:: 45 | forall A B C, Proper (equal A B ==> equal B C ==> equal A C) (dot A B C); 46 | plus_compat:: 47 | forall A B, Proper (equal A B ==> equal A B ==> equal A B) (plus A B); 48 | dot_assoc: forall A B C D (x: X A B) y (z: X C D), x*(y*z) == (x*y)*z; 49 | dot_neutral_left: forall A B (x: X A B), 1*x == x; 50 | dot_neutral_right: forall A B (x: X A B), x*1 == x; 51 | plus_idem: forall A B (x: X A B), x+x == x; 52 | plus_assoc: forall A B (x y z: X A B), x+(y+z) == (x+y)+z; 53 | plus_com: forall A B (x y: X A B), x+y == y+x; 54 | dot_distr_left: forall A B C (x y: X A B) (z: X B C), (x+y)*z == x*z + y*z; 55 | dot_distr_right: forall A B C (x y: X B A) (z: X C B), z*(x+y) == z*x + z*y; 56 | star_make_left: forall A (a:X A A), 1 + a#*a == a#; 57 | star_destruct_left: forall A B (a: X A A) (c: X A B), a*c <== c -> a#*c <== c; 58 | star_destruct_right: forall A B (a: X A A) (c: X B A), c*a <== c -> c*a# <== c 59 | }. 60 | Arguments StrictKleeneAlgebra G {Ops}. 61 | 62 | (** Lifting an equivalence relation to option types *) 63 | 64 | Section oe. 65 | Variable A: Type. 66 | Variable R: relation A. 67 | Inductive oequal: relation (option A) := 68 | | oe_some: forall x y, R x y -> oequal (Some x) (Some y) 69 | | oe_none: oequal None None. 70 | Hypothesis HR: Equivalence R. 71 | Lemma oequal_equivalence: Equivalence oequal. 72 | Proof. 73 | constructor. 74 | intros [x|]; constructor. reflexivity. 75 | intros x y [x' y' H|]; constructor. symmetry. assumption. 76 | intros x y z [x' y' H|] H'; trivial. 77 | inversion_clear H'. constructor. rewrite H. assumption. 78 | Qed. 79 | End oe. 80 | 81 | Unset Strict Implicit. 82 | 83 | (** Definition of the faithful embedding from Strict Kleene Algebras 84 | to Kleene Algebras *) 85 | 86 | Section F. 87 | Context G Ops `{@StrictKleeneAlgebra G Ops}. 88 | 89 | Program Instance oGraph: Graph := { 90 | T := T; 91 | X A B := option (X A B); 92 | equal A B := oequal (equal A B) 93 | }. 94 | Obligation 1. 95 | intros. apply oequal_equivalence, G. 96 | Defined. 97 | 98 | Definition inj A B (x: @X G A B): @X oGraph A B := Some x. 99 | Lemma faithful: forall A B (x y: X A B), inj x == inj y -> x == y. 100 | Proof. 101 | intros A B x y Hxy. inversion_clear Hxy. assumption. 102 | Qed. 103 | 104 | #[global] Instance oMonoid_Ops: Monoid_Ops oGraph := { 105 | dot A B C x y := 106 | match x,y with 107 | | Some x, Some y => Some (x*y) 108 | | _,_ => None 109 | end; 110 | one A := Some 1 111 | }. 112 | 113 | #[global] Instance oSemiLattice_Ops: SemiLattice_Ops oGraph := { 114 | plus A B x y := 115 | match x,y with 116 | | None,y => y 117 | | x,None => x 118 | | Some x, Some y => Some (x+y) 119 | end; 120 | zero A B := None 121 | }. 122 | 123 | #[global] Instance oStar_Op: Star_Op oGraph := { 124 | star A x := 125 | match x with 126 | | None => Some 1 127 | | Some x => Some (x#) 128 | end 129 | }. 130 | 131 | Instance oMonoid: Monoid oGraph. 132 | Proof. 133 | constructor; intros. 134 | intros _ _ [x x' Hx|] _ _ [y y' Hy|]; simpl; constructor. 135 | apply dot_compat; assumption. 136 | destruct x; try constructor. 137 | destruct y; try constructor. 138 | destruct z; constructor. apply dot_assoc. 139 | destruct x; simpl; constructor. apply dot_neutral_left. 140 | destruct x; simpl; constructor. apply dot_neutral_right. 141 | Qed. 142 | 143 | Instance oSemiLattice: SemiLattice oGraph. 144 | Proof. 145 | constructor; intros. 146 | intros _ _ [x x' Hx|] _ _ [y y' Hy|]; simpl; constructor; trivial. 147 | apply plus_compat; assumption. 148 | destruct x; simpl; constructor. reflexivity. 149 | destruct x; simpl; constructor. apply plus_idem. 150 | destruct x; destruct y; destruct z; simpl; constructor; try reflexivity. 151 | apply plus_assoc. 152 | destruct x; destruct y; simpl; constructor; try reflexivity. 153 | apply plus_com. 154 | Qed. 155 | 156 | Instance oIdemSemiRing: IdemSemiRing oGraph. 157 | Proof. 158 | constructor; eauto with typeclass_instances; intros. 159 | destruct x; reflexivity. 160 | destruct x; destruct y; destruct z; simpl; constructor; try reflexivity. 161 | apply dot_distr_left. 162 | destruct x; destruct y; destruct z; simpl; constructor; try reflexivity. 163 | apply dot_distr_right. 164 | Qed. 165 | 166 | #[global] Instance oKleeneAlgebra: KleeneAlgebra oGraph. 167 | Proof. 168 | constructor; eauto with typeclass_instances. 169 | intros A [a|]; simpl; constructor; try reflexivity. 170 | apply star_make_left. 171 | intros A B [a|] [c|] Hac; simpl in *; try constructor. 172 | apply star_destruct_left. inversion_clear Hac. assumption. 173 | rewrite dot_neutral_left. apply plus_idem. 174 | intros A B [a|] [c|] Hac; simpl in *; try constructor. 175 | apply star_destruct_right. inversion_clear Hac. assumption. 176 | rewrite dot_neutral_right. apply plus_idem. 177 | Qed. 178 | End F. 179 | 180 | (** The exported tactic embeds the goal in Kleene algebras and calls [kleene_reflexivity] *) 181 | Ltac skleene_reflexivity := 182 | (* [parse] converts an expression of strict Kleene algebras into an expression of Kleene algebras *) 183 | let rec parse t := 184 | match t with 185 | | @dot ?G ?O ?A ?B ?C ?x ?y => 186 | let x := parse x in 187 | let y := parse y in 188 | constr:(@Classes.dot (@oGraph G) (@oMonoid_Ops G O) A B C x y) 189 | | @one ?G ?O ?A => 190 | constr:(@Classes.one (@oGraph G) (@oMonoid_Ops G O) A) 191 | | @plus ?G ?O ?A ?B ?x ?y => 192 | let x := parse x in 193 | let y := parse y in 194 | constr:(@Classes.plus (@oGraph G) (@oSemiLattice_Ops G O) A B x y) 195 | | @star ?G ?O ?A ?x => 196 | let x := parse x in 197 | constr:(@Classes.star (@oGraph G) (@oStar_Op G O) A x) 198 | | _ => constr:(inj t) 199 | end 200 | in 201 | unfold leq; 202 | lazymatch goal with 203 | | |- @equal ?G ?A ?B ?x ?y => 204 | let x := parse x in 205 | let y := parse y in 206 | apply faithful; change (@equal (@oGraph G) A B x y); kleene_reflexivity 207 | end. 208 | 209 | (*begintests 210 | Section t. 211 | Context `{StrictKleeneAlgebra}. 212 | Lemma test: forall A B (a: X A B) (b: X B A), a*(b*a)# == (a*b)#*a. 213 | Proof. 214 | intros. 215 | skleene_reflexivity. 216 | Qed. 217 | Lemma test': forall A (a b: X A A), (a+b+1)# == a#*(b*a#)#. 218 | Proof. 219 | intros. 220 | skleene_reflexivity. 221 | Qed. 222 | Lemma test'': forall A (a b: X A A), (a*a+b)# <== a#*(b*a#)#. 223 | Proof. 224 | intros. 225 | skleene_reflexivity. 226 | Qed. 227 | Lemma test''': forall A (a b: X A A), (a*a+b)# <== a*(b*a#)#. 228 | Proof. 229 | intros. 230 | try skleene_reflexivity. 231 | Abort. 232 | End t. 233 | endtests*) 234 | -------------------------------------------------------------------------------- /theories/StrictStarForm.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Definition of the "strict star form" property for regular expressions, 10 | together with an algorithm to put any regex into a strict star form one. 11 | 12 | 13 | Proof of correctness and completeness. 14 | Definition of the corresponding [kleene_ssf] tactic. 15 | *) 16 | 17 | From ATBR Require Import Common. 18 | From ATBR Require Import Classes. 19 | From ATBR Require Import Graph. 20 | From ATBR Require Import SemiLattice. 21 | From ATBR Require Import Monoid. 22 | From ATBR Require Import SemiRing. 23 | From ATBR Require Import KleeneAlgebra. 24 | From ATBR Require Import Model_RegExp. 25 | Import RegExp.Load. 26 | From ATBR Require Reification. 27 | From Coq Require Import Bool. 28 | 29 | Open Scope lazy_bool_scope. 30 | 31 | 32 | (* A regexp is [strict] if it does not accept the empty word *) 33 | Inductive strict: regex -> Prop := 34 | | strict_zero: strict 0 35 | | strict_var: forall i, strict (RegExp.var i) 36 | | strict_plus: forall a b, strict a -> strict b -> strict (a+b) 37 | | strict_dot_l: forall a b, strict a -> strict (a*b) 38 | | strict_dot_r: forall a b, strict b -> strict (a*b). 39 | 40 | 41 | (* Conversely, a regexp is [non_strict] if it does accept the empty word *) 42 | Inductive non_strict: regex -> Prop := 43 | | non_strict_one: non_strict 1 44 | | non_strict_star: forall a, non_strict (a#) 45 | | non_strict_dot: forall a b, non_strict a -> non_strict b -> non_strict (a*b) 46 | | non_strict_plus_l: forall a b, non_strict a -> non_strict (a+b) 47 | | non_strict_plus_r: forall a b, non_strict b -> non_strict (a+b). 48 | 49 | Lemma non_strict_not_strict: forall a, non_strict a -> ~ strict a. 50 | Proof. induction 1; intro Ha; inversion_clear Ha; auto. Qed. 51 | 52 | 53 | (* A regexp is [in_star_normal_form] if all stared sub-terms are strict *) 54 | Inductive strict_star_form: regex -> Prop := 55 | | ssf_zero: strict_star_form 0 56 | | ssf_one: strict_star_form 1 57 | | ssf_var: forall i, strict_star_form (RegExp.var i) 58 | | ssf_star: forall a, strict_star_form a -> strict a -> strict_star_form (a#) 59 | | ssf_plus: forall a b, strict_star_form a -> strict_star_form b -> strict_star_form (a+b) 60 | | ssf_dot: forall a b, strict_star_form a -> strict_star_form b -> strict_star_form (a*b). 61 | 62 | (* The function [rewrite] below converts a regexp into an equivalent one, in star normal form *) 63 | 64 | Fixpoint contains_one e : bool := 65 | match e with 66 | | RegExp.star a => true 67 | | RegExp.one => true 68 | | RegExp.plus a b => contains_one a ||| contains_one b 69 | | RegExp.dot a b => contains_one a &&& contains_one b 70 | | _ => false 71 | end. 72 | 73 | Definition plus_but_one a b := 74 | if RegExp.is_one a then b 75 | else if RegExp.is_one b then a 76 | else RegExp.plus a b. 77 | 78 | Fixpoint remove e := 79 | if contains_one e then 80 | match e with 81 | | RegExp.plus a b => plus_but_one (remove a) (remove b) 82 | | RegExp.dot a b => plus_but_one (remove a) (remove b) 83 | | RegExp.star e => e 84 | | e => e 85 | end 86 | else e. 87 | 88 | Definition dot' a b := 89 | if RegExp.is_one a then b 90 | else if RegExp.is_one b then a 91 | else RegExp.dot a b. 92 | 93 | Definition star' a := 94 | if RegExp.is_one a then RegExp.one else RegExp.star a. 95 | 96 | Fixpoint ssf e := 97 | match e with 98 | | RegExp.plus a b => RegExp.plus (ssf a) (ssf b) 99 | | RegExp.dot a b => dot' (ssf a) (ssf b) 100 | | RegExp.star e => star' (remove (ssf e)) 101 | | e => e 102 | end. 103 | 104 | Lemma star_plus_one: forall a: regex, (1+a)# == a#. 105 | Proof. 106 | intros. 107 | rewrite star_distr, star_one, dot_neutral_right, dot_neutral_left. reflexivity. 108 | Qed. 109 | 110 | Lemma star_plus_star_1: forall a b: regex, (a+b)# == (a#+b)#. 111 | intros. 112 | setoid_rewrite star_distr. setoid_rewrite star_idem. reflexivity. 113 | Qed. 114 | 115 | Lemma star_plus_star: forall a b: regex, (a+b)# == (a#+b#)#. 116 | Proof. 117 | intros. 118 | rewrite star_plus_star_1. rewrite plus_com. rewrite star_plus_star_1. rewrite plus_com. reflexivity. 119 | Qed. 120 | 121 | Lemma star_plus_but_one: forall a b: regex, (plus_but_one a b) # == (a + b)#. 122 | Proof. 123 | intros. 124 | unfold plus_but_one; RegExp.destruct_tests; fold_regex. 125 | rewrite star_plus_one. reflexivity. 126 | rewrite plus_com. rewrite star_plus_one. reflexivity. 127 | reflexivity. 128 | Qed. 129 | 130 | Lemma star'_star: forall a: regex, star' a == a# . 131 | Proof. 132 | intros; unfold star'; RegExp.destruct_tests; fold_regex; auto with algebra. 133 | Qed. 134 | 135 | Lemma dot'_dot: forall a b: regex, dot' a b == a * b. 136 | Proof. 137 | intros; unfold dot'; RegExp.destruct_tests; fold_regex; auto with algebra. 138 | Qed. 139 | 140 | 141 | Lemma contains_one_correct: forall a: regex, contains_one a = true -> a == a + 1. 142 | Proof. 143 | intros. 144 | induction a; simpl in H; fold_regex. 145 | auto with algebra. 146 | 147 | discriminate. 148 | 149 | destruct (contains_one a1). 2:discriminate. 150 | rewrite IHa1 by trivial. 151 | rewrite IHa2 by trivial. 152 | semiring_reflexivity. 153 | 154 | destruct (contains_one a1). 155 | rewrite IHa1 by trivial. semiring_reflexivity. 156 | rewrite IHa2 by trivial. semiring_reflexivity. 157 | 158 | rewrite <- star_make_left. semiring_reflexivity. 159 | 160 | discriminate. 161 | Qed. 162 | 163 | Lemma star_dot_leq_star_plus: forall a b: regex, (a*b)# <== (a+b)#. 164 | intros a b. 165 | (* TODO: debug very slow typeclass resolution... *) 166 | rewrite plus_com, star_distr. 167 | transitivity (1*(a*b#)#); [rewrite dot_neutral_left|]; auto with algebra. 168 | Qed. 169 | 170 | Lemma star_plus_star_dot: forall a b: regex, 171 | contains_one a = true -> contains_one b = true -> (a+b)# == (a*b)#. 172 | Proof. 173 | intros. 174 | rewrite (contains_one_correct a), (contains_one_correct b); trivial. 175 | apply leq_antisym. 176 | apply star_incr. semiring_reflexivity. 177 | apply star_dot_leq_star_plus. 178 | Qed. 179 | 180 | 181 | Lemma star_remove: forall a: regex, remove a # == a #. 182 | Proof. 183 | induction a; simpl; fold_regex; auto with algebra. 184 | case_eq (contains_one a1); intro Ha1; trivial. 185 | case_eq (contains_one a2); intro Ha2; trivial. 186 | rewrite star_plus_but_one. 187 | rewrite star_plus_star. rewrite IHa1, IHa2. rewrite <- star_plus_star. 188 | apply star_plus_star_dot; assumption. 189 | 190 | case (contains_one a1 ||| contains_one a2); trivial. 191 | rewrite star_plus_but_one. 192 | rewrite star_plus_star. rewrite IHa1, IHa2. 193 | symmetry. apply star_plus_star. 194 | Qed. 195 | 196 | 197 | (** correctness of the rewriting procedure *) 198 | Theorem ssf_correct: forall a: regex, ssf a == a. 199 | Proof. 200 | induction a; trivial; simpl; fold_regex; auto with compat. 201 | rewrite dot'_dot. auto with compat. 202 | rewrite star'_star. rewrite star_remove. auto with compat. 203 | Qed. 204 | 205 | 206 | (** tactic to put Kleene algebra expressions into strict star form *) 207 | Theorem ssf_correct': forall e, RegExp.equal e (ssf e). 208 | Proof. intros. apply RegExp.equal_sym, ssf_correct. Qed. 209 | Ltac kleene_ssf := kleene_normalize_ ssf_correct'. 210 | 211 | (* 212 | Section test. 213 | Context `{KA: KleeneAlgebra}. 214 | Goal forall A (a b: X A A), (a*1)#*b == b+(a+1)#+b*1#. 215 | intros. kleene_ssf. 216 | Abort. 217 | Goal forall A (a b: X A A), (a#+b)# <== b+((a+1)*b#)#. 218 | intros. kleene_ssf. 219 | Abort. 220 | End test. 221 | *) 222 | 223 | (** below: completeness of the rewriting procedure *) 224 | 225 | #[local] Hint Constructors strict_star_form : core. 226 | #[local] Hint Constructors strict : core. 227 | 228 | Lemma remove_nf: forall a, strict_star_form a -> strict_star_form (remove a). 229 | Proof. 230 | induction 1; simpl; auto. 231 | 232 | unfold plus_but_one. 233 | case_eq (contains_one a); intro Ha; simpl. 234 | RegExp.destruct_tests; auto. 235 | case_eq (contains_one b); intro Hb; simpl; auto. 236 | RegExp.destruct_tests; auto. 237 | 238 | unfold plus_but_one. 239 | case_eq (contains_one a); intro Ha; simpl. 240 | case_eq (contains_one b); intro Hb; simpl; auto. 241 | RegExp.destruct_tests; auto. 242 | RegExp.destruct_tests; auto. 243 | Qed. 244 | 245 | Lemma contains_one_false_strict: forall a, contains_one a = false -> strict a. 246 | Proof. 247 | induction a; simpl; intro Ha; try discriminate; auto. 248 | destruct (contains_one a1); auto. 249 | destruct (contains_one a1); auto. discriminate. 250 | Qed. 251 | #[local] Hint Resolve contains_one_false_strict : core. 252 | 253 | Lemma remove_strict: forall a, strict_star_form a -> RegExp.is_one (remove a) = false -> strict (remove a). 254 | Proof. 255 | induction 1; simpl; auto. 256 | 257 | unfold plus_but_one. 258 | case_eq (contains_one a); intro Ha; simpl. 259 | RegExp.destruct_tests; auto. 260 | case_eq (contains_one b); intro Hb; simpl; auto. 261 | RegExp.destruct_tests; auto. 262 | 263 | unfold plus_but_one. 264 | case_eq (contains_one a); intro Ha; simpl; auto. 265 | case_eq (contains_one b); intro Hb; simpl; auto. 266 | RegExp.destruct_tests; auto. 267 | Qed. 268 | 269 | (** completeness of the rewriting procedure *) 270 | Theorem ssf_complete: forall a, strict_star_form (ssf a). 271 | Proof. 272 | induction a; simpl; auto. 273 | unfold dot'. RegExp.destruct_tests; auto. 274 | unfold star'. RegExp.destruct_tests; auto. 275 | constructor. 276 | apply remove_nf; trivial. 277 | apply remove_strict; trivial. 278 | Qed. 279 | -------------------------------------------------------------------------------- /theories/Utils_WF.v: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* This is part of ATBR, it is distributed under the terms of the *) 3 | (* GNU Lesser General Public License version 3 *) 4 | (* (see file LICENSE for more details) *) 5 | (* *) 6 | (* Copyright 2009-2011: Thomas Braibant, Damien Pous. *) 7 | (**************************************************************************) 8 | 9 | (** Several results to ease the definition and the analysis of 10 | (well-founded) recursive functions *) 11 | 12 | From ATBR Require Import Common. 13 | Set Implicit Arguments. 14 | 15 | (** Trick to compute with well-founded recursions: lazily add 2^n 16 | Acc_intro constructors in front of a well_foundedness proof, so 17 | that the actual proof is never reached in practise *) 18 | Fixpoint guard A (R: A -> A -> Prop) n (wfR: well_founded R): well_founded R := 19 | match n with 20 | | 0 => wfR 21 | | S n => fun x => Acc_intro x (fun y _ => guard n (guard n wfR) y) 22 | end. 23 | 24 | (** Lexicographic product of two well-founded relations *) 25 | Section lexico. 26 | Variables A B: Type. 27 | Variable R: relation A. 28 | Variable S: relation B. 29 | Inductive lexico: relation (A*B) := 30 | | lexico_left: forall a a' b b', R a' a -> lexico (a',b') (a,b) 31 | | lexico_right: forall a b b', S b' b -> lexico (a,b') (a,b) 32 | . 33 | Hypothesis HR: well_founded R. 34 | Hypothesis HS: well_founded S. 35 | Theorem lexico_wf: well_founded lexico. 36 | Proof. 37 | intros [a b]. revert b. 38 | induction a as [a IHa] using (well_founded_induction HR). 39 | induction b as [b IHb] using (well_founded_induction HS). 40 | constructor. intros [a' b'] H. inversion_clear H; auto. 41 | Qed. 42 | End lexico. 43 | 44 | (** A relation contained in a well-founded relation is well-founded *) 45 | Section wf_incl. 46 | Variable A: Type. 47 | Variable S: relation A. 48 | Hypothesis HS: well_founded S. 49 | Variable R: relation A. 50 | Hypothesis H: forall a' a, R a' a -> S a' a. 51 | Theorem incl_wf: well_founded R. 52 | Proof. 53 | intros a. induction a as [a IHa] using (well_founded_induction HS). 54 | constructor. eauto. 55 | Qed. 56 | End wf_incl. 57 | 58 | (** Equivalent of [well_founded_ltof], using an underlying well-founded relation *) 59 | Section wf_of. 60 | Variables U V: Type. 61 | Variable f: U -> V. 62 | Variable R: relation V. 63 | Hypothesis HR: well_founded R. 64 | Definition rel_of: relation U := fun a' a => R (f a') (f a). 65 | Theorem rel_of_wf: well_founded rel_of. 66 | Proof. 67 | unfold rel_of. 68 | intro a. remember (f a) as fa. revert a Heqfa. 69 | induction fa as [fa IHa] using (well_founded_induction HR). 70 | constructor. intros a' H. subst. eauto. 71 | Qed. 72 | End wf_of. 73 | 74 | (** Similarly, in the other direction *) 75 | Section wf_to. 76 | Variables U V: Type. 77 | Variable f: U -> V. 78 | Variable R: relation U. 79 | Inductive rel_to: relation V := 80 | rel_to_intro: forall a' a, R a' a -> rel_to (f a') (f a). 81 | Hypothesis HR: well_founded rel_to. 82 | Theorem rel_to_wf: well_founded R. 83 | Proof. 84 | intro a. remember (f a) as fa. revert a Heqfa. 85 | induction fa as [fa IHa] using (well_founded_induction HR). 86 | constructor. intros a' H. subst. eapply IHa; trivial. constructor. trivial. 87 | Qed. 88 | End wf_to. 89 | 90 | (** Combination of the above reductions : reduction to a lexicographic product of two well-founded relations *) 91 | Section wf_lexico_incl. 92 | Variables U A B: Type. 93 | Variable f: U -> A*B. 94 | Variable RA: relation A. 95 | Variable RB: relation B. 96 | Hypothesis HRA: well_founded RA. 97 | Hypothesis HRB: well_founded RB. 98 | Variable R: relation U. 99 | Hypothesis H: forall u' u, R u' u -> lexico RA RB (f u') (f u). 100 | Theorem lexico_incl_wf: well_founded R. 101 | Proof. 102 | apply (rel_to_wf (f:=f)). eapply incl_wf. apply lexico_wf; eassumption. 103 | intros [a' b'] [a b] [u' u Hab]. auto. 104 | Qed. 105 | End wf_lexico_incl. 106 | 107 | 108 | (** Lazy partial fixpoint operators (lazy iterator): 109 | we use these functions to avoid the computation of a (2^n) worst-case 110 | bound which is never reached in practise *) 111 | Section powerfix. 112 | 113 | Variables A B: Type. 114 | Notation Fun := (A -> B). 115 | 116 | (** the three following functions "iterate" their [f] argument lazily: iteration stops whenever [f] 117 | no longer makes recursive calls. 118 | - [powerfix' n f k] iterates [f] at most [(2^n-1)] times and then yields to [k] 119 | - [powerfix n f k] iterates [f] at most [(2^n)] times and then yields to [k] 120 | - [linearfix n f k] iterates [f] at most [n] times and then yields to [k] 121 | *) 122 | Fixpoint powerfix' n (f: Fun -> Fun) (k: Fun): Fun := 123 | fun a => match n with O => k a | S n => f (powerfix' n f (powerfix' n f k)) a end. 124 | Definition powerfix n f k a := f (powerfix' n f k) a. 125 | Fixpoint linearfix n (f: Fun -> Fun) (k: Fun): Fun := 126 | fun a => match n with O => k a | S n => f (linearfix n f k) a end. 127 | 128 | (** [power n = 2^n] *) 129 | Fixpoint power n := match n with O => 1 | S n => 2*power n end. 130 | 131 | Lemma power_positive: forall n, 0 < power n. 132 | Proof. induction n; simpl; lia. Qed. 133 | 134 | (** Characterisation of [powerfix] with [linearfix] *) 135 | Section linear_carac. 136 | 137 | Context {R} `{E: Equivalence B R}. 138 | Variable f: Fun -> Fun. 139 | (** the functional [f] as to use its first argument "in extension" *) 140 | Hypothesis Hf: Proper (pointwise_relation A R ==> @eq A ==> R) f. 141 | 142 | Instance linearfix_compat n: 143 | Proper (pointwise_relation A R ==> pointwise_relation A R) (linearfix n f). 144 | Proof. 145 | induction n; intros k k' H a; simpl. 146 | apply H. 147 | apply Hf; auto. 148 | Qed. 149 | 150 | Lemma linearfix_plus: forall n m k, pointwise_relation A R 151 | (linearfix n f (linearfix m f k)) (linearfix (n + m) f k). 152 | Proof. 153 | induction n; intros m k a; simpl. 154 | reflexivity. 155 | rewrite IHn. reflexivity. 156 | Qed. 157 | 158 | Instance powerfix'_compat n: 159 | Proper (pointwise_relation A R ==> pointwise_relation A R) (powerfix' n f). 160 | Proof. 161 | induction n; intros k k' H a; simpl. 162 | apply H. 163 | apply Hf; auto. 164 | Qed. 165 | 166 | Instance powerfix_compat n: 167 | Proper (pointwise_relation A R ==> pointwise_relation A R) (powerfix n f). 168 | Proof. 169 | intros k k' H. unfold powerfix. setoid_rewrite H. reflexivity. 170 | Qed. 171 | 172 | Lemma powerfix'_linearfix: forall n k, 173 | pointwise_relation A R (powerfix' n f k) (linearfix (pred (power n)) f k). 174 | Proof. 175 | induction n; intros; simpl; intro a. 176 | reflexivity. 177 | rewrite IHn. rewrite IHn. 178 | pose proof (power_positive n). 179 | replace (pred (power n + (power n + 0))) with (S (pred (power n) + pred (power n))) by lia. 180 | rewrite linearfix_plus. 181 | reflexivity. 182 | Qed. 183 | 184 | (** The expected characterisation *) 185 | Theorem powerfix_linearfix: forall n k, 186 | pointwise_relation A R (powerfix n f k) (linearfix (power n) f k). 187 | Proof. 188 | intros. unfold powerfix. setoid_rewrite powerfix'_linearfix. 189 | generalize (power_positive n). destruct (power n). 190 | intro. lia_false. 191 | intro. reflexivity. 192 | Qed. 193 | 194 | End linear_carac. 195 | 196 | (** [powerfix_invariant] gives an induction principle for [powerfix], that does not care 197 | about the number of iterations -- in particular, the trivial "emptyfix" function : 198 | ([fun f k a => k a]) satisfies the same induction principle, so that this can only be 199 | used to reason about partial correctness. *) 200 | Section invariant. 201 | Variable P: Fun -> Prop. 202 | Hypothesis HP: forall k, P k -> P (fun a => k a). 203 | (* Alternative hypothesis: *) 204 | (* Hypothesis HP: Proper (pointwise_relation A (@eq B) ==> iff) P. *) 205 | Lemma powerfix'_invariant': forall n f g, (forall k, P k -> P (f k)) -> P g -> P (powerfix' n f g). 206 | Proof. 207 | induction n; intros f g Hf Hg; simpl; apply HP; auto. 208 | Qed. 209 | Lemma powerfix_invariant': forall n f g, (forall k, P k -> P (f k)) -> P g -> P (powerfix n f g). 210 | Proof. 211 | intros n f g Hf Hg. apply HP, Hf, powerfix'_invariant'; assumption. 212 | Qed. 213 | End invariant. 214 | 215 | End powerfix. 216 | 217 | (** Another way to construct well-founded relations: start with a well-founded one (e.g., the empty one), 218 | and progressively add pairs satisfying some acyclicity property w.r.t. the current relation *) 219 | 220 | From Coq Require Relations. 221 | 222 | Section add_pair. 223 | Import Relations. 224 | 225 | Variable T: Set. 226 | Definition add_pair i j R: relation T := fun s t => s=i /\ t=j \/ R s t. 227 | 228 | Lemma wf_add_pair: forall R, well_founded R -> 229 | forall i j, ~ clos_refl_trans T R j i -> well_founded (add_pair i j R). 230 | Proof. 231 | intros R Hwf i j Hij. 232 | 233 | assert (Hi: forall v, clos_refl_trans _ R v i -> Acc (add_pair i j R) v). 234 | induction v as [v IH] using (well_founded_induction Hwf); intros Hui. 235 | constructor. intros u [[-> ->]|Huv]. 236 | elim Hij. assumption. 237 | apply IH. assumption. 238 | eauto using rt_trans, rt_step. 239 | 240 | intro v. induction v as [v IH] using (well_founded_induction Hwf). 241 | constructor. intros u [[-> ->] | Huv]. 242 | apply Hi. constructor 2. 243 | apply IH. assumption. 244 | Qed. 245 | End add_pair. 246 | 247 | (** An induction principle for [Fix], which is less demanding than the corresponding results 248 | of the standard library (no additional hypothesis about [P] or [F]) *) 249 | Section Fix_induction. 250 | Variable A: Type. 251 | Variable R: relation A. 252 | Hypothesis Hwf: well_founded R. 253 | Variable T: A -> Type. 254 | Variable F: forall x, (forall y, R y x -> T y) -> T x. 255 | Variable P: forall x, T x -> Prop. 256 | 257 | Hypothesis IH: forall x (G: forall y, R y x -> T y), (forall y (H: R y x), P (G y H)) -> P (F G). 258 | Theorem Fix_induction: forall x, P (Fix Hwf _ F x). 259 | Proof. 260 | unfold Fix. intro x. generalize (Hwf x) as Hx. 261 | induction x as [x IHwf] using (well_founded_induction Hwf); intros. 262 | rewrite <- Fix_F_eq. auto. 263 | Qed. 264 | End Fix_induction. 265 | Arguments Fix_induction [A R] Hwf [T F P]. 266 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name ATBR) 3 | (libraries coq-atbr.plugin) 4 | (synopsis "Coq library and tactic for deciding Kleene algebras") 5 | (flags :standard 6 | -w -variable-collision 7 | -w -projection-no-head-constant 8 | -w -undo-batch-mode 9 | -w -undeclared-scope 10 | -w -ambiguous-paths)) 11 | --------------------------------------------------------------------------------