├── .dockerignore ├── .github └── workflows │ └── build.yml ├── .gitignore ├── DCO1.1.txt ├── Dockerfile ├── Formal_ML.opam ├── LICENSE.txt ├── Makefile ├── Makefile.coq_modules ├── README.md ├── TAGS ├── _CoqProject ├── breast-cancer-wisconsin.data ├── breast-cancer-wisconsin.names ├── coq ├── API.v ├── CertRL │ ├── LM │ │ ├── README.md │ │ ├── R_compl.v │ │ ├── check_sub_structure.v │ │ ├── compatible.v │ │ ├── continuous_linear_map.v │ │ ├── fixed_point.v │ │ ├── hierarchyD.v │ │ ├── hilbert.v │ │ ├── lax_milgram.v │ │ ├── lax_milgram_cea.v │ │ ├── linear_map.v │ │ └── logic_tricks.v │ ├── README.md │ ├── cond_expt.v │ ├── finite_time.v │ ├── mdp.v │ ├── mdp_turtle.v │ ├── orderfun.v │ ├── pmf_monad.v │ ├── pmf_prob.v │ ├── qvalues.v │ └── refs.md ├── FHE │ ├── arith.v │ ├── encode.v │ ├── encrypt.v │ ├── nth_root.v │ ├── polyinterp.v │ └── zp_prim_root.v ├── NeuralNetworks │ ├── AxiomaticNormedRealVectorSpace.v │ ├── DefinedFunctions.v │ ├── Gen_NN.v │ ├── NN.v │ ├── derivlemmas.v │ ├── nDefinedFunctions.v │ └── testderiv.v ├── ProbTheory │ ├── Almost.v │ ├── BorelSigmaAlgebra.v │ ├── ConditionalExpectation.v │ ├── DiscreteProbSpace.v │ ├── Dynkin.v │ ├── Event.v │ ├── Expectation.v │ ├── FunctionsToReal.v │ ├── Gaussian.v │ ├── Independence.v │ ├── Martingale.v │ ├── MartingaleConvergence.v │ ├── MartingaleStopped.v │ ├── Measures.v │ ├── OrthoProject.v │ ├── ProbSpace.v │ ├── ProductSpace.v │ ├── ProductSpaceDep.v │ ├── RandomVariable.v │ ├── RandomVariableFinite.v │ ├── RandomVariableL2.v │ ├── RandomVariableLinf.v │ ├── RandomVariableLpNat.v │ ├── RandomVariableLpR.v │ ├── RbarExpectation.v │ ├── RealRandomVariable.v │ ├── RealVectorHilbert.v │ ├── SigmaAlgebras.v │ ├── SimpleExpectation.v │ ├── VectorConditionalExpectation.v │ ├── VectorRandomVariable.v │ └── lintp_wrapper.v ├── QLearn │ ├── Bellman.v │ ├── Dvoretzky.v │ ├── Tsitsiklis.v │ ├── infprod.v │ ├── jaakkola_vector.v │ ├── lim_add.v │ ├── qlearn.v │ ├── qlearn_aux.v │ ├── qlearn_redux.v │ ├── slln.v │ ├── sumtest.v │ ├── uniform_converge.v │ └── vecslln.v ├── lib_utils │ ├── LibUtils.v │ ├── LibUtilsAssoc.v │ ├── LibUtilsBag.v │ ├── LibUtilsBindings.v │ ├── LibUtilsBindingsNat.v │ ├── LibUtilsClosure.v │ ├── LibUtilsCompat.v │ ├── LibUtilsCoqLibAdd.v │ ├── LibUtilsDigits.v │ ├── LibUtilsFresh.v │ ├── LibUtilsGroupByDomain.v │ ├── LibUtilsInterleaved.v │ ├── LibUtilsLattice.v │ ├── LibUtilsLift.v │ ├── LibUtilsLiftIterators.v │ ├── LibUtilsListAdd.v │ ├── LibUtilsResult.v │ ├── LibUtilsSortingAdd.v │ ├── LibUtilsStringAdd.v │ ├── LibUtilsSublist.v │ └── README.md └── utils │ ├── Assoc.v │ ├── BasicUtils.v │ ├── ClassicUtils.v │ ├── CoquelicotAdd.v │ ├── DVector.v │ ├── ELim_Seq.v │ ├── ExtrFloatishIEEE.v │ ├── FiniteType.v │ ├── FiniteTypeVector.v │ ├── Floatish.v │ ├── Floatish │ ├── FloatishDef.v │ ├── FloatishIEEE.v │ ├── FloatishInterval.v │ ├── FloatishOps.v │ ├── FloatishReal.v │ └── FloatishRealOps.v │ ├── Isomorphism.v │ ├── ListAdd.v │ ├── NumberIso.v │ ├── PairEncoding.v │ ├── PushNeg.v │ ├── Quotient.v │ ├── RbarAdd.v │ ├── RealAdd.v │ ├── RiemannAdd.v │ ├── StreamAdd.v │ ├── StreamLimits.v │ ├── Sums.v │ ├── Utils.v │ ├── Vector.v │ ├── improper_integrals.v │ ├── nvector.v │ └── quotient_space.v └── ocaml ├── Makefile ├── NnoptExtraction.v ├── nnopt.ml └── src ├── Pretty.ml ├── Pretty.mli ├── Util.ml └── Util.mli /.dockerignore: -------------------------------------------------------------------------------- 1 | **/*.vo 2 | **/*.vok 3 | **/*.vos 4 | **/*.glob 5 | **/*.aux 6 | extracted 7 | ocaml/_build 8 | bin 9 | 10 | .git 11 | **/.DS_Store 12 | **/*~ 13 | **/.#* -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Tests 3 | 4 | on: [push, pull_request] 5 | 6 | 7 | jobs: 8 | build: 9 | name: Build 10 | runs-on: ubuntu-latest # container actions require GNU/Linux 11 | strategy: 12 | matrix: 13 | coq_container: 14 | # - coqorg/coq:8.12.2 15 | # - coqorg/coq:8.16.1-ocaml-4.13.1-flambda 16 | - coqorg/coq:8.18.0-ocaml-4.13.1-flambda 17 | container: 18 | image: ${{ matrix.coq_container }} 19 | options: --user root 20 | steps: 21 | - uses: actions/checkout@v4 22 | with: 23 | persist-credentials: false 24 | - name: Fix permissions 25 | run: chown -R 1000 . 26 | - name: ls 27 | run: ls -la . 28 | - name: Install Opam dependencies 29 | run: su coq -c 'eval $(opam env) && opam install --deps-only --with-test --with-doc -y -j 2 ./Formal_ML.opam' 30 | - name: Build using Make 31 | run: su coq -c 'eval $(opam env) && make -kj 2' 32 | - name: Build documentation 33 | run: su coq -c 'eval $(opam env) && make -kj 2 doc' 34 | 35 | # - uses: coq-community/docker-coq-action@v1 36 | # with: 37 | # opam_file: 'Formal_ML.opam' 38 | # coq_version: ${{ matrix.coq_version }} 39 | # ocaml_version: ${{ matrix.ocaml_version }} 40 | # # export: 'OPAMWITHTEST OPAMWITHDOC' 41 | # export: 'OPAMWITHDOC' 42 | # after_script: | 43 | # sudo cp -a $(opam config var Formal_ML:build)/documentation . 44 | # env: 45 | # OPAMWITHDOC: 'true' 46 | # OPAMWITHTEST: 'true' 47 | # - if: ${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }} 48 | # name: deploy documentation 49 | # uses: JamesIves/github-pages-deploy-action@3.7.1 50 | # with: 51 | # ACCESS_TOKEN: ${{ secrets.ACCESS_TOKEN }} 52 | # REPOSITORY_NAME: FormalML/FormalML.github.io # the target repository 53 | # TARGET_FOLDER: main/documentation # target directory 54 | # BRANCH: main # The branch the action should deploy to. 55 | # FOLDER: documentation # The folder the action should deploy. 56 | # CLEAN: true # Automatically remove deleted files from the deploy branch 57 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.vo 2 | *.vio 3 | *.vos 4 | *.vok 5 | *.glob 6 | *.aux 7 | .coqdeps.d 8 | .#* 9 | Makefile.coq 10 | Makefile.coq.conf 11 | .Makefile.coq.d 12 | extracted 13 | ocaml/_build 14 | bin 15 | 16 | .DS_Store 17 | *.cache 18 | *.d 19 | *.cache 20 | *.v# 21 | *.v~ 22 | .Makefile.coq.d 23 | documentation/html 24 | 25 | .lia.cache 26 | .nra.cache 27 | -------------------------------------------------------------------------------- /DCO1.1.txt: -------------------------------------------------------------------------------- 1 | Developer's Certificate of Origin 1.1 2 | 3 | By making a contribution to this project, I certify that: 4 | 5 | (a) The contribution was created in whole or in part by me and I 6 | have the right to submit it under the open source license 7 | indicated in the file; or 8 | 9 | (b) The contribution is based upon previous work that, to the best 10 | of my knowledge, is covered under an appropriate open source 11 | license and I have the right under that license to submit that 12 | work with modifications, whether created in whole or in part 13 | by me, under the same open source license (unless I am 14 | permitted to submit under a different license), as indicated 15 | in the file; or 16 | 17 | (c) The contribution was provided directly to me by some other 18 | person who certified (a), (b) or (c) and I have not modified 19 | it. 20 | 21 | (d) I understand and agree that this project and the contribution 22 | are public and that a record of the contribution (including all 23 | personal information I submit with it, including my sign-off) is 24 | maintained indefinitely and may be redistributed consistent with 25 | this project or the open source license(s) involved. 26 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | ARG coq_image="coqorg/coq:8.12.2" 2 | FROM ${coq_image} 3 | 4 | MAINTAINER Avi Shinnar "shinnar@us.ibm.com" 5 | 6 | # needs to be a subdirectory to avoid causing problems with 7 | # the /home/coq/.opam directory (and probably other stuff) 8 | WORKDIR /home/coq 9 | 10 | COPY --chown=coq:coq Formal_ML.opam ./formal_ml/ 11 | 12 | RUN ["/bin/bash", "--login", "-c", "set -x \ 13 | && if [ -n \"${COMPILER_EDGE}\" ]; then opam switch ${COMPILER_EDGE} && eval $(opam env); fi \ 14 | && opam update -y \ 15 | && opam install --deps-only --with-test --with-doc -y -j ${NJOBS} ./formal_ml \ 16 | && opam clean -a -c -s --logs"] 17 | 18 | 19 | COPY --chown=coq:coq breast-cancer-wisconsin.data breast-cancer-wisconsin.names ./formal_ml/ 20 | COPY --chown=coq:coq _CoqProject Makefile Makefile.coq_modules ./formal_ml/ 21 | COPY --chown=coq:coq coq ./formal_ml/coq 22 | COPY --chown=coq:coq ocaml ./formal_ml/ocaml 23 | 24 | RUN ["/bin/bash", "--login", "-c", "set -x && cd formal_ml && \ 25 | make && make doc"] 26 | 27 | # CMD ["/bin/bash", "--login", "-c", "set -x && cd formal_ml && \ 28 | # make test"] -------------------------------------------------------------------------------- /Formal_ML.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "Formal_ML" 3 | version: "~dev" 4 | synopsis: "Exploring formal verification for symbolic neural networks" 5 | maintainer: "Avi Shinnar " 6 | authors: "Avi Shinnar " 7 | license: "Apache-2.0" 8 | homepage: "https://github.com/ibm/formalml" 9 | bug-reports: "https://github.com/ibm/formalml/issues" 10 | depends: [ 11 | "ocaml" {>= "4.07.0"} 12 | "coq" {>= "8.12.1"} 13 | "coq-mathcomp-ssreflect" 14 | "coq-mathcomp-algebra" 15 | "coq-mathcomp-algebra-tactics" 16 | "coq-mathcomp-real-closed" 17 | "coq-mathcomp-analysis" {< "1.0.0"} 18 | "coq-coquelicot" {= "3.3.1" } 19 | "coq-flocq" {>= "4.0.0" } 20 | "coq-interval" {>= "4.8.0"} 21 | "coq-ext-lib" {<= "1.0.0"} 22 | "ocamlbuild" 23 | "base64" 24 | "menhir" 25 | "csv" 26 | "coq-coq2html" {with-doc} 27 | ] 28 | build: [[make] 29 | [make "doc"] {with-doc} 30 | [make "test"] {with-test} 31 | ] 32 | install: [make] 33 | dev-repo: "git+https://github.com/IBM/FormalML.git" 34 | url { 35 | src: "git+https://github.com/IBM/FormalML.git" 36 | } 37 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright 2017-2018 IBM Corporation 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Contains the list of all the Coq modules 2 | include Makefile.coq_modules 3 | 4 | COQ_FILES = $(addprefix coq/,$(MODULES:%=%.v)) 5 | 6 | all: coq # ocaml 7 | 8 | coq: Makefile.coq 9 | @$(MAKE) -f Makefile.coq 10 | 11 | Makefile.coq: Makefile Makefile.coq_modules $(COQ_FILES) 12 | @coq_makefile -f _CoqProject $(COQ_FILES) -o Makefile.coq 13 | 14 | ocaml: coq 15 | @$(MAKE) -C ocaml native 16 | 17 | clean-coq: 18 | - @$(MAKE) -f Makefile.coq clean 19 | 20 | clean-ocaml: 21 | @$(MAKE) -C ocaml clean 22 | 23 | 24 | COQ_FILES_FOR_DOC = $(MODULES:%=%.v) 25 | GLOB_FILES_FOR_DOC = $(MODULES:%=%.glob) 26 | 27 | doc: coq 28 | mkdir -p documentation/html 29 | rm -f documentation/html/*.html 30 | cd coq && coq2html -d ../documentation/html -base FormalML -external http://coquelicot.saclay.inria.fr/html/ Coquelicot $(COQ_FILES_FOR_DOC) $(GLOB_FILES_FOR_DOC) 31 | 32 | test: coq ocaml 33 | ./bin/nnopt 34 | 35 | clean: clean-coq clean-ocaml 36 | rm -rf documentation/html 37 | 38 | .PHONY: all ocaml clean clean-coq coq test doc 39 | -------------------------------------------------------------------------------- /Makefile.coq_modules: -------------------------------------------------------------------------------- 1 | # 2 | # Copyright 2015-2016 IBM Corporation 3 | # 4 | # Licensed under the Apache License, Version 2.0 (the "License"); 5 | # you may not use this file except in compliance with the License. 6 | # You may obtain a copy of the License at 7 | # 8 | # http://www.apache.org/licenses/LICENSE-2.0 9 | # 10 | # Unless required by applicable law or agreed to in writing, software 11 | # distributed under the License is distributed on an "AS IS" BASIS, 12 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | # See the License for the specific language governing permissions and 14 | # limitations under the License. 15 | # 16 | 17 | QCERT_LIB_UTILS = LibUtilsAssoc LibUtilsBag LibUtilsBindings LibUtilsBindingsNat \ 18 | LibUtilsClosure LibUtilsCompat LibUtilsCoqLibAdd LibUtilsDigits \ 19 | LibUtilsFresh LibUtilsGroupByDomain LibUtilsInterleaved \ 20 | LibUtilsLattice LibUtilsLift LibUtilsLiftIterators LibUtilsListAdd \ 21 | LibUtilsResult LibUtilsSortingAdd LibUtilsStringAdd LibUtilsSublist \ 22 | LibUtils 23 | 24 | ELFIC_UTILS = R_compl check_sub_structure compatible continuous_linear_map fixed_point \ 25 | hierarchyD hilbert linear_map logic_tricks lax_milgram lax_milgram_cea 26 | 27 | 28 | UTILS = BasicUtils \ 29 | Assoc \ 30 | ClassicUtils \ 31 | CoquelicotAdd \ 32 | ELim_Seq \ 33 | ExtrFloatishIEEE \ 34 | improper_integrals \ 35 | Isomorphism \ 36 | ListAdd \ 37 | FiniteType \ 38 | FiniteTypeVector \ 39 | NumberIso \ 40 | PairEncoding \ 41 | Quotient \ 42 | quotient_space \ 43 | RealAdd \ 44 | RbarAdd \ 45 | RiemannAdd \ 46 | StreamAdd \ 47 | StreamLimits \ 48 | Sums \ 49 | nvector \ 50 | Vector \ 51 | PushNeg \ 52 | DVector \ 53 | Utils \ 54 | Floatish/FloatishDef \ 55 | Floatish/FloatishOps \ 56 | Floatish/FloatishRealOps \ 57 | Floatish/FloatishInterval \ 58 | Floatish/FloatishIEEE \ 59 | Floatish/FloatishReal \ 60 | Floatish 61 | 62 | NEURAL_NETWORKS = AxiomaticNormedRealVectorSpace \ 63 | DefinedFunctions \ 64 | derivlemmas \ 65 | Gen_NN 66 | 67 | 68 | CERTRL = pmf_monad \ 69 | qvalues \ 70 | mdp \ 71 | mdp_turtle \ 72 | finite_time \ 73 | cond_expt \ 74 | pmf_prob 75 | 76 | PROB_THEORY = \ 77 | Almost \ 78 | BorelSigmaAlgebra \ 79 | DiscreteProbSpace \ 80 | Dynkin \ 81 | Event \ 82 | Independence \ 83 | ProbSpace \ 84 | FunctionsToReal \ 85 | Measures \ 86 | RandomVariable \ 87 | RealRandomVariable \ 88 | RandomVariableFinite \ 89 | RandomVariableL2 \ 90 | RandomVariableLpNat \ 91 | RandomVariableLpR \ 92 | RandomVariableLinf \ 93 | OrthoProject \ 94 | RealVectorHilbert \ 95 | SimpleExpectation \ 96 | ConditionalExpectation \ 97 | Expectation \ 98 | RbarExpectation \ 99 | VectorConditionalExpectation \ 100 | SigmaAlgebras \ 101 | VectorRandomVariable \ 102 | Martingale \ 103 | MartingaleConvergence \ 104 | MartingaleStopped \ 105 | Gaussian \ 106 | ProductSpace \ 107 | ProductSpaceDep 108 | 109 | 110 | QLEARN = \ 111 | Dvoretzky \ 112 | Bellman \ 113 | qlearn_aux \ 114 | qlearn \ 115 | qlearn_redux \ 116 | infprod \ 117 | sumtest \ 118 | slln \ 119 | vecslln \ 120 | uniform_converge \ 121 | lim_add \ 122 | Tsitsiklis \ 123 | jaakkola_vector 124 | 125 | FHE = \ 126 | nth_root \ 127 | encode \ 128 | encrypt \ 129 | zp_prim_root \ 130 | arith 131 | 132 | MODULES = $(addprefix lib_utils/,$(QCERT_LIB_UTILS)) \ 133 | $(addprefix CertRL/LM/,$(ELFIC_UTILS)) \ 134 | $(addprefix utils/,$(UTILS)) \ 135 | $(addprefix NeuralNetworks/,$(NEURAL_NETWORKS)) \ 136 | $(addprefix ProbTheory/,$(PROB_THEORY)) \ 137 | $(addprefix CertRL/,$(CERTRL)) \ 138 | $(addprefix QLearn/,$(QLEARN)) \ 139 | $(addprefix FHE/,$(FHE)) \ 140 | API 141 | 142 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Formal_ML [![Build Status](https://github.com/IBM/FormalML/workflows/Tests/badge.svg?branch=master)](https://github.com/IBM/FormalML/actions?query=workflow%3ATests+branch%3Amaster) 2 | Formalization of Machine Learning Theory with Applications to Program Synthesis 3 | 4 | This repository contains 5 | - a partial formalization of key results from https://arxiv.org/abs/1804.07795 6 | - The CertRL library as reported in https://arxiv.org/abs/2009.11403 7 | - a formalization of Dvoretzky's stochastic approximation theorem as reported in https://arxiv.org/abs/2202.05959 8 | 9 | ## Getting Started 10 | 11 | To compile the Coq code in this repository, 12 | - first install opam [opam (ocaml package manager)](https://opam.ocaml.org/). 13 | - Add support for coq ocaml repositories: `opam repo add coq-released --set-default https://coq.inria.fr/opam/released`. 14 | - If you want to create a local environment (switch), you can run `opam switch create nnsopt 4.07.0`. 15 | - Next, run `opam install . --deps-only`. This should install all the dependencies needed, including Coq. 16 | - Once the prerequisites are installed, run `make` to compile it. 17 | 18 | Alternatively, the included Docker file can be built using Docker to compile the coq code in a suitable environment. 19 | `docker build --build-arg=coq_image="coqorg/coq:8.8.2" --pull -t nn_sopt .` 20 | 21 | ## License 22 | This repository is distributed under the terms of the Apache 2.0 License, see LICENSE.txt. 23 | It is currently in an Alpha release, without warranties of any kind. Keep in mind that this is an active exploratory research project. 24 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R coq FormalML -arg -set -arg "Warnings=+default,-ambiguous-path,-coercions,-hiding-delimiting-key,-overwriting-delimiting-key,-redundant-canonical-projection,-typechecker,-ssr-search-moved,-deprecated,-notation-overridden" -------------------------------------------------------------------------------- /breast-cancer-wisconsin.names: -------------------------------------------------------------------------------- 1 | Citation Request: 2 | This breast cancer databases was obtained from the University of Wisconsin 3 | Hospitals, Madison from Dr. William H. Wolberg. If you publish results 4 | when using this database, then please include this information in your 5 | acknowledgements. Also, please cite one or more of: 6 | 7 | 1. O. L. Mangasarian and W. H. Wolberg: "Cancer diagnosis via linear 8 | programming", SIAM News, Volume 23, Number 5, September 1990, pp 1 & 18. 9 | 10 | 2. William H. Wolberg and O.L. Mangasarian: "Multisurface method of 11 | pattern separation for medical diagnosis applied to breast cytology", 12 | Proceedings of the National Academy of Sciences, U.S.A., Volume 87, 13 | December 1990, pp 9193-9196. 14 | 15 | 3. O. L. Mangasarian, R. Setiono, and W.H. Wolberg: "Pattern recognition 16 | via linear programming: Theory and application to medical diagnosis", 17 | in: "Large-scale numerical optimization", Thomas F. Coleman and Yuying 18 | Li, editors, SIAM Publications, Philadelphia 1990, pp 22-30. 19 | 20 | 4. K. P. Bennett & O. L. Mangasarian: "Robust linear programming 21 | discrimination of two linearly inseparable sets", Optimization Methods 22 | and Software 1, 1992, 23-34 (Gordon & Breach Science Publishers). 23 | 24 | 1. Title: Wisconsin Breast Cancer Database (January 8, 1991) 25 | 26 | 2. Sources: 27 | -- Dr. WIlliam H. Wolberg (physician) 28 | University of Wisconsin Hospitals 29 | Madison, Wisconsin 30 | USA 31 | -- Donor: Olvi Mangasarian (mangasarian@cs.wisc.edu) 32 | Received by David W. Aha (aha@cs.jhu.edu) 33 | -- Date: 15 July 1992 34 | 35 | 3. Past Usage: 36 | 37 | Attributes 2 through 10 have been used to represent instances. 38 | Each instance has one of 2 possible classes: benign or malignant. 39 | 40 | 1. Wolberg,~W.~H., \& Mangasarian,~O.~L. (1990). Multisurface method of 41 | pattern separation for medical diagnosis applied to breast cytology. In 42 | {\it Proceedings of the National Academy of Sciences}, {\it 87}, 43 | 9193--9196. 44 | -- Size of data set: only 369 instances (at that point in time) 45 | -- Collected classification results: 1 trial only 46 | -- Two pairs of parallel hyperplanes were found to be consistent with 47 | 50% of the data 48 | -- Accuracy on remaining 50% of dataset: 93.5% 49 | -- Three pairs of parallel hyperplanes were found to be consistent with 50 | 67% of data 51 | -- Accuracy on remaining 33% of dataset: 95.9% 52 | 53 | 2. Zhang,~J. (1992). Selecting typical instances in instance-based 54 | learning. In {\it Proceedings of the Ninth International Machine 55 | Learning Conference} (pp. 470--479). Aberdeen, Scotland: Morgan 56 | Kaufmann. 57 | -- Size of data set: only 369 instances (at that point in time) 58 | -- Applied 4 instance-based learning algorithms 59 | -- Collected classification results averaged over 10 trials 60 | -- Best accuracy result: 61 | -- 1-nearest neighbor: 93.7% 62 | -- trained on 200 instances, tested on the other 169 63 | -- Also of interest: 64 | -- Using only typical instances: 92.2% (storing only 23.1 instances) 65 | -- trained on 200 instances, tested on the other 169 66 | 67 | 4. Relevant Information: 68 | 69 | Samples arrive periodically as Dr. Wolberg reports his clinical cases. 70 | The database therefore reflects this chronological grouping of the data. 71 | This grouping information appears immediately below, having been removed 72 | from the data itself: 73 | 74 | Group 1: 367 instances (January 1989) 75 | Group 2: 70 instances (October 1989) 76 | Group 3: 31 instances (February 1990) 77 | Group 4: 17 instances (April 1990) 78 | Group 5: 48 instances (August 1990) 79 | Group 6: 49 instances (Updated January 1991) 80 | Group 7: 31 instances (June 1991) 81 | Group 8: 86 instances (November 1991) 82 | ----------------------------------------- 83 | Total: 699 points (as of the donated datbase on 15 July 1992) 84 | 85 | Note that the results summarized above in Past Usage refer to a dataset 86 | of size 369, while Group 1 has only 367 instances. This is because it 87 | originally contained 369 instances; 2 were removed. The following 88 | statements summarizes changes to the original Group 1's set of data: 89 | 90 | ##### Group 1 : 367 points: 200B 167M (January 1989) 91 | ##### Revised Jan 10, 1991: Replaced zero bare nuclei in 1080185 & 1187805 92 | ##### Revised Nov 22,1991: Removed 765878,4,5,9,7,10,10,10,3,8,1 no record 93 | ##### : Removed 484201,2,7,8,8,4,3,10,3,4,1 zero epithelial 94 | ##### : Changed 0 to 1 in field 6 of sample 1219406 95 | ##### : Changed 0 to 1 in field 8 of following sample: 96 | ##### : 1182404,2,3,1,1,1,2,0,1,1,1 97 | 98 | 5. Number of Instances: 699 (as of 15 July 1992) 99 | 100 | 6. Number of Attributes: 10 plus the class attribute 101 | 102 | 7. Attribute Information: (class attribute has been moved to last column) 103 | 104 | # Attribute Domain 105 | -- ----------------------------------------- 106 | 1. Sample code number id number 107 | 2. Clump Thickness 1 - 10 108 | 3. Uniformity of Cell Size 1 - 10 109 | 4. Uniformity of Cell Shape 1 - 10 110 | 5. Marginal Adhesion 1 - 10 111 | 6. Single Epithelial Cell Size 1 - 10 112 | 7. Bare Nuclei 1 - 10 113 | 8. Bland Chromatin 1 - 10 114 | 9. Normal Nucleoli 1 - 10 115 | 10. Mitoses 1 - 10 116 | 11. Class: (2 for benign, 4 for malignant) 117 | 118 | 8. Missing attribute values: 16 119 | 120 | There are 16 instances in Groups 1 to 6 that contain a single missing 121 | (i.e., unavailable) attribute value, now denoted by "?". 122 | 123 | 9. Class distribution: 124 | 125 | Benign: 458 (65.5%) 126 | Malignant: 241 (34.5%) 127 | -------------------------------------------------------------------------------- /coq/API.v: -------------------------------------------------------------------------------- 1 | Require Import FloatishIEEE. 2 | Require Import ExtrFloatishIEEE. 3 | 4 | 5 | (* Require Import ExtrR. *) 6 | (* Our stuff modules *) 7 | 8 | Require Import Utils. 9 | Require Import Vector. 10 | Require Gen_NN. 11 | Require Import DefinedFunctions. 12 | Require Import FloatishDef. 13 | Require Import BinInt. 14 | Require Import String. 15 | Require Import Streams. 16 | Local Open Scope list. 17 | 18 | Existing Instance floatish_IEEE. 19 | 20 | Example test := 21 | mk_env_entry (Name "f", DTfloat) (FfromZ 1)%Z :: 22 | mk_env_entry (Name "v", DTVector 3) (ConstVector 3 ((FfromZ (-2)))%Z) :: 23 | mk_env_entry (Name "m", DTMatrix 2 3) (ConstMatrix 2 3 (FfromZ 3))%Z :: nil. 24 | Module API. 25 | Example opt := @Gen_NN.opt floatish_IEEE. 26 | Example opt2 := @Gen_NN.opt2 floatish_IEEE. 27 | Example test_update := @Gen_NN.test_update floatish_IEEE. 28 | Example testopt := @Gen_NN.testopt floatish_IEEE. 29 | Example testreeopt := @Gen_NN.testreeopt floatish_IEEE. 30 | Example gradenv := @Gen_NN.gradenv floatish_IEEE. 31 | Example gradenv_tree := @Gen_NN.gradenv_tree floatish_IEEE. 32 | Example test_env := test. 33 | 34 | Example discard_first {A} (l:list (list A)) : list (list A) := List.map (@List.tl A) l. 35 | Definition normalizeIntData := Gen_NN.normalizeIntData. 36 | Definition init_env2 := Gen_NN.init_env2. 37 | CoFixpoint mkIndexedStream {A} (i : nat) (ran : nat -> A) : Stream A := 38 | Cons (ran i) (mkIndexedStream (S i) ran). 39 | Definition streamtake := Gen_NN.streamtake. 40 | Definition df_env := DefinedFunctions.df_env. 41 | Definition eval_wisconsin_batch (nsamp:nat) 42 | (env:df_env) (data : Matrix float nsamp 10) : list float := 43 | match Gen_NN.eval_wisconsin_batch nsamp env data with 44 | | Some val => val :: nil 45 | | _ => nil 46 | end. 47 | 48 | Definition wisconsin_test := Gen_NN.wisconsin_test. 49 | Definition wisconsin_test_env := Gen_NN.wisconsin_test_env. 50 | Definition wisconsin_gradenv_tree := Gen_NN.wisconsin_gradenv_tree. 51 | Definition wisconsin_gradenv := Gen_NN.wisconsin_gradenv. 52 | Definition nn_test := Gen_NN.NN_test. 53 | Definition nn_test_val := Gen_NN.NN_test_val. 54 | Definition nn_test_env := Gen_NN.NN_test_env. 55 | Definition nn_test_gradenv_tree := Gen_NN.NN_test_gradenv_tree. 56 | Definition nn_test_gradenv := Gen_NN.NN_test_gradenv. 57 | 58 | End API. 59 | -------------------------------------------------------------------------------- /coq/CertRL/LM/README.md: -------------------------------------------------------------------------------- 1 | This subdirectory contains the [`elfic`](https://www.lri.fr/~sboldo/elfic/) library, which provided a [formal proof of the Lax-Milgram theorem](https://hal.inria.fr/hal-01391578/document). 2 | 3 | In particular, we use the Banach Fixed Point theorem as proven in the file `fixed_point.v`. 4 | 5 | We use this library as a dependency for our project. For historical 6 | reasons, it is currently copied into this repository. Now that an 7 | official gitlab repository is available at 8 | https://depot.lipn.univ-paris13.fr/mayero/coq-num-analysis/ and there 9 | are plans on an OPAM release, this code will likely be replaced with 10 | a normal dependency in the future. 11 | -------------------------------------------------------------------------------- /coq/CertRL/LM/R_compl.v: -------------------------------------------------------------------------------- 1 | (** 2 | This file is part of the Elfic library 3 | 4 | Copyright (C) Boldo, Clément, Faissole, Martin, Mayero 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 3 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | COPYING file for more details. 15 | *) 16 | 17 | Require Export Reals Coquelicot.Coquelicot. 18 | 19 | Open Scope R_scope. 20 | 21 | Section RC. 22 | 23 | (** If a degree-2 polynomial is always nonnegative, its dicriminant is nonpositive *) 24 | 25 | Lemma discr_neg: forall a b c, 26 | (forall x, 0 <= a*x*x+b*x+c) -> 27 | b*b-4*a*c <= 0. 28 | intros. 29 | case (Req_dec a 0); intros H'. 30 | cut (b=0). 31 | intros H1; rewrite H'; rewrite H1. 32 | right; ring. 33 | case (Req_dec b 0); trivial; intros. 34 | absurd (0 <= a*((-c-1)/b)*((-c-1)/b)+b*((-c-1)/b)+c). 35 | 2: apply H. 36 | apply Rlt_not_le. 37 | rewrite H'; apply Rle_lt_trans with (-1). 38 | right; field; trivial. 39 | apply Ropp_lt_gt_0_contravar; apply Rlt_gt; auto with real. 40 | assert (0 <= c). 41 | apply Rle_trans with (a*0*0+b*0+c);[idtac|right; ring]. 42 | apply H. 43 | assert (0 < a). 44 | cut (0 <= a). 45 | intros T; case T;auto with real. 46 | intros T'; absurd (a=0); auto. 47 | case (Req_dec b 0); intros. 48 | case (Rle_or_lt 0 a); trivial; intros. 49 | absurd (0 <= a* sqrt ((c+1)/(-a)) * sqrt ((c+1)/(-a)) +b*sqrt ((c+1)/(-a))+c). 50 | 2: apply H. 51 | apply Rlt_not_le. 52 | rewrite H1; ring_simplify ( 0 * sqrt ((c + 1) / - a)). 53 | rewrite Rmult_assoc. 54 | rewrite sqrt_sqrt. 55 | apply Rle_lt_trans with (-1). 56 | right; field; auto with real. 57 | apply Ropp_lt_gt_0_contravar; apply Rlt_gt; auto with real. 58 | unfold Rdiv; apply Rmult_le_pos; auto with real. 59 | case H0; intros. 60 | apply Rmult_le_reg_l with (c*c/(b*b)). 61 | unfold Rdiv; apply Rmult_lt_0_compat. 62 | apply Rmult_lt_0_compat; trivial. 63 | apply Rinv_0_lt_compat. 64 | fold (Rsqr b); auto with real. 65 | ring_simplify. 66 | apply Rle_trans with (a*(-c/b)*(-c/b)+b*(-c/b)+c). 67 | apply H. 68 | right; field; trivial. 69 | apply Rmult_le_reg_l with (b*b). 70 | fold (Rsqr b); auto with real. 71 | ring_simplify. 72 | apply Rle_trans with (Rsqr b); auto with real. 73 | apply Rplus_le_reg_l with (-Rsqr b); ring_simplify. 74 | apply Rle_trans with (a*(-b)*(-b)+b*(-b)+c). 75 | apply H. 76 | rewrite <- H2; unfold Rsqr; right; ring. 77 | case (Rle_or_lt (b * b - 4 * a * c) 0); trivial. 78 | intros H2. 79 | absurd ( 0 <= a * (-b/(2*a)) * (-b/(2*a)) + b * (-b/(2*a)) + c). 80 | apply Rlt_not_le. 81 | replace (a * (- b / (2*a)) * (- b / (2*a)) + b * (- b / (2*a)) + c) with 82 | (-b*b/(4*a)+c). 83 | apply Rmult_lt_reg_l with (4*a). 84 | repeat apply Rmult_lt_0_compat; auto with real. 85 | apply Rplus_lt_reg_r with (b*b-4*a*c). 86 | apply Rle_lt_trans with 0%R. 87 | right; field; auto. 88 | apply Rlt_le_trans with (1:=H2); right; ring. 89 | field; auto. 90 | apply H. 91 | Qed. 92 | 93 | Lemma contraction_lt_any: forall k d, 0 <= k < 1 -> 0 < d -> exists N, pow k N < d. 94 | Proof. 95 | intros k d Hk Hd. 96 | case (proj1 Hk); intros Hk'. 97 | (* 0 < k *) 98 | assert (ln k < 0). 99 | rewrite <- ln_1. 100 | apply ln_increasing; try apply Hk; assumption. 101 | exists (Z.abs_nat (up (ln d / ln k))). 102 | apply ln_lt_inv; try assumption. 103 | now apply pow_lt. 104 | rewrite <- Rpower_pow; trivial. 105 | unfold Rpower. 106 | rewrite ln_exp. 107 | apply Rmult_lt_reg_l with (- /ln k). 108 | apply Ropp_gt_lt_0_contravar. 109 | now apply Rinv_lt_0_compat. 110 | apply Rle_lt_trans with (-(INR (Z.abs_nat (up (ln d / ln k))))). 111 | right; field. 112 | now apply Rlt_not_eq. 113 | rewrite Ropp_mult_distr_l_reverse. 114 | apply Ropp_lt_contravar. 115 | generalize (archimed (ln d / ln k)); intros (Y1,_). 116 | rewrite Rmult_comm. 117 | apply Rlt_le_trans with (1:=Y1). 118 | generalize (up (ln d / ln k)); clear; intros x. 119 | rewrite INR_IZR_INZ, Zabs2Nat.id_abs. 120 | apply IZR_le. 121 | case (Zabs_spec x); intros (T1,T2); rewrite T2; auto with zarith. 122 | (* k = 0 *) 123 | exists 1%nat. 124 | rewrite <- Hk';simpl. 125 | now rewrite Rmult_0_l. 126 | Qed. 127 | 128 | Lemma contraction_lt_any': forall k d, 0 <= k < 1 -> 0 < d -> exists N, (0 < N)%nat /\ pow k N < d. 129 | Proof. 130 | intros k d H1 H2. 131 | destruct (contraction_lt_any k d H1 H2) as (N,HN). 132 | case_eq N. 133 | intros H3; exists 1%nat; split. 134 | now apply le_n. 135 | rewrite H3 in HN; simpl in HN. 136 | simpl; rewrite Rmult_1_r. 137 | now apply Rlt_trans with 1. 138 | intros m Hm. 139 | exists N; split; try assumption. 140 | rewrite Hm. 141 | now auto with arith. 142 | Qed. 143 | 144 | Lemma Rinv_le_cancel: forall x y : R, 0 < y -> / y <= / x -> x <= y. 145 | Proof. 146 | intros x y H1 H2. 147 | case (Req_dec x 0); intros Hx. 148 | rewrite Hx; now left. 149 | destruct H2. 150 | left; now apply Rinv_lt_cancel. 151 | right; rewrite <- Rinv_involutive. 152 | 2: now apply Rgt_not_eq. 153 | rewrite H. 154 | now apply sym_eq, Rinv_involutive. 155 | Qed. 156 | 157 | Lemma Rlt_R1_pow: forall x n, 0 <= x < 1 -> (0 < n)%nat -> x ^ n < 1. 158 | Proof. 159 | intros x n (Hx1,Hx2) Hn. 160 | case (Req_dec x 0); intros H'. 161 | rewrite H', pow_i; try assumption. 162 | apply Rlt_0_1. 163 | apply Rinv_lt_cancel. 164 | apply Rlt_0_1. 165 | rewrite Rinv_1. 166 | rewrite Rinv_pow; try assumption. 167 | apply Rlt_pow_R1; try assumption. 168 | rewrite <- Rinv_1. 169 | apply Rinv_lt_contravar; try assumption. 170 | rewrite Rmult_1_r. 171 | destruct Hx1; trivial. 172 | contradict H; now apply not_eq_sym. 173 | Qed. 174 | 175 | Lemma Rle_pow_le: forall (x : R) (m n : nat), 0 < x <= 1 -> (m <= n)%nat -> x ^ n <= x ^ m. 176 | Proof. 177 | intros x m n (Hx1,Hx2) H. 178 | apply Rinv_le_cancel. 179 | now apply pow_lt. 180 | rewrite 2!Rinv_pow; try now apply Rgt_not_eq. 181 | apply Rle_pow; try assumption. 182 | rewrite <- Rinv_1. 183 | apply Rinv_le_contravar; try assumption. 184 | Qed. 185 | 186 | Lemma is_finite_betw: forall x y z, 187 | Rbar_le (Finite x) y -> Rbar_le y (Finite z) -> is_finite y. 188 | Proof. 189 | intros x y z; destruct y; easy. 190 | Qed. 191 | 192 | Lemma Rplus_plus_reg_l : forall (a b c:R), b = c -> plus a b = a + c. 193 | Proof. 194 | intros. rewrite H. reflexivity. 195 | Qed. 196 | 197 | Lemma Rplus_plus_reg_r : forall a b c, b = c -> plus b a = c + a. 198 | Proof. 199 | intros. rewrite H. reflexivity. 200 | Qed. 201 | 202 | Context {E : NormedModule R_AbsRing}. 203 | 204 | Lemma norm_scal_R: forall l (x:E), norm (scal l x) = abs l * norm x. 205 | Proof. 206 | intros l x. 207 | apply Rle_antisym; try apply norm_scal. 208 | case (Req_dec l 0); intros V. 209 | rewrite V; unfold abs; simpl. 210 | rewrite Rabs_R0, Rmult_0_l. 211 | apply norm_ge_0. 212 | apply Rmult_le_reg_l with (abs (/l)). 213 | unfold abs; simpl. 214 | apply Rabs_pos_lt. 215 | now apply Rinv_neq_0_compat. 216 | apply Rle_trans with (norm x). 217 | rewrite <- Rmult_assoc. 218 | unfold abs; simpl. 219 | rewrite <- Rabs_mult. 220 | rewrite Rinv_l; trivial. 221 | rewrite Rabs_R1, Rmult_1_l. 222 | apply Rle_refl. 223 | apply Rle_trans with (norm (scal (/l) (scal l x))). 224 | right; apply f_equal. 225 | rewrite scal_assoc. 226 | apply trans_eq with (scal one x). 227 | apply sym_eq, scal_one. 228 | apply f_equal2; trivial. 229 | unfold one, mult; simpl. 230 | now field. 231 | apply (norm_scal (/l) (scal l x)). 232 | Qed. 233 | 234 | Lemma sum_n_eq_zero: forall m (L:nat -> E), 235 | (forall i, (i <= m)%nat -> L i = zero) -> 236 | sum_n L m = zero. 237 | Proof. 238 | intros m L H. 239 | apply trans_eq with (sum_n (fun n => zero) m). 240 | now apply sum_n_ext_loc. 241 | clear; induction m. 242 | now rewrite sum_O. 243 | rewrite sum_Sn, IHm. 244 | apply plus_zero_l. 245 | Qed. 246 | 247 | End RC. 248 | -------------------------------------------------------------------------------- /coq/CertRL/LM/check_sub_structure.v: -------------------------------------------------------------------------------- 1 | (** 2 | This file is part of the Elfic library 3 | 4 | Copyright (C) Boldo, Clément, Faissole, Martin, Mayero 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 3 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | COPYING file for more details. 15 | *) 16 | 17 | Require Export Reals Coquelicot.Coquelicot. 18 | Require Export compatible hilbert. 19 | Require Export ProofIrrelevance. 20 | 21 | (** Sub-groups *) 22 | 23 | Section Subgroups. 24 | 25 | Context {G : AbelianGroup}. 26 | Context {P: G -> Prop}. 27 | Context {CCP: compatible_g P}. 28 | 29 | Record Sg:= mk_Sg { 30 | val :> G ; 31 | H: P val 32 | }. 33 | 34 | Lemma Sg_eq: forall (x y:Sg), (val x = val y) -> x = y. 35 | Proof. 36 | intros x y H. 37 | destruct x; destruct y. 38 | simpl in H. 39 | revert H0 H1. 40 | rewrite <- H. 41 | intros H0 H1; f_equal. 42 | apply proof_irrelevance. 43 | Qed. 44 | 45 | Definition Sg_zero : Sg := mk_Sg zero (compatible_g_zero P CCP). 46 | 47 | Definition Sg_plus (x y : Sg) : Sg := 48 | mk_Sg (plus x y) 49 | (compatible_g_plus P (val x) (val y) CCP (H x) (H y)). 50 | 51 | Definition Sg_opp (x : Sg) : Sg := 52 | mk_Sg (opp x) 53 | (compatible_g_opp P (val x) CCP (H x)). 54 | 55 | Lemma Sg_plus_comm: forall (x y:Sg), Sg_plus x y = Sg_plus y x. 56 | Proof. 57 | intros x y; apply Sg_eq. 58 | unfold Sg_plus; simpl. 59 | apply plus_comm. 60 | Qed. 61 | 62 | Lemma Sg_plus_assoc: 63 | forall (x y z:Sg ), Sg_plus x (Sg_plus y z) = Sg_plus (Sg_plus x y) z. 64 | Proof. 65 | intros x y z; apply Sg_eq. 66 | unfold Sg_plus; simpl. 67 | apply plus_assoc. 68 | Qed. 69 | 70 | Lemma Sg_plus_zero_r: forall x:Sg, Sg_plus x Sg_zero = x. 71 | Proof. 72 | intros x; apply Sg_eq. 73 | unfold Sg_plus; simpl. 74 | apply plus_zero_r. 75 | Qed. 76 | 77 | Lemma Sg_plus_opp_r: forall x:Sg, Sg_plus x (Sg_opp x) = Sg_zero. 78 | Proof. 79 | intros x; apply Sg_eq. 80 | unfold Sg_plus; simpl. 81 | apply plus_opp_r. 82 | Qed. 83 | 84 | Definition Sg_AbelianGroup_mixin := 85 | AbelianGroup.Mixin Sg Sg_plus Sg_opp Sg_zero Sg_plus_comm 86 | Sg_plus_assoc Sg_plus_zero_r Sg_plus_opp_r. 87 | 88 | Canonical Sg_AbelianGroup := 89 | AbelianGroup.Pack Sg (Sg_AbelianGroup_mixin) Sg. 90 | 91 | End Subgroups. 92 | 93 | (** Sub-modules *) 94 | 95 | Section Submodules. 96 | 97 | Context {G : ModuleSpace R_Ring}. 98 | Context {P: G -> Prop}. 99 | 100 | Hypothesis CPM: compatible_m P. 101 | 102 | Let Sg_Mplus := (@Sg_plus _ P (proj1 CPM)). 103 | 104 | Definition Sg_scal a (x: Sg) : (Sg):= 105 | mk_Sg (scal a (val x)) 106 | (compatible_m_scal P a (val x) CPM (H x)). 107 | 108 | Lemma Sg_mult_one_l : forall (x : Sg), Sg_scal (@one R_Ring) x = x. 109 | Proof. 110 | intros x; apply Sg_eq. 111 | unfold Sg_scal; simpl. 112 | apply scal_one. 113 | Qed. 114 | 115 | Lemma Sg_mult_assoc : forall x y (f: Sg), Sg_scal x (Sg_scal y f) = Sg_scal (mult x y) f. 116 | Proof. 117 | intros x y f; apply Sg_eq. 118 | unfold Sg_scal; simpl. 119 | apply scal_assoc. 120 | Qed. 121 | 122 | Lemma Sg_mult_distr_l : forall x (u v: Sg), 123 | Sg_scal x (Sg_Mplus u v) = Sg_Mplus (Sg_scal x u) (Sg_scal x v). 124 | Proof. 125 | intros x u v; apply Sg_eq. 126 | unfold Sg_plus; simpl. 127 | apply scal_distr_l. 128 | Qed. 129 | 130 | Lemma Sg_mult_distr_r : forall x y u, 131 | Sg_scal (plus x y) u = Sg_Mplus (Sg_scal x u) (Sg_scal y u). 132 | Proof. 133 | intros x y u; apply Sg_eq. 134 | unfold Sg_plus; unfold Sg_scal; simpl. 135 | apply scal_distr_r. 136 | Qed. 137 | 138 | Definition Sg_MAbelianGroup_mixin := 139 | AbelianGroup.Mixin Sg Sg_Mplus Sg_opp Sg_zero Sg_plus_comm 140 | Sg_plus_assoc Sg_plus_zero_r Sg_plus_opp_r. 141 | 142 | Canonical Sg_MAbelianGroup := 143 | AbelianGroup.Pack Sg (Sg_MAbelianGroup_mixin) (@Sg _ P). 144 | 145 | Definition Sg_ModuleSpace_mixin := 146 | ModuleSpace.Mixin R_Ring (Sg_MAbelianGroup) 147 | _ Sg_mult_assoc Sg_mult_one_l Sg_mult_distr_l Sg_mult_distr_r. 148 | 149 | Canonical Sg_ModuleSpace := 150 | ModuleSpace.Pack R_Ring Sg (ModuleSpace.Class _ _ _ Sg_ModuleSpace_mixin) (@Sg G P). 151 | 152 | End Submodules. 153 | 154 | (** Sub-prehilbert *) 155 | 156 | Section Subprehilbert. 157 | 158 | Context {G : PreHilbert}. 159 | Context {P: G -> Prop}. 160 | Hypothesis CPM: compatible_m P. 161 | 162 | Let Sg_plus := (@Sg_plus _ P (proj1 CPM)). 163 | Let Sg_scal := (@Sg_scal _ P CPM). 164 | 165 | Definition Sg_inner (x y : @Sg G P) : R := 166 | (inner (val x) (val y)). 167 | 168 | Lemma Sg_inner_comm : forall (x y : Sg), 169 | Sg_inner x y = Sg_inner y x. 170 | Proof. 171 | intros x y. 172 | apply inner_sym. 173 | Qed. 174 | 175 | Lemma Sg_inner_pos : forall (x : Sg), 176 | 0 <= Sg_inner x x. 177 | Proof. 178 | intros x. 179 | apply inner_ge_0. 180 | Qed. 181 | 182 | Lemma Sg_inner_def : forall (x : Sg), 183 | Sg_inner x x= 0 -> x = @Sg_zero G P (proj1 CPM). 184 | Proof. 185 | intros x Hx; apply Sg_eq; simpl. 186 | now apply inner_eq_0. 187 | Qed. 188 | 189 | Lemma Sg_inner_scal : forall (x y: Sg) (l : R), 190 | Sg_inner (Sg_scal l x) y = l * (Sg_inner x y). 191 | intros x y l. 192 | apply inner_scal_l. 193 | Qed. 194 | 195 | Lemma Sg_inner_plus : forall (x y z: Sg), 196 | Sg_inner (Sg_plus x y) z = plus (Sg_inner x z) (Sg_inner y z). 197 | Proof. 198 | intros x y z. 199 | apply inner_plus_l. 200 | Qed. 201 | 202 | Definition Sg_PreHilbert_mixin := 203 | PreHilbert.Mixin (@Sg_ModuleSpace G P CPM) 204 | _ Sg_inner_comm Sg_inner_pos Sg_inner_def Sg_inner_scal Sg_inner_plus. 205 | 206 | Canonical Sg_PreHilbert := 207 | PreHilbert.Pack Sg (PreHilbert.Class _ _ Sg_PreHilbert_mixin) (@Sg G P). 208 | 209 | End Subprehilbert. 210 | 211 | (** Sub-hilbert *) 212 | 213 | Section Subhilbert. 214 | 215 | Context {G : Hilbert}. 216 | Context {P: G -> Prop}. 217 | 218 | Hypothesis CPM: compatible_m P. 219 | 220 | Let Sg_plus := (@Sg_plus _ P (proj1 CPM)). 221 | Let Sg_scal := (@Sg_scal _ P CPM). 222 | 223 | Definition Sg_cleanFilter (Fi : (Sg -> Prop) -> Prop) : (G -> Prop) -> Prop 224 | := fun A : ((G -> Prop)) => exists V : (Sg -> Prop), Fi V /\ 225 | (forall f : (@Sg G P), V f -> A (val f)). 226 | 227 | Lemma Sg_cleanFilterProper: forall (Fi: (Sg -> Prop) -> Prop), 228 | ProperFilter Fi -> ProperFilter (Sg_cleanFilter Fi). 229 | Proof. 230 | intros Fi (FF1,FF2). 231 | constructor. 232 | unfold Sg_cleanFilter. 233 | intros P0 (V,(HV1,HV2)). 234 | destruct (FF1 V HV1) as (f,Hf). 235 | specialize (HV2 f). 236 | exists (val f). 237 | apply HV2; trivial. 238 | constructor; unfold Sg_cleanFilter. 239 | exists (fun _ => True); split; try easy. 240 | apply FF2. 241 | intros P0 Q (Vp,(HP1,HP2)) (Vq,(HQ1,HQ2)). 242 | exists (fun x => Vp x /\ Vq x); split. 243 | now apply FF2. 244 | intros f (Hf1,Hf2). 245 | split. 246 | now apply HP2. 247 | now apply HQ2. 248 | intros P0 Q H (Vp,(HP1,HP2)). 249 | exists Vp; split. 250 | easy. 251 | intros f Hf. 252 | now apply H, HP2. 253 | Qed. 254 | 255 | Definition Sg_lim_v (Fi : (Sg -> Prop) -> Prop) := 256 | lim (Sg_cleanFilter Fi). 257 | 258 | End Subhilbert. 259 | -------------------------------------------------------------------------------- /coq/CertRL/LM/compatible.v: -------------------------------------------------------------------------------- 1 | (** 2 | This file is part of the Elfic library 3 | 4 | Copyright (C) Boldo, Clément, Faissole, Martin, Mayero 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 3 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | COPYING file for more details. 15 | *) 16 | 17 | Require Export Reals Coquelicot.Coquelicot. 18 | 19 | (** AbelianGroup-compatibility *) 20 | 21 | Section AboutCompatibleG. 22 | 23 | Context {E : AbelianGroup}. 24 | 25 | Definition compatible_g (P: E -> Prop) : Prop := 26 | (forall (x y:E), P x -> P y -> P (plus x (opp y))) /\ 27 | (exists (x:E), P x). 28 | 29 | Lemma compatible_g_zero: forall P, compatible_g P -> P zero. 30 | Proof. 31 | intros P HP; destruct HP as (H1,(e,He)). 32 | specialize (H1 e e). 33 | rewrite plus_opp_r in H1. 34 | now apply H1. 35 | Qed. 36 | 37 | Lemma compatible_g_opp: forall P x, compatible_g P 38 | -> P x -> P (opp x). 39 | Proof. 40 | intros P x HP Hx. 41 | rewrite <- plus_zero_l. 42 | apply HP; try assumption. 43 | now apply compatible_g_zero. 44 | Qed. 45 | 46 | Lemma compatible_g_plus: forall P x y, compatible_g P 47 | -> P x -> P y -> P (plus x y). 48 | Proof. 49 | intros P x y HP Hx Hy. 50 | rewrite <- (opp_opp y). 51 | apply HP; try assumption. 52 | now apply compatible_g_opp. 53 | Qed. 54 | 55 | End AboutCompatibleG. 56 | 57 | (** ModuleSpace-compatibility *) 58 | 59 | Section AboutCompatibleM. 60 | 61 | Context {E : ModuleSpace R_Ring}. 62 | 63 | Definition compatible_m (phi:E->Prop):= 64 | compatible_g phi /\ 65 | (forall (x:E) (l:R), phi x -> phi (scal l x)). 66 | 67 | Lemma compatible_m_zero: forall P, compatible_m P -> P zero. 68 | Proof. 69 | intros. destruct H. 70 | apply (compatible_g_zero P); trivial. 71 | Qed. 72 | 73 | Lemma compatible_m_plus: forall P x y, compatible_m P 74 | -> P x -> P y -> P (plus x y). 75 | Proof. 76 | intros P x y Hp Hx Hy. 77 | destruct Hp. 78 | apply (compatible_g_plus P x y); trivial. 79 | Qed. 80 | 81 | Lemma compatible_m_scal: forall P a y, compatible_m P 82 | -> P y -> P (scal a y). 83 | Proof. 84 | intros P x y HP Hy. 85 | apply HP; trivial. 86 | Qed. 87 | 88 | Lemma compatible_m_opp: forall P x, compatible_m P 89 | -> P x -> P (opp x). 90 | Proof. 91 | intros. destruct H. 92 | apply (compatible_g_opp P); trivial. 93 | Qed. 94 | 95 | End AboutCompatibleM. 96 | 97 | (** Sums and direct sums *) 98 | 99 | Section Compat_m. 100 | 101 | Context {E : ModuleSpace R_Ring}. 102 | 103 | Variable phi:E->Prop. 104 | Variable phi':E->Prop. 105 | 106 | Definition m_plus (phi phi':E -> Prop) 107 | := (fun (x:E) => exists u u', phi u -> phi' u' -> x=plus u u'). 108 | 109 | Hypothesis Cphi: compatible_m phi. 110 | Hypothesis Cphi': compatible_m phi'. 111 | 112 | Lemma compatible_m_plus2: compatible_m (m_plus phi phi'). 113 | unfold compatible_m in *; unfold compatible_g in *. 114 | destruct Cphi as ((Cphi1,(a,Cphi2)),Cphi3). 115 | destruct Cphi' as ((Cphi1',(a',Cphi2')),Cphi3'). 116 | unfold m_plus in *. 117 | split. 118 | split; intros. exists (plus x (opp y)). exists zero. 119 | intros. rewrite plus_zero_r. reflexivity. 120 | exists (plus a a'). exists a. exists a'. intros. 121 | reflexivity. 122 | intros. exists (scal l x). exists (scal zero x). 123 | intros. rewrite <- scal_distr_r. rewrite plus_zero_r. 124 | reflexivity. 125 | Qed. 126 | 127 | Definition direct_sumable := forall x, phi x -> phi' x -> x = zero. 128 | 129 | Lemma direct_sum_eq1: 130 | direct_sumable -> 131 | (forall u u' , phi u -> phi' u' -> plus u u' = zero -> u=zero /\ u'=zero). 132 | intros. split. 133 | unfold compatible_m in *. 134 | unfold compatible_g in *. 135 | assert (u = opp u'). 136 | rewrite <- plus_opp_r with u' in H2. 137 | rewrite plus_comm in H2. 138 | apply plus_reg_l in H2. 139 | trivial. 140 | assert (phi' u). 141 | rewrite H3 in H2. 142 | rewrite H3. 143 | rewrite <- scal_opp_one. 144 | apply (proj2 Cphi'). trivial. 145 | apply H; trivial. 146 | assert (u' = opp u). 147 | rewrite <- plus_opp_r with u in H2. 148 | apply plus_reg_l in H2. trivial. 149 | assert (phi u'). 150 | rewrite H3 in H2. 151 | rewrite H3. 152 | rewrite <- scal_opp_one. 153 | apply (proj2 Cphi). trivial. 154 | apply H; trivial. 155 | Qed. 156 | 157 | Lemma plus_u_opp_v : forall (u v : E), u = v <-> (plus u (opp v) = zero). 158 | intros; split. 159 | + intros. rewrite H. rewrite plus_opp_r. reflexivity. 160 | + intros. apply plus_reg_r with (opp v). rewrite plus_opp_r; trivial. 161 | Qed. 162 | 163 | Lemma plus_assoc_gen : forall (a b c d : E), 164 | plus (plus a b) (plus c d) = plus (plus a c) (plus b d). 165 | intros. rewrite plus_assoc. symmetry. rewrite plus_assoc. 166 | assert (plus a (plus b c) = plus (plus a b) c). 167 | apply plus_assoc. 168 | assert (plus a (plus c b) = plus (plus a c) b). 169 | apply plus_assoc. 170 | rewrite <- H; rewrite <-H0. 171 | rewrite (plus_comm c b). reflexivity. 172 | Qed. 173 | 174 | Lemma direct_sum_eq2: 175 | (forall u u' , phi u -> phi' u' -> plus u u' = zero -> u=zero /\ u'=zero) -> 176 | (forall u v u' v', phi u -> phi v -> phi' u' -> phi' v' -> plus u u' = plus v v' -> u=v /\ u'=v'). 177 | intros. unfold compatible_m in *; unfold compatible_g in *. 178 | destruct Cphi as ((Cphi1,(x,Cphi2)),Cphi3). 179 | destruct Cphi' as ((Cphi'1,(x',Cphi'2)),Cphi'3). 180 | assert (plus (plus u (opp v)) (plus u' (opp v')) = zero). 181 | rewrite plus_assoc_gen. rewrite H4. 182 | rewrite plus_assoc_gen. rewrite plus_opp_r. rewrite plus_opp_r. 183 | rewrite plus_zero_r. reflexivity. 184 | rewrite plus_u_opp_v. 185 | rewrite (plus_u_opp_v u' v'). 186 | apply H. 187 | apply Cphi1; trivial. 188 | apply Cphi'1; trivial. 189 | trivial. 190 | Qed. 191 | 192 | Lemma direct_sum_eq3: 193 | (forall u v u' v', phi u -> phi v -> phi' u' -> phi' v' -> plus u u' = plus v v' -> u=v /\ u'=v') 194 | -> direct_sumable. 195 | intros. 196 | unfold compatible_m in *; unfold compatible_g in *; unfold direct_sumable. 197 | intros. 198 | destruct Cphi as ((Cphi1,(y,Cphi2)),Cphi3). 199 | destruct Cphi' as ((Cphi'1,(y',Cphi'2)),Cphi'3). 200 | apply (Cphi3 y zero) in Cphi2. 201 | apply (Cphi'3 y' zero) in Cphi'2. 202 | apply (Cphi'3 x (opp one)) in H1. 203 | assert ((x = zero) /\ (opp x = zero)). 204 | apply H. trivial. rewrite <- (scal_zero_l y). trivial. 205 | rewrite <- scal_opp_one. trivial. 206 | rewrite <- (scal_zero_l y'). trivial. 207 | rewrite plus_opp_r. 208 | rewrite plus_zero_l. reflexivity. 209 | intuition. 210 | Qed. 211 | 212 | End Compat_m. 213 | -------------------------------------------------------------------------------- /coq/CertRL/LM/lax_milgram_cea.v: -------------------------------------------------------------------------------- 1 | (** 2 | This file is part of the Elfic library 3 | 4 | Copyright (C) Boldo, Clément, Faissole, Martin, Mayero 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 3 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | COPYING file for more details. 15 | *) 16 | 17 | Require Import hilbert. 18 | Require Export Decidable. 19 | Require Export FunctionalExtensionality. 20 | Require Export mathcomp.ssreflect.ssreflect. 21 | Require Export Coquelicot.Hierarchy. 22 | Require Export Reals. 23 | Require Export logic_tricks. 24 | Require Export ProofIrrelevanceFacts. 25 | Require Export lax_milgram. 26 | 27 | (** Lax-Milgram-Cea's Theorem *) 28 | 29 | Section LMC. 30 | 31 | Context { E : Hilbert }. 32 | 33 | Variable a : E -> E -> R. 34 | Variable M : R. 35 | Variable alpha : R. 36 | Hypothesis Hba : is_bounded_bilinear_mapping a M. 37 | Hypothesis Hca : is_coercive a alpha. 38 | 39 | Lemma Galerkin_orthogonality (u uh : E) 40 | (f:topo_dual E) (phi : E -> Prop) : 41 | (forall (f : topo_dual E), decidable (exists u : E, f u <> 0)) -> 42 | phi uh -> 43 | is_sol_linear_pb_phi a (fun x:E => True) f u -> 44 | is_sol_linear_pb_phi a phi f uh -> 45 | (forall vh : E, phi vh -> a (minus u uh) vh = 0). 46 | Proof. 47 | intros Hd phi_uh Hle Hleh vh SubEh. 48 | unfold minus. 49 | destruct Hba as ((Hba1,(Hba2,(Hba3,Hba4))),_). 50 | rewrite Hba3. 51 | replace (opp uh) with (scal (opp one) uh). 52 | rewrite Hba1. 53 | rewrite scal_opp_one. 54 | unfold is_sol_linear_pb_phi in Hle. 55 | destruct Hle as (_,Hle). 56 | rewrite Hle. 57 | rewrite (proj2 Hleh). 58 | rewrite plus_opp_r. 59 | reflexivity. 60 | trivial. 61 | trivial. 62 | rewrite scal_opp_one. 63 | reflexivity. 64 | Qed. 65 | 66 | Lemma Lax_Milgram_Cea (u uh : E) (f:topo_dual E) (phi : E -> Prop) : 67 | (forall (f : topo_dual E), decidable (exists u : E, f u <> 0)) -> 68 | phi uh -> compatible_m phi -> my_complete phi -> 69 | is_sol_linear_pb_phi a (fun x:E => True) f u -> 70 | is_sol_linear_pb_phi a phi f uh -> (forall vh : E, phi vh -> 71 | norm (minus u uh) <= (M/alpha) * norm (minus u vh)). 72 | Proof. 73 | intros Hdf Huh HM HC H1 H2 vh Hvh. 74 | destruct (is_zero_dec (minus u uh)). 75 | rewrite H. 76 | rewrite norm_zero. 77 | apply Rmult_le_pos. 78 | destruct Hba as (_,(Hb,_)). 79 | replace (M / alpha) with (M * / alpha); try trivial. 80 | replace 0 with (0*0). 81 | apply Rmult_le_compat; intuition. 82 | intuition. 83 | destruct Hca as (Hc,_). 84 | apply Rinv_0_lt_compat in Hc. 85 | intuition. ring. 86 | apply norm_ge_0. 87 | assert (Ha : a (minus u uh) (minus u vh) = a (minus u uh) u). 88 | transitivity (minus (a (minus u uh) u) (a (minus u uh) vh)). 89 | destruct Hba as ((Hba1,(Hba2,(Hba3,Hba4))),_). 90 | rewrite Hba4. 91 | unfold minus at 3. 92 | replace (a (minus u uh) (opp vh)) with (opp (a (minus u uh) vh)). 93 | reflexivity. 94 | replace (opp vh) with (scal (opp one) vh). 95 | rewrite Hba2. 96 | rewrite scal_opp_one. 97 | reflexivity. 98 | rewrite scal_opp_one. 99 | reflexivity. 100 | replace (a (minus u uh) vh) with 0. 101 | unfold minus at 1. 102 | rewrite opp_zero. 103 | rewrite plus_zero_r. 104 | reflexivity. 105 | symmetry. 106 | apply Galerkin_orthogonality with f phi; try assumption. 107 | apply Rmult_le_reg_l with alpha. 108 | apply Hca. 109 | field_simplify. 110 | replace (alpha * norm (minus u uh) / 1) with (alpha * norm (minus u uh)) 111 | by field. 112 | replace (M * norm (minus u vh) / 1) with (M * norm (minus u vh)) by field. 113 | apply Rmult_le_reg_r with (norm (minus u uh)). 114 | now apply norm_gt_0. 115 | unfold is_bounded_bilinear_mapping in Hba. 116 | destruct Hba as (H0,H3). 117 | unfold is_bounded_bi in H3. 118 | destruct H3 as (H3,H4). 119 | specialize (H4 (minus u uh) (minus u vh)). 120 | apply Rle_trans with (norm (a (minus u uh) (minus u vh))); 121 | try assumption. 122 | rewrite Ha. 123 | destruct Hca as (H5,H6). 124 | unfold is_sol_linear_pb_phi in *. 125 | destruct H1 as (X1,H1). 126 | destruct H2 as (X2,H2). 127 | replace (a (minus u uh) u) 128 | with (a (minus u uh) (minus u uh)). 129 | specialize (H6 (minus u uh)). 130 | unfold norm at 3. 131 | simpl. 132 | apply Rle_trans with (a (minus u uh) (minus u uh)). 133 | trivial. 134 | unfold abs. 135 | simpl. 136 | apply Rle_abs. 137 | destruct H0 as (H0,H7). 138 | destruct H7 as (H7,(H8,H9)). 139 | unfold minus. 140 | rewrite H9. 141 | replace (a (plus u (opp uh)) u) with 142 | (plus (a (plus u (opp uh)) u) 0). 143 | f_equal. 144 | now rewrite plus_zero_r. 145 | specialize (H1 uh). 146 | apply H1 in X1. 147 | specialize (H2 uh). 148 | apply H2 in X2. 149 | clear H1 H2. 150 | rewrite H8. 151 | replace (a u (opp uh)) with (opp (a u uh)). 152 | rewrite X1. 153 | replace (a (opp uh) (opp uh)) with (a uh uh). 154 | rewrite X2. 155 | rewrite plus_opp_l; reflexivity. 156 | replace (opp uh) with (scal (opp one) uh). 157 | replace (opp uh) with (scal (opp one) uh). 158 | rewrite H0 H7 2!scal_opp_l scal_one opp_opp scal_one. 159 | reflexivity. 160 | rewrite scal_opp_one. 161 | reflexivity. 162 | rewrite scal_opp_one; reflexivity. 163 | replace (opp uh) with (scal (opp one) uh). 164 | rewrite H7 scal_opp_one. 165 | reflexivity. 166 | rewrite scal_opp_one. 167 | reflexivity. 168 | rewrite plus_zero_r; reflexivity. 169 | replace (M * norm (minus u vh) * norm (minus u uh)) with 170 | (M * norm (minus u uh) * norm (minus u vh)) by ring. 171 | assumption. 172 | destruct Hca. 173 | intro Hk. 174 | rewrite Hk in H0. 175 | absurd (0 < 0); try assumption. 176 | exact (Rlt_irrefl 0). 177 | Qed. 178 | 179 | End LMC. 180 | -------------------------------------------------------------------------------- /coq/CertRL/LM/linear_map.v: -------------------------------------------------------------------------------- 1 | (** 2 | This file is part of the Elfic library 3 | 4 | Copyright (C) Boldo, Clément, Faissole, Martin, Mayero 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 3 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | COPYING file for more details. 15 | *) 16 | 17 | Require Import FunctionalExtensionality. 18 | Require Export compatible. 19 | 20 | (** About functions from E to F *) 21 | 22 | (** Note that Coquelicot has: U UniformSpace, then T->U UniformSpace, 23 | and similar for CompleteSpace *) 24 | 25 | (** Functions to a ModuleSpace are a ModuleSpace *) 26 | 27 | Section Fcts. 28 | 29 | Context {E : Type}. 30 | Context {F : ModuleSpace R_Ring}. 31 | 32 | Definition fct_plus (f:E->F) (g:E->F) : (E->F) := 33 | fun x => plus (f x) (g x). 34 | 35 | Definition fct_scal (l:R) (f:E->F) : (E->F) := 36 | fun x => scal l (f x). 37 | 38 | Definition fct_opp (f:E->F) : (E -> F) := 39 | fun x => opp (f x). 40 | 41 | Definition fct_zero:E->F := fun _ => zero. 42 | 43 | Lemma fct_plus_comm: forall (f g:E->F), fct_plus f g = fct_plus g f. 44 | Proof. 45 | intros f g. 46 | apply functional_extensionality. 47 | intros x; apply plus_comm. 48 | Qed. 49 | 50 | Lemma fct_plus_assoc: 51 | forall (f g h:E->F), fct_plus f (fct_plus g h) = fct_plus (fct_plus f g) h. 52 | Proof. 53 | intros f g h. 54 | apply functional_extensionality. 55 | intros x; apply plus_assoc. 56 | Qed. 57 | 58 | Lemma fct_plus_zero_r: forall f:E->F, fct_plus f fct_zero = f. 59 | Proof. 60 | intros f. 61 | apply functional_extensionality. 62 | intros x; apply plus_zero_r. 63 | Qed. 64 | 65 | Lemma fct_plus_opp_r: forall f:E->F, fct_plus f (fct_opp f) = fct_zero. 66 | Proof. 67 | intros f. 68 | apply functional_extensionality. 69 | intros x; apply plus_opp_r. 70 | Qed. 71 | 72 | Definition fct_AbelianGroup_mixin := 73 | AbelianGroup.Mixin (E->F) fct_plus fct_opp fct_zero fct_plus_comm 74 | fct_plus_assoc fct_plus_zero_r fct_plus_opp_r. 75 | 76 | Canonical fct_AbelianGroup := 77 | AbelianGroup.Pack (E->F) (fct_AbelianGroup_mixin) (E->F). 78 | 79 | Lemma fct_scal_assoc: forall x y (u:E->F), 80 | fct_scal x (fct_scal y u) = fct_scal (mult x y) u. 81 | Proof. 82 | intros x y u. 83 | apply functional_extensionality. 84 | intros x0; apply scal_assoc. 85 | Qed. 86 | 87 | Lemma fct_scal_one: forall (u:E->F), fct_scal one u = u. 88 | Proof. 89 | intros u. 90 | apply functional_extensionality. 91 | intros x; apply scal_one. 92 | Qed. 93 | 94 | Lemma fct_scal_distr_l: forall x (u v:E->F), fct_scal x (plus u v) = fct_plus (fct_scal x u) (fct_scal x v). 95 | Proof. 96 | intros x u v. 97 | apply functional_extensionality. 98 | intros x0; apply scal_distr_l. 99 | Qed. 100 | 101 | Lemma fct_scal_distr_r: forall (x y:R) (u:E->F), fct_scal (Rplus x y) u = fct_plus (fct_scal x u) (fct_scal y u). 102 | Proof. 103 | intros x y u. 104 | apply functional_extensionality. 105 | intros x0. 106 | apply (scal_distr_r x y). 107 | Qed. 108 | 109 | Definition fct_ModuleSpace_mixin := 110 | ModuleSpace.Mixin R_Ring fct_AbelianGroup fct_scal fct_scal_assoc 111 | fct_scal_one fct_scal_distr_l fct_scal_distr_r. 112 | 113 | Canonical fct_ModuleSpace := 114 | ModuleSpace.Pack R_Ring (E->F) 115 | (ModuleSpace.Class R_Ring (E->F) _ fct_ModuleSpace_mixin) (E->F). 116 | 117 | End Fcts. 118 | 119 | (** Linear Mapping *) 120 | 121 | Section SSG_linear_mapping. 122 | 123 | Context {E : ModuleSpace R_Ring}. 124 | Context {F : ModuleSpace R_Ring}. 125 | 126 | (* p18, def 55 *) 127 | Definition is_linear_mapping (phi: E -> F) := 128 | (forall (x y : E), phi (plus x y) = plus (phi x) (phi y)) 129 | /\ (forall (x : E) (l:R), phi (scal l x) = scal l (phi x)). 130 | 131 | Theorem compatible_g_is_linear_mapping: 132 | compatible_g is_linear_mapping. 133 | Proof. 134 | split. 135 | intros f g (Hf1,Hf2) (Hg1,Hg2). 136 | split. 137 | + intros x y. 138 | unfold plus at 1 4 5; unfold opp; simpl. 139 | unfold fct_plus, fct_opp. 140 | rewrite Hf1, Hg1. 141 | rewrite opp_plus. 142 | repeat rewrite <- plus_assoc. 143 | apply f_equal. 144 | repeat rewrite plus_assoc. 145 | apply f_equal2; try easy. 146 | apply plus_comm. 147 | + intros x l. 148 | unfold plus, opp;simpl. 149 | unfold fct_plus, fct_opp. 150 | rewrite Hf2, Hg2. 151 | rewrite <- scal_opp_l. 152 | rewrite scal_distr_l. 153 | apply f_equal. 154 | rewrite scal_opp_l. 155 | now rewrite scal_opp_r. 156 | + exists zero. 157 | split; unfold zero; intros; simpl; unfold fct_zero. 158 | now rewrite plus_zero_l. 159 | now rewrite scal_zero_r. 160 | Qed. 161 | 162 | Lemma is_linear_mapping_zero: forall f, 163 | is_linear_mapping f -> f zero = zero. 164 | Proof. 165 | intros f (Hf1,Hf2). 166 | apply trans_eq with (f (scal zero zero)). 167 | now rewrite scal_zero_l. 168 | rewrite Hf2. 169 | apply scal_zero_l. 170 | Qed. 171 | 172 | Lemma is_linear_mapping_opp: forall f x, 173 | is_linear_mapping f -> f (opp x) = opp (f x). 174 | Proof. 175 | intros f y (Hf1,Hf2). 176 | rewrite <- scal_opp_one. 177 | rewrite Hf2. 178 | now rewrite scal_opp_one. 179 | Qed. 180 | 181 | Lemma is_linear_mapping_f_zero: 182 | is_linear_mapping (fun (x:E) => @zero F). 183 | Proof. 184 | split; intros. 185 | apply sym_eq, plus_zero_l. 186 | apply sym_eq, scal_zero_r. 187 | Qed. 188 | 189 | Lemma is_linear_mapping_f_opp: forall (f:E->F), 190 | is_linear_mapping f -> 191 | is_linear_mapping (opp f). 192 | Proof. 193 | intros f (H1,H2); split. 194 | intros x y; unfold opp; simpl; unfold fct_opp. 195 | rewrite H1. 196 | apply opp_plus. 197 | intros x l; unfold opp; simpl; unfold fct_opp. 198 | rewrite H2. 199 | now rewrite <- scal_opp_r. 200 | Qed. 201 | 202 | Lemma is_linear_mapping_f_plus: forall (f g:E->F), 203 | is_linear_mapping f -> is_linear_mapping g -> 204 | is_linear_mapping (plus f g). 205 | Proof. 206 | intros f g (H1,K1) (H2,K2); split. 207 | intros x y; unfold plus at 1 4 5; simpl; unfold fct_plus. 208 | rewrite H1, H2. 209 | rewrite <- 2!plus_assoc; apply f_equal. 210 | rewrite plus_comm, plus_assoc. 211 | rewrite <- 2!plus_assoc; apply f_equal, plus_comm. 212 | intros x l; unfold plus; simpl; unfold fct_plus. 213 | rewrite K1, K2. 214 | now rewrite scal_distr_l. 215 | Qed. 216 | 217 | Lemma is_linear_mapping_f_scal: forall l, forall (f:E->F), 218 | is_linear_mapping f -> 219 | is_linear_mapping (scal l f). 220 | Proof. 221 | intros l f (H1,H2); split. 222 | intros x y; unfold scal; simpl; unfold fct_scal. 223 | now rewrite H1, scal_distr_l. 224 | intros x k. 225 | unfold scal at 1 4; simpl; unfold fct_scal. 226 | rewrite H2, 2!scal_assoc. 227 | unfold mult; simpl. 228 | now rewrite Rmult_comm. 229 | Qed. 230 | 231 | End SSG_linear_mapping. 232 | 233 | Section SSG_bilinear_mapping. 234 | 235 | Context {E : ModuleSpace R_Ring}. 236 | Context {F : ModuleSpace R_Ring}. 237 | Context {G : ModuleSpace R_Ring}. 238 | 239 | Definition is_bilinear_mapping (phi: E -> F -> G) := 240 | (forall (x:E) (y:F) (l:R), phi (scal l x) y = scal l (phi x y)) /\ 241 | (forall (x:E) (y:F) (l:R), phi x (scal l y) = scal l (phi x y)) /\ 242 | (forall (x y: E) (z:F), phi (plus x y) z = plus (phi x z) (phi y z)) /\ 243 | (forall (x:E) (y z : F), phi x (plus y z) = plus (phi x y) (phi x z)). 244 | 245 | Theorem compatible_g_is_bilinear_mapping: 246 | compatible_g is_bilinear_mapping. 247 | split. 248 | intros f g (Hf1,(Hf2,(Hf3,Hf4))) (Hg1,(Hg2,(Hg3,Hg4))). 249 | split. 250 | intros x y l;unfold plus; unfold opp; simpl;unfold fct_plus, fct_opp;unfold plus, opp; simpl; 251 | unfold fct_plus, fct_opp;rewrite Hf1,Hg1;rewrite <- scal_opp_r;now rewrite scal_distr_l. 252 | split. 253 | intros x y l;unfold plus; unfold opp; simpl;unfold fct_plus, fct_opp;unfold plus, opp; simpl; 254 | unfold fct_plus, fct_opp;rewrite Hf2,Hg2;rewrite <- scal_opp_r;now rewrite scal_distr_l. 255 | split. 256 | intros x y z; unfold plus at 1 4 5; unfold opp;simpl; unfold fct_plus, fct_opp; 257 | unfold plus at 1 5 6;unfold opp;simpl;unfold fct_plus, fct_opp;rewrite Hf3,Hg3; 258 | rewrite opp_plus;rewrite plus_assoc;rewrite plus_assoc;apply f_equal2;trivial. 259 | rewrite <- plus_assoc;rewrite (plus_comm (f y z) (opp (g x z)));now rewrite plus_assoc. 260 | intros x y z; unfold plus at 1 4 5; unfold opp;simpl; unfold fct_plus, fct_opp. 261 | unfold plus at 1 4 5;unfold opp;simpl;unfold fct_plus, fct_opp. rewrite Hf4,Hg4; 262 | rewrite opp_plus;rewrite plus_assoc;rewrite plus_assoc;apply f_equal2;trivial. 263 | rewrite <- plus_assoc;rewrite (plus_comm (f x z) (opp (g x y)));now rewrite plus_assoc. 264 | exists zero;split. 265 | unfold zero;intros;simpl;unfold fct_zero; simpl;unfold zero;simpl;unfold fct_zero; 266 | now rewrite scal_zero_r. 267 | split. 268 | unfold zero;intros;simpl;unfold fct_zero; simpl;unfold zero;simpl;unfold fct_zero; 269 | now rewrite scal_zero_r. 270 | split. 271 | unfold zero;intros;simpl;unfold fct_zero; simpl;unfold zero;simpl;unfold fct_zero; 272 | now rewrite plus_zero_l. 273 | unfold zero;intros;simpl;unfold fct_zero; simpl;unfold zero;simpl;unfold fct_zero; 274 | now rewrite plus_zero_l. 275 | Qed. 276 | 277 | End SSG_bilinear_mapping. 278 | 279 | (** Injections, surjections, bijections *) 280 | 281 | Section Inj_Surj_Bij. 282 | 283 | Context {E : ModuleSpace R_Ring}. 284 | Context {F : ModuleSpace R_Ring}. 285 | 286 | Definition is_injective (f: E -> F) := 287 | forall (x y : E), f x = f y -> x = y. 288 | 289 | Definition is_surjective (f: E -> F) := 290 | forall (y : F), exists (x : E), f x = y. 291 | 292 | Definition is_bijective (f: E -> F) := 293 | (is_injective f) /\ (is_surjective f). 294 | 295 | End Inj_Surj_Bij. 296 | -------------------------------------------------------------------------------- /coq/CertRL/LM/logic_tricks.v: -------------------------------------------------------------------------------- 1 | (** 2 | This file is part of the Elfic library 3 | 4 | Copyright (C) Boldo, Clément, Faissole, Martin, Mayero 5 | 6 | This library is free software; you can redistribute it and/or 7 | modify it under the terms of the GNU Lesser General Public 8 | License as published by the Free Software Foundation; either 9 | version 3 of the License, or (at your option) any later version. 10 | 11 | This library is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | COPYING file for more details. 15 | *) 16 | 17 | Require Import Decidable. 18 | Require Import Arith. 19 | 20 | (** Intuitionistic tricks for decidability *) 21 | 22 | Section LT. 23 | 24 | Lemma logic_not_not : forall Q, False <-> ((Q \/~Q) -> False). 25 | split. 26 | now intros H H'. 27 | intros H'. 28 | apply H'. 29 | right. 30 | intros H. 31 | apply H'. 32 | now left. 33 | Qed. 34 | 35 | Lemma logic_notex_forall (T : Type) : 36 | forall (P : T -> Prop) (x : T), 37 | (forall x, P x) -> (~ exists x, ~ P x). 38 | Proof. 39 | intros P x H. 40 | intro H0. 41 | destruct H0 as (t,H0). 42 | apply H0. 43 | apply H. 44 | Qed. 45 | 46 | Lemma logic_dec_notnot (T : Type) : 47 | forall P : T -> Prop, forall x : T, 48 | (decidable (P x)) -> (P x <-> ~~ P x). 49 | Proof. 50 | intros P x Dec. 51 | split. 52 | + intro H. 53 | intuition. 54 | + intro H. 55 | unfold decidable in Dec. 56 | destruct Dec. 57 | trivial. 58 | exfalso. 59 | apply H. 60 | exact H0. 61 | Qed. 62 | 63 | Lemma decidable_ext: forall P Q, decidable P -> (P <->Q) -> decidable Q. 64 | Proof. 65 | intros P Q HP (H1,H2). 66 | case HP; intros HP'. 67 | left; now apply H1. 68 | right; intros HQ. 69 | now apply HP', H2. 70 | Qed. 71 | 72 | Lemma decidable_ext_aux: forall (T : Type), forall P1 P2 Q, 73 | decidable (exists w:T, P1 w /\ Q w) -> 74 | (forall x, P1 x <-> P2 x) -> 75 | decidable (exists w, P2 w /\ Q w). 76 | Proof. 77 | intros T P1 P2 Q H H1. 78 | case H. 79 | intros (w,(Hw1,Hw2)). 80 | left; exists w; split; try assumption. 81 | now apply H1. 82 | intros H2; right; intros (w,(Hw1,Hw2)). 83 | apply H2; exists w; split; try assumption. 84 | now apply H1. 85 | Qed. 86 | 87 | Lemma decidable_and: forall (T : Type), forall P1 P2 (w : T), 88 | decidable (P1 w) -> decidable (P2 w) -> decidable (P1 w /\ P2 w). 89 | Proof. 90 | intros T P1 P2 w H1 H2. 91 | unfold decidable. 92 | destruct H1. 93 | destruct H2. 94 | left; intuition. 95 | right. 96 | intro. 97 | now apply H0. 98 | destruct H2. 99 | right. 100 | intro. 101 | now apply H. 102 | right. 103 | intro. 104 | now apply H. 105 | Qed. 106 | 107 | (** Strong induction *) 108 | 109 | Theorem strong_induction: 110 | forall P : nat -> Prop, 111 | (forall n : nat, (forall k : nat, ((k < n)%nat -> P k)) -> P n) -> 112 | forall n : nat, P n. 113 | Proof. 114 | intros P H n. 115 | assert (forall k, (k < S n)%nat -> P k). 116 | induction n. 117 | intros k Hk. 118 | replace k with 0%nat. 119 | apply H. 120 | intros m Hm; contradict Hm. 121 | apply lt_n_0. 122 | generalize Hk; case k; trivial. 123 | intros m Hm; contradict Hm. 124 | apply le_not_lt. 125 | now auto with arith. 126 | intros k Hk. 127 | apply H. 128 | intros m Hm. 129 | apply IHn. 130 | apply lt_le_trans with (1:=Hm). 131 | now apply gt_S_le. 132 | apply H0. 133 | apply le_n. 134 | Qed. 135 | 136 | (** Equivalent definition for existence + uniqueness *) 137 | 138 | Lemma unique_existence1: forall (A : Type) (P : A -> Prop), 139 | (exists x : A, P x) /\ uniqueness P -> (exists ! x : A, P x). 140 | Proof. 141 | intros A P. 142 | apply unique_existence. 143 | Qed. 144 | 145 | End LT. 146 | -------------------------------------------------------------------------------- /coq/CertRL/README.md: -------------------------------------------------------------------------------- 1 | # The CertRL library 2 | 3 | In this subdirectory we give a formal proof of convergence of the classical policy and value iteration algorithms in Reinforcement Learning. 4 | 5 | Our formalization is novel in that it utilizes the Finitary Giry Monad and a proof technique called Metric Coinduction. 6 | 7 | For more information, see our [CPP paper](https://dl.acm.org/doi/10.1145/3437992.3439927). 8 | 9 | ## Contents 10 | Here is a brief summary of the main files in this directory: 11 | 12 | * [`mdp.v`](https://github.com/IBM/FormalML/blob/master/coq/CertRL/mdp.v) 13 | * defines Markov Decision Processes (MDP) and proves various properties about them 14 | * definitions of long-term values (LTVs) 15 | * optimal value function 16 | * contraction and metric coinduction 17 | * proofs that LTVs are convergent 18 | * proofs that they satisfy the Bellman equation. 19 | * [`finite_time.v`](https://github.com/IBM/FormalML/blob/master/coq/CertRL/finite_time.v) 20 | * Proves the bellman equation for the optimal value function over a finite list of policies. 21 | * [`pmf_monad.v`](https://github.com/IBM/FormalML/blob/master/coq/CertRL/pmf_monad.v) 22 | * Contains the infrastructure for the monad structure on the the type of discrete probability measures on a type. 23 | * [`mdp_turtle.v`](https://github.com/IBM/FormalML/blob/master/coq/CertRL/mdp_turtle.v) 24 | * Defines a term of the `MDP` type. 25 | 26 | -------------------------------------------------------------------------------- /coq/CertRL/orderfun.v: -------------------------------------------------------------------------------- 1 | Require Import Sets.Ensembles. 2 | Require Import Coq.Program.Basics. 3 | 4 | Section range. 5 | Local Open Scope program_scope. 6 | 7 | Class NonEmpty (A : Type) := 8 | ex : A. 9 | 10 | Definition range {A B : Type} (f : A -> B): Ensemble B := fun y:B => exists x:A, f x = y. 11 | 12 | Definition mem {A : Type}(a : A) (X : Ensemble A) : Prop := X a. 13 | 14 | Notation "a ∈ X" := (mem a X) (at level 99). 15 | 16 | Definition preimage {A B : Type} (f : A -> B) (s : Ensemble B) : Ensemble A := 17 | fun x => f x ∈ s. 18 | 19 | Notation "f ⁻¹ s" := (preimage f s) (at level 99). 20 | 21 | Definition image {A B : Type} (f : A -> B) (s : Ensemble A) : Ensemble B := 22 | fun b => exists a, (a ∈ s) /\ f a = b. 23 | 24 | Notation "f '' s" := (image f s) (at level 1000). 25 | 26 | Lemma mem_range_iff {A B : Type} (f : A -> B) (y : B) : (y ∈ range f) <-> exists x:A, f x = y. 27 | Proof. 28 | firstorder. 29 | Qed. 30 | 31 | Hint Resolve mem_range_iff : range. 32 | 33 | Lemma mem_range_self {A B} (a : A) (f : A -> B) : (f a ∈ range f). 34 | Proof. 35 | now exists a. 36 | Qed. 37 | 38 | Hint Resolve mem_range_self : range. 39 | 40 | Lemma range_id {A} : range (fun x => x) = Full_set A. 41 | Proof. 42 | unfold range. 43 | apply Extensionality_Ensembles. 44 | 45 | split. 46 | - constructor. 47 | - intros x Hx. now exists x. 48 | Qed. 49 | 50 | Hint Resolve range_id : range. 51 | 52 | Lemma exists_range_iff {A B} (f : A -> B) (p : B -> Prop): 53 | (exists b, (b ∈ range f) /\ p b) <-> (exists a, p (f a)). 54 | Proof. 55 | intuition. 56 | * destruct H as [b [[a Ha] Hpb]]. 57 | exists a ; subst ; auto. 58 | * destruct H. 59 | exists (f x). auto with range. 60 | Qed. 61 | 62 | Lemma forall_range {A B}(f : A -> B) (p : B -> Prop) : 63 | (forall b, (b ∈ range f) /\ p b) -> (forall a, p (f a)). 64 | Proof. 65 | intros H i. 66 | now destruct (H (f i)). 67 | Qed. 68 | 69 | Lemma image_full_set {A B}(f : A -> B) : 70 | (f '' Full_set A) = range f. 71 | Proof. 72 | apply Extensionality_Ensembles. 73 | split. 74 | - intros x Hx. 75 | destruct Hx as [a [_ Hfa]] ; subst ; 76 | apply mem_range_self. 77 | - intros x Hx. 78 | destruct Hx as [a Ha]. now exists a. 79 | Qed. 80 | 81 | Notation "A ⊆ B" := (Included _ A B) (at level 50). 82 | 83 | Lemma image_subset_range {A B} (f : A -> B) (s : Ensemble A) : (f '' s) ⊆ (range f). 84 | Proof. 85 | intros x [x0 [H1 H2]] ; subst. 86 | apply mem_range_self. 87 | Qed. 88 | 89 | Lemma range_comp {A B C} (f : A -> B) (g: B -> C): range (fun x => g (f x)) = (g '' range f). 90 | Proof. 91 | apply Extensionality_Ensembles. 92 | split. 93 | - intros x Hx. 94 | destruct Hx ; subst. 95 | exists (f x0). 96 | split ; trivial ; apply mem_range_self. 97 | - intros x [x0 [[x1 Hx1] H2]] ; subst. 98 | exists x1 ; trivial. 99 | Qed. 100 | 101 | Lemma range_subset_iff {A B} (f : A -> B) (s : Ensemble B) : range f ⊆ s <-> forall y, f y ∈ s. 102 | Proof. 103 | split. 104 | * intros H y. 105 | specialize (H (f y)). 106 | apply H. apply mem_range_self. 107 | * intros H y [x Hyx] ; subst. 108 | apply H. 109 | Qed. 110 | 111 | Lemma range_comp_subset_range {A B C} (f : A -> B) (g : B -> C) : range (g ∘ f) ⊆ range g. 112 | Proof. 113 | intros x [x0 Hx0]. 114 | now exists (f x0). 115 | Qed. 116 | 117 | Lemma range_nonempty {A B} (f : A -> B) (ne : NonEmpty A) : exists x, (x ∈ range f). 118 | Proof. 119 | exists (f ne). apply mem_range_self. 120 | Qed. 121 | 122 | Notation "A ∩ B" := (Intersection _ A B) (at level 50). 123 | Lemma image_preimage_eq_subset_inter {A B} {f : A -> B} {s : Ensemble B} : 124 | (f '' (f ⁻¹ s)) = s ∩ (range f). 125 | Proof. 126 | apply Extensionality_Ensembles. 127 | split. 128 | * intros x Hx ; destruct Hx ; subst. 129 | destruct H. 130 | constructor. do 2 red in H. 131 | now rewrite H0 in H. 132 | rewrite <-H0 ; apply mem_range_self. 133 | * intros x Hx ; destruct Hx. 134 | destruct H0 as [x0 Hx0]. 135 | exists x0 ; split ; trivial. 136 | red ; now subst. 137 | Qed. 138 | 139 | 140 | End range. 141 | -------------------------------------------------------------------------------- /coq/CertRL/refs.md: -------------------------------------------------------------------------------- 1 | # References: 2 | 3 | 4 | ## Reinforcement Learning (MDPs). 5 | * Policy iteration/MDP definitions (from a coalgebraic viewpoint) : https://homepage.tudelft.nl/c9d1n/papers/cmcs-2018.pdf 6 | * Using the Banach fixed point theorem proven as part of the elfic library, in this paper : https://www.lri.fr/~sboldo/elfic/index.html 7 | * Lecture notes of Alessandro Lazaric : http://researchers.lille.inria.fr/~lazaric/Webpage/MVA-RL_Course14_files/notes-lecture-02.pdf 8 | * Applications of metric coinduction : https://arxiv.org/pdf/0908.2793.pdf 9 | * Monad structure `pmf` is independent, but also described in : https://github.com/jtassarotti/coq-proba/blob/master/theories/monad/finite/monad.v 10 | 11 | ## Stochastic Approximation. 12 | * Dvoretzky's stochastic convergence result, section 8 of this paper (which generalizes Robbins-Monro): https://projecteuclid.org/download/pdf_1/euclid.bsmsp/1200501645 13 | -------------------------------------------------------------------------------- /coq/NeuralNetworks/AxiomaticNormedRealVectorSpace.v: -------------------------------------------------------------------------------- 1 | (*using definitions from http://www.math.ucla.edu/~tao/resource/general/121.1.00s/vector_axioms.html *) 2 | 3 | Require Import Reals.Rbase. 4 | Require Import Reals.Rfunctions. 5 | 6 | Module AxiomaticNormedRealVectorSpace. 7 | 8 | Inductive rvector (d: nat) : Set := 9 | | zero 10 | | add (x y : rvector d) 11 | | inverse (x: rvector d) 12 | | smult (r:R) (x: rvector d). 13 | 14 | Class NormedVectorSpace (d: nat) := 15 | { 16 | norm: rvector d -> R; 17 | 18 | rv_axiom_additive : forall x y z : rvector d, 19 | (add d x y) = (add d y x) /\ 20 | (add d (add d x y) z) = (add d x (add d y z)) /\ 21 | (add d (zero d) x) = (add d x (zero d)) /\ 22 | (add d x (zero d)) = x /\ 23 | (add d (inverse d x) x) = (add d x (inverse d x)) /\ 24 | (add d x (inverse d x)) = zero d; 25 | 26 | rv_axiom_multiplicaive : forall (x : rvector d), forall (b c : R), 27 | smult d R0 x = zero d /\ 28 | smult d R1 x = x /\ 29 | smult d (Rmult b c) x = smult d b (smult d c x); 30 | 31 | rv_axiom_distributive : forall (x y : rvector d), forall (a b : R), 32 | smult d b (add d x y) = add d (smult d b x) (smult d b y) /\ 33 | smult d (Rplus a b) x = add d (smult d a x) (smult d b x); 34 | 35 | norm_axiom_zero : forall (x:rvector d), 36 | norm (zero d) = R0 <-> x=zero d; 37 | 38 | norm_axiom_abs : forall (x: rvector d), forall (a:R), 39 | norm (smult d a x) = Rmult (Rabs a) (norm x); 40 | 41 | norm_axiom_add : forall (x y : rvector d), 42 | norm (add d x y) = Rplus (norm x) (norm y); 43 | }. 44 | 45 | End AxiomaticNormedRealVectorSpace. 46 | -------------------------------------------------------------------------------- /coq/NeuralNetworks/NN.v: -------------------------------------------------------------------------------- 1 | Require Import Reals.Rbase. 2 | Require Import Reals.Rfunctions. 3 | Require Import Arith. 4 | Require Import String. 5 | Require Import Vector. 6 | 7 | Require Import AxiomaticNormedRealVectorSpace. 8 | 9 | Module NN. 10 | 11 | Section SeriesDivergence. 12 | 13 | Definition converges (s: nat -> R) := 14 | exists sum:R, infinite_sum s sum. 15 | 16 | Definition diverges (s: nat -> R) : Prop := 17 | ~(converges s). 18 | 19 | Definition diverges_right (s: nat -> R) : Prop := 20 | forall m: R, 21 | exists N: nat, 22 | forall n: nat, 23 | n >= N -> Rgt (s n) m. 24 | 25 | Definition diverges_left (s: nat -> R) : Prop := 26 | forall m: R, 27 | exists N: nat, 28 | forall n:nat, 29 | n >= N -> Rlt (s n) m. 30 | 31 | End SeriesDivergence. 32 | 33 | Section AssumptionC. 34 | 35 | Local Open Scope R_scope. 36 | Definition Assumption_C_1 (ak : nat -> R) : Prop := 37 | let 38 | ak_squared (n : nat) := (ak n)^2 39 | in 40 | (forall n, ak n >= 0) /\ 41 | diverges_right ak /\ 42 | converges ak_squared. 43 | 44 | Definition Assumption_C_2 (s: Set) (x: nat -> rvector s) : Prop := 45 | exists M : R, 46 | forall k: nat, norm s (x k) < M. 47 | 48 | (* TODO *) 49 | Definition Assumption_C_3 (zeta: nat -> R) : Prop := 50 | ZeroMeanBoundedVariance zeta. 51 | 52 | Definition Assumption_C (s: Set) (zeta: nat -> R) (alpha: nat -> R) (x : nat -> rvector s) : Prop := 53 | Assumption_C_1 alpha /\ Assumption_C_2 s x /\ Assumption_C_3 zeta. 54 | 55 | Local Close Scope R_scope. 56 | 57 | End AssumptionC. 58 | 59 | End NN. 60 | -------------------------------------------------------------------------------- /coq/ProbTheory/Independence.v: -------------------------------------------------------------------------------- 1 | Require Import Program.Basics. 2 | Require Import Coq.Reals.Rbase. 3 | 4 | Require Import Lra Lia. 5 | Require Import List. 6 | Require Import Morphisms EquivDec. 7 | 8 | Require Import Classical ClassicalFacts. 9 | 10 | Require Import utils.Utils. 11 | Import ListNotations. 12 | Require Export Event ProbSpace SigmaAlgebras. 13 | 14 | Require Import Dynkin. 15 | 16 | Set Bullet Behavior "Strict Subproofs". 17 | 18 | Section sigma_indep. 19 | 20 | Local Open Scope R. 21 | Local Open Scope prob. 22 | 23 | Context {Ts:Type} 24 | {dom: SigmaAlgebra Ts} 25 | (prts:ProbSpace dom). 26 | 27 | Definition independent_sas {dom1} (sub1:sa_sub dom1 dom) {dom2} (sub2:sa_sub dom2 dom) 28 | := forall (A:event dom1) (B:event dom2), 29 | independent_events prts (event_sa_sub sub1 A) (event_sa_sub sub2 B). 30 | 31 | Definition independent_sa_collection {Idx} (doms:Idx->SigmaAlgebra Ts) {sub:IsSubAlgebras dom doms} 32 | := 33 | forall (l:forall n, event (doms n)), 34 | independent_event_collection prts (fun n => event_sa_sub (sub n) (l n)). 35 | 36 | Definition pairwise_independent_sa_collection {Idx} (doms:Idx->SigmaAlgebra Ts) {sub:IsSubAlgebras dom doms} 37 | := forall (l:forall n, event (doms n)), 38 | pairwise_independent_event_collection prts (fun n => event_sa_sub (sub n) (l n)). 39 | 40 | 41 | Lemma independent_sas_sub_proper 42 | {dom1} (sub1:sa_sub dom1 dom) 43 | {dom1'} (sub1':sa_sub dom1' dom) 44 | (sasub1:sa_sub dom1' dom1) 45 | {dom2} (sub2:sa_sub dom2 dom) 46 | {dom2'} (sub2':sa_sub dom2' dom) 47 | (sasub2:sa_sub dom2' dom2) : 48 | independent_sas sub1 sub2 -> independent_sas sub1' sub2'. 49 | Proof. 50 | intros HH A B. 51 | red in HH. 52 | generalize (HH (event_sa_sub sasub1 A) 53 | (event_sa_sub sasub2 B)). 54 | now apply independent_events_proper. 55 | Qed. 56 | 57 | Lemma independent_sas_proper 58 | {dom1} (sub1:sa_sub dom1 dom) 59 | {dom1'} (sub1':sa_sub dom1' dom) 60 | (eqq1:sa_equiv dom1 dom1') 61 | {dom2} (sub2:sa_sub dom2 dom) 62 | {dom2'} (sub2':sa_sub dom2' dom) 63 | (eqq2:sa_equiv dom2 dom2') : 64 | independent_sas sub1 sub2 <-> independent_sas sub1' sub2'. 65 | Proof. 66 | split; intros. 67 | - assert (sa_sub dom1' dom1) by now apply sa_equiv_sub. 68 | assert (sa_sub dom2' dom2) by now apply sa_equiv_sub. 69 | now apply (independent_sas_sub_proper sub1 sub1' H0 sub2 sub2' H1). 70 | - assert (sa_sub dom1 dom1') by now apply sa_equiv_sub. 71 | assert (sa_sub dom2 dom2') by now apply sa_equiv_sub. 72 | now apply (independent_sas_sub_proper sub1' sub1 H0 sub2' sub2 H1). 73 | Qed. 74 | 75 | Lemma independent_sa_collection_proper {Idx} 76 | (doms:Idx->SigmaAlgebra Ts) {sub:IsSubAlgebras dom doms} 77 | (doms':Idx->SigmaAlgebra Ts) {sub':IsSubAlgebras dom doms'} 78 | (eqq:pointwise_relation _ sa_equiv doms doms') : 79 | independent_sa_collection doms <-> independent_sa_collection doms'. 80 | Proof. 81 | split; intros HH l. 82 | - generalize (HH (fun n => exist _ _ (proj2 (eqq n _) (proj2_sig (l n))))). 83 | now apply independent_event_collection_proper; intros ??; simpl. 84 | - generalize (HH (fun n => exist _ _ (proj1 (eqq n _) (proj2_sig (l n))))). 85 | now apply independent_event_collection_proper; intros ??; simpl. 86 | Qed. 87 | 88 | Lemma pairwise_independent_sa_collection_proper {Idx} 89 | (doms:Idx->SigmaAlgebra Ts) {sub:IsSubAlgebras dom doms} 90 | (doms':Idx->SigmaAlgebra Ts) {sub':IsSubAlgebras dom doms'} 91 | (eqq:pointwise_relation _ sa_equiv doms doms') : 92 | pairwise_independent_sa_collection doms <-> pairwise_independent_sa_collection doms'. 93 | Proof. 94 | split; intros HH l. 95 | - generalize (HH (fun n => exist _ _ (proj2 (eqq n _) (proj2_sig (l n))))). 96 | now apply pairwise_independent_event_collection_proper; intros ??; simpl. 97 | - generalize (HH (fun n => exist _ _ (proj1 (eqq n _) (proj2_sig (l n))))). 98 | now apply pairwise_independent_event_collection_proper; intros ??; simpl. 99 | Qed. 100 | 101 | Definition independent_eventcoll (dom1 : pre_event Ts -> Prop) (dom2 : pre_event Ts -> Prop) 102 | := forall (A:event dom) (B:event dom), 103 | dom1 A -> dom2 B -> 104 | independent_events prts A B. 105 | 106 | Lemma independent_sas_eventcoll {dom1} (sub1:sa_sub dom1 dom) {dom2} (sub2:sa_sub dom2 dom) : 107 | independent_sas sub1 sub2 <-> independent_eventcoll (sa_sigma dom1) (sa_sigma dom2). 108 | Proof. 109 | split; intros HH A B. 110 | - intros. 111 | specialize (HH (exist _ _ H) (exist _ _ H0)). 112 | revert HH. 113 | apply independent_events_proper 114 | ; now intros ?; simpl. 115 | - apply HH. 116 | + now destruct A; simpl. 117 | + now destruct B; simpl. 118 | Qed. 119 | 120 | Lemma independent_eventcoll_union (dom1 dom2 dom3: pre_event Ts -> Prop) : 121 | independent_eventcoll dom1 dom3 -> 122 | independent_eventcoll dom2 dom3 -> 123 | independent_eventcoll (pre_event_union dom1 dom2) dom3. 124 | Proof. 125 | intros. 126 | now intros A B [C|C]; [apply H | apply H0]. 127 | Qed. 128 | 129 | Lemma independent_eventcoll_inter_l (dom1 dom2 dom3: pre_event Ts -> Prop) : 130 | independent_eventcoll dom1 dom3 -> 131 | independent_eventcoll (pre_event_inter dom1 dom2) dom3. 132 | Proof. 133 | intros. 134 | intros A B [C1 C2] ?. 135 | now apply H. 136 | Qed. 137 | 138 | Lemma independent_eventcoll_inter_r (dom1 dom2 dom3: pre_event Ts -> Prop) : 139 | independent_eventcoll dom2 dom3 -> 140 | independent_eventcoll (pre_event_inter dom1 dom2) dom3. 141 | Proof. 142 | intros. 143 | intros A B [C1 C2] ?. 144 | now apply H. 145 | Qed. 146 | 147 | Definition independent_eventcoll_class domr : (pre_event Ts) -> Prop 148 | := fun x => exists pf, 149 | forall y, domr y -> 150 | independent_events prts (exist _ x pf) y. 151 | 152 | Instance independent_eventcoll_class_lambda domr : 153 | Lambda_system (independent_eventcoll_class (fun x : event dom => domr x)). 154 | Proof. 155 | constructor. 156 | - exists sa_all. intros ??. 157 | generalize (independent_events_all_l _ y) 158 | ; apply independent_events_proper; intros ?; simpl; reflexivity. 159 | - unfold independent_eventcoll_class; intros ???; intros. 160 | split; intros [pf HH]. 161 | + assert (pf':sa_sigma _ y). 162 | { 163 | now generalize pf; apply sa_proper. 164 | } 165 | exists pf'. 166 | intros B saB. 167 | generalize (HH B saB). 168 | apply independent_events_proper; intros ?; simpl; try reflexivity. 169 | symmetry; apply H. 170 | + assert (pf':sa_sigma _ x). 171 | { 172 | now generalize pf; apply sa_proper. 173 | } 174 | exists pf'. 175 | intros B saB. 176 | generalize (HH B saB). 177 | apply independent_events_proper; intros ?; simpl; try reflexivity. 178 | apply H. 179 | - unfold independent_eventcoll_class. 180 | intros ? [pf HH]. 181 | exists (sa_complement _ pf); intros B saB. 182 | specialize (HH B saB). 183 | apply independent_events_complement_l in HH. 184 | revert HH. 185 | apply independent_events_proper; intros ?; simpl; reflexivity. 186 | - unfold independent_eventcoll_class. 187 | intros ???. 188 | assert (sas:forall x, sa_sigma _ (an x)). 189 | { 190 | now intros x; destruct (H x). 191 | } 192 | exists (sa_countable_union an sas); intros B saB. 193 | assert (forall x, 194 | independent_events prts 195 | (exist _ _ (sas x)) B). 196 | { 197 | intros x; destruct (H x) as [pf HH]. 198 | generalize (HH B saB). 199 | apply independent_events_proper; intros ?; simpl; reflexivity. 200 | } 201 | 202 | generalize (independent_events_disjoint_countable_union prts (fun n => exist _ _ (sas n)) B H1) 203 | ; intros HH. 204 | cut_to HH. 205 | + revert HH. 206 | apply independent_events_proper; intros ?; simpl; reflexivity. 207 | + apply collection_is_pairwise_disjoint_pre. 208 | apply H0. 209 | Qed. 210 | 211 | Lemma independent_eventcoll_generated_l (dom1 dom2: pre_event Ts -> Prop) 212 | (sub1:pre_event_sub dom1 (sa_sigma dom)) 213 | {pi1 : Pi_system dom1} 214 | : 215 | independent_eventcoll dom1 dom2 -> 216 | independent_eventcoll (sa_sigma (generated_sa dom1)) dom2. 217 | Proof. 218 | intros. 219 | generalize (@Dynkin _ dom1 (independent_eventcoll_class dom2)) 220 | ; intros HH. 221 | cut_to HH; trivial. 222 | - unfold independent_eventcoll_class, independent_eventcoll in *. 223 | intros. 224 | red in HH. 225 | destruct (HH _ H0) as [pf HH2]. 226 | generalize (HH2 _ H1). 227 | apply independent_events_proper; intros ?; simpl; reflexivity. 228 | - apply independent_eventcoll_class_lambda. 229 | - intros ??. 230 | red. 231 | exists (sub1 _ H0); intros. 232 | apply H; trivial. 233 | Qed. 234 | 235 | Lemma independent_eventcoll_symm (dom1 dom2: pre_event Ts -> Prop) : 236 | independent_eventcoll dom1 dom2 -> 237 | independent_eventcoll dom2 dom1. 238 | Proof. 239 | intros ?????. 240 | apply independent_events_symm. 241 | now apply H. 242 | Qed. 243 | 244 | Lemma independent_eventcoll_generated_r (dom1 dom2: pre_event Ts -> Prop) 245 | (sub1:pre_event_sub dom2 (sa_sigma dom)) 246 | {pi2 : Pi_system dom2} 247 | : 248 | independent_eventcoll dom1 dom2 -> 249 | independent_eventcoll dom1 (sa_sigma (generated_sa dom2)). 250 | Proof. 251 | intros. 252 | apply independent_eventcoll_symm. 253 | apply independent_eventcoll_generated_l; trivial. 254 | now apply independent_eventcoll_symm. 255 | Qed. 256 | 257 | (* 258 | Lemma independent_coll_generated_union (dom1 dom2 dom3: pre_event Ts -> Prop) 259 | (sub1:pre_event_sub dom1 (sa_sigma dom)) 260 | (sub2:pre_event_sub dom2 (sa_sigma dom)) 261 | {pi1 : Pi_system dom1} 262 | {pi2 : Pi_system dom2} : 263 | independent_eventcoll dom1 dom3 -> 264 | independent_eventcoll dom2 dom3 -> 265 | independent_eventcoll (sa_sigma (generated_sa (pre_event_union dom1 dom2))) dom3. 266 | Proof. 267 | intros indep1 indep2. 268 | generalize (independent_eventcoll_union dom1 dom2 dom3 indep1 indep2). 269 | apply independent_eventcoll_generated_l. 270 | - intros ? [?|?]; auto. 271 | - intros ????. 272 | red. 273 | 274 | generalize (@Dynkin _ (fun _ => True) (independent_eventcoll_class dom3)) 275 | ; intros HH. 276 | apply HH; trivial. 277 | 278 | 279 | 280 | 4: simpl. 281 | 282 | Set Printing All. 283 | 284 | 285 | Qed. 286 | 287 | 288 | 289 | Lemma independent_sas_union {dom1} (sub1:sa_sub dom1 dom) {dom2} (sub2:sa_sub dom2 dom) 290 | {dom3} (sub3:sa_sub dom3 dom) : 291 | independent_sas sub1 sub3 -> 292 | independent_sas sub2 sub3 -> 293 | independent_sas (union_sa_sub_both sub1 sub2) sub3. 294 | *) 295 | 296 | 297 | Lemma independent_coll_inter3 (dom1 dom2 dom3: pre_event Ts -> Prop) 298 | (sub1:pre_event_sub dom1 (sa_sigma dom)) 299 | (sub2:pre_event_sub dom2 (sa_sigma dom)) : 300 | 301 | (forall A B C : event dom, dom1 A -> dom2 B -> dom3 C -> 302 | ps_P ((A ∩ B) ∩ C ) = ps_P A * ps_P B * ps_P C) -> 303 | independent_eventcoll dom1 dom2 -> 304 | independent_eventcoll (fun x => exists e1 e2, dom1 e1 /\ dom2 e2 /\ pre_event_equiv x (pre_event_inter e1 e2)) dom3. 305 | Proof. 306 | unfold independent_eventcoll in *. 307 | intros. 308 | unfold independent_events. 309 | destruct H1 as [? [? [? [? ?]]]]. 310 | specialize (sub1 x H1). 311 | specialize (sub2 x0 H3). 312 | assert (event_equiv A (event_inter (exist _ _ sub1) (exist _ _ sub2))). 313 | { 314 | destruct A. 315 | intro z. 316 | now specialize (H4 z). 317 | } 318 | rewrite H5. 319 | rewrite (H0 (exist _ _ sub1) (exist _ _ sub2) H1 H3). 320 | now rewrite H. 321 | Qed. 322 | 323 | End sigma_indep. 324 | 325 | 326 | 327 | -------------------------------------------------------------------------------- /coq/QLearn/lim_add.v: -------------------------------------------------------------------------------- 1 | Require Import Reals Coquelicot.Coquelicot. 2 | Require Import utils.Utils. 3 | Require Import Lra Lia. 4 | 5 | Lemma Lim_y_m1 : 6 | Lim (fun y => y / (1 - y)) 0 = 0. 7 | Proof. 8 | rewrite Lim_div. 9 | - rewrite Lim_id, Lim_minus, Lim_const, Lim_id. 10 | + simpl; f_equal; lra. 11 | + apply ex_lim_const. 12 | + apply ex_lim_id. 13 | + now rewrite Lim_const, Lim_id. 14 | - apply ex_lim_id. 15 | - apply ex_lim_minus. 16 | + apply ex_lim_const. 17 | + apply ex_lim_id. 18 | + now rewrite Lim_const, Lim_id. 19 | - rewrite Lim_minus. 20 | + rewrite Lim_const, Lim_id. 21 | simpl. 22 | replace (1 + - 0) with 1 by lra. 23 | rewrite Rbar_finite_eq; lra. 24 | + apply ex_lim_const. 25 | + apply ex_lim_id. 26 | + now rewrite Lim_const, Lim_id. 27 | - rewrite Lim_id, Lim_minus, Lim_const, Lim_id; try easy. 28 | + apply ex_lim_const. 29 | + apply ex_lim_id. 30 | + now rewrite Lim_const, Lim_id. 31 | Qed. 32 | 33 | Lemma ex_lim_y_m1 : 34 | ex_lim (fun y => (y / (1 - y))) 0. 35 | Proof. 36 | apply ex_lim_div. 37 | + apply ex_lim_id. 38 | + apply ex_lim_minus. 39 | * apply ex_lim_const. 40 | * apply ex_lim_id. 41 | * now rewrite Lim_const, Lim_id. 42 | + rewrite Lim_minus. 43 | * rewrite Lim_const, Lim_id. 44 | simpl. 45 | rewrite Rbar_finite_eq; lra. 46 | * apply ex_lim_const. 47 | * apply ex_lim_id. 48 | * now rewrite Lim_const, Lim_id. 49 | + rewrite Lim_id, Lim_minus. 50 | * now rewrite Lim_const, Lim_id. 51 | * apply ex_lim_const. 52 | * apply ex_lim_id. 53 | * now rewrite Lim_const, Lim_id. 54 | Qed. 55 | 56 | Lemma Lim_Rabs (c : R) : 57 | Lim Rabs c = Rabs c. 58 | Proof. 59 | apply Lim_continuity. 60 | apply Rcontinuity_abs. 61 | Qed. 62 | 63 | Lemma is_lim_Rabs (c : R) : 64 | is_lim Rabs c (Rabs c). 65 | Proof. 66 | apply is_lim_continuity. 67 | apply Rcontinuity_abs. 68 | Qed. 69 | 70 | Lemma ex_lim_Rabs (c : R) : 71 | ex_lim Rabs c. 72 | Proof. 73 | eexists. 74 | apply is_lim_Rabs. 75 | Qed. 76 | 77 | Lemma ex_lim_Rabs_y_m1 : 78 | ex_lim (fun y => (Rabs y / (1 - Rabs y))) 0. 79 | Proof. 80 | apply ex_lim_div. 81 | + apply ex_lim_Rabs. 82 | + apply ex_lim_minus. 83 | * apply ex_lim_const. 84 | * apply ex_lim_Rabs. 85 | * now rewrite Lim_const, Lim_Rabs. 86 | + rewrite Lim_minus. 87 | * rewrite Lim_const, Lim_Rabs, Rabs_R0. 88 | simpl. 89 | rewrite Rbar_finite_eq; lra. 90 | * apply ex_lim_const. 91 | * apply ex_lim_Rabs. 92 | * now rewrite Lim_const, Lim_Rabs. 93 | + rewrite Lim_Rabs, Lim_minus. 94 | * now rewrite Lim_const, Lim_Rabs. 95 | * apply ex_lim_const. 96 | * apply ex_lim_Rabs. 97 | * now rewrite Lim_const, Lim_Rabs. 98 | Qed. 99 | 100 | Lemma Lim_Rabs_y_m1 : 101 | Lim (fun y => Rabs y / (1 - Rabs y)) 0 = 0. 102 | Proof. 103 | rewrite (Lim_comp (fun y => y / (1 - y)) Rabs 0). 104 | - now rewrite Lim_Rabs, Rabs_R0, Lim_y_m1. 105 | - rewrite Lim_Rabs, Rabs_R0. 106 | apply ex_lim_y_m1. 107 | - apply ex_lim_Rabs. 108 | - assert (0 < 1) by lra. 109 | exists (mkposreal _ H). 110 | intros. 111 | rewrite Lim_Rabs, Rabs_R0. 112 | unfold not; intros. 113 | rewrite Rbar_finite_eq in H2. 114 | apply Rabs_eq_0 in H2. 115 | lra. 116 | Qed. 117 | 118 | Lemma Lim_c_y_m1 (c : R) : 119 | Lim (fun y => c * (y / (1 - y))) 0 = 0. 120 | Proof. 121 | rewrite Lim_scal_l, Lim_y_m1. 122 | simpl. 123 | now rewrite Rmult_0_r. 124 | Qed. 125 | 126 | Lemma Lim_c_Rabs_y_m1 (c : R) : 127 | Lim (fun y => c * (Rabs y / (1 - Rabs y))) 0 = 0. 128 | Proof. 129 | rewrite Lim_scal_l, Lim_Rabs_y_m1. 130 | simpl. 131 | now rewrite Rmult_0_r. 132 | Qed. 133 | 134 | Lemma ex_lim_c_y_m1 (c : R) : 135 | ex_lim (fun y => c * (y / (1 - y))) 0. 136 | Proof. 137 | apply ex_lim_scal_l. 138 | apply ex_lim_y_m1. 139 | Qed. 140 | 141 | Lemma ex_lim_c_Rabs_y_m1 (c : R) : 142 | ex_lim (fun y => c * (Rabs y / (1 - Rabs y))) 0. 143 | Proof. 144 | apply ex_lim_scal_l. 145 | apply ex_lim_Rabs_y_m1. 146 | Qed. 147 | 148 | Lemma is_lim_c_y_m1 (c : R) : 149 | is_lim (fun y => c * (y / (1 - y))) 0 0. 150 | Proof. 151 | rewrite <- Lim_c_y_m1 at 2. 152 | apply Lim_correct. 153 | apply ex_lim_c_y_m1. 154 | Qed. 155 | 156 | Lemma Lim_exp_c_y_m1 (c : R) : 157 | c <> 0 -> 158 | Lim (fun y => exp (c * (y / (1 - y)))) 0 = 1. 159 | Proof. 160 | intros cn0. 161 | rewrite Lim_comp. 162 | - rewrite Lim_c_y_m1. 163 | rewrite Lim_exp. 164 | now rewrite exp_0. 165 | - rewrite Lim_c_y_m1. 166 | apply ex_lim_exp. 167 | - apply ex_lim_c_y_m1. 168 | - assert (0 < 1/2) by lra. 169 | exists (mkposreal _ H). 170 | intros. 171 | rewrite Lim_c_y_m1. 172 | unfold not; intros. 173 | unfold ball in H0. 174 | simpl in H0. 175 | unfold AbsRing_ball in H0. 176 | unfold abs, minus,plus, opp in H0; simpl in H0. 177 | replace (y + - 0) with y in H0 by lra. 178 | rewrite Rbar_finite_eq in H2. 179 | apply Rmult_integral in H2. 180 | destruct H2; try easy. 181 | unfold Rdiv in H2. 182 | apply Rmult_integral in H2. 183 | destruct H2; try easy. 184 | rewrite <- Rinv_0 in H2. 185 | apply (f_equal (fun z => /z)) in H2. 186 | rewrite Rinv_inv, Rinv_inv in H2. 187 | rewrite Rabs_lt_both in H0. 188 | lra. 189 | Qed. 190 | 191 | Lemma Lim_exp_c_Rabs_y_m1 (c : R) : 192 | c <> 0 -> 193 | Lim (fun y => exp (c * (Rabs y / (1 - Rabs y)))) 0 = 1. 194 | Proof. 195 | intros cn0. 196 | rewrite Lim_comp. 197 | - rewrite Lim_c_Rabs_y_m1. 198 | rewrite Lim_exp. 199 | now rewrite exp_0. 200 | - rewrite Lim_c_Rabs_y_m1. 201 | apply ex_lim_exp. 202 | - apply ex_lim_c_Rabs_y_m1. 203 | - assert (0 < 1/2) by lra. 204 | exists (mkposreal _ H). 205 | intros. 206 | rewrite Lim_c_Rabs_y_m1. 207 | unfold not; intros. 208 | unfold ball in H0. 209 | simpl in H0. 210 | unfold AbsRing_ball in H0. 211 | unfold abs, minus,plus, opp in H0; simpl in H0. 212 | replace (y + - 0) with y in H0 by lra. 213 | rewrite Rbar_finite_eq in H2. 214 | apply Rmult_integral in H2. 215 | destruct H2; try easy. 216 | unfold Rdiv in H2. 217 | apply Rmult_integral in H2. 218 | destruct H2. 219 | + now apply Rabs_eq_0 in H2. 220 | + rewrite <- Rinv_0 in H2. 221 | apply (f_equal (fun z => /z)) in H2. 222 | rewrite Rinv_inv, Rinv_inv in H2. 223 | lra. 224 | Qed. 225 | 226 | Lemma is_lim_exp_c_y_m1 (c : R) : 227 | c <> 0 -> 228 | is_lim (fun y => exp (c * (y / (1 - y)))) 0 1. 229 | Proof. 230 | intros cn0. 231 | rewrite <- (Lim_exp_c_y_m1 c cn0). 232 | apply Lim_correct. 233 | apply ex_lim_comp. 234 | - apply ex_lim_exp. 235 | - apply ex_lim_c_y_m1. 236 | - assert (0 < 1/2) by lra. 237 | exists (mkposreal _ H). 238 | intros. 239 | rewrite Lim_c_y_m1. 240 | unfold not; intros. 241 | unfold ball in H0. 242 | simpl in H0. 243 | unfold AbsRing_ball in H0. 244 | unfold abs, minus,plus, opp in H0; simpl in H0. 245 | replace (y + - 0) with y in H0 by lra. 246 | rewrite Rbar_finite_eq in H2. 247 | apply Rmult_integral in H2. 248 | destruct H2; try easy. 249 | unfold Rdiv in H2. 250 | apply Rmult_integral in H2. 251 | destruct H2; try easy. 252 | rewrite <- Rinv_0 in H2. 253 | apply (f_equal (fun z => /z)) in H2. 254 | rewrite Rinv_inv, Rinv_inv in H2. 255 | rewrite Rabs_lt_both in H0. 256 | lra. 257 | Qed. 258 | 259 | Lemma is_lim_exp_c_Rabs_y_m1 (c : R) : 260 | c <> 0 -> 261 | is_lim (fun y => exp (c * (Rabs y / (1 - Rabs y)))) 0 1. 262 | Proof. 263 | intros cn0. 264 | rewrite <- (Lim_exp_c_Rabs_y_m1 c cn0). 265 | apply Lim_correct. 266 | apply ex_lim_comp. 267 | - apply ex_lim_exp. 268 | - apply ex_lim_c_Rabs_y_m1. 269 | - assert (0 < 1/2) by lra. 270 | exists (mkposreal _ H). 271 | intros. 272 | rewrite Lim_c_Rabs_y_m1. 273 | unfold not; intros. 274 | unfold ball in H0. 275 | simpl in H0. 276 | unfold AbsRing_ball in H0. 277 | unfold abs, minus,plus, opp in H0; simpl in H0. 278 | replace (y + - 0) with y in H0 by lra. 279 | rewrite Rbar_finite_eq in H2. 280 | apply Rmult_integral in H2. 281 | destruct H2; try easy. 282 | unfold Rdiv in H2. 283 | apply Rmult_integral in H2. 284 | destruct H2. 285 | + now apply Rabs_eq_0 in H2. 286 | + rewrite <- Rinv_0 in H2. 287 | apply (f_equal (fun z => /z)) in H2. 288 | rewrite Rinv_inv, Rinv_inv in H2. 289 | lra. 290 | Qed. 291 | 292 | Lemma filterlim_right (f : R -> R) (l : Rbar) : 293 | is_lim f 0 l -> 294 | filterlim f (at_right 0) (Rbar_locally l). 295 | Proof. 296 | apply filterlim_filter_le_1. 297 | intros ??. 298 | destruct H as [eps ?]. 299 | exists eps. 300 | intros. 301 | apply H; trivial. 302 | lra. 303 | Qed. 304 | 305 | Definition is_lim_pos (f : posreal -> R) (l : Rbar) := 306 | filterlim (fun y => lift_posreal_f f 0 y) (at_right 0) (Rbar_locally l). 307 | 308 | Lemma filterlim_const_at_right0 (c : R) : 309 | filterlim (fun _ => c) (at_right 0) (Rbar_locally c). 310 | Proof. 311 | apply filterlim_const. 312 | Qed. 313 | 314 | Lemma filterlim_at_right_0_Rbar_ext (f g : R -> R) (l : Rbar) : 315 | (forall x, 0 < x -> f x = g x) -> 316 | filterlim f (at_right 0) (Rbar_locally l) <-> filterlim g (at_right 0) (Rbar_locally l). 317 | Proof. 318 | intros. 319 | split; apply filterlim_within_ext. 320 | - apply H. 321 | - symmetry; now apply H. 322 | Qed. 323 | 324 | Lemma filterlim_at_right_0_ext (f g : R -> R) (l : R) : 325 | (forall x, 0 < x -> f x = g x) -> 326 | filterlim f (at_right 0) (locally l) <-> filterlim g (at_right 0) (locally l). 327 | Proof. 328 | intros. 329 | split; apply filterlim_within_ext. 330 | - apply H. 331 | - symmetry; now apply H. 332 | Qed. 333 | 334 | Lemma is_lim_pos_ext (f g : posreal -> R) (l : R) : 335 | (forall x, f x = g x) -> 336 | is_lim_pos f l <-> is_lim_pos g l. 337 | Proof. 338 | intros. 339 | apply filterlim_at_right_0_ext. 340 | intros. 341 | unfold lift_posreal_f. 342 | match_destr. 343 | Qed. 344 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtils.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | (** Gathers all exports needed to access the utility modules. *) 18 | 19 | Require Export LibUtilsAssoc. 20 | Require Export LibUtilsBag. 21 | Require Export LibUtilsBindings. 22 | Require Export LibUtilsBindingsNat. 23 | Require Export LibUtilsClosure. 24 | Require Export LibUtilsCompat. 25 | Require Export LibUtilsCoqLibAdd. 26 | Require Export LibUtilsDigits. 27 | Require Export LibUtilsFresh. 28 | Require Export LibUtilsGroupByDomain. 29 | Require Export LibUtilsInterleaved. 30 | Require Export LibUtilsLattice. 31 | Require Export LibUtilsLift. 32 | Require Export LibUtilsLiftIterators. 33 | Require Export LibUtilsListAdd. 34 | Require Export LibUtilsResult. 35 | Require Export LibUtilsSortingAdd. 36 | Require Export LibUtilsStringAdd. 37 | Require Export LibUtilsSublist. 38 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsBindingsNat.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | (** This module provides support for bindings where the key is a 18 | natural number. *) 19 | 20 | Require Import Arith. 21 | Require Import NPeano. 22 | Require Import LibUtilsBindings. 23 | 24 | Section BindingsNat. 25 | 26 | Global Program Instance ODT_nat : (@ODT nat) 27 | := mkODT _ _ lt Nat.lt_strorder lt_dec Nat.compare _. 28 | Next Obligation. 29 | simpl. 30 | apply Nat.compare_spec. 31 | Qed. 32 | 33 | End BindingsNat. 34 | 35 | Hint Unfold rec_sort rec_concat_sort : fml. 36 | Hint Resolve drec_sort_sorted drec_concat_sort_sorted : fml. 37 | Hint Resolve is_list_sorted_NoDup_strlt : fml. 38 | 39 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsClosure.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Licensed under the Apache License, Version 2.0 (the "License"); 3 | * you may not use this file except in compliance with the License. 4 | * You may obtain a copy of the License at 5 | * 6 | * http://www.apache.org/licenses/LICENSE-2.0 7 | * 8 | * Unless required by applicable law or agreed to in writing, software 9 | * distributed under the License is distributed on an "AS IS" BASIS, 10 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | * See the License for the specific language governing permissions and 12 | * limitations under the License. 13 | *) 14 | 15 | Require Import String. 16 | Require Import List. 17 | 18 | Section Closure. 19 | (** Function closures over code [C] and types [T] *) 20 | Context {C:Set}. 21 | Context {T:Set}. 22 | 23 | (** Assuming we can compute free variables in code *) 24 | Context {free_vars : C -> list string}. 25 | 26 | Definition code_closed_for_params (params:list string) (c:C) : Prop := 27 | forall v, In v (free_vars c) -> In v params. 28 | 29 | Record closure := 30 | mkClosure 31 | { closure_params: list (string * option T); 32 | closure_output : option T; 33 | closure_body : C; }. 34 | 35 | Definition closure_is_closed (f:closure) : Prop := 36 | code_closed_for_params (map fst f.(closure_params)) f.(closure_body). 37 | 38 | Definition closed_closure := 39 | { c : closure | closure_is_closed c }. 40 | 41 | End Closure. 42 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsCompat.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | (** This module defines a notion of compatibility between two 18 | association lists. Two association lists are compatible if the values 19 | for their common keys are equal. *) 20 | 21 | Require Import List. 22 | Require Import Sumbool. 23 | Require Import Arith. 24 | Require Import Bool. 25 | Require Import Permutation. 26 | Require Import Equivalence. 27 | Require Import EquivDec. 28 | Require Import RelationClasses. 29 | Require Import Orders. 30 | Require Import LibUtilsCoqLibAdd. 31 | Require Import LibUtilsListAdd. 32 | Require Import LibUtilsSortingAdd. 33 | Require Import LibUtilsAssoc. 34 | 35 | Section Compat. 36 | Context {A B:Type} `{EqDec A eq} `{EqDec B eq}. 37 | 38 | Definition compatible_with {A B:Type} `{EqDec A eq} `{EqDec B eq} 39 | (a:A) (b:B) (l₂:list (A * B)) : bool 40 | := match assoc_lookupr equiv_dec l₂ a with 41 | | Some d' => if equiv_dec b d' then true else false 42 | | None => true 43 | end. 44 | 45 | Definition compatible {A B:Type} `{EqDec A eq} `{EqDec B eq} (l₁ l₂:list (A * B)) : bool 46 | := forallb (fun xy => compatible_with (fst xy) (snd xy) l₂) l₁. 47 | 48 | Lemma compatible_nil_l (l:list (A * B)) : compatible nil l = true. 49 | Proof. 50 | reflexivity. 51 | Qed. 52 | 53 | Lemma compatible_nil_r (l:list (A * B)) : compatible l nil = true. 54 | Proof. 55 | induction l; simpl; auto. 56 | Qed. 57 | 58 | Lemma compatible_with_cons_inv {x:A} {y:B} {a l} : 59 | compatible_with x y (a :: l) = true -> 60 | compatible_with x y l = true. 61 | Proof. 62 | destruct a. 63 | unfold compatible_with; simpl; intros. 64 | match_case; intros. 65 | rewrite H2 in H1. 66 | trivial. 67 | Qed. 68 | 69 | Lemma compatible_cons_inv_r {a} {l1 l2:list (A*B)} : 70 | compatible l1 (a::l2) = true -> compatible l1 l2 = true. 71 | Proof. 72 | unfold compatible. 73 | repeat rewrite forallb_forall. intros. 74 | eapply compatible_with_cons_inv; eauto. 75 | Qed. 76 | 77 | Ltac case_eqdec := 78 | match goal with 79 | | [|- context [@equiv_dec ?a ?b ?c ?d ?x ?y]] => 80 | let HH:=(fresh "eqs") in case_eq (@equiv_dec a b c d x y); [intros ? HH|intros HH]; try rewrite HH 81 | | [H: context [@equiv_dec ?a ?b ?c ?d ?x ?y] |- _] => 82 | let HH:=(fresh "eqs") in case_eq (@equiv_dec a b c d x y); [intros ? HH|intros HH]; try rewrite HH in H 83 | end; unfold equiv, complement in *; try subst. 84 | 85 | Lemma compatible_middle (l1 l2 l3:list (A * B)) a : 86 | compatible (l1 ++ a :: l2) l3 = compatible (a::l1++l2) l3. 87 | Proof. 88 | induction l1; simpl; trivial. 89 | rewrite IHl1. simpl. 90 | repeat rewrite andb_assoc. 91 | f_equal. 92 | rewrite andb_comm. 93 | auto. 94 | Qed. 95 | 96 | Lemma compatible_cons_r (l l':list (A * B)) a : 97 | NoDup (domain l) -> 98 | compatible l l' = true -> 99 | compatible_with (fst a) (snd a) l = true -> 100 | compatible l (a :: l') = true. 101 | Proof. 102 | intros. 103 | apply forallb_forall. 104 | unfold compatible in *. 105 | rewrite forallb_forall in H2. 106 | intros. 107 | specialize (H2 _ H4). 108 | unfold compatible_with in *; simpl in *. 109 | destruct a as [y yv]; destruct x as [x xv]; simpl in *. 110 | repeat dest_eqdec; intuition. 111 | generalize H4. 112 | apply in_dom in H4. 113 | apply (@in_dom_lookupr A B l y equiv_dec) in H4. 114 | elim H4; clear H4; intros. 115 | unfold not in H4. 116 | rewrite H4 in H3. 117 | unfold not in *. 118 | destruct (@assoc_lookupr A B (@eq A) (fun x0 y0 : A => @eq A x0 y0 -> False) 119 | (@equiv_dec A (@eq A) equiv0 H) l' y). 120 | destruct (equiv_dec xv b); congruence. 121 | revert H3. 122 | dest_eqdec; intuition. 123 | apply assoc_lookupr_in in H4. 124 | assert (x = xv). apply (nodup_in_eq H1 H4 H5); eauto. 125 | rewrite H6. destruct (equiv_dec xv xv); congruence. 126 | destruct (@assoc_lookupr A B (@eq A) (fun x0 y0 : A => @eq A x0 y0 -> False) 127 | (@equiv_dec A (@eq A) equiv0 H) l' x); congruence. 128 | Qed. 129 | 130 | Lemma compatible_perm_proper_l (l1 l2 l3:list (A * B)) : 131 | Permutation l1 l2 -> 132 | NoDup (domain l3) -> 133 | compatible l1 l3 = true -> 134 | compatible l2 l3 = true. 135 | Proof. 136 | revert l2 l3. induction l1; simpl; intros. 137 | - apply Permutation_nil in H1. subst. simpl. trivial. 138 | - assert (inl:In a l2) 139 | by (apply (Permutation_in _ H1); simpl; intuition). 140 | destruct (in_split _ _ inl) as [l21 [l22 ?]]; subst. 141 | rewrite <- Permutation_middle in H1. 142 | apply Permutation_cons_inv in H1. 143 | rewrite andb_true_iff in H3; intuition. 144 | specialize (IHl1 _ _ H1 H2 H5). 145 | rewrite compatible_middle. simpl. 146 | rewrite H4, IHl1. simpl; trivial. 147 | Qed. 148 | 149 | Lemma compatible_refl (l:list (A * B)) : 150 | NoDup (domain l) -> compatible l l = true. 151 | Proof. 152 | intros. 153 | induction l; try reflexivity. 154 | inversion H1; clear H1; subst. 155 | specialize (IHl H5). 156 | simpl. 157 | rewrite andb_true_inversion. 158 | split. 159 | - destruct a; simpl in *. 160 | unfold compatible_with. 161 | simpl. 162 | assert (assoc_lookupr equiv_dec l a = None) by 163 | (apply assoc_lookupr_nin_none; assumption). 164 | rewrite H1; simpl. 165 | destruct (equiv_dec a a); try congruence. 166 | destruct (equiv_dec b b); congruence. 167 | - apply compatible_cons_r; try assumption. 168 | destruct a; simpl in *. 169 | unfold compatible_with. 170 | assert (assoc_lookupr equiv_dec l a = None) by 171 | (apply assoc_lookupr_nin_none; assumption). 172 | rewrite H1; simpl. 173 | reflexivity. 174 | Qed. 175 | 176 | Lemma compatible_single_nin (b:list (A*B)) x d : 177 | ~ In x (domain b) -> 178 | compatible b ((x, d) :: nil) = true. 179 | Proof. 180 | revert x d. induction b; simpl; trivial. 181 | destruct a; simpl. intuition. 182 | rewrite IHb; trivial. 183 | rewrite andb_true_iff; intuition. 184 | unfold compatible_with. 185 | simpl. 186 | destruct (equiv_dec a x); intuition. 187 | Qed. 188 | 189 | Lemma compatible_true_sym (l1 l2:list (A*B)) : 190 | NoDup (domain l2) -> compatible l1 l2 = true -> 191 | compatible l2 l1 = true. 192 | Proof. 193 | unfold compatible. repeat rewrite forallb_forall. 194 | intros. 195 | unfold compatible_with in *. 196 | match_case; intros. 197 | apply assoc_lookupr_in in H4. 198 | specialize (H2 _ H4); simpl in *. 199 | destruct x. 200 | rewrite (in_assoc_lookupr_nodup _ _ _ equiv_dec H1 H3) in H2. 201 | simpl. match_destr. match_destr_in H2. congruence. 202 | Qed. 203 | 204 | Lemma compatible_false_sym (l1 l2:list (A*B)) : 205 | NoDup (domain l1) -> compatible l1 l2 = false -> 206 | compatible l2 l1 = false. 207 | Proof. 208 | unfold compatible. 209 | repeat rewrite forallb_not_existb, negb_false_iff, existsb_exists. 210 | intros ? [?[??]]. 211 | rewrite negb_true_iff in *. 212 | unfold compatible_with in H3. 213 | match_case_in H3; intros; rewrite H4 in H3; try discriminate. 214 | match_destr_in H3. 215 | destruct x; simpl in *. 216 | exists (a, b). split. 217 | - eapply assoc_lookupr_in; eauto. 218 | - simpl. rewrite negb_true_iff. unfold compatible_with. 219 | rewrite (in_assoc_lookupr_nodup _ _ _ equiv_dec H1 H2). 220 | match_destr. 221 | congruence. 222 | Qed. 223 | 224 | Lemma compatible_sym (l1 l2:list (A*B)) : 225 | NoDup (domain l1) -> NoDup (domain l2) -> 226 | compatible l1 l2 = compatible l2 l1. 227 | Proof. 228 | intros. 229 | case_eq (compatible l1 l2); intros. 230 | - symmetry. eapply compatible_true_sym; trivial. 231 | - symmetry. eapply compatible_false_sym; trivial. 232 | Qed. 233 | 234 | Lemma same_domain_compatible (l₁ l₂:list (A*B)) : 235 | NoDup (domain l₁) -> 236 | domain l₁ = domain l₂ -> 237 | compatible l₁ l₂ = true -> 238 | l₁ = l₂. 239 | Proof. 240 | intros nd eqq. 241 | rewrite eqq in nd. 242 | revert nd eqq. 243 | revert l₂. 244 | induction l₁; destruct l₂; simpl 245 | ; try discriminate; trivial. 246 | destruct a; destruct p; simpl. 247 | intros nd eqq; invcs nd; invcs eqq. 248 | rewrite andb_true_iff; intros [cw c]. 249 | f_equal. 250 | - unfold compatible_with in cw. 251 | simpl in cw. 252 | rewrite (assoc_lookupr_nin_none l₂ a0 equiv_dec) in cw by trivial. 253 | destruct (equiv_dec a0 a0); [|congruence]. 254 | match_destr_in cw. 255 | congruence. 256 | - apply compatible_cons_inv_r in c. 257 | auto. 258 | Qed. 259 | 260 | End Compat. 261 | 262 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsFresh.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | (** Support for creating and reasoning about fresh names (represented 18 | as strings). *) 19 | 20 | Require Import String. 21 | Require Import List. 22 | Require Import Permutation. 23 | Require Import Arith Min. 24 | Require Import EquivDec. 25 | Require Import Morphisms. 26 | Require Import Lia. 27 | Require Import LibUtilsCoqLibAdd. 28 | Require Import LibUtilsListAdd. 29 | Require Import LibUtilsStringAdd. 30 | Require Import LibUtilsDigits. 31 | Require Import LibUtilsLift. 32 | Require Import LibUtilsSublist. 33 | 34 | Section Fresh. 35 | 36 | Section finder. 37 | Context {A:Type}. 38 | Context (incr:A->A). 39 | Context (f:A->bool). 40 | 41 | Fixpoint find_bounded (bound:nat) (init:A) 42 | := match bound with 43 | | O => None 44 | | S n => 45 | if f init 46 | then Some init 47 | else find_bounded n (incr init) 48 | end. 49 | 50 | Lemma find_bounded_correct bound init y : 51 | find_bounded bound init = Some y -> 52 | f y = true. 53 | Proof. 54 | revert init. 55 | induction bound; simpl; intros. 56 | - discriminate. 57 | - match_case_in H; intros eqq; rewrite eqq in H. 58 | + inversion H; congruence. 59 | + eauto. 60 | Qed. 61 | End finder. 62 | 63 | Lemma find_bounded_S_ge f bound init y : 64 | find_bounded S f bound init = Some y -> 65 | y >= init. 66 | Proof. 67 | revert init y. 68 | induction bound; simpl; intros. 69 | - discriminate. 70 | - match_destr_in H. 71 | + inversion H; subst; lia. 72 | + specialize (IHbound (S init) _ H). 73 | lia. 74 | Qed. 75 | 76 | Lemma find_bounded_S_seq f bound init : 77 | find_bounded S f bound init = find f (seq init bound). 78 | Proof. 79 | revert init. 80 | induction bound; simpl; trivial; intros. 81 | match_destr; auto. 82 | Qed. 83 | 84 | Lemma find_bounded_S_nin_finds' {A:Type} f {dec:EqDec A eq} (dom:list A) 85 | (bound:nat) (pf:bound > length dom) 86 | (inj:forall x y, f x = f y -> x = y) : 87 | {y:A | lift f (find_bounded S 88 | (fun x => 89 | if in_dec equiv_dec (f x) dom 90 | then false else true) 91 | bound 0) = Some y}. 92 | Proof. 93 | rewrite find_bounded_S_seq. 94 | rewrite <- (find_over_map (fun x => if in_dec equiv_dec x dom then false else true) f). 95 | apply find_fresh_from. 96 | - rewrite map_length. 97 | rewrite seq_length. 98 | trivial. 99 | - apply map_inj_NoDup; trivial. 100 | apply seq_NoDup. 101 | Defined. 102 | 103 | (* This version has better computational properties *) 104 | Definition find_bounded_S_nin_finds {A:Type} f {dec:EqDec A eq} (dom:list A) 105 | (bound:nat) (pf:bound > length dom) 106 | (inj:forall x y, f x = f y -> x = y) : 107 | {y:A | lift f (find_bounded S 108 | (fun x => 109 | if in_dec equiv_dec (f x) dom 110 | then false else true) 111 | bound 0) = Some y}. 112 | Proof. 113 | case_eq (find_bounded S 114 | (fun x : nat => if in_dec equiv_dec (f x) dom then false else true) 115 | bound 0). 116 | - intros; simpl. 117 | exists (f n); reflexivity. 118 | - destruct (find_bounded_S_nin_finds' f dom bound pf inj); intros. 119 | rewrite H in e. 120 | simpl in e. discriminate. 121 | Defined. 122 | 123 | Definition find_fresh_inj_f {A:Type} {dec:EqDec A eq} f (inj:forall x y, f x = f y -> x = y) (dom:list A) : A 124 | := proj1_sig (find_bounded_S_nin_finds f dom (S (length dom)) (gt_Sn_n _) inj). 125 | 126 | Lemma find_fresh_inj_f_fresh {A:Type} {dec:EqDec A eq} f (inj:forall x y, f x = f y -> x = y) (dom:list A) : 127 | ~ In (find_fresh_inj_f f inj dom) dom. 128 | Proof. 129 | unfold find_fresh_inj_f. 130 | match goal with 131 | | [|- context[ proj1_sig ?x ]] => destruct x 132 | end; simpl. 133 | apply some_lift in e. 134 | destruct e as [? e ?]; subst. 135 | apply find_bounded_correct in e. 136 | match_destr_in e. 137 | Qed. 138 | 139 | Definition find_fresh_string (dom:list string) 140 | := find_fresh_inj_f 141 | nat_to_string16 142 | nat_to_string16_inj 143 | dom. 144 | 145 | Lemma find_fresh_string_is_fresh (dom:list string) : 146 | ~ In (find_fresh_string dom) dom. 147 | Proof. 148 | unfold find_fresh_string. 149 | apply find_fresh_inj_f_fresh. 150 | Qed. 151 | 152 | 153 | (* Java equivalent: NnrcOptimizer.fresh_var (serves same purpose, not an exact translation) *) 154 | Definition fresh_var (pre:string) (dom:list string) := 155 | let problems:=filter (prefix pre) dom in 156 | let problemEnds:= 157 | map (fun x => substring (String.length pre) (String.length x - String.length pre) x) problems in 158 | append pre (find_fresh_string problemEnds). 159 | 160 | Lemma fresh_var_fresh pre (dom:list string) : 161 | ~ In (fresh_var pre dom) dom. 162 | Proof. 163 | unfold fresh_var. 164 | intros inn. 165 | rewrite in_of_append in inn. 166 | apply find_fresh_string_is_fresh in inn. 167 | trivial. 168 | Qed. 169 | 170 | Lemma fresh_var_fresh1 x1 pre dom : 171 | x1 <> fresh_var pre (x1::dom). 172 | Proof. 173 | intro inn. 174 | apply (fresh_var_fresh pre (x1::dom)). 175 | rewrite <- inn. 176 | simpl; intuition. 177 | Qed. 178 | 179 | Lemma fresh_var_fresh2 x1 x2 pre dom : 180 | x2 <> fresh_var pre (x1::x2::dom). 181 | Proof. 182 | intro inn. 183 | apply (fresh_var_fresh pre (x1::x2::dom)). 184 | rewrite <- inn. 185 | simpl; intuition. 186 | Qed. 187 | 188 | Lemma fresh_var_fresh3 x1 x2 x3 pre dom : 189 | x3 <> fresh_var pre (x1::x2::x3::dom). 190 | Proof. 191 | intro inn. 192 | apply (fresh_var_fresh pre (x1::x2::x3::dom)). 193 | rewrite <- inn. 194 | simpl; intuition. 195 | Qed. 196 | 197 | Lemma fresh_var_fresh4 x1 x2 x3 x4 pre dom : 198 | x4 <> fresh_var pre (x1::x2::x3::x4::dom). 199 | Proof. 200 | intro inn. 201 | apply (fresh_var_fresh pre (x1::x2::x3::x4::dom)). 202 | rewrite <- inn. 203 | simpl; intuition. 204 | Qed. 205 | 206 | Definition fresh_var2 pre1 pre2 (dom:list string) := 207 | let fresh_var1 := fresh_var pre1 dom in 208 | (fresh_var1, fresh_var pre2 (fresh_var1::dom)). 209 | 210 | Lemma fresh_var2_distinct pre1 pre2 dom : 211 | (fst (fresh_var2 pre1 pre2 dom)) <> 212 | (snd (fresh_var2 pre1 pre2 dom)). 213 | Proof. 214 | unfold fresh_var2; simpl. 215 | apply fresh_var_fresh1. 216 | Qed. 217 | 218 | Definition fresh_var3 pre1 pre2 pre3 (dom:list string) := 219 | let fresh_var1 := fresh_var pre1 dom in 220 | let fresh_var2 := fresh_var pre2 (fresh_var1::dom) in 221 | let fresh_var3 := fresh_var pre3 (fresh_var2::fresh_var1::dom) in 222 | (fresh_var1, fresh_var2, fresh_var3). 223 | 224 | Lemma fresh_var3_distinct pre1 pre2 pre3 dom : 225 | (fst (fst (fresh_var3 pre1 pre2 pre3 dom))) <> 226 | (snd (fst (fresh_var3 pre1 pre2 pre3 dom))) /\ 227 | (snd (fst (fresh_var3 pre1 pre2 pre3 dom))) <> 228 | (snd (fresh_var3 pre1 pre2 pre3 dom)) /\ 229 | (fst (fst (fresh_var3 pre1 pre2 pre3 dom))) <> 230 | (snd (fresh_var3 pre1 pre2 pre3 dom)). 231 | Proof. 232 | unfold fresh_var3; simpl. 233 | split;[|split]. 234 | - apply fresh_var_fresh1. 235 | - apply fresh_var_fresh1. 236 | - apply fresh_var_fresh2. 237 | Qed. 238 | 239 | (* given a variable, gets the "base": the part before the last seperator *) 240 | Definition get_var_base (sep:string) (var:string) 241 | := match index 0 (string_reverse sep) (string_reverse var) with 242 | | Some n => substring 0 (String.length var - (S n)) var 243 | | None => var 244 | end. 245 | 246 | Lemma get_var_base_pre sep var : 247 | prefix (get_var_base sep var) var = true. 248 | Proof. 249 | unfold get_var_base. 250 | match_destr; simpl. 251 | - apply substring_prefix. 252 | - apply prefix_refl. 253 | Qed. 254 | 255 | Definition fresh_var_from sep (oldvar:string) (dom:list string) : string 256 | := if in_dec string_dec oldvar dom 257 | then fresh_var (append (get_var_base sep oldvar) sep) dom 258 | else oldvar. 259 | 260 | Lemma fresh_var_from_fresh sep oldvar (dom:list string) : 261 | ~ In (fresh_var_from sep oldvar dom) dom. 262 | Proof. 263 | unfold fresh_var_from. 264 | match_destr. 265 | apply fresh_var_fresh. 266 | Qed. 267 | 268 | Lemma find_fresh_inj_f_equivlist x y : 269 | equivlist x y -> 270 | find_fresh_inj_f nat_to_string16 nat_to_string16_inj x = 271 | find_fresh_inj_f nat_to_string16 nat_to_string16_inj y. 272 | Proof. 273 | intros. 274 | unfold find_fresh_inj_f; simpl. 275 | repeat (match goal with 276 | | [|- context[ proj1_sig ?x ]] => destruct x 277 | end; simpl). 278 | apply some_lift in e. 279 | destruct e as [? e ?]; subst. 280 | apply some_lift in e0. 281 | destruct e0 as [? e0 ?]; subst. 282 | f_equal. 283 | rewrite find_bounded_S_seq in e, e0. 284 | rewrite (find_ext 285 | (fun x0 : nat => if in_dec equiv_dec (nat_to_string16 x0) x then false else true) 286 | (fun x0 : nat => if in_dec equiv_dec (nat_to_string16 x0) y then false else true)) in e. 287 | - eapply find_seq_same; eauto. 288 | - intros. 289 | do 2 match_destr. 290 | + rewrite H in i; congruence. 291 | + rewrite <- H in i; congruence. 292 | Qed. 293 | 294 | Global Instance find_fresh_string_equivlist : Proper (equivlist ==> eq) find_fresh_string. 295 | Proof. 296 | intros ???. 297 | unfold find_fresh_string. 298 | apply find_fresh_inj_f_equivlist; trivial. 299 | Qed. 300 | (* 301 | Eval vm_compute in 302 | fresh_var_from "$"%string "cat_var$5"%string ("cat_var$0"::"i"::"cat_var$5"::"tmp1"::"tmp2"::"cat_var1"::nil)%string. 303 | *) 304 | 305 | Global Instance fresh_var_equivlist : Proper (eq ==> equivlist ==> eq) fresh_var. 306 | Proof. 307 | intros ??????; subst. 308 | unfold fresh_var. 309 | rewrite H0. 310 | reflexivity. 311 | Qed. 312 | 313 | Lemma fresh_var_from_id sep v l : 314 | ~ In v l -> 315 | fresh_var_from sep v l = v. 316 | Proof. 317 | unfold fresh_var_from. 318 | match_destr; tauto. 319 | Qed. 320 | 321 | Lemma fresh_var_from_nincl {sep v l l2} : 322 | In (fresh_var_from sep v l) l2 -> ~ incl l2 l. 323 | Proof. 324 | intros inn1 incl. 325 | apply (fresh_var_from_fresh sep v l). 326 | apply incl; trivial. 327 | Qed. 328 | 329 | Lemma fresh_var_from_incl_nin sep v l1 l2 : 330 | incl l2 l1 -> 331 | ~ In (fresh_var_from sep v l1) l2. 332 | Proof. 333 | intros incl1 inn. 334 | apply (fresh_var_from_nincl inn); trivial. 335 | Qed. 336 | 337 | End Fresh. 338 | 339 | Ltac prove_fresh_nin 340 | := match goal with 341 | | [ |- ~ In (fresh_var ?pre ?l) _ ] => 342 | solve[generalize (fresh_var_fresh pre l); simpl; intuition] 343 | | [ |- In (fresh_var ?pre ?l) _ -> False] => 344 | solve[generalize (fresh_var_fresh pre l); simpl; intuition] 345 | | [ |- ~ (fresh_var ?pre ?l) = _ ] => 346 | solve[generalize (fresh_var_fresh pre l); simpl; intuition] 347 | | [ |- (fresh_var ?pre ?l) <> _ ] => 348 | solve[generalize (fresh_var_fresh pre l); simpl; intuition] 349 | | [ H:In (fresh_var ?pre ?l) _ |- _ ] => 350 | solve[generalize (fresh_var_fresh pre l); simpl; intuition] 351 | | [ H:(fresh_var ?pre ?l) = _ |- _ ] => 352 | solve[generalize (fresh_var_fresh pre l); simpl; intuition] 353 | end. 354 | 355 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsLattice.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | (** Definition of a lattice, loosely based on ideas from "A 18 | reflection-based proof tactic for lattices in Coq" and 19 | [http://www.pps.univ-paris-diderot.fr/~sozeau/repos/coq/order/] *) 20 | 21 | Require Import RelationClasses. 22 | Require Import Morphisms. 23 | Require Import Equivalence. 24 | Require Import EquivDec. 25 | 26 | Section Lattice. 27 | 28 | Definition part_le {A} {eqA} {R} `{part:PartialOrder A eqA R} : _ := R. 29 | Infix "≤" := part_le (at level 70, no associativity). 30 | 31 | Definition associative {A} eqA `{equivA : Equivalence A eqA} (op : A->A-> A) 32 | := forall x₁ x₂ x₃, equiv (op (op x₁ x₂) x₃) (op x₁ (op x₂ x₃)). 33 | 34 | Definition commutative {A} eqA `{equivA : Equivalence A eqA} (op : A->A->A) 35 | := forall x₁ x₂, equiv (op x₁ x₂) (op x₂ x₁). 36 | 37 | Definition idempotent {A} eqA `{equivA : Equivalence A eqA} (op : A->A->A) 38 | := forall x, equiv (op x x) x. 39 | 40 | Definition absorptive {A} eqA `{equivA : Equivalence A eqA} 41 | (op1 op2 : A->A->A) 42 | := forall x y, op1 x (op2 x y) === x. 43 | 44 | Definition is_unit_r {A} eqA `{equivA : Equivalence A eqA} 45 | (op : A->A->A) (unit:A) 46 | := forall a, op a unit === a. 47 | 48 | Definition is_unit_l {A} eqA `{equivA : Equivalence A eqA} 49 | (op : A->A->A) (unit:A) 50 | := forall a, op unit a === a. 51 | 52 | Class Lattice (A:Type) (eqA:A->A->Prop) {equivA:Equivalence eqA} 53 | := { 54 | meet : A -> A -> A; 55 | join : A -> A -> A; 56 | 57 | meet_morphism :> Proper (eqA ==> eqA ==> eqA) meet ; 58 | join_morphism :> Proper (eqA ==> eqA ==> eqA) join ; 59 | 60 | meet_commutative : commutative eqA meet; 61 | meet_associative : associative eqA meet; 62 | meet_idempotent : idempotent eqA meet; 63 | 64 | join_commutative : commutative eqA join; 65 | join_associative : associative eqA join; 66 | join_idempotent : idempotent eqA join; 67 | 68 | meet_absorptive : absorptive eqA meet join; 69 | join_absorptive : absorptive eqA join meet 70 | }. 71 | 72 | Infix "⊓" := meet (at level 70). (* ⊓ = \sqcap *) 73 | Infix "⊔" := join (at level 70). (* ⊔ = \sqcup *) 74 | 75 | (** A lattice that is consistent with a specified partial order. *) 76 | 77 | Class OLattice {A:Type} 78 | (eqA:A->A->Prop) 79 | (ordA:A->A->Prop) 80 | {equivA:Equivalence eqA} 81 | {lattice:Lattice A eqA} 82 | {pre:PreOrder ordA} 83 | {po:PartialOrder eqA ordA} 84 | := { 85 | consistent_meet: forall a b, a ≤ b <-> a ⊓ b === a 86 | }. 87 | 88 | Section oprops. 89 | Context {A eqA ordA} `{olattice:OLattice A eqA ordA}. 90 | 91 | Lemma consistent_join 92 | : forall a b, a ≤ b <-> a ⊔ b === b. 93 | Proof. 94 | intros. 95 | rewrite consistent_meet. 96 | split; intros eqq. 97 | - rewrite <- eqq. 98 | rewrite join_commutative, meet_commutative. 99 | rewrite (join_absorptive b a). 100 | reflexivity. 101 | - rewrite <- eqq. 102 | rewrite (meet_absorptive a b). 103 | reflexivity. 104 | Qed. 105 | 106 | Lemma meet_leq_l a b: (a ⊓ b) ≤ a. 107 | Proof. 108 | rewrite consistent_meet. 109 | rewrite meet_commutative. 110 | rewrite <- meet_associative, meet_idempotent. 111 | reflexivity. 112 | Qed. 113 | 114 | Lemma meet_leq_r a b: (a ⊓ b) ≤ b. 115 | Proof. 116 | rewrite meet_commutative. 117 | apply meet_leq_l. 118 | Qed. 119 | 120 | Theorem meet_most {a b c} : a ≤ b -> a ≤ c -> a ≤ (b ⊓ c). 121 | Proof. 122 | intros sub1 sub2. 123 | rewrite consistent_meet in sub1,sub2. 124 | rewrite <- sub1, <- sub2. 125 | rewrite meet_associative. 126 | rewrite (meet_commutative c b). 127 | apply meet_leq_r. 128 | Qed. 129 | 130 | Lemma join_leq_l a b: a ≤ (a ⊔ b). 131 | Proof. 132 | rewrite consistent_join. 133 | rewrite <- join_associative, join_idempotent. 134 | reflexivity. 135 | Qed. 136 | 137 | Lemma join_leq_r a b: b ≤ (a ⊔ b). 138 | Proof. 139 | rewrite join_commutative. 140 | apply join_leq_l. 141 | Qed. 142 | 143 | Theorem join_least {a b c} : a ≤ c -> b ≤ c -> (a ⊔ b) ≤ c. 144 | Proof. 145 | intros sub1 sub2. 146 | rewrite consistent_join in sub1,sub2. 147 | rewrite consistent_join. 148 | rewrite join_associative. 149 | rewrite sub2, sub1. 150 | reflexivity. 151 | Qed. 152 | 153 | Global Instance meet_leq_proper : 154 | Proper (part_le ==> part_le ==> part_le) meet. 155 | Proof. 156 | unfold Proper, respectful. 157 | intros a1 a2 aleq b1 b2 bleq. 158 | rewrite consistent_meet in aleq, bleq |- *. 159 | rewrite meet_associative. 160 | rewrite (meet_commutative a2 b2). 161 | rewrite <- (meet_associative b1 b2 a2). 162 | rewrite bleq. 163 | rewrite (meet_commutative b1 a2). 164 | rewrite <- meet_associative. 165 | rewrite aleq. 166 | reflexivity. 167 | Qed. 168 | 169 | Global Instance join_leq_proper : 170 | Proper (part_le ==> part_le ==> part_le) join. 171 | Proof. 172 | unfold Proper, respectful. 173 | intros a1 a2 aleq b1 b2 bleq. 174 | rewrite consistent_join in aleq, bleq |- *. 175 | rewrite join_associative. 176 | rewrite (join_commutative a2 b2). 177 | rewrite <- (join_associative b1 b2 a2). 178 | rewrite bleq. 179 | rewrite (join_commutative b2 a2). 180 | rewrite <- join_associative. 181 | rewrite aleq. 182 | reflexivity. 183 | Qed. 184 | 185 | 186 | (** If the equivalence relation is decidable, 187 | then we can decide the leq relation using either meet or join 188 | *) 189 | Lemma leq_dec_meet `{dec:EqDec A eqA} a b : {a ≤ b} + {~ a ≤ b}. 190 | Proof. 191 | generalize (consistent_meet a b). 192 | destruct (meet a b == a); unfold equiv, complement in *; intuition. 193 | Defined. 194 | 195 | Lemma leq_dec_join `{dec:EqDec A eqA} a b : {a ≤ b} + {~ a ≤ b}. 196 | Proof. 197 | generalize (consistent_join a b). 198 | destruct (join a b == b); unfold equiv, complement in *; intuition. 199 | Defined. 200 | 201 | End oprops. 202 | 203 | (* A bounded lattice *) 204 | Class BLattice {A:Type} 205 | (eqA:A->A->Prop) 206 | {equivA:Equivalence eqA} 207 | {lattice:Lattice A eqA} 208 | := { 209 | top:A; 210 | bottom:A; 211 | join_bottom_r: is_unit_r eqA join bottom; 212 | meet_top_r: is_unit_r eqA meet top 213 | }. 214 | 215 | Section bprops. 216 | 217 | Lemma is_unit_l_r {A} eqA `{equivA : Equivalence A eqA} 218 | (op : A->A->A) : commutative eqA op -> 219 | (forall unit, is_unit_l eqA op unit <-> is_unit_r eqA op unit). 220 | Proof. 221 | unfold is_unit_l, is_unit_r. 222 | intros comm unit. 223 | split; intros; rewrite comm; trivial. 224 | Qed. 225 | 226 | Context {A eqA} `{blattice:BLattice A eqA}. 227 | 228 | Lemma join_bottom_l: is_unit_l eqA join bottom. 229 | Proof. 230 | apply is_unit_l_r. 231 | - apply join_commutative. 232 | - apply join_bottom_r. 233 | Qed. 234 | 235 | Lemma meet_top_l: is_unit_l eqA meet top. 236 | Proof. 237 | apply is_unit_l_r. 238 | - apply meet_commutative. 239 | - apply meet_top_r. 240 | Qed. 241 | 242 | Lemma meet_bottom_r : forall a, a ⊓ bottom === bottom. 243 | Proof. 244 | intros a. 245 | generalize (join_bottom_l a); intros leq. 246 | rewrite <- leq. 247 | rewrite meet_commutative. 248 | rewrite (meet_absorptive bottom a). 249 | reflexivity. 250 | Qed. 251 | 252 | Lemma meet_bottom_l : forall a, bottom ⊓ a === bottom. 253 | Proof. 254 | intros a. 255 | rewrite meet_commutative, meet_bottom_r. 256 | reflexivity. 257 | Qed. 258 | 259 | Lemma join_top_r : forall a, a ⊔ top === top. 260 | Proof. 261 | intros a. 262 | generalize (meet_top_l a); intros leq. 263 | rewrite <- leq. 264 | rewrite join_commutative. 265 | rewrite (join_absorptive top a). 266 | reflexivity. 267 | Qed. 268 | 269 | Lemma join_top_l : forall a, top ⊔ a === top. 270 | Proof. 271 | intros a. 272 | rewrite join_commutative, join_top_r. 273 | reflexivity. 274 | Qed. 275 | 276 | End bprops. 277 | 278 | Section boprops. 279 | 280 | Context {A eqA ordA equiv} 281 | {lattice:@Lattice A eqA equiv} 282 | {pre part} 283 | {blattice:@BLattice A eqA equiv lattice} 284 | {olattice:@OLattice A eqA ordA equiv lattice pre part}. 285 | 286 | Lemma le_top : forall a, a ≤ top. 287 | Proof. 288 | intros. 289 | rewrite consistent_join, join_top_r. 290 | reflexivity. 291 | Qed. 292 | 293 | Lemma bottom_le : forall a, bottom ≤ a. 294 | Proof. 295 | intros. 296 | rewrite consistent_join, join_bottom_l. 297 | reflexivity. 298 | Qed. 299 | 300 | Lemma bottom_le_top : bottom ≤ top. 301 | Proof. 302 | apply le_top. 303 | Qed. 304 | 305 | End boprops. 306 | 307 | End Lattice. 308 | 309 | Infix "≤" := part_le (at level 70, no associativity). 310 | Infix "⊓" := meet (at level 70). (* ⊓ = \sqcap *) 311 | Infix "⊔" := join (at level 70). (* ⊔ = \sqcup *) 312 | 313 | -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsLift.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | (** This module contains definitions and properties of lifting 18 | operations over option types. They are used extensively through the 19 | code to propagate errors. *) 20 | 21 | Require Import List. 22 | Require Import RelationClasses. 23 | Require Import EquivDec. 24 | 25 | Section Lift. 26 | 27 | (** * Lifting over option types *) 28 | 29 | Definition lift {A B:Type} (f:A->B) : (option A -> option B) 30 | := fun a => 31 | match a with 32 | | None => None 33 | | Some a' => Some (f a') 34 | end. 35 | 36 | Definition olift {A B} (f:A -> option B) (x:option A) : option B := 37 | match x with 38 | | None => None 39 | | Some x' => f x' 40 | end. 41 | 42 | Definition bind {A B:Type} a b := (@olift A B b a). 43 | 44 | Definition lift2 {A B C:Type} (f:A -> B -> C) (x:option A) (y:option B) : option C := 45 | match x,y with 46 | | Some x', Some y' => Some (f x' y') 47 | | _,_ => None 48 | end. 49 | 50 | Definition olift_some {A B} (f:A -> option B) (x:A) : 51 | olift f (Some x) = f x. 52 | Proof. reflexivity. Qed. 53 | 54 | Definition olift2 {A B C} (f:A -> B -> option C) (x1:option A) (x2:option B) : option C := 55 | match x1,x2 with 56 | | Some d1, Some d2 => f d1 d2 57 | | _,_ => None 58 | end. 59 | 60 | (** * Lift properties *) 61 | 62 | Lemma lift_some_simpl {A B:Type} (f:A->B) x : lift f (Some x) = Some (f x). 63 | Proof. 64 | reflexivity. 65 | Qed. 66 | 67 | Lemma lift_some_simpl_eq {A B:Type} (f:A->B) x y : 68 | f x = f y <-> 69 | lift f (Some x) = Some (f y). 70 | Proof. 71 | simpl; split; [|inversion 1]; congruence. 72 | Qed. 73 | 74 | Lemma lift_none_simpl {A B:Type} (f:A->B) : lift f None = None. 75 | Proof. reflexivity. Qed. 76 | 77 | Lemma lift_none {A B:Type} {f:A->B} {x} : 78 | x = None -> 79 | lift f x = None. 80 | Proof. 81 | intros; subst; reflexivity. 82 | Qed. 83 | 84 | Lemma lift_some {A B:Type} {f:A->B} {x y} z : 85 | x = Some z -> 86 | f z = y -> 87 | lift f x = Some y. 88 | Proof. 89 | intros; subst; reflexivity. 90 | Qed. 91 | 92 | Lemma none_lift {A B:Type} {f:A->B} {x} : 93 | lift f x = None -> 94 | x = None. 95 | Proof. 96 | destruct x; simpl; intuition discriminate. 97 | Qed. 98 | 99 | Lemma some_lift {A B:Type} {f:A->B} {x y} : 100 | lift f x = Some y -> 101 | {z | x = Some z & y = f z}. 102 | Proof. 103 | destruct x; simpl; intuition; [inversion H; eauto|discriminate]. 104 | Qed. 105 | 106 | Lemma some_lift2 {A B C:Type} {f:A->B->C} {x y z} : 107 | lift2 f x y = Some z -> 108 | {x':A & {y':B | x = Some x' & y = Some y' /\ z = f x' y'}}. 109 | Proof. 110 | destruct x; simpl; intuition; [inversion H; eauto|discriminate]. 111 | destruct y; simpl; intuition; [inversion H; eauto|discriminate]. 112 | Qed. 113 | 114 | Lemma some_olift {A B:Type} {f:A->option B} {x y} : 115 | olift f x = Some y -> 116 | {z | x = Some z & Some y = f z}. 117 | Proof. 118 | destruct x; simpl; intuition; [inversion H; eauto|discriminate]. 119 | Qed. 120 | 121 | Lemma some_olift2 {A B C:Type} {f:A->B->option C} {x y z} : 122 | olift2 f x y = Some z -> 123 | {x':A & {y':B | x = Some x' & y = Some y' /\ Some z = f x' y'}}. 124 | Proof. 125 | destruct x; simpl; intuition; [inversion H; eauto|discriminate]. 126 | destruct y; simpl; intuition; [inversion H; eauto|discriminate]. 127 | Qed. 128 | 129 | Lemma lift_injective {A B:Type} (f:A->B) : 130 | (forall x y, f x = f y -> x = y) -> 131 | (forall x y, lift f x = lift f y -> x = y). 132 | Proof. 133 | destruct x; destruct y; simpl; inversion 1; auto. 134 | f_equal; auto. 135 | Qed. 136 | 137 | Lemma lift_id {A} (x:option A) : 138 | lift (fun l'' => l'') x = x. 139 | Proof. 140 | destruct x; reflexivity. 141 | Qed. 142 | 143 | Lemma lift_ext {A B:Type} (f g : A -> B) (x : option A) : 144 | (forall a, f a = g a) -> 145 | lift f x = lift g x. 146 | Proof. 147 | destruct x; simpl; intros HH; trivial. 148 | rewrite HH; trivial. 149 | Qed. 150 | 151 | Lemma match_lift_id {A} (x:option A) : 152 | match x with 153 | | None => None 154 | | Some l'' => Some l'' 155 | end = x. 156 | Proof. 157 | destruct x; reflexivity. 158 | Qed. 159 | 160 | Lemma olift_id_lift_some {A} (x:option A) : 161 | olift id (lift Some x) = x. 162 | Proof. 163 | destruct x; simpl; reflexivity. 164 | Qed. 165 | 166 | Lemma olift_commute {A B C} (f: A->B->option C) d₁ d₂ : 167 | olift (fun d₁ => 168 | olift (fun d₂ => f d₁ d₂) d₂) d₁ 169 | = 170 | olift (fun d₂ => 171 | olift (fun d₁ => f d₁ d₂) d₁) d₂. 172 | Proof. 173 | destruct d₁; destruct d₂; simpl; trivial. 174 | Qed. 175 | 176 | Lemma olift2_none_r {A B C} (f:A -> B -> option C) (x1:option A) : 177 | olift2 f x1 None = None. 178 | Proof. 179 | destruct x1; reflexivity. 180 | Qed. 181 | 182 | Lemma olift2_somes {A B C} (f:A -> B -> option C) (x1:A) (x2:B) : 183 | olift2 f (Some x1) (Some x2) = f x1 x2. 184 | Proof. reflexivity. Qed. 185 | 186 | Lemma olift_ext {A B:Type} (f g : A -> option B) (x : option A) : 187 | (forall a, x = Some a -> f a = g a) -> 188 | olift f x = olift g x. 189 | Proof. 190 | destruct x; simpl; auto. 191 | Qed. 192 | 193 | Lemma olift2_ext {A B C : Type} 194 | (f g : A -> B -> option C) (x : option A) (y: option B) : 195 | (forall (a : A) (b:B), x = Some a -> y = Some b -> f a b = g a b) -> 196 | olift2 f x y = olift2 g x y. 197 | Proof. 198 | unfold olift2; intros. 199 | destruct x; destruct y; simpl; auto. 200 | Qed. 201 | 202 | 203 | Lemma olift_is_lift {A B} (f:A->B) x : olift (fun x => Some (f x)) x = lift f x. 204 | Proof. 205 | reflexivity. 206 | Qed. 207 | 208 | Lemma lift_lift {A B C} (f:B->C) (g:A->B) (x:option A) : lift f (lift g x) = lift (fun x => f (g x)) x. 209 | Proof. 210 | destruct x; simpl; trivial. 211 | Qed. 212 | 213 | Lemma olift_lift {A B C} (f:B->option C) (g:A->B) (x:option A) : olift f (lift g x) = olift (fun x => f (g x)) x. 214 | Proof. 215 | destruct x; simpl; trivial. 216 | Qed. 217 | 218 | Lemma lift_olift {A B C} (f:B->C) (g:A->option B) x: 219 | lift f (olift g x) = olift (fun x => lift f (g x)) x. 220 | Proof. 221 | destruct x; simpl; trivial. 222 | Qed. 223 | 224 | Lemma olift_eta {A B : Type} (f : A -> option B) (x : option A) : 225 | olift f x = olift (fun x => f x) x. 226 | Proof. 227 | destruct x; simpl; trivial. 228 | Qed. 229 | 230 | 231 | 232 | Definition rif {A} (e:A -> option bool) (a:A) : option (list A) := 233 | match (e a) with 234 | | None => None 235 | | Some b => 236 | if b then Some (a::nil) else Some nil 237 | end. 238 | 239 | Definition liftP {A:Type} (P:A->Prop) (xo:option A) : Prop 240 | := match xo with 241 | | Some x => P x 242 | | None => True 243 | end. 244 | 245 | Definition lift2P {A B:Type} (P:A->B->Prop) (xo:option A) (yo:option B) : Prop 246 | := match xo, yo with 247 | | Some x, Some y => P x y 248 | | None, None => True 249 | | _ , _ => False 250 | end. 251 | 252 | (* Right Biased lift2P: if A is None, that is fine. *) 253 | Definition lift2Pl {A B:Type} (P:A->B->Prop) (xo:option A) (yo:option B) : Prop 254 | := match xo, yo with 255 | | Some x, Some y => P x y 256 | | None, _ => True 257 | | _ , _ => False 258 | end. 259 | 260 | (* Right Biased lift2P: if B is None, that is fine. *) 261 | Definition lift2Pr {A B:Type} (P:A->B->Prop) (xo:option A) (yo:option B) : Prop 262 | := match xo, yo with 263 | | Some x, Some y => P x y 264 | | _, None => True 265 | | _ , _ => False 266 | end. 267 | 268 | Global Instance lift2P_refl {A:Type} R {refl:@Reflexive A R} : Reflexive (lift2P R). 269 | Proof. 270 | unfold lift2P; intros x. 271 | destruct x; eauto. 272 | Qed. 273 | 274 | Global Instance lift2P_sym {A:Type} R {refl:@Symmetric A R} : Symmetric (lift2P R). 275 | Proof. 276 | unfold lift2P; intros x y. 277 | destruct x; destruct y; eauto. 278 | Qed. 279 | 280 | Global Instance lift2P_trans {A:Type} R {refl:@Transitive A R} : Transitive (lift2P R). 281 | Proof. 282 | unfold lift2P; intros x y z. 283 | destruct x; destruct y; destruct z; try contradiction; eauto. 284 | Qed. 285 | 286 | Global Instance lift2P_equiv {A:Type} R {refl:@Equivalence A R} : Equivalence (lift2P R). 287 | Proof. 288 | constructor. 289 | - red; intros; reflexivity. 290 | - red; intros; symmetry; trivial. 291 | - red; intros; etransitivity; eauto. 292 | Qed. 293 | 294 | (* lazy lifting *) 295 | Definition mk_lazy_lift {A B:Type} {dec:EqDec A eq} (f:B->A->A->B) b a1 a2 296 | := if a1 == a2 297 | then b 298 | else f b a1 a2. 299 | 300 | Lemma mk_lazy_lift_id {A B:Type} {dec:EqDec A eq} (f:B->A->A->B) b a : 301 | mk_lazy_lift f b a a = b. 302 | Proof. 303 | unfold mk_lazy_lift. 304 | destruct (equiv_dec a a); congruence. 305 | Qed. 306 | 307 | Lemma mk_lazy_lift_prop 308 | {A B:Type} {dec:EqDec A eq} (f:B->A->A->B) {P} {s v1 v2} : 309 | (v1 = v2 -> P s) -> (v1 <> v2 -> P (f s v1 v2)) -> P (mk_lazy_lift f s v1 v2). 310 | Proof. 311 | unfold mk_lazy_lift. 312 | destruct (equiv_dec v1 v2); tauto. 313 | Qed. 314 | 315 | Lemma mk_lazy_lift_prop_inv 316 | {A B:Type} {dec:EqDec A eq} (f:B->A->A->B) {P:B->Prop} {s v1 v2} : 317 | P (mk_lazy_lift f s v1 v2) -> {v1 = v2 /\ P s} + {v1 <> v2 /\ P (f s v1 v2)}. 318 | Proof. 319 | unfold mk_lazy_lift. 320 | destruct (equiv_dec v1 v2); eauto. 321 | Qed. 322 | 323 | Lemma mk_lazy_lift_prop_invt 324 | {A B:Type} {dec:EqDec A eq} (f:B->A->A->B) {P:B->Type} {s v1 v2} : 325 | P (mk_lazy_lift f s v1 v2) -> (P s + {v1=v2}) + (P (f s v1 v2) + {v1<>v2}). 326 | Proof. 327 | unfold mk_lazy_lift. 328 | destruct (equiv_dec v1 v2); tauto. 329 | Qed. 330 | 331 | Lemma mk_lazy_lift_under 332 | {A B C:Type} {dec:EqDec A eq} {f1:B->C} {f2:B->A->A->B}: 333 | (forall s v v', f1 (f2 s v v') = f1 s) -> 334 | forall s v v', f1 (mk_lazy_lift f2 s v v') = f1 s. 335 | Proof. 336 | unfold mk_lazy_lift; intros. 337 | destruct (equiv_dec v v'); eauto. 338 | Qed. 339 | 340 | End Lift. 341 | 342 | Hint Rewrite @olift_some : alg. 343 | Hint Rewrite @olift2_none_r : alg. 344 | Hint Rewrite @olift2_somes : alg. 345 | 346 | (** * Tactics *) 347 | 348 | Ltac case_option 349 | := match goal with 350 | [|- context [match ?x with 351 | | Some _ => _ 352 | | None => _ 353 | end]] => case_eq x 354 | end. 355 | 356 | Ltac case_lift 357 | := match goal with 358 | [|- context [lift _ ?x]] => case_eq x 359 | end. 360 | 361 | Ltac case_option_in H 362 | := match type of H with 363 | context [match ?x with 364 | | Some _ => _ 365 | | None => _ 366 | end] => let HH:=(fresh "eqs") in case_eq x; [intros ? HH|intros HH]; try rewrite HH in H 367 | end. 368 | 369 | Ltac case_lift_in H 370 | := match type of H with 371 | context [lift _ ?x] => let HH:=(fresh "eqs") in case_eq x; [intros ? HH|intros HH]; try rewrite HH in H 372 | end. 373 | 374 | Lemma match_eq_lemma : 375 | forall A B (l1: option A) (l2:option A) f (z:B), 376 | l1 = l2 -> 377 | match l1 with 378 | | Some x => f x 379 | | None => z 380 | end 381 | = 382 | match l2 with 383 | | Some x => f x 384 | | None => z 385 | end. 386 | Proof. 387 | do 3 intro. 388 | intuition. 389 | subst;apply eq_refl. 390 | Qed. -------------------------------------------------------------------------------- /coq/lib_utils/LibUtilsResult.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright 2015-2016 IBM Corporation 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | *) 16 | 17 | Require Import List. 18 | 19 | Section Result. 20 | Section definition. 21 | Context (A: Type). (**r Type of success *) 22 | Context (E: Type). (**r Type of failure *) 23 | 24 | Inductive Result : Type := 25 | | Success : A -> Result 26 | | Failure : E -> Result. 27 | End definition. 28 | 29 | Section operations. 30 | Definition lift_failure {A B E:Type} (f:A -> Result B E) : (Result A E -> Result B E) := 31 | fun r => 32 | match r with 33 | | Success _ _ a => f a 34 | | Failure _ _ e => Failure _ _ e 35 | end. 36 | 37 | Definition lift_failure_in {A B E:Type} (f: A -> B) : (Result A E -> Result B E) := 38 | fun r => 39 | lift_failure (fun a :A => Success _ _ (f a)) r. 40 | 41 | Definition raise_failure {A B E:Type} (f:A -> B) (e:E) : (Result A E -> Result B E) := 42 | fun r => 43 | Failure _ _ e. 44 | 45 | Definition lift_failure_in_two {A B C E:Type} (f:A -> B -> C) 46 | : (Result A E -> Result B E -> Result C E) := 47 | fun a => 48 | match a with 49 | | Failure _ _ e => fun b => Failure _ _ e 50 | | Success _ _ a => 51 | (fun b => 52 | match b with 53 | | Failure _ _ e => Failure _ _ e 54 | | Success _ _ b => 55 | Success _ _ (f a b) 56 | end) 57 | end. 58 | 59 | Definition lift_failure_in_three {A B C D E:Type} (f:A -> B -> C -> D) 60 | : (Result A E -> Result B E -> Result C E -> Result D E) := 61 | fun a => 62 | match a with 63 | | Failure _ _ e => fun b => fun c => Failure _ _ e 64 | | Success _ _ a => 65 | (fun b => 66 | match b with 67 | | Failure _ _ e => fun c => Failure _ _ e 68 | | Success _ _ b => 69 | (fun c => 70 | match c with 71 | | Failure _ _ e => Failure _ _ e 72 | | Success _ _ c => 73 | Success _ _ (f a b c) 74 | end) 75 | end) 76 | end. 77 | 78 | Definition lift_failure_map {A B E:Type} (f: A -> Result B E) (al:list A) : Result (list B) E := 79 | let init_bl := Success _ _ nil in 80 | let proc_one (a:A) (acc:Result (list B) E) : Result (list B) E := 81 | lift_failure_in_two 82 | cons 83 | (f a) 84 | acc 85 | in 86 | fold_right proc_one init_bl al. 87 | 88 | Definition result_of_option {A E:Type} (a:option A) (e:E) : Result A E := 89 | match a with 90 | | Some a => Success _ _ a 91 | | None => Failure _ _ e 92 | end. 93 | 94 | Definition option_of_result {A E:Type} (r:Result A E) : option A := 95 | match r with 96 | | Failure _ _ _ => None 97 | | Success _ _ a => Some a 98 | end. 99 | 100 | End operations. 101 | End Result. 102 | 103 | -------------------------------------------------------------------------------- /coq/lib_utils/README.md: -------------------------------------------------------------------------------- 1 | This subdirectory contains the utils library from the [`Q*cert`](https://querycert.github.io/), with files/modules prefixed to avoid conflicts. 2 | 3 | We use this library (with permission from the authors) as it provides a wealth of useful basic definitions and properties. 4 | -------------------------------------------------------------------------------- /coq/utils/Assoc.v: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IBM/FormalML/1bfa4da3e0e88b8d700e96117a3316a189a3b45c/coq/utils/Assoc.v -------------------------------------------------------------------------------- /coq/utils/BasicUtils.v: -------------------------------------------------------------------------------- 1 | Require Import Equivalence EquivDec Eqdep_dec Morphisms. 2 | 3 | Require Import LibUtilsCoqLibAdd LibUtilsDigits. 4 | 5 | Definition coerce {A B:Type} (pf:A=B) : A -> B. 6 | Proof. 7 | destruct pf. 8 | intro a; exact a. 9 | Defined. 10 | 11 | Local Existing Instance Equivalence_pullback. 12 | 13 | Local Instance EqDec_pullback {A B} (R:A->A->Prop) {eqR:Equivalence R} {decR:EqDec A R} (f:B->A) : 14 | EqDec B (fun x y : B => R (f x) (f y)). 15 | Proof. 16 | intros x y. 17 | destruct (decR (f x) (f y)). 18 | - left; trivial. 19 | - right; trivial. 20 | Defined. 21 | 22 | Lemma dec_complement {A} {p:A->Prop} (dec_p: forall x, {p x} + {~ p x}) : 23 | forall x, {~ p x} + {~ ~ p x}. 24 | Proof. 25 | intros x. 26 | destruct (dec_p x). 27 | - right; tauto. 28 | - left; trivial. 29 | Defined. 30 | 31 | Lemma ne_symm {A} (x y : A) : x <> y <-> y <> x. 32 | Proof. 33 | split; intros. 34 | * intros Hxy ; symmetry in Hxy ; firstorder. 35 | * intros Hxy ; symmetry in Hxy ; firstorder. 36 | Qed. 37 | 38 | Definition rv_eq {Ts Td:Type} : (Ts -> Td) -> (Ts -> Td) -> Prop 39 | := pointwise_relation Ts eq. 40 | 41 | (* This instance is Local, since it is too general *) 42 | Local Instance rv_eq_equiv 43 | {Ts Td:Type} : 44 | Equivalence (@rv_eq Ts Td). 45 | Proof. 46 | typeclasses eauto. 47 | Qed. 48 | 49 | Lemma refl_refl {T} {R:T->T->Prop} {refl:Reflexive R} x y : x = y -> R x y. 50 | Proof. 51 | intros; subst. 52 | apply refl. 53 | Qed. 54 | 55 | Global Instance sigT_eqdec {A} {B:A->Type} (decA:EqDec A eq) (decB:forall x, EqDec (B x) eq) : 56 | EqDec (sigT B) eq. 57 | Proof. 58 | intros [x y] [x' y']. 59 | destruct (decA x x'). 60 | - red in e; subst. 61 | destruct (decB _ y y'). 62 | + left. 63 | congruence. 64 | + right. 65 | intros HH. 66 | apply inj_pair2_eq_dec in HH; [| auto]. 67 | congruence. 68 | - right. 69 | congruence. 70 | Defined. 71 | 72 | Lemma index_pf_irrel n m pf1 pf2 : 73 | exist (fun n' : nat => (n' < n)%nat) m pf1 = exist (fun n' : nat => (n' < n)%nat) m pf2. 74 | Proof. 75 | f_equal. 76 | apply digit_pf_irrel. 77 | Qed. 78 | -------------------------------------------------------------------------------- /coq/utils/ClassicUtils.v: -------------------------------------------------------------------------------- 1 | Require Import LibUtilsCoqLibAdd. 2 | 3 | Require Import ClassicalDescription. 4 | Require Import PeanoNat. 5 | Require Import Morphisms. 6 | 7 | Section find. 8 | Context {P: nat -> Prop} (dec:forall a, {P a} + {~ P a}). 9 | 10 | Fixpoint find_first n : option nat 11 | := match n with 12 | | 0 => if dec 0%nat then Some 0%nat else None 13 | | S k => match find_first k with 14 | | Some x => Some x 15 | | None => if dec (S k) then Some (S k) else None 16 | end 17 | end. 18 | 19 | Lemma find_first_some n k : find_first n = Some k -> P k. 20 | induction n; simpl. 21 | - match_destr; congruence. 22 | - match_option. 23 | + intros; apply IHn; congruence. 24 | + match_destr; congruence. 25 | Qed. 26 | 27 | Lemma find_first_none n : find_first n = None -> forall k, (k <= n)%nat -> ~ P k. 28 | induction n; simpl. 29 | - match_destr; intros. 30 | apply Nat.le_0_r in H0. 31 | congruence. 32 | - match_option. 33 | match_destr. 34 | intros. 35 | apply Nat.le_succ_r in H0. 36 | destruct H0. 37 | + auto. 38 | + congruence. 39 | Qed. 40 | 41 | Lemma find_first_some_first n k : find_first n = Some k -> forall i, (i < k)%nat -> ~ P i. 42 | induction n; simpl. 43 | - match_destr; intros. 44 | invcs H. 45 | now apply Nat.nlt_0_r in H0. 46 | - match_option. 47 | + intros; apply IHn; congruence. 48 | + match_destr; intros. 49 | invcs H. 50 | apply (find_first_none n); trivial. 51 | now apply Nat.lt_succ_r. 52 | Qed. 53 | 54 | End find. 55 | 56 | Definition classic_min_of_sumbool (P: nat -> Prop) : 57 | { n : nat | P n /\ forall k, (k < n)%nat -> ~ P k} + {forall n, ~ P n}. 58 | Proof. 59 | destruct (ClassicalDescription.excluded_middle_informative (exists n, P n /\ forall k, (k < n)%nat -> ~ P k)). 60 | - left. 61 | assert ( exists! n : nat, P n /\ (forall k : nat, (k < n)%nat -> ~ P k)). 62 | { 63 | destruct e as [n [Pn Pmin]]. 64 | exists n. 65 | split; [auto| intros ?[??]]. 66 | apply Nat.le_antisymm. 67 | - apply Nat.nlt_ge. 68 | intros ?. 69 | specialize (Pmin _ H1); tauto. 70 | - apply Nat.nlt_ge. 71 | intros ?. 72 | specialize (H0 _ H1); tauto. 73 | } 74 | now apply constructive_definite_description in H. 75 | - right. 76 | intros k pk. 77 | case_eq (find_first (fun a => ClassicalDescription.excluded_middle_informative (P a)) k). 78 | + intros. 79 | apply n. 80 | exists n0. 81 | split. 82 | * eapply find_first_some; eauto. 83 | * apply (find_first_some_first _ _ _ H). 84 | + intros HH. 85 | eapply find_first_none in HH; eauto. 86 | Qed. 87 | 88 | Definition classic_min_of (P: nat -> Prop) : option nat 89 | := match classic_min_of_sumbool P with 90 | | inleft n => Some (proj1_sig n) 91 | | inright _ => None 92 | end. 93 | 94 | Lemma classic_min_of_some P k : classic_min_of P = Some k -> P k. 95 | Proof. 96 | unfold classic_min_of. 97 | match_destr. 98 | destruct s as [?[??]]. 99 | now intros HH; invcs HH. 100 | Qed. 101 | 102 | Lemma classic_min_of_some_first P k : classic_min_of P = Some k -> forall j, (j < k)%nat -> ~ P j. 103 | Proof. 104 | unfold classic_min_of. 105 | match_destr. 106 | destruct s as [?[??]]. 107 | now intros HH; invcs HH. 108 | Qed. 109 | 110 | Lemma classic_min_of_none P : classic_min_of P = None -> forall k, ~ P k. 111 | Proof. 112 | unfold classic_min_of. 113 | match_destr. 114 | Qed. 115 | 116 | Global Instance classic_min_of_proper : 117 | Proper (pointwise_relation _ iff ==> eq) classic_min_of. 118 | Proof. 119 | intros ???. 120 | unfold classic_min_of. 121 | repeat match_destr. 122 | - destruct s as [?[??]]. 123 | destruct s0 as [?[??]]; simpl. 124 | f_equal. 125 | apply antisymmetry. 126 | + apply Compare_dec.not_lt; intros HH. 127 | apply H in y0. 128 | specialize (n _ HH); tauto. 129 | + apply Compare_dec.not_lt; intros HH. 130 | apply H in x1. 131 | specialize (n0 _ HH); tauto. 132 | - destruct s as [?[??]]. 133 | elim (n x0). 134 | now apply H. 135 | - destruct s as [?[??]]. 136 | elim (n x0). 137 | now apply H. 138 | Qed. 139 | 140 | -------------------------------------------------------------------------------- /coq/utils/ExtrFloatishIEEE.v: -------------------------------------------------------------------------------- 1 | Require Import Extraction. 2 | Require Import FloatishIEEE. 3 | 4 | (* This is assumed by fromZ *) 5 | Require Import ExtrOcamlZInt. 6 | 7 | Extract Constant IEEE_float => "float". 8 | 9 | Extract Inlined Constant IEEE_zero => "0.". 10 | Extract Inlined Constant IEEE_opp => "Float.neg". 11 | Extract Inlined Constant IEEE_plus => "Float.add". 12 | Extract Inlined Constant IEEE_minus => "Float.sub". 13 | Extract Inlined Constant IEEE_mult => "Float.mul". 14 | Extract Inlined Constant IEEE_div => "Float.div". 15 | Extract Inlined Constant IEEE_sqrt => "Float.sqrt". 16 | Extract Inlined Constant IEEE_abs => "Float.abs". 17 | 18 | 19 | Extract Inlined Constant IEEE_exp => "Float.exp". 20 | Extract Inlined Constant IEEE_ln => "Float.log". 21 | 22 | Extract Inlined Constant IEEE_pi => "Float.pi". 23 | Extract Inlined Constant IEEE_sin => "Float.sin". 24 | Extract Inlined Constant IEEE_cos => "Float.cos". 25 | 26 | Extract Inlined Constant IEEE_fromZ => "Float.of_int". 27 | 28 | Extract Inlined Constant IEEE_eq => "Float.equal". 29 | Extract Inlined Constant IEEE_neq => "(fun x y -> x <> y)". 30 | Extract Inlined Constant IEEE_lt => "(fun x y -> x < y)". 31 | Extract Inlined Constant IEEE_le => "(fun x y -> x <= y)". 32 | Extract Inlined Constant IEEE_gt => "(fun x y -> x > y)". 33 | Extract Inlined Constant IEEE_ge => "(fun x y -> x >= y)". 34 | -------------------------------------------------------------------------------- /coq/utils/Floatish.v: -------------------------------------------------------------------------------- 1 | Require Export FloatishDef. 2 | Require Export FloatishOps. 3 | 4 | Require Export FloatishInterval. 5 | Require Export FloatishIEEE. 6 | Require Export FloatishReal. 7 | 8 | Require Export FloatishRealOps. 9 | -------------------------------------------------------------------------------- /coq/utils/Floatish/FloatishDef.v: -------------------------------------------------------------------------------- 1 | Require Import BinInt. 2 | 3 | Declare Scope float. 4 | 5 | Class floatish : Type := 6 | { 7 | float : Type 8 | ; Fzero : float 9 | 10 | ; Fopp : float -> float 11 | 12 | ; Fplus : float -> float -> float 13 | ; Fminus : float -> float -> float 14 | ; Fmult : float -> float -> float 15 | ; Fdiv : float -> float -> float 16 | 17 | ; Fsqrt : float -> float 18 | ; Fabs : float -> float 19 | 20 | ; Fexp : float -> float 21 | ; Fln : float -> float 22 | 23 | ; Fsin : float -> float 24 | ; Fcos : float -> float 25 | ; Fpi : float 26 | 27 | ; FfromZ : Z -> float 28 | 29 | ; Feq : float -> float -> bool 30 | ; Fneq : float -> float -> bool 31 | ; Flt : float -> float -> bool 32 | ; Fle : float -> float -> bool 33 | ; Fgt : float -> float -> bool 34 | ; Fge : float -> float -> bool 35 | }. 36 | 37 | Notation "0" := (Fzero) : float. 38 | Notation "1" := (FfromZ 1) : float. 39 | Notation "2" := (FfromZ 2) : float. 40 | Notation "- x" := (Fopp x) (at level 35, right associativity) : float. 41 | Notation "x + y" := (Fplus x y) (at level 50, left associativity) : float. 42 | Notation "x - y" := (Fminus x y) (at level 50, left associativity) : float. 43 | Notation "x * y" := (Fmult x y) (at level 40, left associativity) : float. 44 | Notation "x / y" := (Fdiv x y) (at level 40, left associativity) : float. 45 | 46 | 47 | Notation "x ==b y" := (Feq x y) (at level 70, no associativity) : float. 48 | Notation "x != y" := (Fneq x y) (at level 70, no associativity) : float. 49 | Notation "x < y" := (Flt x y) (at level 70, no associativity) : float. 50 | Notation "x <= y" := (Fle x y) (at level 70, no associativity) : float. 51 | Notation "x > y" := (Fgt x y) (at level 70, no associativity) : float. 52 | Notation "x >= y" := (Fge x y) (at level 70, no associativity) : float. 53 | -------------------------------------------------------------------------------- /coq/utils/Floatish/FloatishIEEE.v: -------------------------------------------------------------------------------- 1 | Require Import Flocq.IEEE754.BinarySingleNaN. 2 | Require Import BinInt. 3 | 4 | Require Import FloatishDef. 5 | 6 | Require Import Flocq.IEEE754.Binary. 7 | Require Import Flocq.IEEE754.Bits. 8 | 9 | 10 | Definition IEEE_float := binary64. 11 | Definition IEEE_zero : IEEE_float := B754_zero 53 1024 false. 12 | Definition IEEE_opp := b64_opp. 13 | Definition IEEE_plus := b64_plus mode_NE. 14 | Definition IEEE_minus := b64_minus mode_NE. 15 | Definition IEEE_mult := b64_mult mode_NE. 16 | Definition IEEE_div := b64_div mode_NE. 17 | Definition IEEE_sqrt := b64_sqrt mode_NE. 18 | Definition IEEE_abs := b64_abs. 19 | 20 | Definition IEEE_fromZ i := binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE i 0 false. 21 | 22 | Definition IEEE_eq (x y:IEEE_float) 23 | := (match b64_compare x y with 24 | | Some Eq => true 25 | | _ => false 26 | end). 27 | 28 | Definition IEEE_neq (x y:IEEE_float) 29 | := (match b64_compare x y with 30 | | Some Eq => false 31 | | Some _ => true 32 | | _ => false 33 | end). 34 | 35 | Definition IEEE_lt (x y:IEEE_float) 36 | := (match b64_compare x y with 37 | | Some Lt => true 38 | | _ => false 39 | end). 40 | 41 | Definition IEEE_le (x y:IEEE_float) 42 | := (match b64_compare x y with 43 | | Some Lt => true 44 | | Some Eq => true 45 | | _ => false 46 | end). 47 | 48 | 49 | Definition IEEE_gt (x y:IEEE_float) 50 | := (match b64_compare x y with 51 | | Some Gt => true 52 | | _ => false 53 | end). 54 | 55 | 56 | Definition IEEE_ge (x y:IEEE_float) 57 | := (match b64_compare x y with 58 | | Some Gt => true 59 | | Some Eq => true 60 | | _ => false 61 | end). 62 | 63 | (* following function will be defined only via extraction *) 64 | Axiom IEEE_exp : IEEE_float -> IEEE_float. 65 | Axiom IEEE_ln : IEEE_float -> IEEE_float. 66 | Axiom IEEE_pi : IEEE_float. 67 | Axiom IEEE_sin : IEEE_float -> IEEE_float. 68 | Axiom IEEE_cos : IEEE_float -> IEEE_float. 69 | 70 | Local Instance floatish_IEEE : floatish := 71 | { 72 | float := IEEE_float 73 | ; Fzero := IEEE_zero 74 | ; Fopp := IEEE_opp 75 | ; Fplus := IEEE_plus 76 | ; Fminus := IEEE_minus 77 | ; Fmult := IEEE_mult 78 | ; Fdiv := IEEE_div 79 | ; Fsqrt := IEEE_sqrt 80 | ; Fabs := IEEE_abs 81 | 82 | ; Fexp := IEEE_exp 83 | ; Fln := IEEE_ln 84 | 85 | ; Fpi := IEEE_pi 86 | ; Fsin := IEEE_sin 87 | ; Fcos := IEEE_cos 88 | 89 | ; FfromZ := IEEE_fromZ 90 | 91 | 92 | ; Feq := IEEE_eq 93 | ; Fneq := IEEE_neq 94 | ; Flt := IEEE_lt 95 | ; Fle := IEEE_le 96 | ; Fgt := IEEE_gt 97 | ; Fge := IEEE_ge 98 | }. 99 | -------------------------------------------------------------------------------- /coq/utils/Floatish/FloatishInterval.v: -------------------------------------------------------------------------------- 1 | Require Import BinInt. 2 | 3 | Require Import Interval.Real.Xreal. 4 | 5 | Require Import Interval.Interval.Transcend. 6 | Require Import Interval.Float.Specific_ops. 7 | Require Import Interval.Float.Specific_stdz. 8 | Require Import Interval.Float.Basic. 9 | 10 | Require Import FloatishDef. 11 | 12 | Module F := SpecificFloat StdZRadix2. 13 | Module A := TranscendentalFloatFast F. 14 | 15 | Local Instance floatish_interval_gen (prec:Z) : floatish := 16 | { 17 | float := F.type 18 | ; Fzero := F.zero 19 | 20 | ; Fopp := F.neg 21 | 22 | ; Fplus := F.add_slow rnd_NE prec 23 | ; Fminus x y := F.add_slow rnd_NE prec x (F.neg y) 24 | ; Fmult := F.mul rnd_NE prec 25 | ; Fdiv := F.div rnd_NE prec 26 | 27 | ; Fsqrt := F.sqrt rnd_NE prec 28 | ; Fabs := F.abs 29 | 30 | ; Fexp x := A.I.midpoint(A.exp_fast prec x) 31 | ; Fln x := A.I.midpoint(A.ln_fast prec x) 32 | 33 | ; Fsin x := A.I.midpoint(A.sin_fast prec x) 34 | ; Fcos x := A.I.midpoint(A.cos_fast prec x) 35 | ; Fpi := F.mul rnd_NE prec (F.fromZ 4) (A.I.midpoint (A.pi4 prec)) 36 | 37 | ; FfromZ := F.fromZ 38 | 39 | ; Feq (x y:F.type) 40 | := (match F.cmp x y with 41 | | Xeq => true 42 | | _ => false 43 | end) 44 | 45 | ; Fneq (x y:F.type) 46 | := (match F.cmp x y with 47 | | Xeq => false 48 | | _ => true 49 | end) 50 | 51 | ; Flt (x y:F.type) 52 | := (match F.cmp x y with 53 | | Xlt => true 54 | | _ => false 55 | end) 56 | 57 | ; Fle (x y:F.type) 58 | := (match F.cmp x y with 59 | | Xlt => true 60 | | Xeq => true 61 | | _ => false 62 | end) 63 | 64 | ; Fgt (x y:F.type) 65 | := (match F.cmp x y with 66 | | Xgt => true 67 | | _ => false 68 | end) 69 | 70 | ; Fge (x y:F.type) 71 | := (match F.cmp x y with 72 | | Xgt => true 73 | | Xeq => true 74 | | _ => false 75 | end) 76 | }. 77 | 78 | 79 | Local Instance floatish_interval : floatish := floatish_interval_gen 53. 80 | 81 | Definition FZF (r:float) := F.nearbyint rnd_NE r. 82 | Definition FZFscale (n:Z) (r:float) := FZF (Fmult (FfromZ n) r). 83 | -------------------------------------------------------------------------------- /coq/utils/Floatish/FloatishOps.v: -------------------------------------------------------------------------------- 1 | Require Import FloatishDef. 2 | 3 | Section floatish_ops. 4 | 5 | Context {floatish_impl:floatish}. 6 | Local Open Scope float. 7 | 8 | Definition pos_sign (e:float) 9 | := if e >= 0 then 1 else Fopp 1. 10 | 11 | Definition neg_sign (e:float) 12 | := if e <= 0 then Fopp 1 else 1. 13 | 14 | Definition sign (e:float) 15 | := if e < 0 then Fopp 1 16 | else if e > 0 then 1 17 | else 0. 18 | 19 | Definition Fmax (x y:float) 20 | := if x < y then y else x. 21 | 22 | Definition Fmin (x y:float) 23 | := if x > y then y else x. 24 | 25 | End floatish_ops. 26 | -------------------------------------------------------------------------------- /coq/utils/Floatish/FloatishReal.v: -------------------------------------------------------------------------------- 1 | Require Import BinInt Reals Lra. 2 | 3 | Require Import FloatishDef. 4 | 5 | Local Instance floatish_R : floatish := 6 | { 7 | float := R 8 | ; Fzero := 0%R 9 | ; Fopp := Ropp 10 | ; Fplus := Rplus 11 | ; Fminus := Rminus 12 | ; Fmult := Rmult 13 | ; Fdiv := Rdiv 14 | ; Fsqrt := sqrt 15 | ; Fabs := Rabs 16 | 17 | ; Fexp := exp 18 | ; Fln := ln 19 | 20 | ; Fpi := PI 21 | ; Fsin := sin 22 | ; Fcos := cos 23 | 24 | ; FfromZ := IZR 25 | 26 | 27 | ; Feq x y := if Req_EM_T x y then true else false 28 | ; Fneq x y := if Req_EM_T x y then false else true 29 | ; Flt x y := if Rlt_dec x y then true else false 30 | ; Fle x y := if Rle_dec x y then true else false 31 | ; Fgt x y := if Rgt_dec x y then true else false 32 | ; Fge x y := if Rge_dec x y then true else false 33 | }. 34 | -------------------------------------------------------------------------------- /coq/utils/Floatish/FloatishRealOps.v: -------------------------------------------------------------------------------- 1 | Require Import BinInt Reals Lra. 2 | Require Import FloatishDef FloatishReal FloatishOps. 3 | 4 | Section real_pfs. 5 | 6 | Local Existing Instance floatish_R. 7 | Lemma Fmax_Rmax x y : Fmax x y = Rmax x y. 8 | Proof. 9 | vm_compute. 10 | destruct (Rlt_dec x y); destruct (Rle_dec); lra. 11 | Qed. 12 | 13 | Lemma Fmin_Rmin x y : Fmin x y = Rmin x y. 14 | Proof. 15 | vm_compute. 16 | destruct (Rgt_dec x y); destruct (Rle_dec); lra. 17 | Qed. 18 | 19 | End real_pfs. 20 | 21 | Hint Rewrite Fmax_Rmax Fmin_Rmin : Rarith. 22 | -------------------------------------------------------------------------------- /coq/utils/Isomorphism.v: -------------------------------------------------------------------------------- 1 | Require Import NArith List Rbase. 2 | 3 | Class Isomorphism (A B:Type) := 4 | { 5 | iso_f : A -> B ; 6 | iso_b : B -> A ; 7 | iso_f_b : forall b, iso_f (iso_b b) = b ; 8 | iso_b_f : forall a, iso_b (iso_f a) = a 9 | }. 10 | 11 | (* 12 | We would like to just declare 13 | Require Import RelationClasses. 14 | Global Instance Isomorphism_equiv : Equivalence Isomorphism. 15 | 16 | But this runs into universe issues. 17 | *) 18 | 19 | Global Instance Isomorphism_refl {A} : Isomorphism A A 20 | := { 21 | iso_b a := a ; 22 | iso_f a := a ; 23 | iso_f_b := @eq_refl A; 24 | iso_b_f := @eq_refl A 25 | }. 26 | 27 | Instance Isomorphism_symm {A B} (iso:Isomorphism A B) : Isomorphism B A 28 | := { 29 | iso_b := iso_f ; 30 | iso_f := iso_b ; 31 | iso_f_b := iso_b_f ; 32 | iso_b_f := iso_f_b 33 | }. 34 | 35 | Program Instance Isomorphism_trans {A B C} (iso1:Isomorphism A B) (iso2:Isomorphism B C) : Isomorphism A C 36 | := { 37 | iso_f a := @iso_f _ _ iso2 (@iso_f _ _ iso1 a) ; 38 | iso_b b := @iso_b _ _ iso1 (@iso_b _ _ iso2 b) 39 | }. 40 | Next Obligation. 41 | repeat rewrite iso_f_b; trivial. 42 | Qed. 43 | Next Obligation. 44 | repeat rewrite iso_b_f; trivial. 45 | Qed. 46 | 47 | Program Instance Isomorphism_prod {A B C D} (iso1:Isomorphism A C) (iso2:Isomorphism B D) : Isomorphism (A*B) (C*D) 48 | := { 49 | iso_f '(a,c) := (iso_f a, iso_f c) ; 50 | iso_b '(b,d) := (iso_b b, iso_b d) 51 | }. 52 | Next Obligation. 53 | repeat rewrite iso_f_b; trivial. 54 | Qed. 55 | Next Obligation. 56 | repeat rewrite iso_b_f; trivial. 57 | Qed. 58 | 59 | Program Instance Isomorphism_list {A B} (iso1:Isomorphism A B) : Isomorphism (list A) (list B) 60 | := { 61 | iso_f := map iso_f ; 62 | iso_b := map iso_b 63 | }. 64 | Next Obligation. 65 | rewrite map_map. 66 | erewrite map_ext; try apply map_id. 67 | intros. 68 | apply iso_f_b. 69 | Qed. 70 | Next Obligation. 71 | rewrite map_map. 72 | erewrite map_ext; try apply map_id. 73 | intros. 74 | apply iso_b_f. 75 | Qed. 76 | 77 | Global Instance nat_to_N_iso : Isomorphism nat N 78 | := { 79 | iso_f := N.of_nat ; 80 | iso_b := N.to_nat ; 81 | iso_f_b := N2Nat.id ; 82 | iso_b_f := Nat2N.id ; 83 | }. 84 | 85 | Program Local Instance Isomorphism_flip {A B} : Isomorphism (A*B) (B*A) 86 | := {| iso_f '(x, y) := (y,x) 87 | ; iso_b '(y, x) := (x,y) 88 | ; iso_f_b '(y,x) := eq_refl 89 | ; iso_b_f '(x,y) := eq_refl 90 | |}. 91 | 92 | Section nd. 93 | Lemma iso_b_nodup {A B} {iso:Isomorphism A B} l : 94 | NoDup l -> 95 | NoDup (map iso_b l). 96 | Proof. 97 | intros. 98 | apply (NoDup_map_inv (iso_f)). 99 | rewrite map_map. 100 | erewrite map_ext; try rewrite map_id; trivial. 101 | intros. 102 | now rewrite iso_f_b. 103 | Qed. 104 | 105 | Lemma iso_f_nodup {A B} {iso:Isomorphism A B} l : 106 | NoDup l -> 107 | NoDup (map iso_f l). 108 | Proof. 109 | intros. 110 | apply (NoDup_map_inv (iso_b)). 111 | rewrite map_map. 112 | erewrite map_ext; try rewrite map_id; trivial. 113 | intros. 114 | now rewrite iso_b_f. 115 | Qed. 116 | 117 | End nd. 118 | -------------------------------------------------------------------------------- /coq/utils/NumberIso.v: -------------------------------------------------------------------------------- 1 | Require Import BinNums BinNat Nat List. 2 | Require Import Lia. 3 | 4 | Require Import LibUtils Isomorphism PairEncoding. 5 | Import ListNotations. 6 | 7 | Require Import QArith Qcanon. 8 | 9 | Global Program Instance positive_N_iso : Isomorphism positive N 10 | := {iso_f n := Pos.pred_N n ; 11 | iso_b n := N.succ_pos n 12 | }. 13 | Next Obligation. 14 | apply N.pos_pred_succ. 15 | Qed. 16 | Next Obligation. 17 | destruct a; simpl; trivial. 18 | apply Pos.succ_pred_double. 19 | Qed. 20 | 21 | 22 | 23 | Global Program Instance Z_N_iso : Isomorphism Z N 24 | := { iso_f n := (if Z_ge_lt_dec n 0 then (Z.to_N n)*2 else (Z.to_N (- n))*2-1)%N ; 25 | iso_b n := if (n mod 2)%N then Z.of_N (n / 2)%N else (- (Z.of_N ((n+1) / 2)%N))%Z 26 | }. 27 | Next Obligation. 28 | case_eq ((b mod 2)%N); [intros modeq | intros ? modeq]. 29 | - generalize (N.div_mod b 2); intros HH. 30 | destruct ( Z_ge_lt_dec (Z.of_N (b / 2)) 0); lia. 31 | - assert (modeq2:(b mod 2 = 1)%N). 32 | { generalize (N.mod_upper_bound b 2); lia. } 33 | clear modeq. 34 | generalize (N.div_mod b 2); intros HH. 35 | rewrite modeq2 in HH. 36 | cut_to HH; [| lia]. 37 | destruct ( Z_ge_lt_dec (- Z.of_N ((b + 1) / 2)) 0). 38 | + generalize (N2Z.is_nonneg ((b+1) / 2)); intros HH2. 39 | assert ((Z.of_N ((b+1) / 2)%N = 0%Z)) by lia. 40 | generalize (f_equal Z.to_N H); intros HH3. 41 | rewrite N2Z.id in HH3. 42 | rewrite Z2N.inj_0 in HH3. 43 | generalize (N.div_str_pos (b+1) 2); intros HH4. 44 | lia. 45 | + rewrite Z.opp_involutive. 46 | rewrite N2Z.id. 47 | assert (modeq3:((b+1) mod 2 = 0)%N). 48 | { 49 | rewrite <- N.add_mod_idemp_l by lia. 50 | rewrite modeq2. 51 | simpl. 52 | rewrite N.mod_same; lia. 53 | } 54 | generalize (N.div_mod (b+1) 2); intros HH5. 55 | lia. 56 | Qed. 57 | Next Obligation. 58 | destruct (Z_ge_lt_dec a 0). 59 | - rewrite N.mod_mul by lia. 60 | rewrite N.div_mul by lia. 61 | rewrite Z2N.id; lia. 62 | - match_case; intros. 63 | + apply N.mod_divide in H; [| lia]. 64 | destruct H as [k HH]. 65 | lia. 66 | + rewrite N.sub_add by lia. 67 | rewrite N.div_mul by lia. 68 | rewrite Z2N.id by lia. 69 | rewrite Z.opp_involutive; lia. 70 | Qed. 71 | 72 | Global Program Instance Q_Zpos_iso : Isomorphism Q (Z*positive) 73 | := { iso_f q := (Qnum q, Qden q) ; 74 | iso_b '(z,p) := Qmake z p 75 | }. 76 | Next Obligation. 77 | now destruct a. 78 | Qed. 79 | 80 | Global Instance Q_N_iso : Isomorphism Q N 81 | := Isomorphism_trans 82 | Q_Zpos_iso 83 | (Isomorphism_trans 84 | (Isomorphism_prod 85 | Z_N_iso positive_N_iso) N_pair_encoder). 86 | 87 | Global Instance Q_nat_iso : Isomorphism Q nat 88 | := Isomorphism_trans 89 | Q_N_iso 90 | (Isomorphism_symm nat_to_N_iso). 91 | 92 | Require Import ZArith. 93 | 94 | 95 | 96 | Program Instance Qc_Qpos_iso : Isomorphism Q (Qc*positive) 97 | := { 98 | iso_f q := (Q2Qc q, Z.to_pos (Z.gcd (Qnum q) (Zpos (Qden q)))); 99 | iso_b '(qc,m) := ((this qc) * (Z.pos m # m))%Q 100 | }. 101 | Next Obligation. 102 | f_equal. 103 | - apply Qc_is_canon. 104 | unfold Qeq; simpl. 105 | case_eq ( (Z.ggcd (Qnum q * Z.pos p) (Z.pos (Qden q * p)))); intros; simpl. 106 | generalize (Z.ggcd_correct_divisors (Qnum q * Z.pos p) (Z.pos (Qden q * p))); intros HH. 107 | rewrite H in HH. 108 | destruct p0. 109 | destruct HH as [eqq1 eqq2]. 110 | simpl. 111 | destruct q. 112 | destruct this. 113 | simpl in *. 114 | rewrite Pos2Z.inj_mul in eqq2. 115 | assert (eqq12:(Z.pos Qden * (Qnum * Z.pos p)%Z = Z.pos Qden * (z * z0)%Z)%Z) 116 | by now rewrite eqq1. 117 | assert (eqq22:(Z.pos Qden * (Qnum * Z.pos p)%Z = Qnum * (z * z1)%Z)%Z) 118 | by (rewrite <- eqq2; lia). 119 | rewrite eqq12 in eqq22. 120 | assert (eqq3:( z * (Z.pos Qden * z0) = z * (Qnum * z1))%Z) by lia. 121 | rewrite Z2Pos.id. 122 | + apply Z.mul_cancel_l in eqq3; [ | lia]. 123 | lia. 124 | + rewrite <- Pos2Z.inj_mul in eqq2. 125 | generalize (Pos2Z.pos_is_pos (Qden * p)); intros HH1. 126 | rewrite eqq2 in HH1. 127 | rewrite Z.mul_comm in HH1. 128 | generalize (Z.ggcd_gcd (Qnum * Z.pos p) (Z.pos (Qden * p))); intros HH2. 129 | rewrite H in HH2; simpl in HH2. 130 | 131 | generalize (Z.gcd_nonneg (Qnum * Z.pos p) (Z.pos (Qden * p))); intros HH3. 132 | rewrite <- HH2 in HH3. 133 | assert (HH4:(z = 0 \/ 0 < z)%Z) by lia. 134 | destruct HH4. 135 | * subst. 136 | lia. 137 | * eapply Zmult_gt_0_lt_0_reg_r. 138 | -- apply Z.lt_gt. 139 | apply H0. 140 | -- lia. 141 | - simpl. 142 | rewrite Pos2Z.inj_mul. 143 | rewrite Z.gcd_mul_mono_r. 144 | destruct q; simpl. 145 | apply Qred_iff in canon. 146 | rewrite canon. 147 | simpl. 148 | trivial. 149 | Qed. 150 | Next Obligation. 151 | generalize (Qred_correct a); intros HH. 152 | red in HH. 153 | rewrite <- Z.ggcd_gcd. 154 | unfold Qred. 155 | destruct a. 156 | generalize (Z.ggcd_correct_divisors Qnum (Z.pos Qden)). 157 | case_eq (Z.ggcd Qnum (Z.pos Qden)). 158 | intros z [p q] eqq [HH1 HH2]. 159 | simpl. 160 | rewrite eqq, HH1; simpl. 161 | unfold Qmult; simpl. 162 | assert (zn:(z <> 0)%Z). 163 | { 164 | intro; subst. 165 | simpl in HH2. 166 | lia. 167 | } 168 | assert (zpos:(z > 0)%Z). 169 | { 170 | generalize (Z.gcd_nonneg Qnum (Z.pos Qden)); intros HH3. 171 | rewrite <- Z.ggcd_gcd in HH3. 172 | rewrite eqq in HH3; simpl in HH3. 173 | lia. 174 | } 175 | assert (qpos:(q>0)%Z). 176 | { 177 | generalize (Pos2Z.is_pos Qden); intros HH3. 178 | eapply Z.lt_gt. 179 | eapply Zmult_lt_0_reg_r. 180 | + eapply Z.gt_lt. 181 | eapply zpos. 182 | + lia. 183 | } 184 | rewrite Z2Pos.id by lia. 185 | f_equal. 186 | + lia. 187 | + rewrite <- Z2Pos.inj_mul by lia. 188 | apply Pos2Z.inj_pos. 189 | rewrite HH2. 190 | rewrite Z2Pos.id by lia. 191 | lia. 192 | Qed. 193 | -------------------------------------------------------------------------------- /coq/utils/PushNeg.v: -------------------------------------------------------------------------------- 1 | Require Import Classical ClassicalFacts. 2 | Require Import Reals. 3 | Require Import micromega.Lra. 4 | 5 | (* 6 | **************************************************************************************** 7 | This file develops the tactics `push_neg` and `contrapose` which are inspired by similar 8 | tactics available in Lean's mathlib library. 9 | 10 | * `push_neg` and `push_neg_in` push negations into hypotheses containing nested 11 | quantifiers. 12 | 13 | For example, if we have a hypothesis like this in the local context: 14 | 15 | (H : ~ (forall ϵ:posreal, exists δ:posreal, forall x, (Rabs(x - x0) <= δ)%R -> 16 | ((Rabs (f x - f x0))< ϵ)%R)) 17 | 18 | `push_neg_in H` transforms it to: 19 | 20 | (H : exists x : posreal, 21 | forall x1 : posreal, 22 | exists x2 : R, (Rabs (x2 - x0) <= x1)%R /\ (Rabs (f x2 - f x0) >= x)%R 23 | 24 | *`contrapose` and `contrapose_in` replace an implication by it's contrapositive. 25 | 26 | NOTE: These tactics may utilize classical axioms (the law of excluded middle). 27 | **************************************************************************************** 28 | *) 29 | 30 | 31 | Section rewrites. 32 | 33 | Lemma not_not (P : Prop): ~(~ P) <-> P. 34 | Proof. 35 | split; intros. 36 | + now apply NNPP. 37 | + firstorder. 38 | Qed. 39 | 40 | Lemma not_and (P Q:Prop) : ~(P /\ Q) <-> (P -> ~Q). 41 | Proof. 42 | firstorder. 43 | Qed. 44 | 45 | Lemma not_or (P Q:Prop) : ~(P \/ Q) <-> (~ P /\ ~ Q). 46 | Proof. 47 | firstorder. 48 | Qed. 49 | 50 | Lemma not_forall {A : Type} (S : A -> Prop): ~(forall x, S x) <-> exists x, ~ S x. 51 | Proof. 52 | split; intros. 53 | + now apply not_all_ex_not. 54 | + firstorder. 55 | Qed. 56 | 57 | Lemma not_exists {A : Type} (S : A -> Prop): ~(exists x, S x) <-> forall x, ~ S x. 58 | Proof. 59 | firstorder. 60 | Qed. 61 | 62 | Lemma not_imply : forall P Q:Prop, ~ (P -> Q) <-> P /\ ~ Q. 63 | Proof. 64 | intros P Q. 65 | split; intros. 66 | - now apply imply_to_and. 67 | - firstorder. 68 | Qed. 69 | 70 | Lemma not_lt (a b : R): ~ (a < b)%R <-> (a >= b)%R. 71 | Proof. 72 | lra. 73 | Qed. 74 | 75 | Lemma not_le (a b : R): ~ (a <= b)%R <-> (a > b)%R. 76 | Proof. 77 | lra. 78 | Qed. 79 | 80 | Lemma not_gt (a b : R): ~ (a > b)%R <-> (a <= b)%R. 81 | Proof. 82 | lra. 83 | Qed. 84 | 85 | Lemma not_ge (a b : R): ~ (a >= b)%R <-> (a < b)%R. 86 | Proof. 87 | lra. 88 | Qed. 89 | 90 | Lemma not_eq {A : Type} (a b : A) : ~(a = b) <-> a <> b. 91 | Proof. 92 | reflexivity. 93 | Qed. 94 | 95 | Lemma not_impl_contr (p q : Prop) : (~q -> ~p) <-> (p -> q). 96 | Proof. 97 | split; intros; try (apply NNPP); firstorder. 98 | Qed. 99 | 100 | End rewrites. 101 | 102 | Ltac push_neg := 103 | repeat match goal with 104 | | [ |- context[~ (_ < _)%R]] => setoid_rewrite not_lt 105 | | [ |- context[~ (_ <= _)%R]] => setoid_rewrite not_le 106 | | [ |- context[~ (_ > _)%R]] => setoid_rewrite not_gt 107 | | [ |- context[~ (_ >= _)%R]] => setoid_rewrite not_ge 108 | | [ |- context[~ (~ _)]] => setoid_rewrite not_not 109 | | [ |- context[~ (_ /\ _)]] => setoid_rewrite not_and 110 | | [ |- context[~(_ \/ _)]] => setoid_rewrite not_or 111 | | [ |- context[~(_ -> _)]] => setoid_rewrite not_imply 112 | | [ |- context[~(_ = _)]] => setoid_rewrite not_eq 113 | | [ |- context[~ exists _, _]] => setoid_rewrite not_exists 114 | | [ |- context[~ (forall _, _)]] => setoid_rewrite not_forall 115 | end. 116 | 117 | 118 | Ltac push_neg_in H := 119 | repeat match type of H with 120 | | context[~ (_ < _)%R] => setoid_rewrite not_lt in H 121 | | context[~ (_ <= _)%R] => setoid_rewrite not_le in H 122 | | context[~ (_ > _)%R] => setoid_rewrite not_gt in H 123 | | context[~ (_ >= _)%R] => setoid_rewrite not_ge in H 124 | | context[~ (~ _)] => setoid_rewrite not_not in H 125 | | context[~ (_ /\ _)] => setoid_rewrite not_and in H 126 | | context[~(_ \/ _)] => setoid_rewrite not_or in H 127 | | context[~(_ -> _)] => setoid_rewrite not_imply in H 128 | | context[~(_ = _)] => setoid_rewrite not_eq in H 129 | | context[~ exists _, _] => setoid_rewrite not_exists in H 130 | | context[~ (forall _, _)] => setoid_rewrite not_forall in H 131 | end. 132 | 133 | Ltac contrapose := 134 | match goal with 135 | | [ |- ~ (_ -> _)] => setoid_rewrite not_impl_contr 136 | | [ |- (_ -> _)] => setoid_rewrite <-not_impl_contr 137 | end. 138 | 139 | 140 | Ltac contrapose_in H := 141 | match type of H with 142 | | ~ (_ -> _) => setoid_rewrite not_impl_contr in H 143 | | (_ -> _) => setoid_rewrite <-not_impl_contr in H 144 | end. 145 | 146 | Ltac contra_neg := contrapose; push_neg. 147 | 148 | Ltac contra_neg_in H := contrapose_in H ; push_neg_in H. 149 | 150 | Lemma tests1 151 | (p q : Prop) 152 | (P : nat -> Prop) (x y z : R) 153 | (H1 : ~ exists x : nat, P x) 154 | (H2 : ~ forall x : nat, P x) 155 | (H3 : ~ (x < y)%R) 156 | (H4 : ~ (x <= y)%R) 157 | (H5 : ~ (x > y)%R) 158 | (H6 : ~ (~ q)) 159 | (H7 : ~ (p -> (p -> q))) 160 | (H8 : ~ (p /\ q)) 161 | (H9 : ~ (p \/ q)): True. 162 | Proof. 163 | push_neg_in H1. 164 | push_neg_in H2. 165 | push_neg_in H3. 166 | push_neg_in H4. 167 | push_neg_in H5. 168 | push_neg_in H6. 169 | push_neg_in H7. 170 | push_neg_in H8. 171 | push_neg_in H9. 172 | trivial. 173 | Qed. 174 | 175 | Lemma tests2 {x : nat -> R} 176 | (H1 : ~ exists x y : nat, forall z:nat, x = z \/ y = z) 177 | (H2 : ~ forall x y : nat, x = y /\ y = x) 178 | (H3 : ~(forall eps : R, exists N:nat, forall m n : nat, m >= N -> n >= N -> (Rabs (x n - x m)%R <= eps)%R)) 179 | : True. 180 | Proof. 181 | push_neg_in H1. 182 | push_neg_in H2. 183 | push_neg_in H3. 184 | trivial. 185 | Qed. 186 | 187 | Lemma test3 {f : R -> R}(x0 : R) 188 | (H : ~ (forall ϵ:posreal, exists δ:posreal, forall x, (Rabs(x - x0) <= δ)%R -> 189 | ((Rabs (f x - f x0))< ϵ)%R)) : True. 190 | Proof. 191 | push_neg_in H. 192 | trivial. 193 | Qed. 194 | 195 | Lemma test4 {p q : Prop} (Hpq1 : (p -> q)) (Hpq2 : ~q -> ~p) : (~q -> ~p) /\ (p -> q). 196 | Proof. 197 | split. 198 | + clear Hpq2. contrapose_in Hpq1. exact Hpq1. 199 | + clear Hpq1. contrapose_in Hpq2. push_neg_in Hpq2. 200 | exact Hpq2. 201 | Qed. 202 | 203 | Lemma test5 {p q : Prop} (Hpq1 : (p -> q)) (Hpq2 : ~q -> ~p) : (~q -> ~p) /\ (p -> q). 204 | Proof. 205 | split. 206 | + clear Hpq2. now contra_neg. 207 | + clear Hpq1. now contra_neg_in Hpq2. 208 | Qed. 209 | -------------------------------------------------------------------------------- /coq/utils/StreamAdd.v: -------------------------------------------------------------------------------- 1 | Require Import Utils. 2 | 3 | Require Import List. 4 | Require Import Streams. 5 | Require Import Equivalence. 6 | Require Import Morphisms. 7 | 8 | Local Open Scope equiv_scope. 9 | 10 | Global Instance EqSt_equiv {A} : Equivalence (@EqSt A). 11 | Proof. 12 | constructor. 13 | - intros ?; apply EqSt_reflex. 14 | - intros ??; apply sym_EqSt. 15 | - intros ??; apply trans_EqSt. 16 | Qed. 17 | 18 | Fixpoint ConsList {A:Type} (l:list A) (s:Stream A) : Stream A 19 | := match l with 20 | | nil => s 21 | | cons x xs => Cons x (ConsList xs s) 22 | end. 23 | 24 | Global Instance ConsList_proper {A} : Proper (eq ==> @EqSt A ==> @EqSt A) (@ConsList A). 25 | Proof. 26 | repeat red; intros; subst. 27 | induction y; simpl; trivial. 28 | constructor; simpl; trivial. 29 | Qed. 30 | 31 | Lemma ConsList_app {A:Type} (l1 l2:list A) (s:Stream A) : 32 | ConsList (l1++l2) s = ConsList l1 (ConsList l2 s). 33 | Proof. 34 | induction l1; simpl; trivial. 35 | rewrite IHl1; trivial. 36 | Qed. 37 | 38 | Section Cutting. 39 | 40 | Context {A:Type}. 41 | 42 | Fixpoint firstn (n:nat) (l:Stream A) : list A := 43 | match n with 44 | | 0 => nil 45 | | S n => match l with 46 | | Cons a l => a::(firstn n l) 47 | end 48 | end. 49 | 50 | Global Instance firstn_proper : Proper (eq ==> @EqSt A ==> eq) firstn. 51 | Proof. 52 | repeat red; intros; subst. 53 | revert x0 y0 H0. 54 | induction y; simpl; trivial; intros x0 y0. 55 | inversion 1. 56 | destruct x0; destruct y0; simpl in *. 57 | f_equal; auto. 58 | Qed. 59 | 60 | Fixpoint skipn (n:nat)(s:Stream A) : Stream A := 61 | match n with 62 | | 0 => s 63 | | S n => match s with 64 | | Cons a s' => skipn n s' 65 | end 66 | end. 67 | 68 | Global Instance skipn_proper : Proper (eq ==> @EqSt A ==> @EqSt A) skipn. 69 | Proof. 70 | repeat red; intros; subst. 71 | revert x0 y0 H0. 72 | induction y; simpl; trivial; intros x0 y0. 73 | inversion 1. 74 | destruct x0; destruct y0; simpl in *. 75 | f_equal; auto. 76 | Qed. 77 | 78 | Lemma firstn_length n l : length (firstn n l) = n. 79 | Proof. 80 | revert l. 81 | induction n; simpl; trivial. 82 | destruct l; simpl. 83 | rewrite IHn. 84 | trivial. 85 | Qed. 86 | 87 | Lemma firstn_cons n a l: firstn (S n) (Streams.Cons a l) = cons a (firstn n l). 88 | Proof. 89 | reflexivity. 90 | Qed. 91 | 92 | Lemma firstn_O l: firstn 0 l = nil. 93 | Proof. 94 | reflexivity. 95 | Qed. 96 | 97 | Lemma firstn_ConsList n (l:list A) (s:Stream A) : 98 | n < length l -> 99 | firstn n (ConsList l s) = List.firstn n l. 100 | Proof. 101 | revert n. 102 | induction l; simpl. 103 | - intros. inversion H. 104 | - intros. 105 | destruct n; simpl; trivial. 106 | rewrite IHl; auto with arith. 107 | Qed. 108 | 109 | Lemma firstn_skipn n s : ConsList (firstn n s) (skipn n s) = s. 110 | Proof. 111 | revert s. 112 | induction n; trivial; intros [s]; simpl. 113 | rewrite IHn; trivial. 114 | Qed. 115 | 116 | Lemma firstn_skipn_swap n1 n2 s : firstn n1 (skipn n2 s) = List.skipn n2 (firstn (n2+n1) s). 117 | Proof. 118 | revert n1 s. 119 | induction n2; simpl; trivial. 120 | intros n1 [s]; auto. 121 | Qed. 122 | 123 | Lemma firstn_firstn (s:Stream A) (i j : nat) : 124 | List.firstn i (firstn j s) = firstn (min i j) s. 125 | Proof. 126 | revert s j. 127 | induction i; simpl; trivial. 128 | intros [s]; simpl. 129 | destruct j; simpl; trivial. 130 | rewrite IHi. 131 | trivial. 132 | Qed. 133 | 134 | Lemma firstn_firstn_swap (s:Stream A) (i j : nat) : 135 | List.firstn i (firstn j s) = List.firstn j (firstn i s). 136 | Proof. 137 | repeat rewrite firstn_firstn. 138 | rewrite Min.min_comm. 139 | trivial. 140 | Qed. 141 | 142 | End Cutting. 143 | 144 | -------------------------------------------------------------------------------- /coq/utils/StreamLimits.v: -------------------------------------------------------------------------------- 1 | Require Import Streams. 2 | Require Import Rbase Rlimit. 3 | 4 | Require Import StreamAdd. 5 | 6 | Definition Stream_limit {A} (f:list A -> R) (s:Stream A) (l:R) 7 | := forall eps : R, 8 | (eps > 0)%R -> 9 | exists N : nat, forall n : nat, n >= N -> (Rfunctions.R_dist (f (firstn n s)) l < eps)%R. 10 | 11 | -------------------------------------------------------------------------------- /coq/utils/Utils.v: -------------------------------------------------------------------------------- 1 | (** Gathers all exports needed to access the utility modules. *) 2 | 3 | Require Export LibUtils. 4 | Require Export BasicUtils. 5 | Require Export ClassicUtils. 6 | Require Export Assoc. 7 | Require Export CoquelicotAdd. 8 | Require Export FiniteType. 9 | Require Export improper_integrals. 10 | Require Export Isomorphism. 11 | Require Export ListAdd. 12 | Require Export Quotient. 13 | Require Export PairEncoding. 14 | Require Export NumberIso. 15 | Require Export RealAdd. 16 | Require Export ELim_Seq. 17 | Require Export RbarAdd. 18 | Require Export RiemannAdd. 19 | Require Export Sums. 20 | -------------------------------------------------------------------------------- /coq/utils/nvector.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import BinInt. 3 | Require Import Lia. 4 | Require Import LibUtils. 5 | 6 | Require Import VectorDef. 7 | Require Vector. 8 | 9 | Section Vector. 10 | 11 | Definition vector (T:Type) (n:nat) := Vector.t T n. 12 | 13 | Definition vnil {T} : vector T 0 := nil T. 14 | 15 | Definition vcons {T} (n:nat) (c:T) (v:vector T n) : vector T (S n) := 16 | cons T c n v. 17 | 18 | Definition vappend {T} (n1 n2:nat) (v1:vector T n1) (v2:vector T n2) : vector T (n1 + n2) 19 | := append v1 v2. 20 | 21 | Definition vmap {A B} {n} (f:A->B) (v : vector A n) : vector B n := map f v. 22 | 23 | Definition vhd {T} {n:nat} (v : vector T (S n)):T := hd v. 24 | 25 | Definition vtl {T} {n:nat} (v : vector T (S n)) : vector T n := tl v. 26 | 27 | Definition vlast {T} {n:nat} (v : vector T (S n)) := last v. 28 | 29 | Definition vnth {T} {n:nat} (v : vector T n) (i:nat | i T := 33 | fun i => vnth v i. 34 | 35 | Program Definition ConstVector {T} (n:nat) (c:T) : vector T n 36 | := of_list (repeat c n). 37 | Next Obligation. 38 | now rewrite repeat_length. 39 | Qed. 40 | 41 | Program Definition build_vector {T} {n:nat} (v:{n':nat | n' < n}%nat -> T) : vector T n 42 | := of_list (Vector.vector_to_list v). 43 | Next Obligation. 44 | apply Vector.vector_to_list_length. 45 | Qed. 46 | 47 | Lemma to_list_length {T} {n:nat} (v : vector T n) : length (to_list v) = n. 48 | induction v; simpl; trivial. 49 | now f_equal. 50 | Qed. 51 | 52 | Program Definition vcombine {T1 T2} {n:nat} (v1:vector T1 n) (v2:vector T2 n): vector (T1*T2) n := 53 | of_list (combine (to_list v1) (to_list v2)). 54 | Next Obligation. 55 | rewrite combine_length. 56 | rewrite to_list_length, to_list_length. 57 | apply PeanoNat.Nat.min_id. 58 | Qed. 59 | 60 | Definition vector_zip {T1 T2} {n:nat} (v1:vector T1 n) (v2:vector T2 n): vector (T1*T2) n := 61 | vcombine v1 v2. 62 | 63 | Definition vmap2 {A B C} {n} (f:A->B->C) (v1 : vector A n) (v2 : vector B n) : vector C n 64 | := Vector.map2 f v1 v2. 65 | 66 | Definition vmap4 {A B} {n} (f:A->A->A->A->B) (v1 v2 v3 v4 : vector A n) : vector B n := 67 | vmap2 (fun '(a1,a2) '(a3,a4) => f a1 a2 a3 a4) (vcombine v1 v2) (vcombine v3 v4). 68 | 69 | Program Definition vectoro_to_ovector {T} {n} (v:vector (option T) n) : option (vector T n) 70 | := match listo_to_olist (to_list v) with 71 | | None => None 72 | | Some l => Some (of_list l) 73 | end. 74 | Next Obligation. 75 | symmetry in Heq_anonymous. 76 | apply listo_to_olist_some in Heq_anonymous. 77 | rewrite <- map_length with (f := Some). 78 | rewrite <- Heq_anonymous. 79 | now apply to_list_length. 80 | Qed. 81 | 82 | Definition vforall {A} {m:nat} (P: A -> Prop) (v:vector A m) : Prop 83 | := Vector.Forall P v. 84 | 85 | End Vector. 86 | 87 | Section Matrix. 88 | 89 | Definition matrix (T:Type) (n m : nat) := vector (vector T m) n. 90 | 91 | Definition mat_fun {T:Type} (n m : nat) (mat : matrix T n m ) : 92 | {n':nat | n' < n}%nat -> {m':nat | m' < m}%nat -> T := 93 | fun i => fun j => vnth (vnth mat i) j. 94 | 95 | Definition mmap {A B} {n m} (f:A->B) (mat : matrix A n m) : matrix B n m := 96 | vmap (vmap f) mat. 97 | 98 | Definition mnth {T} {n m :nat} (v : matrix T n m) (i:nat | i vcombine a b) (vcombine mat1 mat2). 103 | 104 | Definition matrix_zip {T1 T2} {n m : nat} (mat1 : matrix T1 n m) (mat2 : matrix T2 n m) : matrix (T1*T2) n m := mcombine mat1 mat2. 105 | 106 | Definition build_matrix {T} {n m:nat} 107 | (mat:{n':nat | n' < n}%nat -> {m':nat | m' < m}%nat -> T) : matrix T n m 108 | := vmap build_vector (build_vector mat). 109 | 110 | Definition transpose {T} {m n : nat} (mat:matrix T m n) : matrix T n m 111 | := build_matrix (fun i j => mnth mat j i). 112 | 113 | Definition ConstMatrix {T} (n m : nat) (c:T) : matrix T n m := 114 | ConstVector n (ConstVector m c). 115 | 116 | Definition matrixo_to_omatrix {T} {m n} (v:matrix (option T) m n) : option (matrix T m n) 117 | := vectoro_to_ovector (vmap vectoro_to_ovector v). 118 | 119 | Definition mmap2 {A B C} {n m} (f:A->B->C) (v1 : matrix A n m) (v2 : matrix B n m) : matrix C n m := vmap2 (fun r1 r2 => vmap2 f r1 r2) v1 v2. 120 | 121 | Definition mforall {A} {m n:nat} (P: A -> Prop) (m:matrix A m n) : Prop 122 | := vforall (fun x => vforall P x) m. 123 | 124 | End Matrix. 125 | 126 | Section Tensor. 127 | Fixpoint tensor T (l:list nat) : Type 128 | := match l with 129 | | List.nil => T 130 | | x::l' => vector (tensor T l') x 131 | end. 132 | 133 | Lemma tensor0 T : tensor T List.nil = T. 134 | Proof. 135 | reflexivity. 136 | Qed. 137 | 138 | Lemma tensor1 T n : tensor T (n::List.nil) = vector T n. 139 | Proof. 140 | reflexivity. 141 | Qed. 142 | 143 | Lemma tensor_app T l1 l2 : tensor (tensor T l1) l2 = tensor T (l2++l1). 144 | Proof. 145 | revert l1. 146 | induction l2; intros l1; simpl; trivial. 147 | now rewrite IHl2. 148 | Qed. 149 | 150 | Fixpoint ConstTensor {T} (l : list nat) (c:T) : (tensor T l) := 151 | match l with 152 | | List.nil => c 153 | | x::l' => ConstVector x (ConstTensor l' c) 154 | end. 155 | 156 | Fixpoint Tensor_map {A B} {dims:list nat} (f:A->B) : tensor A dims -> tensor B dims 157 | := match dims with 158 | | List.nil => fun x => f x 159 | | x::l' => vmap (Tensor_map f) 160 | end. 161 | 162 | Definition scalar {T} (c:T) : tensor T List.nil := c. 163 | 164 | End Tensor. 165 | 166 | Inductive NumericType 167 | := FloatType 168 | | IntType. 169 | 170 | 171 | Definition ntype_interp (n:NumericType) : Type 172 | := match n with 173 | | FloatType => nat 174 | | IntType => Z 175 | end. 176 | 177 | Structure BigArray (ln : list nat) (T : NumericType) : Type := 178 | Tensor { tdata :> list (ntype_interp T); _ : length tdata = List.fold_right Nat.mul 1%nat ln }. 179 | 180 | Structure Array1 (n : nat) (T : NumericType) : Type := 181 | array1 { a1data :> list (ntype_interp T); _ : length a1data = n}. 182 | 183 | Structure Array2 (n m : nat) (T : NumericType) : Type := 184 | array2 { a2data :> list (ntype_interp T); _ : length a2data = n * m}. 185 | 186 | Definition tensor_abs_type (T:NumericType) (dims:list nat) := tensor (ntype_interp T) dims. 187 | 188 | Class TensorDef := 189 | { 190 | tensor_t (T:NumericType) (dims:list nat) : Type 191 | ; tensor_repr {T:NumericType} {dims:list nat} : tensor_t T dims -> tensor_abs_type T dims -> Prop 192 | 193 | ; tensor_const {T} (dims : list nat) (c:ntype_interp T) : tensor_t T dims 194 | ; tensor_const_p {T} (dims : list nat) (c:ntype_interp T) : tensor_repr (tensor_const dims c) (ConstTensor dims c) 195 | 196 | ; tensor_map {A B} {dims : list nat} (f:ntype_interp A-> ntype_interp B) (t:tensor_t A dims) : tensor_t B dims 197 | ; tensor_map_p {A B} {dims : list nat} (f:ntype_interp A-> ntype_interp B) (t:tensor_t A dims) : 198 | forall r, tensor_repr t r -> 199 | tensor_repr (tensor_map f t) (Tensor_map f r) 200 | 201 | (* ; tensor_nth {A} {dims : list nat} (indices:list nat) (indices_in_range:True) (t:tensor A dims) : A *) 202 | (* ; tensor_nth_p {A:Type} {dims : list nat} (indices:list nat) (indices_in_range:True) (t:tensor_t A dims) : *) 203 | (* forall r, tensor_repr t r -> *) 204 | (* tensor_repr (tensor_nth indices indices_in_range t) (tensor_nth indices indices_in_range r) *) 205 | }. 206 | 207 | (* 208 | Class TensorDefExt {base:TensorDef} := 209 | { 210 | tensor_transpose; 211 | }. 212 | *) 213 | (* ; tensor_nth {A} {dims : list nat} (indices:list nat) (indices_in_range:True) (t:tensor A dims) : A *) 214 | (* ; tensor_nth_p {A:Type} {dims : list nat} (indices:list nat) (indices_in_range:True) (t:tensor_t A dims) : *) 215 | (* forall r, tensor_repr t r -> *) 216 | (* tensor_repr (tensor_nth indices indices_in_range t) (tensor_nth indices indices_in_range r) *) 217 | 218 | (* Instance trivial_TensorDef : TensorDef := *) 219 | (* { *) 220 | (* tensor_t := tensor; *) 221 | (* tensor_repr _ _ a b := a = b *) 222 | (* }. *) 223 | (* 224 | Fixpoint flat_list_represent_tensor {T} {dims} (l:list A) (t:tensor T dims) : Prop 225 | := 226 | 227 | Instance BigArray_TensorDef : TensorDef 228 | := { 229 | tensor_t A dims := list A; 230 | tensor_repr T dims (l:list A) (tensor T dims) 231 | := fix 232 | }. 233 | *) 234 | 235 | Require Import Floatish. 236 | Section float_ops. 237 | Context {floatish_impl:floatish}. 238 | Local Open Scope float. 239 | 240 | Definition vsum {m:nat} (v:vector float m) : float 241 | := List.fold_right Fplus 0 (to_list v). 242 | 243 | Definition msum {m n:nat} (v:matrix float m n) : float := 244 | vsum (vmap vsum v). 245 | 246 | Definition vdot {m:nat} (v1 v2 : vector float m) : float := 247 | List.fold_right Fplus 0 248 | (List.map (fun '(a,b) => a * b) 249 | (combine (to_list v1) (to_list v2))). 250 | 251 | Definition vadd {m:nat} (v1 v2 : vector float m) := 252 | vmap (fun '(a,b) => a+b) (vcombine v1 v2). 253 | 254 | Definition madd {m n:nat} (mat1 mat2 : matrix float m n) := 255 | mmap (fun '(a,b) => a+b) (mcombine mat1 mat2). 256 | 257 | Definition matrix_vector_mult {n m} (l : matrix float n m)(r : vector float m) : vector float n := 258 | vmap (fun l1 => vdot l1 r) l. 259 | 260 | Definition matrix_vector_add {n m} (l : matrix float n m) (r : vector float n) : matrix float n m := 261 | build_matrix (fun i j => (vnth (vnth l i) j) + (vnth r i)). 262 | 263 | (* 264 | transpose (vmap (fun l1 => vadd l1 r) (transpose l)). 265 | *) 266 | 267 | Definition matrix_mult {n m p} (l : matrix float n m)(r : matrix float m p) : matrix float n p := 268 | build_matrix (fun i k => vsum (build_vector 269 | (fun j => (vnth (vnth l i) j) * 270 | (vnth (vnth r j) k)))). 271 | 272 | (* 273 | transpose (vmap (fun r1 => matrix_vector_mult l r1) (transpose r)). 274 | *) 275 | 276 | End float_ops. 277 | 278 | 279 | 280 | 281 | 282 | 283 | -------------------------------------------------------------------------------- /ocaml/Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Copyright 2015-2016 IBM Corporation 3 | # 4 | # Licensed under the Apache License, Version 2.0 (the "License"); 5 | # you may not use this file except in compliance with the License. 6 | # You may obtain a copy of the License at 7 | # 8 | # http://www.apache.org/licenses/LICENSE-2.0 9 | # 10 | # Unless required by applicable law or agreed to in writing, software 11 | # distributed under the License is distributed on an "AS IS" BASIS, 12 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | # See the License for the specific language governing permissions and 14 | # limitations under the License. 15 | # 16 | 17 | # User-level configuration 18 | # include ../Makefile.config 19 | # Contains the list of all the Coq modules 20 | include ../Makefile.coq_modules 21 | 22 | ## Configuraton 23 | NNOPT_HOME=$(CURDIR)/.. 24 | 25 | ############# Shouldn't have to be changed after this 26 | OCAMLBUILD= ocamlbuild \ 27 | -no-links -classic-display \ 28 | -tags annot -use-ocamlfind -package unix -package base64 -package csv 29 | 30 | MENHIRFLAG=-use-menhir 31 | #MENHIRFLAG= 32 | 33 | ## Mains 34 | MAIN=nnopt 35 | 36 | TARGET=native 37 | 38 | ## Toplevel 39 | all: ../bin/$(MAIN) 40 | 41 | native: ../bin/$(MAIN) 42 | 43 | ## Extraction 44 | VO_FILES = $(MODULES:%=../coq/%.vo) 45 | 46 | extracted: extracted/StaticConfig.ml extracted/NnoptExtracted.ml extracted/NnoptExtracted.mli 47 | 48 | extracted/StaticConfig.ml extracted/NnoptExtracted.ml extracted/NnoptExtracted.mli : $(VO_FILES) NnoptExtraction.v 49 | rm -rf extracted 50 | mkdir -p extracted 51 | echo "(* This file is generated *)" > extracted/StaticConfig.ml 52 | echo "let nnopt_home = \"$(NNOPT_HOME)\"" >> extracted/StaticConfig.ml 53 | (coqc -R ../coq FormalML NnoptExtraction.v) 54 | 55 | ## Native 56 | ../bin/$(MAIN): extracted $(MAIN).$(TARGET) ../bin 57 | cp _build/$(MAIN).$(TARGET) ../bin/$(MAIN) 58 | 59 | ../bin: 60 | @mkdir -p ../bin 61 | 62 | $(MAIN).$(TARGET): extracted 63 | $(OCAMLBUILD) $(MENHIRFLAG) -Is extracted -Is src $(MAIN).$(TARGET) 64 | 65 | ## Clean 66 | 67 | clean: 68 | ocamlbuild -clean -no-log 69 | rm -rf _build 70 | rm -f ../bin/$(MAIN) 71 | 72 | cleanall: clean 73 | rm -f NnoptExtraction.glob NnoptExtraction.vo .NnoptExtraction.aux 74 | rm -rf extracted 75 | rm -rf *~ 76 | 77 | .NOTPARALLEL: 78 | 79 | -------------------------------------------------------------------------------- /ocaml/NnoptExtraction.v: -------------------------------------------------------------------------------- 1 | (* Configuration of the extraction *) 2 | 3 | Require Extraction. 4 | Extraction Language OCaml. 5 | Require Import ExtrOcamlBasic ExtrOcamlString ExtrOcamlZInt ExtrOcamlNatInt. 6 | Extraction Blacklist String List. 7 | 8 | Require Import FloatishIEEE. 9 | Require Import ExtrFloatishIEEE. 10 | 11 | (* Require Import ExtrR. *) 12 | (* Our stuff modules *) 13 | 14 | Require API. 15 | 16 | (* Workaround for https://github.com/coq/coq/issues/13288 , suggested by a comment on the issue. 17 | Coq extraction currently creates a clash between the extracted Decimal.int and the 18 | ocaml int type. 19 | *) 20 | Extract Inductive Decimal.int => unit [ "(fun _ -> ())" "(fun _ -> ())" ] "(fun _ _ _ -> assert false)". 21 | 22 | Cd "./extracted". 23 | 24 | Recursive Extraction Library API. 25 | -------------------------------------------------------------------------------- /ocaml/nnopt.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | open API 4 | open Util 5 | open Pretty 6 | 7 | 8 | let () = Format.printf "Result of running opt: %a\n" (pretty_visible_option pretty_df_env) API.opt ;; 9 | let () = Format.printf "Result of running opt2: %a\n" (pretty_visible_option pretty_df_env) API.opt2 ;; 10 | let () = Format.printf "The testopt environment: %a\n" pretty_df_env API.testopt ;; 11 | let () = Format.printf "The testreeopt environment: %a\n" pretty_df_env API.testreeopt ;; 12 | 13 | let () = Format.printf "The gradenv environment: %a\n" pretty_df_env API.gradenv ;; 14 | let () = Format.printf "The gradenv_tree environment: %a\n" pretty_df_env API.gradenv_tree ;; 15 | 16 | let () = Format.printf "The test_update environment: %a\n" pretty_df_env API.test_update ;; 17 | 18 | let () = Format.printf "The test environment: %a\n" pretty_df_env API.test_env ;; 19 | 20 | let data = read_int_matrix_from_csv "breast-cancer-wisconsin.data" ;; 21 | let actual_data = API.discard_first data ;; 22 | 23 | let () = Format.printf "first part of data without the first column: %d\n" (List.hd (List.hd actual_data)) 24 | let normalized_data = API.normalizeIntData actual_data ;; 25 | let () = Format.printf "first 10 rows of normalized data without the first column: \n%a\n" ( pretty_matrix 10 10) normalized_data ;; 26 | 27 | let () = Random.self_init() 28 | 29 | let randomStream = mkIndexedStream 0 (Obj.magic (API.random_float_vector ())) ;; 30 | let fvals = fst(streamtake 5 randomStream) ;; 31 | let () = Format.printf "random list : %a\n" (pretty_blist pp_print_float) fvals ;; 32 | 33 | let init_env = init_env2 9 15 1 (char_list_of_string "w") (char_list_of_string "b") 34 | (Obj.magic (random_float_matrix ())) (Obj.magic (random_float_matrix ())) ;; 35 | let () = Format.printf "Init environment: %a\n" pretty_df_env init_env ;; 36 | 37 | let wval = eval_wisconsin_batch 10 (Obj.magic init_env) (Obj.magic normalized_data) ;; 38 | let () = Format.printf "wisconsin init loss value : %a\n" (pretty_blist pp_print_float) (Obj.magic wval) ;; 39 | 40 | let wval2 = wisconsin_test 10 100 (Obj.magic init_env) (Obj.magic normalized_data) ;; 41 | let () = Format.printf "wisconsin loss value : %a\n" (pretty_blist pp_print_float) (Obj.magic wval2) ;; 42 | (* 43 | let wenv = wisconsin_test_env 6 10 (Obj.magic init_env) (Obj.magic normalized_data) ;; 44 | let () = Format.printf "wisconsin test env: %a\n" pretty_df_env wenv ;; 45 | 46 | let nnval = nn_test_val ;; 47 | let () = Format.printf "nn test init loss value : %a\n" (pretty_blist pp_print_float) (Obj.magic nnval) ;; 48 | 49 | let wval3 = nn_test 1 ;; 50 | let () = Format.printf "NN test loss value : %a\n" (pretty_blist pp_print_float) (Obj.magic wval3) ;; 51 | 52 | let wenv3 = nn_test_env 1 ;; 53 | let () = Format.printf "NN test env: %a\n" pretty_df_env wenv3 ;; 54 | 55 | let wenv4 = nn_test_gradenv ;; 56 | let () = Format.printf "NN gradenv env: %a\n" pretty_df_env wenv4 ;; 57 | 58 | let wenv5 = nn_test_gradenv_tree ;; 59 | let () = Format.printf "NN gradenv env tree: %a\n" pretty_df_env wenv5 ;; 60 | *) 61 | (* 62 | let gradenvtree = wisconsin_gradenv_tree 1 (Obj.magic init_env) (Obj.magic normalized_data) ;; 63 | let () = Format.printf "wisconsin gradenv_tree : %a\n" pretty_df_env gradenvtree ;; 64 | 65 | let gradenv = wisconsin_gradenv 1 (Obj.magic init_env) (Obj.magic normalized_data) ;; 66 | let () = Format.printf "wisconsin gradenv : %a\n" pretty_df_env gradenv ;; 67 | *) 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /ocaml/src/Pretty.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | open API 4 | 5 | let rec subVar_to_list sv = 6 | begin match sv with 7 | | Name s -> (Util.string_of_char_list s, []) 8 | | Sub (v,i) -> let (s,r) = subVar_to_list v in 9 | (s, i::r) 10 | end 11 | 12 | let pretty_const_string s ff _ = pp_print_string ff s 13 | 14 | let pretty_blist ?(bstart="[") ?(bend="]") ?(bsep=",") pp ff l = 15 | pp_print_string ff bstart ; 16 | (pp_print_list ~pp_sep:(pretty_const_string bsep)) pp ff l ; 17 | pp_print_string ff bend 18 | 19 | let pretty_subVar ff sv = 20 | let (s,l) = subVar_to_list sv in 21 | pp_print_string ff s ; 22 | if l <> [] 23 | then pretty_blist pp_print_int ff l 24 | 25 | let pretty_definition_function_types ff dft = 26 | begin match dft with 27 | | DTfloat -> fprintf ff "%s" "float" 28 | | DTVector m -> fprintf ff "%s[%d]" "float" m 29 | | DTMatrix (m,n) -> fprintf ff "%s[%d,%d]" "float" m n 30 | end 31 | 32 | let pretty_var_type ff (sv, dft) = 33 | fprintf ff "%a{%a}" pretty_subVar sv pretty_definition_function_types dft 34 | 35 | let pretty_vector n ff v = 36 | let fs = List.init n (fun i -> Obj.magic (v i)) in 37 | pretty_blist pp_print_float ff fs 38 | 39 | let pretty_matrix m n ff v = 40 | let fs = List.init m (fun i -> List.init n (fun j -> Obj.magic (v i j))) in 41 | pretty_blist (pretty_blist pp_print_float) ff fs 42 | 43 | let pretty_definition_function_types_interp ff dft value = 44 | begin match dft with 45 | | DTfloat -> pp_print_float ff (Obj.magic value) 46 | | DTVector m -> pretty_vector m ff (Obj.magic value) 47 | | DTMatrix (m,n) -> pretty_matrix m n ff (Obj.magic value) 48 | end 49 | 50 | let pretty_env_entry_type ff (ExistT ((sv, dft), value)) = 51 | pretty_subVar ff sv ; 52 | pp_print_string ff "->" ; 53 | pretty_definition_function_types_interp ff dft value 54 | 55 | let pretty_df_env ff env = 56 | pretty_blist ~bstart:"{" ~bend:"}" pretty_env_entry_type ff env 57 | 58 | (* This should be replaced with Format.pp_print_option from ocaml >=4.08 *) 59 | let pretty_option ?none some formatter value = 60 | begin match value with 61 | | None -> 62 | begin 63 | match none with 64 | | None -> () 65 | | Some none -> none formatter () 66 | end 67 | | Some value -> some formatter value 68 | end 69 | 70 | let pretty_visible_option some formatter value = pretty_option ~none:(pretty_const_string "None") some formatter value 71 | -------------------------------------------------------------------------------- /ocaml/src/Pretty.mli: -------------------------------------------------------------------------------- 1 | open API 2 | open DefinedFunctions 3 | open Vector 4 | 5 | val pretty_subVar : Format.formatter -> coq_SubVar -> unit 6 | 7 | val pretty_definition_function_types : Format.formatter -> definition_function_types -> unit 8 | 9 | val pretty_vector : int -> Format.formatter -> float coq_Vector -> unit 10 | val pretty_matrix : int -> int -> Format.formatter -> float coq_Matrix -> unit 11 | 12 | val pretty_var_type : Format.formatter -> var_type -> unit 13 | 14 | val pretty_env_entry_type : Format.formatter -> env_entry_type -> unit 15 | val pretty_df_env : Format.formatter -> df_env -> unit 16 | 17 | val pretty_visible_option : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit 18 | 19 | val pretty_blist : ?bstart:string -> ?bend:string -> ?bsep:string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit 20 | -------------------------------------------------------------------------------- /ocaml/src/Util.ml: -------------------------------------------------------------------------------- 1 | let string_of_char_list l = 2 | let b = Bytes.create (List.length l) in 3 | let i = ref 0 in 4 | List.iter (fun c -> Bytes.set b !i c; incr i) l; 5 | Bytes.to_string b 6 | 7 | let char_list_of_string s = 8 | let l = ref [] in 9 | String.iter (fun c -> l := c :: !l) s; 10 | List.rev !l 11 | 12 | let read_int_matrix_from_csv name = 13 | let sdata = Csv.load name in 14 | List.map (List.map int_of_string) sdata 15 | 16 | let rec memoized_vector f = 17 | let cache = Hashtbl.create 10 in 18 | begin fun n -> 19 | try Hashtbl.find cache n 20 | with Not_found -> begin 21 | let x = f n in 22 | Hashtbl.add cache n x; x 23 | end 24 | end 25 | 26 | let random_float_vector () = memoized_vector (fun _ -> Random.float 1.0) 27 | let random_float_matrix () = memoized_vector (fun _ -> random_float_vector ()) 28 | 29 | -------------------------------------------------------------------------------- /ocaml/src/Util.mli: -------------------------------------------------------------------------------- 1 | val string_of_char_list : char list -> string 2 | val char_list_of_string : string -> char list 3 | 4 | val read_int_matrix_from_csv : string -> int list list 5 | 6 | val memoized_vector : (int -> 'a) -> int -> 'a 7 | 8 | val random_float_vector : unit -> int -> float 9 | val random_float_matrix : unit -> int -> int -> float 10 | --------------------------------------------------------------------------------