├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── SCIENCE.md ├── _CoqProject.in ├── build-HoTTClasses.sh ├── build-dependencies.sh ├── configure ├── ide └── theories ├── CPP2017.v ├── HoTTBook.v ├── cauchy_completion.v ├── cauchy_dedekind.v ├── cauchy_reals.v ├── cauchy_reals ├── abs.v ├── base.v ├── field.v ├── full_order.v ├── full_ring.v ├── initial.v ├── metric.v ├── order.v ├── recip.v ├── ring.v └── uniform_on_intervals.v ├── cauchy_semidec.v ├── dedekind.v ├── inductives ├── ast.v └── inductives.v ├── partiality.v └── sierpinsky.v /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | Makefile 3 | Makefile.conf 4 | *.vo 5 | *.vo.aux 6 | *.glob 7 | *.v.d 8 | *.native 9 | *.ml4.d 10 | *.mli.d 11 | *.mllib.d 12 | *.timing 13 | _CoqProject 14 | html/ 15 | timing/ 16 | .dir-locals.el 17 | TAGS 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: trusty 2 | sudo: required 3 | 4 | language: c 5 | 6 | addons: 7 | apt: 8 | sources: 9 | - avsm 10 | packages: 11 | - opam 12 | - aspcud 13 | 14 | cache: 15 | apt: true 16 | directories: 17 | - $HOME/.opam 18 | - coq 19 | - HoTT 20 | 21 | before_cache: 22 | - rm -rf $HOME/.opam/log/ 23 | 24 | env: 25 | global: 26 | - NJOBS=2 27 | - OPAMJOBS=2 28 | - COMPILER="4.06.1" 29 | - OPAMYES="true" 30 | 31 | install: 32 | - opam init --compiler=${COMPILER} -n default https://opam.ocaml.org 33 | - eval $(opam config env) 34 | - opam config list 35 | - opam install camlp5.7.12 ocamlfind num 36 | - opam list 37 | 38 | - ./build-dependencies.sh 39 | 40 | script: ./build-HoTTClasses.sh 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 2.1, February 1999 3 | 4 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 5 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | [This is the first released version of the Lesser GPL. It also counts 10 | as the successor of the GNU Library Public License, version 2, hence 11 | the version number 2.1.] 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Lesser General Public License, applies to some 21 | specially designated software packages--typically libraries--of the 22 | Free Software Foundation and other authors who decide to use it. You 23 | can use it too, but we suggest you first think carefully about whether 24 | this license or the ordinary General Public License is the better 25 | strategy to use in any particular case, based on the explanations below. 26 | 27 | When we speak of free software, we are referring to freedom of use, 28 | not price. Our General Public Licenses are designed to make sure that 29 | you have the freedom to distribute copies of free software (and charge 30 | for this service if you wish); that you receive source code or can get 31 | it if you want it; that you can change the software and use pieces of 32 | it in new free programs; and that you are informed that you can do 33 | these things. 34 | 35 | To protect your rights, we need to make restrictions that forbid 36 | distributors to deny you these rights or to ask you to surrender these 37 | rights. These restrictions translate to certain responsibilities for 38 | you if you distribute copies of the library or if you modify it. 39 | 40 | For example, if you distribute copies of the library, whether gratis 41 | or for a fee, you must give the recipients all the rights that we gave 42 | you. You must make sure that they, too, receive or can get the source 43 | code. If you link other code with the library, you must provide 44 | complete object files to the recipients, so that they can relink them 45 | with the library after making changes to the library and recompiling 46 | it. And you must show them these terms so they know their rights. 47 | 48 | We protect your rights with a two-step method: (1) we copyright the 49 | library, and (2) we offer you this license, which gives you legal 50 | permission to copy, distribute and/or modify the library. 51 | 52 | To protect each distributor, we want to make it very clear that 53 | there is no warranty for the free library. Also, if the library is 54 | modified by someone else and passed on, the recipients should know 55 | that what they have is not the original version, so that the original 56 | author's reputation will not be affected by problems that might be 57 | introduced by others. 58 | 59 | Finally, software patents pose a constant threat to the existence of 60 | any free program. We wish to make sure that a company cannot 61 | effectively restrict the users of a free program by obtaining a 62 | restrictive license from a patent holder. Therefore, we insist that 63 | any patent license obtained for a version of the library must be 64 | consistent with the full freedom of use specified in this license. 65 | 66 | Most GNU software, including some libraries, is covered by the 67 | ordinary GNU General Public License. This license, the GNU Lesser 68 | General Public License, applies to certain designated libraries, and 69 | is quite different from the ordinary General Public License. We use 70 | this license for certain libraries in order to permit linking those 71 | libraries into non-free programs. 72 | 73 | When a program is linked with a library, whether statically or using 74 | a shared library, the combination of the two is legally speaking a 75 | combined work, a derivative of the original library. The ordinary 76 | General Public License therefore permits such linking only if the 77 | entire combination fits its criteria of freedom. The Lesser General 78 | Public License permits more lax criteria for linking other code with 79 | the library. 80 | 81 | We call this license the "Lesser" General Public License because it 82 | does Less to protect the user's freedom than the ordinary General 83 | Public License. It also provides other free software developers Less 84 | of an advantage over competing non-free programs. These disadvantages 85 | are the reason we use the ordinary General Public License for many 86 | libraries. However, the Lesser license provides advantages in certain 87 | special circumstances. 88 | 89 | For example, on rare occasions, there may be a special need to 90 | encourage the widest possible use of a certain library, so that it becomes 91 | a de-facto standard. To achieve this, non-free programs must be 92 | allowed to use the library. A more frequent case is that a free 93 | library does the same job as widely used non-free libraries. In this 94 | case, there is little to gain by limiting the free library to free 95 | software only, so we use the Lesser General Public License. 96 | 97 | In other cases, permission to use a particular library in non-free 98 | programs enables a greater number of people to use a large body of 99 | free software. For example, permission to use the GNU C Library in 100 | non-free programs enables many more people to use the whole GNU 101 | operating system, as well as its variant, the GNU/Linux operating 102 | system. 103 | 104 | Although the Lesser General Public License is Less protective of the 105 | users' freedom, it does ensure that the user of a program that is 106 | linked with the Library has the freedom and the wherewithal to run 107 | that program using a modified version of the Library. 108 | 109 | The precise terms and conditions for copying, distribution and 110 | modification follow. Pay close attention to the difference between a 111 | "work based on the library" and a "work that uses the library". The 112 | former contains code derived from the library, whereas the latter must 113 | be combined with the library in order to run. 114 | 115 | GNU LESSER GENERAL PUBLIC LICENSE 116 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 117 | 118 | 0. This License Agreement applies to any software library or other 119 | program which contains a notice placed by the copyright holder or 120 | other authorized party saying it may be distributed under the terms of 121 | this Lesser General Public License (also called "this License"). 122 | Each licensee is addressed as "you". 123 | 124 | A "library" means a collection of software functions and/or data 125 | prepared so as to be conveniently linked with application programs 126 | (which use some of those functions and data) to form executables. 127 | 128 | The "Library", below, refers to any such software library or work 129 | which has been distributed under these terms. A "work based on the 130 | Library" means either the Library or any derivative work under 131 | copyright law: that is to say, a work containing the Library or a 132 | portion of it, either verbatim or with modifications and/or translated 133 | straightforwardly into another language. (Hereinafter, translation is 134 | included without limitation in the term "modification".) 135 | 136 | "Source code" for a work means the preferred form of the work for 137 | making modifications to it. For a library, complete source code means 138 | all the source code for all modules it contains, plus any associated 139 | interface definition files, plus the scripts used to control compilation 140 | and installation of the library. 141 | 142 | Activities other than copying, distribution and modification are not 143 | covered by this License; they are outside its scope. The act of 144 | running a program using the Library is not restricted, and output from 145 | such a program is covered only if its contents constitute a work based 146 | on the Library (independent of the use of the Library in a tool for 147 | writing it). Whether that is true depends on what the Library does 148 | and what the program that uses the Library does. 149 | 150 | 1. You may copy and distribute verbatim copies of the Library's 151 | complete source code as you receive it, in any medium, provided that 152 | you conspicuously and appropriately publish on each copy an 153 | appropriate copyright notice and disclaimer of warranty; keep intact 154 | all the notices that refer to this License and to the absence of any 155 | warranty; and distribute a copy of this License along with the 156 | Library. 157 | 158 | You may charge a fee for the physical act of transferring a copy, 159 | and you may at your option offer warranty protection in exchange for a 160 | fee. 161 | 162 | 2. You may modify your copy or copies of the Library or any portion 163 | of it, thus forming a work based on the Library, and copy and 164 | distribute such modifications or work under the terms of Section 1 165 | above, provided that you also meet all of these conditions: 166 | 167 | a) The modified work must itself be a software library. 168 | 169 | b) You must cause the files modified to carry prominent notices 170 | stating that you changed the files and the date of any change. 171 | 172 | c) You must cause the whole of the work to be licensed at no 173 | charge to all third parties under the terms of this License. 174 | 175 | d) If a facility in the modified Library refers to a function or a 176 | table of data to be supplied by an application program that uses 177 | the facility, other than as an argument passed when the facility 178 | is invoked, then you must make a good faith effort to ensure that, 179 | in the event an application does not supply such function or 180 | table, the facility still operates, and performs whatever part of 181 | its purpose remains meaningful. 182 | 183 | (For example, a function in a library to compute square roots has 184 | a purpose that is entirely well-defined independent of the 185 | application. Therefore, Subsection 2d requires that any 186 | application-supplied function or table used by this function must 187 | be optional: if the application does not supply it, the square 188 | root function must still compute square roots.) 189 | 190 | These requirements apply to the modified work as a whole. If 191 | identifiable sections of that work are not derived from the Library, 192 | and can be reasonably considered independent and separate works in 193 | themselves, then this License, and its terms, do not apply to those 194 | sections when you distribute them as separate works. But when you 195 | distribute the same sections as part of a whole which is a work based 196 | on the Library, the distribution of the whole must be on the terms of 197 | this License, whose permissions for other licensees extend to the 198 | entire whole, and thus to each and every part regardless of who wrote 199 | it. 200 | 201 | Thus, it is not the intent of this section to claim rights or contest 202 | your rights to work written entirely by you; rather, the intent is to 203 | exercise the right to control the distribution of derivative or 204 | collective works based on the Library. 205 | 206 | In addition, mere aggregation of another work not based on the Library 207 | with the Library (or with a work based on the Library) on a volume of 208 | a storage or distribution medium does not bring the other work under 209 | the scope of this License. 210 | 211 | 3. You may opt to apply the terms of the ordinary GNU General Public 212 | License instead of this License to a given copy of the Library. To do 213 | this, you must alter all the notices that refer to this License, so 214 | that they refer to the ordinary GNU General Public License, version 2, 215 | instead of to this License. (If a newer version than version 2 of the 216 | ordinary GNU General Public License has appeared, then you can specify 217 | that version instead if you wish.) Do not make any other change in 218 | these notices. 219 | 220 | Once this change is made in a given copy, it is irreversible for 221 | that copy, so the ordinary GNU General Public License applies to all 222 | subsequent copies and derivative works made from that copy. 223 | 224 | This option is useful when you wish to copy part of the code of 225 | the Library into a program that is not a library. 226 | 227 | 4. You may copy and distribute the Library (or a portion or 228 | derivative of it, under Section 2) in object code or executable form 229 | under the terms of Sections 1 and 2 above provided that you accompany 230 | it with the complete corresponding machine-readable source code, which 231 | must be distributed under the terms of Sections 1 and 2 above on a 232 | medium customarily used for software interchange. 233 | 234 | If distribution of object code is made by offering access to copy 235 | from a designated place, then offering equivalent access to copy the 236 | source code from the same place satisfies the requirement to 237 | distribute the source code, even though third parties are not 238 | compelled to copy the source along with the object code. 239 | 240 | 5. A program that contains no derivative of any portion of the 241 | Library, but is designed to work with the Library by being compiled or 242 | linked with it, is called a "work that uses the Library". Such a 243 | work, in isolation, is not a derivative work of the Library, and 244 | therefore falls outside the scope of this License. 245 | 246 | However, linking a "work that uses the Library" with the Library 247 | creates an executable that is a derivative of the Library (because it 248 | contains portions of the Library), rather than a "work that uses the 249 | library". The executable is therefore covered by this License. 250 | Section 6 states terms for distribution of such executables. 251 | 252 | When a "work that uses the Library" uses material from a header file 253 | that is part of the Library, the object code for the work may be a 254 | derivative work of the Library even though the source code is not. 255 | Whether this is true is especially significant if the work can be 256 | linked without the Library, or if the work is itself a library. The 257 | threshold for this to be true is not precisely defined by law. 258 | 259 | If such an object file uses only numerical parameters, data 260 | structure layouts and accessors, and small macros and small inline 261 | functions (ten lines or less in length), then the use of the object 262 | file is unrestricted, regardless of whether it is legally a derivative 263 | work. (Executables containing this object code plus portions of the 264 | Library will still fall under Section 6.) 265 | 266 | Otherwise, if the work is a derivative of the Library, you may 267 | distribute the object code for the work under the terms of Section 6. 268 | Any executables containing that work also fall under Section 6, 269 | whether or not they are linked directly with the Library itself. 270 | 271 | 6. As an exception to the Sections above, you may also combine or 272 | link a "work that uses the Library" with the Library to produce a 273 | work containing portions of the Library, and distribute that work 274 | under terms of your choice, provided that the terms permit 275 | modification of the work for the customer's own use and reverse 276 | engineering for debugging such modifications. 277 | 278 | You must give prominent notice with each copy of the work that the 279 | Library is used in it and that the Library and its use are covered by 280 | this License. You must supply a copy of this License. If the work 281 | during execution displays copyright notices, you must include the 282 | copyright notice for the Library among them, as well as a reference 283 | directing the user to the copy of this License. Also, you must do one 284 | of these things: 285 | 286 | a) Accompany the work with the complete corresponding 287 | machine-readable source code for the Library including whatever 288 | changes were used in the work (which must be distributed under 289 | Sections 1 and 2 above); and, if the work is an executable linked 290 | with the Library, with the complete machine-readable "work that 291 | uses the Library", as object code and/or source code, so that the 292 | user can modify the Library and then relink to produce a modified 293 | executable containing the modified Library. (It is understood 294 | that the user who changes the contents of definitions files in the 295 | Library will not necessarily be able to recompile the application 296 | to use the modified definitions.) 297 | 298 | b) Use a suitable shared library mechanism for linking with the 299 | Library. A suitable mechanism is one that (1) uses at run time a 300 | copy of the library already present on the user's computer system, 301 | rather than copying library functions into the executable, and (2) 302 | will operate properly with a modified version of the library, if 303 | the user installs one, as long as the modified version is 304 | interface-compatible with the version that the work was made with. 305 | 306 | c) Accompany the work with a written offer, valid for at 307 | least three years, to give the same user the materials 308 | specified in Subsection 6a, above, for a charge no more 309 | than the cost of performing this distribution. 310 | 311 | d) If distribution of the work is made by offering access to copy 312 | from a designated place, offer equivalent access to copy the above 313 | specified materials from the same place. 314 | 315 | e) Verify that the user has already received a copy of these 316 | materials or that you have already sent this user a copy. 317 | 318 | For an executable, the required form of the "work that uses the 319 | Library" must include any data and utility programs needed for 320 | reproducing the executable from it. However, as a special exception, 321 | the materials to be distributed need not include anything that is 322 | normally distributed (in either source or binary form) with the major 323 | components (compiler, kernel, and so on) of the operating system on 324 | which the executable runs, unless that component itself accompanies 325 | the executable. 326 | 327 | It may happen that this requirement contradicts the license 328 | restrictions of other proprietary libraries that do not normally 329 | accompany the operating system. Such a contradiction means you cannot 330 | use both them and the Library together in an executable that you 331 | distribute. 332 | 333 | 7. You may place library facilities that are a work based on the 334 | Library side-by-side in a single library together with other library 335 | facilities not covered by this License, and distribute such a combined 336 | library, provided that the separate distribution of the work based on 337 | the Library and of the other library facilities is otherwise 338 | permitted, and provided that you do these two things: 339 | 340 | a) Accompany the combined library with a copy of the same work 341 | based on the Library, uncombined with any other library 342 | facilities. This must be distributed under the terms of the 343 | Sections above. 344 | 345 | b) Give prominent notice with the combined library of the fact 346 | that part of it is a work based on the Library, and explaining 347 | where to find the accompanying uncombined form of the same work. 348 | 349 | 8. You may not copy, modify, sublicense, link with, or distribute 350 | the Library except as expressly provided under this License. Any 351 | attempt otherwise to copy, modify, sublicense, link with, or 352 | distribute the Library is void, and will automatically terminate your 353 | rights under this License. However, parties who have received copies, 354 | or rights, from you under this License will not have their licenses 355 | terminated so long as such parties remain in full compliance. 356 | 357 | 9. You are not required to accept this License, since you have not 358 | signed it. However, nothing else grants you permission to modify or 359 | distribute the Library or its derivative works. These actions are 360 | prohibited by law if you do not accept this License. Therefore, by 361 | modifying or distributing the Library (or any work based on the 362 | Library), you indicate your acceptance of this License to do so, and 363 | all its terms and conditions for copying, distributing or modifying 364 | the Library or works based on it. 365 | 366 | 10. Each time you redistribute the Library (or any work based on the 367 | Library), the recipient automatically receives a license from the 368 | original licensor to copy, distribute, link with or modify the Library 369 | subject to these terms and conditions. You may not impose any further 370 | restrictions on the recipients' exercise of the rights granted herein. 371 | You are not responsible for enforcing compliance by third parties with 372 | this License. 373 | 374 | 11. If, as a consequence of a court judgment or allegation of patent 375 | infringement or for any other reason (not limited to patent issues), 376 | conditions are imposed on you (whether by court order, agreement or 377 | otherwise) that contradict the conditions of this License, they do not 378 | excuse you from the conditions of this License. If you cannot 379 | distribute so as to satisfy simultaneously your obligations under this 380 | License and any other pertinent obligations, then as a consequence you 381 | may not distribute the Library at all. For example, if a patent 382 | license would not permit royalty-free redistribution of the Library by 383 | all those who receive copies directly or indirectly through you, then 384 | the only way you could satisfy both it and this License would be to 385 | refrain entirely from distribution of the Library. 386 | 387 | If any portion of this section is held invalid or unenforceable under any 388 | particular circumstance, the balance of the section is intended to apply, 389 | and the section as a whole is intended to apply in other circumstances. 390 | 391 | It is not the purpose of this section to induce you to infringe any 392 | patents or other property right claims or to contest validity of any 393 | such claims; this section has the sole purpose of protecting the 394 | integrity of the free software distribution system which is 395 | implemented by public license practices. Many people have made 396 | generous contributions to the wide range of software distributed 397 | through that system in reliance on consistent application of that 398 | system; it is up to the author/donor to decide if he or she is willing 399 | to distribute software through any other system and a licensee cannot 400 | impose that choice. 401 | 402 | This section is intended to make thoroughly clear what is believed to 403 | be a consequence of the rest of this License. 404 | 405 | 12. If the distribution and/or use of the Library is restricted in 406 | certain countries either by patents or by copyrighted interfaces, the 407 | original copyright holder who places the Library under this License may add 408 | an explicit geographical distribution limitation excluding those countries, 409 | so that distribution is permitted only in or among countries not thus 410 | excluded. In such case, this License incorporates the limitation as if 411 | written in the body of this License. 412 | 413 | 13. The Free Software Foundation may publish revised and/or new 414 | versions of the Lesser General Public License from time to time. 415 | Such new versions will be similar in spirit to the present version, 416 | but may differ in detail to address new problems or concerns. 417 | 418 | Each version is given a distinguishing version number. If the Library 419 | specifies a version number of this License which applies to it and 420 | "any later version", you have the option of following the terms and 421 | conditions either of that version or of any later version published by 422 | the Free Software Foundation. If the Library does not specify a 423 | license version number, you may choose any version ever published by 424 | the Free Software Foundation. 425 | 426 | 14. If you wish to incorporate parts of the Library into other free 427 | programs whose distribution conditions are incompatible with these, 428 | write to the author to ask for permission. For software which is 429 | copyrighted by the Free Software Foundation, write to the Free 430 | Software Foundation; we sometimes make exceptions for this. Our 431 | decision will be guided by the two goals of preserving the free status 432 | of all derivatives of our free software and of promoting the sharing 433 | and reuse of software generally. 434 | 435 | NO WARRANTY 436 | 437 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 438 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 439 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 440 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 441 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 442 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 443 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 444 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 445 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 446 | 447 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 448 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 449 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 450 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 451 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 452 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 453 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 454 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 455 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 456 | DAMAGES. 457 | 458 | END OF TERMS AND CONDITIONS 459 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HoTT Classes 2 | 3 | This repository used to contain formalizations of algebra based on 4 | [Math Classes](https://math-classes.github.io/) but for 5 | [HoTT](https://github.com/hott/hott). They have been merged in 6 | upstream HoTT ([commit dd7c823](https://github.com/HoTT/HoTT/commit/dd7c8232a59bbfbab1a880688c5895cf616654fb)). 7 | 8 | Here remain results depending on inductive-inductive types, an 9 | experimental feature not yet merged in Coq, mostly about defining 10 | Cauchy real numbers. 11 | 12 | # Related Publications 13 | 14 | See SCIENCE.md 15 | 16 | # Build 17 | 18 | You can follow what travis does ([.travis.yml](.travis.yml), [build-dependencies.sh](build-dependencies.sh) and [build-HoTTClasses.sh](build-HoTTClasses.sh)), or: 19 | 20 | - Install dependencies: 21 | 22 | - [Coq with inductive-inductive types](https://github.com/mattam82/coq/tree/IR) including its depencies (some Ocaml libraries) 23 | - [HoTT modified to compile with Coq IR](https://github.com/SkySkimmer/HoTT/tree/mz-8.7) 24 | 25 | - In this guide they are installed respectively in directories `coq/` and `HoTT/`. 26 | 27 | - `./configure --hoqdir HoTT/ --coqbin coq/bin/` 28 | 29 | - `make` 30 | 31 | # Using IDEs 32 | 33 | ## Coqide 34 | 35 | The `./ide` script only works if HoTT/ is in your `$PATH`, use `/path/to/HoTT/hoqide -R theories HoTTClasses` otherwise. 36 | 37 | ## Proof General 38 | 39 | [Proof General](https://github.com/ProofGeneral/PG/) understands the `_CoqProject` produced by `./configure`. `./configure` also sets up `.dir-locals.el` so that PG calls the right hoqtop program. 40 | -------------------------------------------------------------------------------- /SCIENCE.md: -------------------------------------------------------------------------------- 1 | # CPP 2017: Formalising Real Numbers in Homotopy Type Theory 2 | 3 | Paper: https://dx.doi.org/10.1145/3018610.3018614 4 | 5 | Slides: http://thedragonrider.free.fr/CPP2017slides.pdf 6 | -------------------------------------------------------------------------------- /_CoqProject.in: -------------------------------------------------------------------------------- 1 | # Library name 2 | -R theories HoTTClasses 3 | 4 | # Stuff from configure 5 | 6 | -------------------------------------------------------------------------------- /build-HoTTClasses.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -x 4 | 5 | printf 'travis_fold:start:main\\r' 6 | 7 | ./configure --hoqdir HoTT --coqbin coq/bin || exit 1 8 | make -j "$NJOBS" 9 | 10 | printf 'travis_fold:end:main\\r' 11 | -------------------------------------------------------------------------------- /build-dependencies.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | ############ Caching ############# 4 | # Storing cache is handled by travis 5 | # We need to invalidate the cache ourselves 6 | 7 | # git ls-remote gets us the desired commit hash 8 | 9 | # git rev-parse HEAD gets us the cached one if it exists 10 | 11 | # If we need to rebuild we just rm -rf the directory, that way we 12 | # don't deal with historical artefacts 13 | 14 | function get_latest { 15 | git ls-remote --exit-code "$1" "refs/heads/$2" | awk '{print $1}'; 16 | } 17 | 18 | set -xe 19 | 20 | printf 'travis_fold:start:cache.check\\r' 21 | 22 | #NB: always use SkySkimmer/HoTT because I can have PRs not yet merged 23 | #in HoTT/HoTT and ejgallego/HoTT 24 | COQ_URL="https://github.com/mattam82/coq.git" 25 | COQ_BRANCH="IR" 26 | HOTT_URL="https://github.com/SkySkimmer/HoTT.git" 27 | HOTT_BRANCH="mz-8.7" 28 | 29 | if [ -d coq ]; 30 | then 31 | pushd coq 32 | LATEST_COQ=$(get_latest "$COQ_URL" "$COQ_BRANCH") 33 | CURRENT_COQ=$(git rev-parse HEAD) 34 | popd 35 | if [ "$LATEST_COQ" != "$CURRENT_COQ" ]; 36 | then 37 | # we need to rebuild HoTT if Coq is changed 38 | rm -rf coq HoTT 39 | fi 40 | fi 41 | 42 | if [ -d HoTT ]; 43 | then 44 | pushd HoTT 45 | LATEST_HOTT=$(get_latest "$HOTT_URL" "$HOTT_BRANCH") 46 | CURRENT_HOTT=$(git rev-parse HEAD) 47 | popd 48 | if [ "$LATEST_HOTT" != "$CURRENT_HOTT" ]; 49 | then rm -rf HoTT 50 | fi 51 | fi 52 | 53 | printf 'travis_fold:end:cache.check\\r' 54 | 55 | if ! [ -d coq ] 56 | then 57 | echo 'Building Coq...' 58 | printf 'travis_fold:start:coq.build\\r' 59 | 60 | git clone --depth 1 -b "$COQ_BRANCH" -- "$COQ_URL" coq 61 | pushd coq 62 | ./configure -local || exit 1 63 | make -j "$NJOBS" tools coqbinaries pluginsopt states || exit 1 64 | popd 65 | 66 | printf 'travis_fold:end:coq.build\\r' 67 | else 68 | echo "Using cached Coq." 69 | fi 70 | 71 | if [ ! "(" -d HoTT ")" ]; 72 | then 73 | echo 'Building HoTT...' 74 | printf 'travis_fold:start:HoTT.build\\r' 75 | 76 | git clone --depth 1 -b "$HOTT_BRANCH" -- "$HOTT_URL" HoTT 77 | pushd HoTT 78 | 79 | # don't let autogen clone some other Coq 80 | mv .git .git-backup 81 | ./autogen.sh 82 | mv .git-backup .git 83 | 84 | ./configure COQBIN="$(pwd)/../coq/bin/" || exit 1 85 | make -j "$NJOBS" || exit 1 86 | popd 87 | 88 | printf 'travis_fold:end:HoTT.build\\r' 89 | else 90 | echo "Using cached HoTT." 91 | fi 92 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | CALLNAME="$0" 4 | OPTFILE="_CoqProject" 5 | 6 | function usage { 7 | >&2 echo "usage: $CALLNAME [options]" 8 | >&2 echo 9 | >&2 echo "options are:" 10 | 11 | >&2 printf '\t--hoqdir \tdirectory containing hoqc, hoqtop and hoqdep' 12 | >&2 printf '\t\t\t(can be passed through environment variable HOQDIR)' 13 | 14 | >&2 printf '\t--coqbin \tdirectory containing coq_makefile' 15 | >&2 printf '\t\t\t(can be passed through environment variable COQBIN)' 16 | 17 | >&2 printf '\t--no-emacs\tdo not generate .dir-locals.el' 18 | 19 | >&2 printf '\t-h\t\tdisplay this list of options and quit' 20 | >&2 printf '\t-help\t\tdisplay this list of options and quit' 21 | >&2 printf '\t--help\t\tdisplay this list of options and quit' 22 | } 23 | 24 | DO_EMACS=true 25 | 26 | while [[ "$#" -gt 0 ]] 27 | do 28 | case "$1" in 29 | "--hoqdir") 30 | if [[ "$#" = 1 ]] 31 | then 32 | >&2 echo "$CALLNAME: option '--hoqdir' needs one argument" 33 | usage 34 | exit 1 35 | fi 36 | HOQDIR="$2" 37 | shift;; 38 | "--coqbin") 39 | if [[ "$#" = 1 ]] 40 | then 41 | >&2 echo "$CALLNAME: option '--coqbin' needs one argument" 42 | usage 43 | exit 1 44 | fi 45 | COQBIN="$2" 46 | shift;; 47 | "--no-emacs") 48 | DO_EMACS=false;; 49 | "-h"|"-help"|"--help") 50 | usage 51 | exit 0;; 52 | *) 53 | >&2 echo "$CALLNAME: unknown argument $1" 54 | usage 55 | exit 1;; 56 | esac 57 | shift 58 | done 59 | 60 | if [ -z "${HOQDIR}" ] 61 | then 62 | OK=true 63 | HOQC=$(command -v hoqc) || OK=false 64 | HOQTOP=$(command -v hoqtop) || OK=false 65 | HOQDEP=$(command -v hoqdep) || OK=false 66 | if $OK 67 | then 68 | : 69 | else 70 | >&2 echo "$CALLNAME: hoqc, hoqtop or hoqdep not in PATH, use option --hoqdir" 71 | usage 72 | exit 1 73 | fi 74 | else 75 | #readlink -nm: canonicalize (strip double slash and . .. and 76 | #symlinks) without checking existence 77 | HOQC=$(readlink -nm "$HOQDIR/hoqc") 78 | HOQTOP=$(readlink -nm "$HOQDIR/hoqtop") 79 | HOQDEP=$(readlink -nm "$HOQDIR/hoqdep") 80 | 81 | fi 82 | 83 | if [ -z "${COQBIN}" ] 84 | then 85 | OK=true 86 | COQMAKEFILE=$(command -v coq_makefile) || OK=false 87 | if $OK 88 | then 89 | : 90 | else 91 | >&2 echo "$CALLNAME: coq_makefile not in PATH, use option --coqbin" 92 | usage 93 | exit 1 94 | fi 95 | else 96 | COQMAKEFILE=$(readlink -nm "$COQBIN/coq_makefile") 97 | if [ -x "$COQMAKEFILE" ] && [ -f "$COQMAKEFILE" ] 98 | then 99 | : 100 | else 101 | >&2 echo "$CALLNAME: $COQMAKEFILE is not executable" 102 | usage 103 | exit 1 104 | fi 105 | fi 106 | 107 | echo "Summary:" 108 | echo "Generate .dir-locals.el: $DO_EMACS" 109 | echo "HOQC=$HOQC" 110 | echo "HOQTOP=$HOQTOP" 111 | echo "HOQDEP=$HOQDEP" 112 | echo "COQMAKEFILE=$COQMAKEFILE" 113 | 114 | ########### Work 115 | 116 | cp "$OPTFILE.in" "$OPTFILE" 117 | 118 | echo "COQC = $HOQC" >> "$OPTFILE" 119 | echo "COQDEP = $HOQDEP" >> "$OPTFILE" 120 | 121 | #non IR find 122 | #HoTTBook and CPP depend on IR 123 | find ./theories -name '*.v' -print >> "$OPTFILE" 124 | 125 | "$COQMAKEFILE" -f "$OPTFILE" -o Makefile || exit 1 126 | 127 | if $DO_EMACS 128 | then echo "((coq-mode . ((coq-prog-name . \"$HOQTOP\"))))" > .dir-locals.el 129 | fi 130 | 131 | echo "$0 success!" 132 | -------------------------------------------------------------------------------- /ide: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | hoqide -R theories HoTTClasses "$@" 4 | 5 | -------------------------------------------------------------------------------- /theories/CPP2017.v: -------------------------------------------------------------------------------- 1 | (** 2 | "Formalising Real Numbers in Homotopy Type Theory" 3 | Gaëtan Gilbert, submitted to CPP 2017. 4 | 5 | This file links the results of the paper with their formalizations 6 | in the HoTT.Classes library. You can lookup definitions and theorems by their 7 | number in the paper. 8 | 9 | This is specifically for the arXiv version at https://arxiv.org/abs/1610.05072 10 | Other versions may have different sections and theorems. *) 11 | 12 | Require Import 13 | HoTT.Classes.interfaces.abstract_algebra 14 | HoTT.Classes.interfaces.orders 15 | HoTTClasses.cauchy_reals 16 | HoTTClasses.dedekind 17 | HoTTClasses.cauchy_semidec. 18 | 19 | (* END OF PREAMBLE *) 20 | (* ================================================== def:premetric *) 21 | (** Definition 2.1 *) 22 | 23 | Definition Def_2_1 := @HoTT.Classes.theory.premetric.PreMetric. 24 | 25 | 26 | (* ================================================== def:approximation *) 27 | (** Definition 2.3 *) 28 | 29 | Definition Def_2_3 := @HoTT.Classes.theory.premetric.Approximation. 30 | 31 | 32 | (* ================================================== def:islimit *) 33 | (** Definition 2.4 *) 34 | 35 | Definition Def_2_4 := @HoTT.Classes.theory.premetric.IsLimit. 36 | 37 | (* ================================================== lem:limit-unique *) 38 | (** Lemma 2.5 *) 39 | 40 | Definition Lem_2_5 := @HoTT.Classes.theory.premetric.limit_unique. 41 | 42 | (* ================================================== def:cauchycomplete *) 43 | (** Definition 2.6 *) 44 | 45 | Definition Def_2_6 := @HoTT.Classes.theory.premetric.CauchyComplete. 46 | 47 | (* ================================================== thm:q-premetric *) 48 | (** Theorem 2.7 *) 49 | 50 | Definition Thm_2_7 := @HoTT.Classes.theory.premetric.Q_premetric. 51 | 52 | (* ================================================== lem:equiv-through-approx *) 53 | (** Lemma 2.8 *) 54 | 55 | Definition Lem_2_8 := @HoTT.Classes.theory.premetric.equiv_through_approx. 56 | 57 | (* ================================================== lem:equiv-lim-lim *) 58 | (** Lemma 2.9 *) 59 | 60 | Definition Lem_2_9 := @HoTT.Classes.theory.premetric.equiv_lim_lim. 61 | 62 | (* ================================================== lem:lim-same-distance *) 63 | (** Lemma 2.10 *) 64 | 65 | Definition Lem_2_10 := @HoTT.Classes.theory.premetric.lim_same_distance. 66 | 67 | (* ================================================== def:lipschitz *) 68 | (** Definition 2.11 *) 69 | 70 | Definition Def_2_11 := @HoTT.Classes.theory.premetric.Lipschitz. 71 | 72 | (* ================================================== def:continuous *) 73 | (** Definition 2.12 *) 74 | 75 | Definition Def_2_12 := @HoTT.Classes.theory.premetric.Continuous. 76 | 77 | (* ================================================== lem:lipschitz-continuous *) 78 | (** Lemma 2.13 *) 79 | 80 | Definition Lem_2_13 := @HoTT.Classes.theory.premetric.lipschitz_continuous. 81 | 82 | (* ================================================== def:close-arrow *) 83 | (** Definition 2.14 *) 84 | 85 | Definition Def_2_14 := @HoTT.Classes.theory.premetric.close_arrow. 86 | 87 | (* ================================================== lem:close-arrow-apply *) 88 | (** Lemma 2.15 *) 89 | 90 | Definition Lem_2_15 := @HoTT.Classes.theory.premetric.close_arrow_apply. 91 | 92 | (* ================================================== thm:arrow-cauchy-complete *) 93 | (** Theorem 2.16 *) 94 | 95 | Definition Thm_2_16 := @HoTT.Classes.theory.premetric.arrow_cauchy_complete. 96 | 97 | (* ================================================== lem:lipschitz-lim-lipschitz *) 98 | (** Lemma 2.17 *) 99 | 100 | Definition Lem_2_17 := @HoTT.Classes.theory.premetric.lipschitz_lim_lipschitz. 101 | 102 | (* ================================================== def:cauchy-completion *) 103 | (** Definition 3.1 *) 104 | 105 | Definition Def_3_1 := @HoTTClasses.cauchy_completion.Cauchy.C. 106 | 107 | (* ================================================== def:c-ind0 *) 108 | (** Definition 3.2 *) 109 | 110 | Definition Def_3_2 := @HoTTClasses.cauchy_completion.C_ind0. 111 | 112 | (* ================================================== def:equiv-rec0 *) 113 | (** Definition 3.3 *) 114 | 115 | Definition Def_3_3 := @HoTTClasses.cauchy_completion.equiv_rec0. 116 | 117 | (* ================================================== def:c-rec *) 118 | (** Definition 3.4 *) 119 | 120 | Definition Def_3_4 := @HoTTClasses.cauchy_completion.C_rec. 121 | 122 | (* ================================================== lem:equiv-refl *) 123 | (** Lemma 3.5 *) 124 | 125 | Definition Lem_3_5 := @HoTTClasses.cauchy_completion.equiv_refl. 126 | 127 | (* ================================================== lem:c-isset *) 128 | (** Lemma 3.6 *) 129 | 130 | Definition Lem_3_6 := @HoTTClasses.cauchy_completion.C_isset. 131 | 132 | (* ================================================== lem:equiv-symm *) 133 | (** Lemma 3.7 *) 134 | 135 | Definition Lem_3_7 := @HoTTClasses.cauchy_completion.equiv_symm. 136 | 137 | (* ================================================== def:balls *) 138 | (** Definition 3.8 *) 139 | 140 | Definition Def_3_8 := @HoTTClasses.cauchy_completion.balls. 141 | 142 | (* ================================================== def:upper-cut *) 143 | (** Definition 3.9 *) 144 | 145 | Definition Def_3_9 := @HoTTClasses.cauchy_completion.upper_cut. 146 | 147 | (* ================================================== lem:balls-separated *) 148 | (** Lemma 3.10 *) 149 | 150 | Definition Lem_3_10 := @HoTTClasses.cauchy_completion.balls_separated. 151 | 152 | (* ================================================== lem:upper-separated *) 153 | (** Lemma 3.11 *) 154 | 155 | Definition Lem_3_11 := @HoTTClasses.cauchy_completion.upper_cut_separated. 156 | 157 | (* ================================================== lem:upper-cut-to-balls *) 158 | (** Lemma 3.12 *) 159 | 160 | Definition Lem_3_12 := @HoTTClasses.cauchy_completion.upper_cut_to_balls. 161 | 162 | (* ================================================== def:equiv-alt-eta *) 163 | (** Definition 3.13 *) 164 | 165 | Definition Def_3_13 := @HoTTClasses.cauchy_completion.equiv_alt_eta. 166 | 167 | (* ================================================== thm:equiv-alt *) 168 | (** Theorem 3.14 *) 169 | 170 | Definition Thm_3_14_def := @HoTTClasses.cauchy_completion.equiv_alt. 171 | Definition Thm_3_14_eta_eta := @HoTTClasses.cauchy_completion.equiv_alt_eta_eta. 172 | Definition Thm_3_14_eta_lim := @HoTTClasses.cauchy_completion.equiv_alt_eta_lim. 173 | Definition Thm_3_14_lim_eta := @HoTTClasses.cauchy_completion.equiv_alt_lim_eta. 174 | Definition Thm_3_14_lim_lim := @HoTTClasses.cauchy_completion.equiv_alt_lim_lim. 175 | 176 | (* ================================================== thm:equiv-alt-equiv *) 177 | (** Theorem 3.15 *) 178 | 179 | Definition Thm_3_15 := @HoTTClasses.cauchy_completion.equiv_alt_rw. 180 | 181 | (* ================================================== thm:c-premetric *) 182 | (** Theorem 3.16 *) 183 | 184 | Definition Thm_3_16 := @HoTTClasses.cauchy_completion.C_premetric. 185 | 186 | (* ================================================== lem:eta-injective *) 187 | (** Lemma 3.17 *) 188 | 189 | Definition Lem_3_17 := @HoTTClasses.cauchy_completion.eta_injective. 190 | 191 | (* ================================================== thm:equiv-lim *) 192 | (** Theorem 3.18 *) 193 | 194 | Definition Thm_3_18 := @HoTTClasses.cauchy_completion.equiv_lim. 195 | 196 | (* ================================================== thm:unique-continuous-extension *) 197 | (** Theorem 3.19 *) 198 | 199 | Definition Thm_3_19 := @HoTTClasses.cauchy_completion.unique_continuous_extension. 200 | 201 | (* ================================================== thm:lipschitz-extend *) 202 | (** Theorem 3.20 *) 203 | 204 | Definition Thm_3_20 := @HoTTClasses.cauchy_completion.lipschitz_extend. 205 | 206 | (* ================================================== thm:c-of-complete *) 207 | (** Theorem 3.21 *) 208 | 209 | Definition Thm_3_21 := @HoTTClasses.cauchy_completion.C_of_complete. 210 | 211 | (* ================================================== thm:c-idempotent-monad *) 212 | (** Theorem 3.22 *) 213 | 214 | (* implied by Lipschitz extension and its computation rules *) 215 | 216 | (* ================================================== lem:lipschitz-extend-same-distance *) 217 | (** Lemma 3.24 *) 218 | 219 | Definition Lem_3_24 := @HoTTClasses.cauchy_completion.lipschitz_extend_same_distance. 220 | 221 | (* ================================================== thm:lipschitz-extend-binary *) 222 | (** Theorem 3.25 *) 223 | 224 | Definition Thm_3_25 := @HoTTClasses.cauchy_completion.lipschitz_extend_binary. 225 | 226 | (* ================================================== lem:r-lt-exists-pos-plus-le *) 227 | (** Lemma 4.1 *) 228 | 229 | Definition Lem_4_1 := @HoTTClasses.cauchy_reals.full_order.Rlt_exists_pos_plus_le. 230 | 231 | (* ================================================== lem:r-le-close *) 232 | (** Lemma 4.2 *) 233 | 234 | Definition Lem_4_2 := @HoTTClasses.cauchy_reals.full_order.Rle_close. 235 | 236 | (* ================================================== lem:r-lt-close-plus *) 237 | (** Lemma 4.3 *) 238 | 239 | Definition Lem_4_3 := @HoTTClasses.cauchy_reals.order.Rlt_close_plus. 240 | 241 | (* ================================================== lem:r-lt-cotrans *) 242 | (** Lemma 4.4 *) 243 | 244 | Definition Lem_4_4 := @HoTTClasses.cauchy_reals.order.Rlt_cotrans. 245 | 246 | (* ================================================== lem:r-lt-plus-pos *) 247 | (** Lemma 4.5 *) 248 | 249 | Definition Lem_4_5 := @HoTTClasses.cauchy_reals.full_order.Rlt_plus_pos. 250 | 251 | (* ================================================== lem:from-below-pr *) 252 | (** Lemma 4.6 *) 253 | 254 | Definition Lem_4_6 := @HoTTClasses.cauchy_reals.full_order.from_below_pr. 255 | 256 | (* ================================================== lem:lipschitz-approx-lim *) 257 | (** Lemma 4.7 *) 258 | 259 | Definition Lem_4_7 := @HoTTClasses.cauchy_reals.full_order.lipschitz_approx_lim. 260 | 261 | (* ================================================== lem:r-not-lt-le-flip *) 262 | (** Lemma 4.8 *) 263 | 264 | Definition Lem_4_8 := @HoTTClasses.cauchy_reals.full_order.R_not_lt_le_flip. 265 | 266 | (* ================================================== def:def-by-surjection *) 267 | (** Definition 4.9 *) 268 | 269 | Definition Def_4_9 := @HoTT.HIT.surjective_factor.surjective_factor. 270 | Definition Def_4_9_pr := @HoTT.HIT.surjective_factor.surjective_factor_pr. 271 | 272 | (* ================================================== def:interval *) 273 | (** Definition 4.10 *) 274 | 275 | Definition Def_4_10 := @HoTT.Classes.theory.premetric.Interval. 276 | 277 | (* ================================================== def:qrmult *) 278 | (** Definition 4.11 *) 279 | 280 | Definition Def_4_11 := @HoTTClasses.cauchy_reals.ring.QRmult. 281 | 282 | (* ================================================== def:r-bounded-mult *) 283 | (** Definition 4.12 *) 284 | 285 | Definition Def_4_12 := @HoTTClasses.cauchy_reals.ring.Rbounded_mult. 286 | 287 | (* ================================================== lem:r-qpos-bounded *) 288 | (** Lemma 4.13 *) 289 | 290 | Definition Lem_4_13 := @HoTTClasses.cauchy_reals.ring.R_Qpos_bounded. 291 | 292 | (* ================================================== lem:interval-back *) 293 | (** Lemma 4.14 *) 294 | 295 | Definition Lem_4_14 := @HoTTClasses.cauchy_reals.ring.interval_back. 296 | 297 | (* ================================================== def:r-mult *) 298 | (** Definition 4.15 *) 299 | 300 | Definition Def_4_15 := @HoTTClasses.cauchy_reals.ring.Rmult. 301 | 302 | (* ================================================== lem:r-mult-interval-proj-applied *) 303 | (** Lemma 4.16 *) 304 | 305 | Definition Lem_4_16 := @HoTTClasses.cauchy_reals.ring.Rmult_interval_proj_applied. 306 | 307 | (* ================================================== lem:r-mult-rat-rat *) 308 | (** Lemma 4.17 *) 309 | 310 | Definition Lem_4_17 := @HoTTClasses.cauchy_reals.ring.Rmult_rat_rat. 311 | 312 | (* ================================================== lem:r-mult-lipschitz-aux-alt *) 313 | (** Lemma 4.18 *) 314 | 315 | Definition Lem_4_18 := @HoTTClasses.cauchy_reals.ring.Rmult_lipschitz_aux_alt. 316 | 317 | (* ================================================== lem:r-mult-continuous-r *) 318 | (** Lemma 4.19 *) 319 | 320 | Definition Lem_4_19 := @HoTTClasses.cauchy_reals.ring.Rmult_continuous_r. 321 | 322 | (* ================================================== lem:r-mult-rat-l *) 323 | (** Lemma 4.20 *) 324 | 325 | Definition Lem_4_20 := @HoTTClasses.cauchy_reals.ring.Rmult_rat_l. 326 | 327 | (* ================================================== lem:r-mult-abs-l *) 328 | (** Lemma 4.21 *) 329 | 330 | Definition Lem_4_21 := @HoTTClasses.cauchy_reals.ring.Rmult_abs_l. 331 | 332 | (* ================================================== lem:r-mult-le-compat-abs *) 333 | (** Lemma 4.22 *) 334 | 335 | Definition Lem_4_22 := @HoTTClasses.cauchy_reals.ring.Rmult_le_compat_abs. 336 | 337 | (* ================================================== thm:r-mult-continuous *) 338 | (** Theorem 4.23 *) 339 | 340 | Definition Thm_4_23 := @HoTTClasses.cauchy_reals.ring.Rmult_continuous. 341 | 342 | (* ================================================== lem:r-mult-pos *) 343 | (** Lemma 4.24 *) 344 | 345 | Definition Lem_4_24 := @HoTTClasses.cauchy_reals.full_ring.real_full_pseudo_srorder. 346 | 347 | (* ================================================== lem:r-mult-pos-decompose-nonneg *) 348 | (** Lemma 4.25 *) 349 | 350 | Definition Lem_4_25 := @HoTTClasses.cauchy_reals.full_ring.Rmult_pos_decompose_nonneg. 351 | 352 | (* ================================================== def:bounded-inverse *) 353 | (** Definition 4.26 *) 354 | 355 | Definition Def_4_26 := @HoTTClasses.cauchy_reals.recip.Qpos_upper_recip. 356 | 357 | (* ================================================== def:r-recip *) 358 | (** Definition 4.27 *) 359 | 360 | Definition Def_4_27 := @HoTTClasses.cauchy_reals.recip.Rrecip. 361 | 362 | (* ================================================== lem:r-recip-rat *) 363 | (** Lemma 4.28 *) 364 | 365 | Definition Lem_4_28 := @HoTTClasses.cauchy_reals.recip.Rrecip_rat. 366 | 367 | (* ================================================== lem:r-recip-upper-recip *) 368 | (** Lemma 4.29 *) 369 | 370 | Definition Lem_4_29 := @HoTTClasses.cauchy_reals.recip.R_recip_upper_recip. 371 | 372 | (* ================================================== lem:r-recip-inverse *) 373 | (** Lemma 4.30 *) 374 | 375 | Definition Lem_4_30 := @HoTTClasses.cauchy_reals.recip.R_recip_inverse. 376 | 377 | (* ================================================== def:increasing-sequence *) 378 | (** Definition 5.1 *) 379 | 380 | Definition Def_5_1 := @HoTTClasses.partiality.IncreasingSequence. 381 | 382 | (* ================================================== def:partial *) 383 | (** Definition 5.2 *) 384 | 385 | Definition Def_5_2 := @HoTTClasses.partiality.Partial.partial. 386 | 387 | (* ================================================== def:sier-top *) 388 | (** Definition 5.3 *) 389 | 390 | Definition Def_5_3 := @HoTTClasses.sierpinsky.SierTop. 391 | 392 | (* ================================================== lem:sier-le-imply *) 393 | (** Lemma 5.4 *) 394 | 395 | Definition Lem_5_4 := @HoTTClasses.sierpinsky.SierLe_imply. 396 | 397 | (* ================================================== def:sier-join *) 398 | (** Definition 5.5 *) 399 | 400 | Definition Def_5_5 := @HoTTClasses.sierpinsky.SierJoin. 401 | 402 | (* ================================================== lem:sier-join-semilattice *) 403 | (** Lemma 5.6 *) 404 | 405 | Definition Lem_5_6 := @HoTTClasses.sierpinsky.SierJoin_is_join. 406 | 407 | (* ================================================== lem:sier-join-disj *) 408 | (** Lemma 5.7 *) 409 | 410 | Definition Lem_5_7 := @HoTTClasses.sierpinsky.top_le_join. 411 | 412 | (* ================================================== def:sier-countable-join *) 413 | (** Definition 5.8 *) 414 | 415 | Definition Def_5_8 := @HoTTClasses.sierpinsky.CountableSup. 416 | 417 | (* ================================================== def:disjoint *) 418 | (** Definition 5.9 *) 419 | 420 | Definition Def_5_9 := @HoTTClasses.sierpinsky.disjoint. 421 | 422 | (* ================================================== def:interleave *) 423 | (** Definition 5.10 *) 424 | 425 | Definition Def_5_10 := @HoTTClasses.sierpinsky.interleave. 426 | 427 | (* ================================================== lem:interleave-top-r *) 428 | (** Lemma 5.11 *) 429 | 430 | Definition Lem_5_11 := @HoTTClasses.sierpinsky.interleave_top_r. 431 | 432 | (* ================================================== lem:interleave-pr *) 433 | (** Lemma 5.12 *) 434 | 435 | Definition Lem_5_12 := @HoTTClasses.sierpinsky.interleave_pr. 436 | 437 | (* ================================================== lem:semidecidable-compare-rat *) 438 | (** Lemma 5.13 *) 439 | 440 | Definition Lem_5_13 := @HoTTClasses.cauchy_semidec.semidecidable_compare_rat_sig. 441 | 442 | (* ================================================== def:is-positive *) 443 | (** Definition 5.14 *) 444 | 445 | Definition Def_5_14 := @HoTTClasses.cauchy_semidec.compare_cauchy_rat. 446 | 447 | (* ================================================== thm:is-positive-ok *) 448 | (** Theorem 5.15 *) 449 | 450 | Definition Thm_5_15 := @HoTTClasses.cauchy_semidec.compare_cauchy_rat_pr. 451 | -------------------------------------------------------------------------------- /theories/HoTTBook.v: -------------------------------------------------------------------------------- 1 | (** The HoTT Book formalization, cauchy reals section. *) 2 | 3 | Require Import 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.orders 6 | HoTTClasses.cauchy_reals 7 | HoTTClasses.dedekind 8 | HoTTClasses.cauchy_dedekind. 9 | 10 | (* END OF PREAMBLE *) 11 | (* ================================================== lem:opp *) 12 | (** Lemma 2.1.1 *) 13 | 14 | Definition Book_2_1_1 := @HoTT.Basics.Overture.inverse. 15 | 16 | (* ================================================== lem:concat *) 17 | (** Lemma 2.1.2 *) 18 | 19 | Definition Book_2_1_2 := @HoTT.Basics.Overture.transitive_paths. 20 | 21 | (* ================================================== thm:omg *) 22 | (** Lemma 2.1.4 *) 23 | 24 | Definition Book_2_1_4_item_i := @HoTT.Basics.PathGroupoids.concat_p1. 25 | Definition Book_2_1_4_item_i' := @HoTT.Basics.PathGroupoids.concat_1p. 26 | Definition Book_2_1_4_item_ii := @HoTT.Basics.PathGroupoids.concat_Vp. 27 | Definition Book_2_1_4_item_ii' := @HoTT.Basics.PathGroupoids.concat_pV. 28 | Definition Book_2_1_4_item_iii := @HoTT.Basics.PathGroupoids.inv_V. 29 | Definition Book_2_1_4_item_iv := @HoTT.Basics.PathGroupoids.concat_p_pp. 30 | 31 | (* ================================================== defn:dedekind-reals *) 32 | (** Definition 11.2.1 *) 33 | 34 | Definition Book_11_2_1 := @HoTTClasses.dedekind.Cut. 35 | 36 | (* ================================================== dedekind-in-cut-as-le *) 37 | (** Lemma 11.2.2 *) 38 | 39 | Definition Book_11_2_2_item_i := @HoTTClasses.dedekind.cut_lt_lower. 40 | Definition Book_11_2_2_item_ii := @HoTTClasses.dedekind.cut_lt_upper. 41 | 42 | (* ================================================== RD-inverse-apart-0 *) 43 | (** Theorem 11.2.4 *) 44 | 45 | 46 | 47 | (* ================================================== RD-archimedean *) 48 | (** Theorem 11.2.6 *) 49 | 50 | Definition Book_11_2_6 := @HoTTClasses.dedekind.Cut_archimedean. 51 | 52 | (* ================================================== ordered-field *) 53 | (** Definition 11.2.7 *) 54 | 55 | Definition Book_11_2_7 := @HoTT.Classes.interfaces.abstract_algebra.Field. 56 | Definition Book_11_2_7' := @HoTT.Classes.interfaces.orders.FullPseudoSemiRingOrder. 57 | 58 | (* ================================================== RD-archimedean-ordered-field *) 59 | (** Theorem 11.2.8 *) 60 | 61 | 62 | 63 | (* ================================================== defn:cauchy-approximation *) 64 | (** Definition 11.2.10 *) 65 | 66 | Definition Book_11_2_10 := @HoTT.Classes.theory.premetric.Approximation. 67 | 68 | (* ================================================== RD-cauchy-complete *) 69 | (** Theorem 11.2.12 *) 70 | 71 | Definition Book_11_2_12 := @HoTTClasses.dedekind.Cut_cauchy_complete. 72 | 73 | 74 | (* ================================================== RD-final-field *) 75 | (** Theorem 11.2.14 *) 76 | 77 | 78 | 79 | (* ================================================== lem:cuts-preserve-admissibility *) 80 | (** Lemma 11.2.15 *) 81 | 82 | 83 | 84 | (* ================================================== RD-dedekind-complete *) 85 | (** Corollary 11.2.16 *) 86 | 87 | 88 | 89 | (* ================================================== defn:cauchy-reals *) 90 | (** Definition 11.3.2 *) 91 | 92 | Definition Book_11_3_2 := @HoTTClasses.cauchy_completion.Cauchy.C. 93 | 94 | (* ================================================== thm:Cauchy-reals-are-a-set *) 95 | (** Theorem 11.3.9 *) 96 | 97 | Definition Book_11_3_9 := @HoTTClasses.cauchy_completion.C_isset. 98 | 99 | (* ================================================== RC-lim-onto *) 100 | (** Lemma 11.3.10 *) 101 | 102 | Definition Book_11_3_10 := @HoTTClasses.cauchy_completion.lim_issurj. 103 | 104 | (* ================================================== RC-lim-factor *) 105 | (** Lemma 11.3.11 *) 106 | 107 | 108 | 109 | (* ================================================== thm:RCsim-symmetric *) 110 | (** Lemma 11.3.12 *) 111 | 112 | Definition Book_11_3_12 := @HoTTClasses.cauchy_completion.equiv_symm. 113 | 114 | (* ================================================== defn:lipschitz *) 115 | (** Definition 11.3.14 *) 116 | 117 | Definition Book_11_3_14 := @HoTT.Classes.theory.premetric.Lipschitz. 118 | 119 | (* ================================================== RC-extend-Q-Lipschitz *) 120 | (** Lemma 11.3.15 *) 121 | 122 | Definition Book_11_3_15 := @HoTTClasses.cauchy_completion.lipschitz_extend. 123 | 124 | (* ================================================== defn:RC-approx *) 125 | (** Theorem 11.3.16 *) 126 | 127 | Definition Book_11_3_16 := @HoTTClasses.cauchy_completion.equiv_alt. 128 | 129 | (* ================================================== thm:RC-sim-characterization *) 130 | (** Theorem 11.3.32 *) 131 | 132 | Definition Book_11_3_32 := @HoTTClasses.cauchy_completion.equiv_alt_rw. 133 | 134 | (* ================================================== thm:RC-sim-lim *) 135 | (** Lemma 11.3.36 *) 136 | 137 | Definition Book_11_3_36 := @HoTTClasses.cauchy_completion.C_equiv_through_approx. 138 | 139 | (* ================================================== thm:RC-sim-lim-term *) 140 | (** Lemma 11.3.37 *) 141 | 142 | Definition Book_11_3_37 := @HoTTClasses.cauchy_completion.equiv_lim. 143 | 144 | (* ================================================== RC-continuous-eq *) 145 | (** Lemma 11.3.39 *) 146 | 147 | Definition Book_11_3_39 := @HoTTClasses.cauchy_completion.unique_continuous_extension. 148 | 149 | (* ================================================== RC-binary-nonexpanding-extension *) 150 | (** Lemma 11.3.40 *) 151 | 152 | Definition Book_11_3_40 := @HoTTClasses.cauchy_completion.lipschitz_extend_binary. 153 | 154 | (* ================================================== RC-archimedean *) 155 | (** Theorem 11.3.41 *) 156 | 157 | Definition Book_11_3_41 := @HoTTClasses.cauchy_reals.base.R_archimedean. 158 | 159 | (* ================================================== thm:RC-le-grow *) 160 | (** Lemma 11.3.42 *) 161 | 162 | Definition Book_11_3_42 := @HoTTClasses.cauchy_reals.order.Rle_close_rat. 163 | 164 | (* ================================================== thm:RC-lt-open *) 165 | (** Lemma 11.3.43 *) 166 | 167 | Definition Book_11_3_43_item_i := @HoTTClasses.cauchy_reals.order.Rlt_close_rat_plus. 168 | 169 | (* ================================================== RC-sim-eqv-le *) 170 | (** Theorem 11.3.44 *) 171 | 172 | Definition Book_11_3_44 := @HoTTClasses.cauchy_reals.metric.equiv_metric_applied_rw. 173 | 174 | (* ================================================== RC-squaring *) 175 | (** Theorem 11.3.46 *) 176 | 177 | 178 | 179 | (* ================================================== RC-archimedean-ordered-field *) 180 | (** Theorem 11.3.48 *) 181 | 182 | Definition Book_11_3_48_item_i := @HoTTClasses.cauchy_reals.base.R_archimedean. 183 | Definition Book_11_3_48_item_ii := @HoTTClasses.cauchy_reals.full_ring.real_full_pseudo_srorder. 184 | Definition Book_11_3_48_item_iii := @HoTTClasses.cauchy_reals.field.real_field. 185 | 186 | (* ================================================== RC-initial-Cauchy-complete *) 187 | (** Theorem 11.3.50 *) 188 | 189 | Definition Book_11_3_50 := @HoTTClasses.cauchy_reals.initial.real_embed. 190 | 191 | (* ================================================== lem:untruncated-linearity-reals-coincide *) 192 | (** Lemma 11.4.1 *) 193 | 194 | 195 | 196 | (* ================================================== when-reals-coincide *) 197 | (** Corollary 11.4.3 *) 198 | 199 | 200 | 201 | (* ================================================== defn:metric-space *) 202 | (** Definition 11.5.1 *) 203 | 204 | 205 | 206 | (* ================================================== defn:complete-metric-space *) 207 | (** Definition 11.5.2 *) 208 | 209 | 210 | 211 | (* ================================================== defn:total-bounded-metric-space *) 212 | (** Definition 11.5.3 *) 213 | 214 | 215 | 216 | (* ================================================== defn:uniformly-continuous *) 217 | (** Definition 11.5.5 *) 218 | 219 | 220 | 221 | (* ================================================== analysis-interval-ctb *) 222 | (** Theorem 11.5.6 *) 223 | 224 | 225 | 226 | (* ================================================== ctb-uniformly-continuous-sup *) 227 | (** Theorem 11.5.7 *) 228 | 229 | 230 | 231 | (* ================================================== analysis-bw-lpo *) 232 | (** Theorem 11.5.9 *) 233 | 234 | 235 | 236 | (* ================================================== classical-Heine-Borel *) 237 | (** Theorem 11.5.11 *) 238 | 239 | 240 | 241 | (* ================================================== defn:inductive-cover *) 242 | (** Definition 11.5.13 *) 243 | 244 | 245 | 246 | (* ================================================== reals-formal-topology-locally-compact *) 247 | (** Lemma 11.5.14 *) 248 | 249 | 250 | 251 | (* ================================================== interval-Heine-Borel *) 252 | (** Corollary 11.5.15 *) 253 | 254 | 255 | 256 | (* ================================================== inductive-cover-classical *) 257 | (** Theorem 11.5.16 *) 258 | 259 | 260 | -------------------------------------------------------------------------------- /theories/cauchy_dedekind.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion 20 | HoTTClasses.partiality 21 | HoTTClasses.sierpinsky 22 | HoTTClasses.cauchy_reals 23 | HoTTClasses.dedekind. 24 | 25 | Section cut_of_cauchy. 26 | 27 | Definition cut_of_cauchy : Cast real Cut 28 | := lipschitz_extend Q (cast Q Cut) 1. 29 | 30 | Definition cut_of_cauchy_rat : forall q : Q, cut_of_cauchy (rat q) = ' q 31 | := fun _ => idpath. 32 | 33 | Global Instance cut_of_cauchy_nonexpanding : NonExpanding cut_of_cauchy 34 | := lipschitz_nonexpanding _. 35 | 36 | Lemma cut_of_cauchy_upper_pr : forall a q, upper (cut_of_cauchy a) q <-> a < rat q. 37 | Proof. 38 | apply (C_ind0 Q (fun a => forall q, upper (cut_of_cauchy a) q <-> a < rat q)). 39 | - intros q r;split. 40 | + intros E. 41 | apply rat_lt_preserving,semi_decidable. trivial. 42 | + intros E;apply rat_lt_reflecting,semi_decidable in E; 43 | trivial. 44 | - intros x IHx q;split. 45 | + intros E. unfold cut_of_cauchy in E. 46 | rewrite lipschitz_extend_lim in E. 47 | simpl in E. apply lim_upper_cut_pr in E. 48 | simpl in E. revert E;apply (Trunc_ind _);intros [e [d E]]. 49 | rewrite Qpos_recip_1,Qpos_mult_1_r in E. 50 | apply IHx in E. 51 | apply (fun E => Rlt_close_rat_plus _ _ E _ _ (equiv_lim _ _ d _)) in E. 52 | assert (Hrw : q - ' e - ' d + ' (d + e) = q) 53 | by abstract ring_tac.ring_with_integers (NatPair.Z nat); 54 | rewrite Hrw in E;clear Hrw. 55 | trivial. 56 | + intros E. unfold cut_of_cauchy;rewrite lipschitz_extend_lim. 57 | simpl. apply lim_upper_cut_pr;simpl. 58 | change (merely (exists e d, upper (cut_of_cauchy (x (e / 1))) 59 | (q - ' e - ' d))). 60 | apply R_archimedean in E;revert E;apply (Trunc_ind _);intros [r [E1 E2]]. 61 | apply rat_lt_reflecting in E2. 62 | pose proof (fun a b => Rlt_close_rat_plus _ _ E1 _ _ 63 | (symmetry _ _ (equiv_lim _ _ a b))) as E3. 64 | pose proof (fun a b => snd (IHx _ _) (E3 a b)) as E4. clear E3. 65 | pose (e := Qpos_diff _ _ E2). 66 | apply tr;exists (e/4),(e/4). 67 | rewrite Qpos_recip_1,Qpos_mult_1_r. 68 | assert (Hrw : q - ' (e / 4) - ' (e / 4) = r + ' (e / 4 + e / 4)); 69 | [|rewrite Hrw;apply E4]. 70 | assert (Hrw : 4 / 4 = 1 :> Q). 71 | { apply dec_recip_inverse. apply lt_ne_flip. solve_propholds. } 72 | rewrite <-(mult_1_r q),<-(mult_1_r r),<-Hrw. 73 | unfold e;clear e. repeat (unfold cast;simpl). 74 | abstract ring_tac.ring_with_integers (NatPair.Z nat). 75 | Qed. 76 | 77 | Lemma cut_of_cauchy_preserves_plus : forall a b, 78 | cut_of_cauchy (a + b) = cut_of_cauchy a + cut_of_cauchy b. 79 | Proof. 80 | intros a. apply (unique_continuous_extension _). 81 | { apply _. } 82 | { change (Continuous ((cut_of_cauchy a +) ∘ cut_of_cauchy)). 83 | apply continuous_compose. 84 | { apply nonexpanding_continuous. apply CutPlus_nonexpanding_l. } 85 | apply _. } 86 | intros r;revert a. apply (unique_continuous_extension _). 87 | { apply _. } 88 | { change (Continuous ((+ cut_of_cauchy (rat r)) ∘ cut_of_cauchy)). 89 | apply _. } 90 | intros q. 91 | change (' (q + r) = ' q + ' r :> Cut). 92 | apply CutPlus_rat. 93 | Qed. 94 | 95 | Lemma cut_of_cauchy_preserves_neg : forall a, 96 | cut_of_cauchy (- a) = - cut_of_cauchy a. 97 | Proof. 98 | (* workaround anomaly when we apply same without the last 2 underscores *) 99 | refine (@groups.preserves_negate real plus 0 negate _ Cut plus 0 negate _ _ _) 100 | ;[exact _|exact _|split]. 101 | - hnf. exact cut_of_cauchy_preserves_plus. 102 | - hnf. reflexivity. 103 | Qed. 104 | 105 | Lemma cut_of_cauchy_lower_pr : forall a q, lower (cut_of_cauchy a) q <-> rat q < a. 106 | Proof. 107 | intros. 108 | rewrite <-(negate_involutive a),cut_of_cauchy_preserves_neg. 109 | change (IsTop (lower (- cut_of_cauchy (- a)) q)) with 110 | (IsTop (upper (cut_of_cauchy (- a)) (- q))). 111 | rewrite involutive. 112 | split;intros E. 113 | - apply cut_of_cauchy_upper_pr in E. 114 | change (- a < - (rat q)) in E. 115 | apply flip_lt_negate. trivial. 116 | - apply cut_of_cauchy_upper_pr. change (- a < - (rat q)). 117 | apply flip_lt_negate in E. trivial. 118 | Qed. 119 | 120 | Lemma cut_of_cauchy_lt_preserving : StrictlyOrderPreserving cut_of_cauchy. 121 | Proof. 122 | intros a b E. 123 | generalize (R_archimedean _ _ E);apply (Trunc_ind _);intros [q [E1 E2]]. 124 | apply tr. exists q. split. 125 | - apply cut_of_cauchy_upper_pr. trivial. 126 | - apply cut_of_cauchy_lower_pr. trivial. 127 | Qed. 128 | 129 | Lemma cut_of_cauchy_lt_reflecting : StrictlyOrderReflecting cut_of_cauchy. 130 | Proof. 131 | intros a b;apply (Trunc_ind _). intros [q [E1 E2]]. 132 | apply cut_of_cauchy_upper_pr in E1;apply cut_of_cauchy_lower_pr in E2. 133 | transitivity (rat q);trivial. 134 | Qed. 135 | 136 | Global Instance cut_of_cauchy_lt_embedding : StrictOrderEmbedding cut_of_cauchy. 137 | Proof. 138 | split. 139 | - apply cut_of_cauchy_lt_preserving. 140 | - apply cut_of_cauchy_lt_reflecting. 141 | Qed. 142 | 143 | Lemma cut_of_cauchy_le_preserving : OrderPreserving cut_of_cauchy. 144 | Proof. 145 | apply full_pseudo_order_preserving. 146 | Qed. 147 | 148 | Lemma cut_of_cauchy_le_reflecting : OrderReflecting cut_of_cauchy. 149 | Proof. 150 | apply full_pseudo_order_reflecting. 151 | Qed. 152 | 153 | Global Instance cut_of_cauchy_le_embedding : OrderEmbedding cut_of_cauchy. 154 | Proof. 155 | split. 156 | - apply cut_of_cauchy_le_preserving. 157 | - apply cut_of_cauchy_le_reflecting. 158 | Qed. 159 | 160 | Global Instance cut_of_cauchy_strong_inj : StrongInjective cut_of_cauchy. 161 | Proof. 162 | apply pseudo_order_embedding_inj. 163 | Qed. 164 | 165 | Global Instance cauchy_lt_rat_semi_decide : forall x q, SemiDecide (rat q < x) 166 | := fun x q => lower (cut_of_cauchy x) q. 167 | Arguments cauchy_lt_rat_semi_decide _ _ /. 168 | 169 | Global Instance cauchy_lt_rat_semi_decidable 170 | : forall x q, SemiDecidable (rat q < x). 171 | Proof. 172 | apply cut_of_cauchy_lower_pr. 173 | Qed. 174 | 175 | Definition compare_cauchy_rat : real -> Q -> partial bool 176 | := fun x q => compare_cut_rat (cut_of_cauchy x) q. 177 | 178 | Lemma compare_cauchy_rat_pr : forall a q b, compare_cauchy_rat a q = eta _ b <-> 179 | match b with 180 | | true => rat q < a 181 | | false => a < rat q 182 | end. 183 | Proof. 184 | intros a q b. 185 | split. 186 | - intros E;apply compare_cut_rat_pr in E. 187 | destruct b;apply (strictly_order_reflecting cut_of_cauchy);exact E. 188 | - intros E;apply compare_cut_rat_pr. 189 | change (' q) with (cut_of_cauchy (rat q)). 190 | destruct b;apply (strictly_order_preserving cut_of_cauchy);exact E. 191 | Qed. 192 | 193 | Lemma compare_cauchy_rat_self : forall q, compare_cauchy_rat (rat q) q = bot _. 194 | Proof. 195 | intros. apply compare_cut_rat_self. 196 | Qed. 197 | 198 | End cut_of_cauchy. 199 | 200 | -------------------------------------------------------------------------------- /theories/cauchy_reals.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTTClasses.cauchy_completion. 19 | 20 | Require Export 21 | HoTTClasses.cauchy_reals.base 22 | HoTTClasses.cauchy_reals.abs 23 | HoTTClasses.cauchy_reals.order 24 | HoTTClasses.cauchy_reals.metric 25 | HoTTClasses.cauchy_reals.ring 26 | HoTTClasses.cauchy_reals.full_order 27 | HoTTClasses.cauchy_reals.full_ring 28 | HoTTClasses.cauchy_reals.recip 29 | HoTTClasses.cauchy_reals.field 30 | HoTTClasses.cauchy_reals.uniform_on_intervals 31 | HoTTClasses.cauchy_reals.initial. 32 | -------------------------------------------------------------------------------- /theories/cauchy_reals/abs.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTTClasses.cauchy_completion. 19 | 20 | Require Export 21 | HoTTClasses.cauchy_reals.base. 22 | 23 | Local Set Universe Minimization ToSet. 24 | 25 | Definition Rabs_val := lipschitz_extend _ (Compose rat abs) 1. 26 | 27 | Global Instance Rabs_nonexpanding : NonExpanding Rabs_val := _. 28 | Typeclasses Opaque Rabs_val. 29 | 30 | Lemma Rabs_of_nonneg' : forall x, 0 <= x -> Rabs_val x = x. 31 | Proof. 32 | unfold le;simpl. intros x E;rewrite <-E. 33 | clear E;revert x;apply (unique_continuous_extension _);try apply _. 34 | intros q;apply (ap rat). 35 | apply ((abs_sig _).2). apply join_ub_l. 36 | Qed. 37 | 38 | Lemma Rabs_of_nonpos' : forall x, x <= 0 -> Rabs_val x = - x. 39 | Proof. 40 | intros x E. 41 | apply meet_l in E. rewrite <-E. 42 | clear E;revert x;apply (unique_continuous_extension _);try apply _. 43 | intros q;apply (ap rat). 44 | apply ((abs_sig _).2). apply meet_lb_r. 45 | Qed. 46 | 47 | Instance Rabs : Abs real. 48 | Proof. 49 | intros u. exists (Rabs_val u). 50 | split. 51 | - apply Rabs_of_nonneg'. 52 | - apply Rabs_of_nonpos'. 53 | Defined. 54 | 55 | Lemma Rabs_of_nonneg@{} : forall x : real, 0 <= x -> abs x = x. 56 | Proof. 57 | intros x;apply ((abs_sig x).2). 58 | Qed. 59 | 60 | Lemma Rabs_of_nonpos : forall x : real, x <= 0 -> abs x = - x. 61 | Proof. 62 | intros x;apply ((abs_sig x).2). 63 | Qed. 64 | 65 | Lemma Rabs_of_0 : abs (A:=real) 0 = 0. 66 | Proof. 67 | apply Rabs_of_nonneg;reflexivity. 68 | Qed. 69 | 70 | Lemma Rabs_of_0' : forall x : real, x = 0 -> abs x = 0. 71 | Proof. 72 | intros x E;rewrite E;apply Rabs_of_0. 73 | Qed. 74 | 75 | Lemma Rabs_nonneg@{} : forall x : real, 0 <= abs x. 76 | Proof. 77 | unfold le;simpl. apply (unique_continuous_extension _);try apply _. 78 | intros;apply (ap rat). 79 | apply join_r. apply Qabs_nonneg. 80 | Qed. 81 | 82 | Instance Rabs_idempotent@{} : UnaryIdempotent (abs (A:=real)). 83 | Proof. 84 | hnf. apply path_forall. intros x. unfold Compose. 85 | apply Rabs_of_nonneg, Rabs_nonneg. 86 | Qed. 87 | 88 | Lemma Rabs_neg_flip@{} : forall a b : real, abs (a - b) = abs (b - a). 89 | Proof. 90 | apply (unique_continuous_binary_extension _);try apply _. 91 | intros q r;change (rat (abs (q - r)) = rat (abs (r - q)));apply (ap rat). 92 | apply Qabs_neg_flip. 93 | Qed. 94 | 95 | Lemma Rabs_is_join@{} : forall x : real, abs x = join (- x) x. 96 | Proof. 97 | eapply @unique_continuous_extension;try apply _. 98 | { change (Continuous (uncurry join ∘ (map2 (-) (@id real)) ∘ BinaryDup)); 99 | apply _. } 100 | intros;apply (ap rat),Qabs_is_join. 101 | Qed. 102 | 103 | Lemma Rabs_le_raw@{} : forall x : real, x <= abs x. 104 | Proof. 105 | intros x;rewrite Rabs_is_join. apply join_ub_r. 106 | Qed. 107 | 108 | Lemma Rabs_le_neg_raw@{} : forall x : real, - x <= abs x. 109 | Proof. 110 | intros x;rewrite Rabs_is_join. apply join_ub_l. 111 | Qed. 112 | 113 | Lemma Rabs_neg@{} : forall x : real, abs (- x) = abs x. 114 | Proof. 115 | intros;rewrite !Rabs_is_join,involutive. apply commutativity. 116 | Qed. 117 | 118 | Lemma Rabs_le_pr@{} : forall x y : real, abs x <= y <-> - y <= x /\ x <= y. 119 | Proof. 120 | intros x y. 121 | split. 122 | - intros E. split. 123 | + apply Rneg_le_flip_equiv. rewrite involutive. transitivity (abs x);trivial. 124 | apply Rabs_le_neg_raw. 125 | + transitivity (abs x);trivial. 126 | apply Rabs_le_raw. 127 | - intros [E1 E2]. 128 | rewrite Rabs_is_join. apply join_le. 129 | + apply Rneg_le_flip_equiv;rewrite involutive;trivial. 130 | + trivial. 131 | Qed. 132 | -------------------------------------------------------------------------------- /theories/cauchy_reals/base.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTTClasses.cauchy_completion 19 | HoTT.Classes.implementations.assume_rationals. 20 | 21 | Local Set Universe Minimization ToSet. 22 | 23 | Definition real := C Q. 24 | Definition rat : Q -> real := eta. 25 | 26 | Instance R0@{} : Zero real := rat 0. 27 | 28 | Instance R1@{} : One real := rat 1. 29 | 30 | Instance Rneg@{} : Negate real. 31 | Proof. 32 | red. apply (lipschitz_extend _ (Compose rat (-)) _). 33 | Defined. 34 | 35 | Instance Rneg_nonexpanding@{} : NonExpanding (@negate real _). 36 | Proof. 37 | apply _. 38 | Qed. 39 | 40 | Lemma Rneg_involutive@{} : forall x : real, - - x = x. 41 | Proof. 42 | change (forall x, - - x = id x). 43 | apply (unique_continuous_extension _);try apply _. 44 | intros;apply (ap rat). apply involutive. 45 | Qed. 46 | 47 | Global Instance Rplus@{} : Plus real 48 | := lipschitz_extend_binary _ _ (fun q r => eta (q + r)) 1 1. 49 | 50 | Definition Rplus_rat_rat@{} q r : rat q + rat r = rat (q + r) 51 | := idpath. 52 | 53 | Global Instance Rplus_nonexpanding_l@{} : forall s : real, NonExpanding (+ s) 54 | := fun _ => lipschitz_nonexpanding _. 55 | Global Instance Rplus_nonexpanding_r@{} : forall s : real, NonExpanding (s +) 56 | := fun _ => lipschitz_nonexpanding _. 57 | 58 | Typeclasses Opaque Rplus. 59 | 60 | Lemma unique_continuous_binary_extension@{} (f : real -> real -> real) 61 | `{!Continuous (uncurry f)} 62 | (g : real -> real -> real) 63 | `{!Continuous (uncurry g)} 64 | : (forall q r, f (rat q) (rat r) = g (rat q) (rat r)) -> 65 | forall u v, f u v = g u v. 66 | Proof. 67 | intros E. 68 | intros x;apply (unique_continuous_extension _). 69 | { change (Continuous (Compose (uncurry f) (pair x))). apply _. } 70 | { change (Continuous (Compose (uncurry g) (pair x))). apply _. } 71 | intros r;revert x;apply (unique_continuous_extension _). 72 | { change (Continuous (Compose (uncurry f) (fun x => (x, rat r)))). apply _. } 73 | { change (Continuous (Compose (uncurry g) (fun x => (x, rat r)))). apply _. } 74 | trivial. 75 | Qed. 76 | 77 | Lemma unique_continuous_ternary_extension@{} (f : real -> real -> real -> real) 78 | `{!Continuous (uncurry (uncurry f))} 79 | (g : real -> real -> real -> real) 80 | `{!Continuous (uncurry (uncurry g))} 81 | : (forall q r s, f (rat q) (rat r) (rat s) = g (rat q) (rat r) (rat s)) -> 82 | forall u v w, f u v w = g u v w. 83 | Proof. 84 | intros E u;apply unique_continuous_binary_extension. 85 | { change (Continuous (Compose (uncurry (uncurry f)) (map2 (pair u) id))). 86 | apply _. } 87 | { change (Continuous (Compose (uncurry (uncurry g)) (map2 (pair u) id))). 88 | apply _. } 89 | intros q r;revert u;apply (unique_continuous_extension _). 90 | { change (Continuous (Compose (uncurry (uncurry f)) 91 | (Compose (fun u => (u, rat r)) (fun u => (u, rat q))))). 92 | apply _. } 93 | { change (Continuous (Compose (uncurry (uncurry g)) 94 | (Compose (fun u => (u, rat r)) (fun u => (u, rat q))))). 95 | apply _. } 96 | auto. 97 | Qed. 98 | 99 | Notation prod_symm := (Prod.equiv_prod_symm _ _). 100 | Notation prod_assoc := (Prod.equiv_prod_assoc _ _ _). 101 | 102 | Instance Rplus_comm@{} : Commutative (@plus _ Rplus). 103 | Proof. 104 | hnf. apply unique_continuous_binary_extension. 105 | { apply _. } 106 | { apply _. } 107 | intros q r;apply (ap rat),plus_comm. 108 | Qed. 109 | 110 | Lemma Rplus_assoc@{} : Associative (@plus _ Rplus). 111 | Proof. 112 | hnf. apply unique_continuous_ternary_extension. 113 | { change (Continuous (uncurry plus ∘ map2 id (uncurry plus) ∘ 114 | ((Prod.equiv_prod_assoc _ real _)^-1))). 115 | apply _. } 116 | { change (Continuous (uncurry plus ∘ map2 (uncurry plus) (@id real))). 117 | apply _. } 118 | intros;change (rat (q + (r + s)) = rat (q + r + s));apply (ap rat),plus_assoc. 119 | Qed. 120 | 121 | Instance Rplus_group@{} : Group real. 122 | Proof. 123 | repeat split. 124 | - apply _. 125 | - exact Rplus_assoc. 126 | - hnf. change mon_unit with 0. 127 | change sg_op with plus. 128 | apply (unique_continuous_extension _);try apply _. 129 | intros;apply (ap rat);apply plus_0_l. 130 | - hnf. change mon_unit with 0. 131 | change sg_op with plus. 132 | apply (unique_continuous_extension _);try apply _. 133 | intros;apply (ap rat);apply plus_0_r. 134 | - hnf; change mon_unit with 0. 135 | change sg_op with plus. 136 | apply (unique_continuous_extension _);try apply _. 137 | { change (Continuous (Compose (uncurry plus) 138 | (Compose (map2 negate (@id real)) BinaryDup))). apply _. 139 | } 140 | intros;apply (ap rat),plus_negate_l. 141 | - hnf; change mon_unit with 0. 142 | change sg_op with plus. 143 | apply (unique_continuous_extension _);try apply _. 144 | { change (Continuous (Compose (uncurry plus) 145 | (Compose (map2 (@id real) negate) BinaryDup)));apply _. } 146 | intros;apply (ap rat),plus_negate_r. 147 | Unshelve. all:exact 1. 148 | Qed. 149 | 150 | Global Instance Rmeet@{} : Meet real 151 | := lipschitz_extend_binary _ _ (fun q r => eta (meet q r)) 1 1. 152 | 153 | Global Instance Rmeet_lipschitz_l@{} : forall s : real, NonExpanding (⊓ s) 154 | := fun _ => lipschitz_nonexpanding _. 155 | Global Instance Rmeet_lipschitz_r@{} : forall s : real, NonExpanding (s ⊓) 156 | := fun _ => lipschitz_nonexpanding _. 157 | 158 | Typeclasses Opaque Rmeet. 159 | 160 | Definition Rmeet_rat_rat@{} q r : meet (rat q) (rat r) = rat (meet q r) 161 | := idpath. 162 | 163 | Global Instance Rjoin@{} : Join real 164 | := lipschitz_extend_binary _ _ (fun q r => eta (join q r)) 1 1. 165 | 166 | Global Instance Rjoin_lipschitz_l@{} : forall s : real, NonExpanding (⊔ s) 167 | := fun _ => lipschitz_nonexpanding _. 168 | Global Instance Rjoin_lipschitz_r@{} : forall s : real, NonExpanding (s ⊔) 169 | := fun _ => lipschitz_nonexpanding _. 170 | 171 | Typeclasses Opaque Rjoin. 172 | 173 | Definition Rjoin_rat_rat@{} q r : join (rat q) (rat r) = rat (join q r) 174 | := idpath. 175 | 176 | Global Instance Rle@{} : Le real := fun x y => join x y = y. 177 | Arguments Rle _ _ /. 178 | 179 | Global Instance Rlt@{} : Lt real := fun x y => 180 | merely (exists q r, x <= (rat q) /\ q < r /\ (rat r) <= y). 181 | Arguments Rlt _ _ /. 182 | 183 | Global Instance Rap@{} : Apart@{UQ UQ} real := fun x y => x < y \/ y < x. 184 | Arguments Rap _ _ /. 185 | 186 | Instance Rjoin_comm@{} : Commutative (@join _ Rjoin). 187 | Proof. 188 | hnf. apply unique_continuous_binary_extension. 189 | { apply _. } 190 | { apply _. } 191 | intros;apply (ap rat). 192 | apply join_sl_order_join_sl. 193 | Qed. 194 | 195 | Existing Instance lattice_order_lattice. 196 | 197 | Lemma R_lattice' : LatticeOrder Rle. 198 | Proof. 199 | split. 200 | - apply @alt_Build_MeetSemiLatticeOrder;[ 201 | repeat split;unfold sg_op,meet_is_sg_op;change Rmeet with meet 202 | |apply _|]. 203 | + apply _. 204 | + hnf. 205 | apply unique_continuous_ternary_extension. 206 | { change (Continuous (uncurry meet ∘ map2 (@id real) (uncurry meet) ∘ 207 | prod_assoc^-1)). 208 | apply _. } 209 | { change (Continuous (uncurry meet ∘ map2 (uncurry meet) (@id real))). 210 | apply _. } 211 | intros;change (rat (q ⊓ (r ⊓ s)) = rat ((q ⊓ r) ⊓ s));apply (ap rat). 212 | apply associativity. 213 | + hnf. 214 | apply unique_continuous_binary_extension;try apply _. 215 | intros;apply (ap rat). apply commutativity. 216 | + hnf. red. 217 | apply (unique_continuous_extension _);try apply _. 218 | { change (Continuous (Compose (uncurry meet) (@BinaryDup real)));apply _. } 219 | intros;apply (ap rat),idempotency,_. 220 | + unfold le,Rle. intros x y;split;intros E. 221 | * rewrite <-E. 222 | clear E;revert x y;apply unique_continuous_binary_extension. 223 | { change (Continuous (uncurry meet ∘ map2 id (uncurry join) ∘ 224 | prod_assoc^-1 ∘ map2 BinaryDup (@id real))). 225 | apply _. } 226 | { apply _. } 227 | intros;apply (ap rat). apply (meet_join_absorption _). 228 | * rewrite <-E. 229 | clear E;revert x y;apply unique_continuous_binary_extension. 230 | { change (Continuous (uncurry join ∘ map2 (uncurry meet) (@id real) ∘ 231 | prod_assoc ∘ map2 id BinaryDup)). 232 | apply _. } 233 | { apply _. } 234 | intros;apply (ap rat). 235 | rewrite (commutativity (f:=join)),(commutativity (f:=meet)). 236 | apply (join_meet_absorption _). 237 | - apply @alt_Build_JoinSemiLatticeOrder;[|apply _|reflexivity]. 238 | repeat split;unfold sg_op,join_is_sg_op;change Rjoin with join. 239 | + apply _. 240 | + hnf. 241 | apply unique_continuous_ternary_extension. 242 | { change (Continuous (uncurry join ∘ map2 (@id real) (uncurry join) ∘ 243 | prod_assoc^-1)). 244 | apply _. } 245 | { change (Continuous (uncurry join ∘ map2 (uncurry join) (@id real))). 246 | apply _. } 247 | intros;apply (ap rat). apply associativity. 248 | + hnf. 249 | apply unique_continuous_binary_extension;try apply _. 250 | intros;apply (ap rat). apply commutativity. 251 | + hnf. red. 252 | apply (unique_continuous_extension _);try apply _. 253 | { change (Continuous (uncurry join ∘ (@BinaryDup real)));apply _. } 254 | intros;apply (ap rat),idempotency,_. 255 | Qed. 256 | 257 | Instance R_lattice@{} : LatticeOrder Rle 258 | := R_lattice'@{Ularge UQ}. 259 | 260 | Lemma Rplus_le_preserving@{} : forall z : real, 261 | OrderPreserving (z +). 262 | Proof. 263 | intros z. hnf. unfold le;simpl. intros x y E. 264 | rewrite <-E;clear E. 265 | revert z x y;apply unique_continuous_ternary_extension. 266 | { change (Continuous (uncurry join ∘ 267 | map2 (uncurry (+)) (uncurry (+) ∘ map2 id (uncurry join)) ∘ 268 | prod_assoc ∘ 269 | (* (u, (v, (u, (v, w)))) *) 270 | map2 id (map2 id prod_symm ∘ prod_assoc^-1 ∘ 271 | prod_symm ∘ map2 id prod_assoc^-1) ∘ 272 | (* (u, (u, ((v,v),w))) *) 273 | prod_assoc^-1 ∘ prod_assoc^-1 ∘ 274 | (* (((u,u),(v,v)),w) *) 275 | map2 (map2 BinaryDup BinaryDup) (@id real))). 276 | apply _. } 277 | { change (Continuous (uncurry (+) ∘ map2 (@id real) (uncurry join) ∘ 278 | prod_assoc^-1)). 279 | apply _. } 280 | intros;change (rat ((q + r) ⊔ (q + (r ⊔ s))) = rat (q + (r ⊔ s)));apply (ap rat). 281 | apply join_r. apply (order_preserving (q +)). 282 | apply join_ub_l. 283 | Qed. 284 | 285 | Lemma Rplus_le_reflecting@{} : forall z : real, 286 | OrderReflecting (z +). 287 | Proof. 288 | intros z x y E. 289 | apply (Rplus_le_preserving (- z)) in E. 290 | (* work around some anomaly Not_found *) 291 | pose proof (simple_associativity (f:=plus) (-z) z) as Hrw. 292 | rewrite !Hrw,!left_inverse,!left_identity in E. 293 | trivial. 294 | Qed. 295 | 296 | Instance Rplus_le_embedding@{} : forall z : real, OrderEmbedding (z +). 297 | Proof. 298 | intros;split. 299 | - apply Rplus_le_preserving. 300 | - apply Rplus_le_reflecting. 301 | Qed. 302 | 303 | Lemma rat_le_preserving : OrderPreserving rat. 304 | Proof. 305 | hnf. intros q r E;hnf. 306 | apply (ap rat). apply join_r,E. 307 | Qed. 308 | 309 | Lemma rat_le_reflecting : OrderReflecting rat. 310 | Proof. 311 | hnf. intros q r E;unfold le,Rle in E. 312 | apply (eta_injective _) in E. rewrite <-E;apply join_ub_l. 313 | Qed. 314 | 315 | Instance rat_le_embedding : OrderEmbedding rat. 316 | Proof. 317 | split. 318 | - apply rat_le_preserving. 319 | - apply rat_le_reflecting. 320 | Qed. 321 | 322 | Lemma rat_lt_preserving@{} : StrictlyOrderPreserving rat. 323 | Proof. 324 | hnf. intros x y E. 325 | hnf. apply tr;exists x,y;repeat split;auto. 326 | Qed. 327 | 328 | Lemma rat_lt_reflecting@{} : StrictlyOrderReflecting rat. 329 | Proof. 330 | hnf. intros x y;apply (Trunc_ind _);intros [q [r [E1 [E2 E3]]]]. 331 | apply (order_reflecting rat) in E1;apply (order_reflecting rat) in E3. 332 | apply le_lt_trans with q;trivial. 333 | apply lt_le_trans with r;trivial. 334 | Qed. 335 | 336 | Instance rat_lt_embedding : StrictOrderEmbedding rat. 337 | Proof. 338 | split. 339 | - apply rat_lt_preserving. 340 | - apply rat_lt_reflecting. 341 | Qed. 342 | 343 | Instance Rlt_irrefl@{} : Irreflexive Rlt. 344 | Proof. 345 | hnf. intros x;hnf;apply (Trunc_ind _);intros [q [r [E1 [E2 E3]]]]. 346 | pose proof (transitivity E3 E1) as E4. 347 | apply rat_le_reflecting in E4. 348 | revert E2;apply le_iff_not_lt_flip. trivial. 349 | Qed. 350 | 351 | Instance Rlt_trans@{} : Transitive Rlt. 352 | Proof. 353 | intros a b c. 354 | unfold Rlt. 355 | apply (Trunc_ind (fun _ => _ -> _));intros [q1 [r1 [E1 [E2 E3]]]]; 356 | apply (Trunc_ind _);intros [q2 [r2 [E4 [E5 E6]]]]. 357 | apply tr. exists q1,r2. split;[|split];trivial. 358 | pose proof (rat_le_reflecting _ _ (transitivity E3 E4)) as E7. 359 | apply lt_le_trans with r1;trivial. 360 | apply lt_le. apply le_lt_trans with q2;trivial. 361 | Qed. 362 | 363 | Instance Rapart_ishprop : forall x y : real, IsHProp (apart x y). 364 | Proof. 365 | unfold apart;simpl. intros x y. 366 | apply Sum.ishprop_sum;try apply _. 367 | intros E1 E2. 368 | apply (irreflexivity lt x). transitivity y;trivial. 369 | Qed. 370 | 371 | Lemma R_le_lt_trans@{} : forall a b c : real, a <= b -> b < c -> a < c. 372 | Proof. 373 | intros a b c E1;apply (Trunc_ind _);intros [q [r [E2 [E3 E4]]]]. 374 | apply tr;exists q,r;auto. 375 | Qed. 376 | 377 | Lemma R_lt_le_trans@{} : forall a b c : real, a < b -> b <= c -> a < c. 378 | Proof. 379 | intros a b c E0 E1;revert E0;apply (Trunc_ind _);intros [q [r [E2 [E3 E4]]]]. 380 | apply tr;exists q,r;auto. 381 | Qed. 382 | 383 | Lemma R_lt_le@{} : forall a b : real, a < b -> a <= b. 384 | Proof. 385 | intros a b;apply (Trunc_ind _);intros [q [r [E1 [E2 E3]]]]. 386 | transitivity (rat q);trivial. 387 | transitivity (rat r);trivial. 388 | apply rat_le_preserving. apply lt_le. trivial. 389 | Qed. 390 | 391 | Lemma R_archimedean@{} : forall u v, u < v -> merely (exists q, u < rat q < v). 392 | Proof. 393 | intros u v;apply (Trunc_ind _);intros [q [r [E1 [E2 E3]]]]. 394 | apply tr;exists ((q+r)/2). 395 | split. 396 | - apply R_le_lt_trans with (rat q);trivial. 397 | apply rat_lt_preserving. apply Q_average_between. exact E2. 398 | - apply R_lt_le_trans with (rat r);trivial. 399 | apply rat_lt_preserving. apply Q_average_between. exact E2. 400 | Qed. 401 | 402 | Lemma R_archimedean_pos@{} : forall u v, 0 <= u -> u < v -> 403 | merely (exists q : Q+, u < rat (' q) < v). 404 | Proof. 405 | intros u v Eu E. 406 | apply (merely_destruct (R_archimedean _ _ E)). intros [q [E1 E2]]. 407 | apply tr. simple refine (existT _ (mkQpos q _) _). 408 | - apply rat_lt_reflecting. apply R_le_lt_trans with u;trivial. 409 | - simpl. unfold cast;simpl. split;trivial. 410 | Qed. 411 | 412 | Lemma Rneg_le_flip@{} : forall x y : real, x <= y -> - y <= - x. 413 | Proof. 414 | intros x y E. 415 | rewrite <-E. 416 | clear E;revert x y;apply unique_continuous_binary_extension. 417 | { change (Continuous (uncurry join ∘ map2 (negate ∘ uncurry join) negate ∘ 418 | prod_symm ∘ prod_assoc^-1 ∘ map2 BinaryDup (@id real))). 419 | apply _. } 420 | { apply _. } 421 | intros q r;change (rat (- (q ⊔ r) ⊔ - q) = rat (- q));apply (ap rat). 422 | apply join_r. apply (snd (flip_le_negate _ _)). apply join_ub_l. 423 | Qed. 424 | 425 | Lemma Rneg_le_flip_equiv@{} : forall x y : real, - y <= - x <-> x <= y. 426 | Proof. 427 | intros x y;split. 428 | - intros E. apply Rneg_le_flip in E. rewrite !involutive in E. 429 | exact E. 430 | - apply Rneg_le_flip. 431 | Qed. 432 | 433 | Lemma Rneg_lt_flip@{} : forall x y : real, - y < - x <-> x < y. 434 | Proof. 435 | intros x y;split;apply (Trunc_ind _);intros [q [r [E1 [E2 E3]]]]. 436 | - apply flip_lt_negate in E2. 437 | apply Rneg_le_flip in E1;apply Rneg_le_flip in E3. 438 | rewrite involutive in E1;rewrite involutive in E3. 439 | apply tr;exists (-r),(-q). auto. 440 | - apply tr;exists (-r),(-q);repeat split. 441 | + change (- y <= - (rat r)). apply (snd (Rneg_le_flip_equiv _ _)),E3. 442 | + apply (snd (flip_lt_negate _ _)),E2. 443 | + change (- rat q <= - x). apply (snd (Rneg_le_flip_equiv _ _)),E1. 444 | Qed. 445 | -------------------------------------------------------------------------------- /theories/cauchy_reals/field.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTTClasses.cauchy_completion. 19 | 20 | Require Export 21 | HoTTClasses.cauchy_reals.base 22 | HoTTClasses.cauchy_reals.abs 23 | HoTTClasses.cauchy_reals.order 24 | HoTTClasses.cauchy_reals.metric 25 | HoTTClasses.cauchy_reals.ring 26 | HoTTClasses.cauchy_reals.full_order 27 | HoTTClasses.cauchy_reals.full_ring 28 | HoTTClasses.cauchy_reals.recip. 29 | 30 | Local Set Universe Minimization ToSet. 31 | 32 | Global Instance real_field : Field real. 33 | Proof. 34 | split;try apply _. 35 | apply R_recip_inverse. 36 | Qed. 37 | -------------------------------------------------------------------------------- /theories/cauchy_reals/full_order.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion. 20 | 21 | Require Export 22 | HoTTClasses.cauchy_reals.base 23 | HoTTClasses.cauchy_reals.abs 24 | HoTTClasses.cauchy_reals.order 25 | HoTTClasses.cauchy_reals.metric 26 | HoTTClasses.cauchy_reals.ring. 27 | 28 | Local Set Universe Minimization ToSet. 29 | 30 | Lemma Rlt_exists_pos_plus_le@{} : forall x y : real, x < y -> 31 | merely (exists e : Q+, x + rat (' e) <= y). 32 | Proof. 33 | intros x y;apply (Trunc_ind _). intros [q [r [E1 [E2 E3]]]]. 34 | apply tr. exists (Qpos_diff _ _ E2). 35 | transitivity (rat r);trivial. 36 | set (d := Qpos_diff _ _ E2). rewrite (Qpos_diff_pr _ _ E2). unfold d;clear d. 37 | change (rat (q + ' Qpos_diff q r E2)) with (rat q + rat (' Qpos_diff q r E2)). 38 | rewrite 2!(plus_comm _ (rat (' _))). 39 | apply (order_preserving (_ +)). trivial. 40 | Qed. 41 | 42 | Lemma Rle_close@{} : forall e u v, close e u v -> 43 | v <= u + rat (' e). 44 | Proof. 45 | intros e u v xi. 46 | apply (order_reflecting ((- u) +)). 47 | rewrite plus_assoc,plus_negate_l,plus_0_l. 48 | apply equiv_to_metric in xi. 49 | transitivity (abs (u - v));[|apply R_lt_le,xi]. 50 | rewrite <-Rabs_neg. rewrite <-negate_swap_l. apply Rabs_le_raw. 51 | Qed. 52 | 53 | Lemma Rlt_plus_pos@{} : forall x (e : Q+), x < x + rat (' e). 54 | Proof. 55 | apply (C_ind0 _ (fun x => forall e, _)). 56 | - intros;apply rat_lt_preserving. apply pos_plus_lt_compat_r. 57 | solve_propholds. 58 | - intros x IHx e. 59 | pose proof (fun a b c => Rlt_close_plus _ _ (IHx _ b) _ _ (equiv_lim _ _ c a)) 60 | as E1. 61 | pose proof (fun a b c => cotransitive (E1 a b c) (lim x + (rat (' e)))) as E2. 62 | pose proof (fun a b => Rle_close _ _ _ (symmetry _ _ (equiv_lim _ x a b))) as E3. 63 | (* in the second branch of cotransitive, 64 | forall n : Q+, lim x + rat e < x a + a + n' <= lim x + 2a + n 65 | where a = E2.a + E3.b 66 | and n = E2.b + E2.c + E3.a *) 67 | apply (merely_destruct (E2 (e/3) (e/3/3) (e/3/3))). 68 | intros [E4|E4]. 69 | + trivial. 70 | + pose proof (E3 (e/3/3) (e/3)) as E5. 71 | rewrite <-plus_assoc in E4. 72 | pose proof (Rplus_le_preserving 73 | (rat (' (e / 3 / 3)) + rat (' (e / 3 / 3 + e / 3))) _ _ E5) as E6. 74 | rewrite (plus_comm _ (x _)) in E6. 75 | pose proof (R_lt_le_trans _ _ _ E4 E6) as E7. 76 | set (d := e/3) in E7. 77 | assert (Hrw : rat (' (e / 3 / 3)) + rat (' (e / 3 / 3 + e / 3)) + 78 | (lim x + rat (' (e / 3 / 3 + e / 3))) 79 | = lim x + rat (' (d + d + ((d/3 + d/3 + d/3))))). 80 | { path_via (lim x + (rat (' (e / 3 / 3)) + rat (' (e / 3 / 3 + e / 3)) 81 | + rat (' (e / 3 / 3 + e / 3)))). 82 | { abstract ring_tac.ring_with_nat. } 83 | { apply ap. apply (ap rat). 84 | unfold d;abstract ring_tac.ring_with_nat. } 85 | } 86 | rewrite Hrw in E7;clear Hrw. 87 | unfold d in E7;rewrite <-!pos_split3 in E7. 88 | destruct (irreflexivity lt _ E7). 89 | Qed. 90 | 91 | Instance Rplus_lt_preserving@{} : forall z : real, StrictlyOrderPreserving (z +). 92 | Proof. 93 | intros z x y E1. apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E1)). 94 | intros [e E2]. 95 | apply R_lt_le_trans with (z + x + rat (' e)). 96 | - apply Rlt_plus_pos. 97 | - rewrite <-plus_assoc. apply (order_preserving (z +)). trivial. 98 | Qed. 99 | 100 | Instance real_strict_srorder : StrictSemiRingOrder Rlt. 101 | Proof. 102 | eapply @from_strict_ring_order;try apply _;[split;apply _|]. 103 | unfold PropHolds. 104 | intros x y E1 E2. 105 | apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E1));intros [e1 E1']. 106 | apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E2));intros [e2 E2']. 107 | apply R_lt_le_trans with (rat (' (e1 * e2))). 108 | - apply rat_lt_preserving;solve_propholds. 109 | - rewrite plus_0_l in E1';rewrite plus_0_l in E2'. 110 | change (rat (' (e1 * e2))) with (rat (' e1) * rat (' e2)). 111 | apply mult_le_compat;trivial;apply rat_le_preserving;solve_propholds. 112 | Qed. 113 | 114 | Lemma Rjoin_plus_r : forall a b c : real, join a b + c = join (a+c) (b+c). 115 | Proof. 116 | apply unique_continuous_ternary_extension. 117 | - change (Continuous (uncurry (@plus real _) ∘ map2 (uncurry join) id)). 118 | apply _. 119 | - change (Continuous (uncurry (@join real _) ∘ map2 120 | (uncurry plus ∘ map2 fst id) 121 | (uncurry plus ∘ map2 snd id) ∘ 122 | BinaryDup)). 123 | apply _. 124 | - intros q r s. change (rat (q ⊔ r + s) = rat ((q + s) ⊔ (r + s))). apply (ap rat). 125 | destruct (total le q r) as [E|E]. 126 | + rewrite join_r;trivial. 127 | rewrite join_r;trivial. 128 | apply (order_preserving (+ s));trivial. 129 | + rewrite join_l;trivial. 130 | rewrite join_l;trivial. 131 | apply (order_preserving (+ s));trivial. 132 | Qed. 133 | 134 | Lemma Rlt_join : forall a b c : real, a < c -> b < c -> 135 | join a b < c. 136 | Proof. 137 | intros a b c E1 E2. 138 | apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E1));intros [e1 E1']. 139 | apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E2));intros [e2 E2']. 140 | destruct (Qpos_lt_min e1 e2) as [n [n1 [n2 [En1 En2]]]]. 141 | apply R_lt_le_trans with (join a b + rat (' n));[apply Rlt_plus_pos|]. 142 | rewrite Rjoin_plus_r. apply join_le. 143 | - etransitivity;[|exact E1']. 144 | apply (order_preserving (a +)),rat_le_preserving. rewrite En1. 145 | unfold cast at 2;simpl. 146 | apply nonneg_plus_le_compat_r. solve_propholds. 147 | - etransitivity;[|exact E2']. 148 | apply (order_preserving (b +)),rat_le_preserving. rewrite En2. 149 | unfold cast at 2;simpl. 150 | apply nonneg_plus_le_compat_r. solve_propholds. 151 | Qed. 152 | 153 | Lemma from_below_is_approx (x : real) : 154 | forall d e : Q+, close (d + e) (x - rat (' d)) (x - rat (' e)). 155 | Proof. 156 | intros;apply metric_to_equiv. 157 | assert (Hrw : (x - rat (' d) - (x - rat (' e))) = 158 | rat (' e) - rat (' d)) 159 | by ring_tac.ring_with_integers (NatPair.Z nat). 160 | rewrite Hrw;clear Hrw. 161 | change (rat (abs (' e - ' d)) < rat (' (d + e))). 162 | apply rat_lt_preserving. 163 | destruct (total le (' e) (' d)) as [E|E]. 164 | - rewrite <-Qabs_neg, Qabs_of_nonneg 165 | by (apply flip_nonpos_negate,(snd (flip_nonpos_minus _ _)),E). 166 | rewrite <-negate_swap_r. apply (strictly_order_preserving ((' d) +)). 167 | apply between_pos. solve_propholds. 168 | - rewrite Qabs_of_nonneg 169 | by (apply (snd (flip_nonneg_minus _ _)),E). 170 | rewrite plus_comm. apply (strictly_order_preserving (+ (' e))). 171 | apply between_pos. solve_propholds. 172 | Qed. 173 | 174 | Definition from_below (x : real) : Approximation real. 175 | Proof. 176 | exists (fun e => x - rat (' e)). 177 | apply from_below_is_approx. 178 | Defined. 179 | 180 | Lemma from_below_pr : forall x, lim (from_below x) = x. 181 | Proof. 182 | intros. apply equiv_path. intros. 183 | rewrite (pos_split2 e). 184 | eapply (triangular _);[rewrite (pos_split2 (e/2));symmetry;apply (equiv_lim _)|]. 185 | simpl. apply metric_to_equiv. 186 | assert (Hrw : (x - rat (' (e / 2 / 2)) - x) = - (rat (' (e / 2 / 2)))) 187 | by ring_tac.ring_with_integers (NatPair.Z nat). 188 | rewrite Hrw;clear Hrw. 189 | rewrite Rabs_neg. 190 | apply rat_lt_preserving. 191 | rewrite Qabs_of_nonneg by solve_propholds. 192 | set (n := e / 2);clearbody n;clear e. 193 | set (k := n / 2);rewrite (pos_split2 n). 194 | fold k. clearbody k;clear n. 195 | apply pos_plus_lt_compat_r. solve_propholds. 196 | Qed. 197 | 198 | Definition lipschitz_approx (f : real -> real) L 199 | `{!Lipschitz f L} 200 | (x : Approximation real) 201 | : Approximation real. 202 | Proof. 203 | exists (fun e => f (x (e / L))). 204 | intros. 205 | rewrite <-(pos_unconjugate L (d + e)),<-Qpos_mult_assoc. 206 | apply (lipschitz f L). 207 | assert (Hrw : ((d + e) / L) = d / L + e / L) 208 | by (apply pos_eq,plus_mult_distr_r); 209 | rewrite Hrw;clear Hrw. 210 | apply approx_equiv. 211 | Defined. 212 | 213 | Lemma lipschitz_approx_lim (f:real -> real) L `{!Lipschitz f L} x 214 | : f (lim x) = lim (lipschitz_approx f L x). 215 | Proof. 216 | apply equiv_path. intros. 217 | rewrite (pos_split2 e). 218 | eapply triangular;[|rewrite (pos_split2 (e/2));apply (equiv_lim _)]. 219 | simpl. set (N := e / 2 / 2 / L). 220 | rewrite <-(pos_unconjugate L (e / 2)),<-Qpos_mult_assoc. 221 | apply (lipschitz f L). 222 | symmetry. rewrite (pos_split2 (e / 2 / L)). 223 | assert (Hrw : e / 2 / L / 2 = N) 224 | by (unfold N;apply pos_eq;ring_tac.ring_with_nat). 225 | rewrite Hrw;clear Hrw. 226 | apply (equiv_lim _). 227 | Qed. 228 | 229 | Lemma Rjoin_0_not_neg : forall x, (forall e : Q+, - rat (' e) < x) -> join 0 x = x. 230 | Proof. 231 | intros x E. 232 | rewrite <-(from_below_pr 0). 233 | rewrite (lipschitz_approx_lim (⊔ x) 1 (from_below 0)). 234 | path_via (lim (const_approx _ x));[|apply lim_cons]. 235 | apply ap, approx_eq, path_forall;intros e. 236 | simpl. apply join_r. 237 | rewrite plus_0_l. apply R_lt_le;trivial. 238 | Qed. 239 | 240 | Lemma R_not_lt_le_flip : forall x y : real, ~ x < y -> y <= x. 241 | Proof. 242 | intros x y E. 243 | apply flip_nonneg_minus. 244 | apply Rjoin_0_not_neg. 245 | intros. 246 | (* work around some anomaly Not_found (when we just apply flip_lt_minus_r) *) 247 | apply (snd (flip_lt_minus_r _ _ _)). 248 | rewrite plus_comm. 249 | assert (E1 : y - rat (' e) < y). 250 | { apply (strictly_order_reflecting (+ (rat (' e)))). 251 | rewrite <-plus_assoc,plus_negate_l,plus_0_r. apply Rlt_plus_pos. } 252 | apply (merely_destruct (cotransitive E1 x));intros [E2|E2];trivial. 253 | destruct (E E2). 254 | Qed. 255 | 256 | Instance real_full_pseudo_order@{} : FullPseudoOrder Rle Rlt. 257 | Proof. 258 | (* Avoid splitting iffs *) 259 | repeat (split;try (revert x; fail 1);try apply _). 260 | - hnf. unfold apart;simpl. intros ??. apply Sum.equiv_sum_symm. 261 | - intros x y;split. 262 | + intros E. 263 | apply (antisymmetry le);apply R_not_lt_le_flip;intros E';apply E;hnf;auto. 264 | + intros [] [E|E];apply (irreflexivity _ _ E). 265 | - apply lt_antisym. 266 | - intros x y;split;intros E;exact E. 267 | - intros x y;split. 268 | + intros E1 E2. apply (irreflexivity lt x). 269 | apply R_le_lt_trans with y;trivial. 270 | + apply R_not_lt_le_flip. 271 | Qed. 272 | 273 | Global Instance real_isapart : IsApart real. 274 | Proof. 275 | apply pseudo_order_apart. 276 | Qed. 277 | -------------------------------------------------------------------------------- /theories/cauchy_reals/full_ring.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion. 20 | 21 | Require Export 22 | HoTTClasses.cauchy_reals.base 23 | HoTTClasses.cauchy_reals.abs 24 | HoTTClasses.cauchy_reals.order 25 | HoTTClasses.cauchy_reals.metric 26 | HoTTClasses.cauchy_reals.ring 27 | HoTTClasses.cauchy_reals.full_order. 28 | 29 | Local Set Universe Minimization ToSet. 30 | 31 | Lemma apart_to_metric : forall x y : real, apart x y -> 0 < abs (x - y). 32 | Proof. 33 | intros x y [E|E];apply flip_pos_minus in E. 34 | - rewrite <-Rabs_neg,<-negate_swap_r. rewrite Rabs_of_nonneg;trivial. 35 | apply R_lt_le;trivial. 36 | - rewrite Rabs_of_nonneg;trivial. 37 | apply R_lt_le;trivial. 38 | Qed. 39 | 40 | Lemma Rlt_join_either : forall a b c, a < join b c -> hor (a < b) (a < c). 41 | Proof. 42 | intros a b c E. 43 | generalize (cotransitive E b);apply (Trunc_ind _);intros [E1|E1]. 44 | - apply tr. auto. 45 | - generalize (cotransitive E c);apply (Trunc_ind _);intros [E2|E2]. 46 | + apply tr. auto. 47 | + destruct (irreflexivity lt _ (Rlt_join _ _ _ E1 E2)). 48 | Qed. 49 | 50 | Lemma Rlt_join_l : forall a b, a < join a b -> a < b. 51 | Proof. 52 | intros a b E;apply (merely_destruct (Rlt_join_either _ _ _ E)); 53 | intros [E1|E1];trivial. 54 | destruct (irreflexivity lt _ E1). 55 | Qed. 56 | 57 | Lemma Rlt_join_r : forall a b, b < join a b -> b < a. 58 | Proof. 59 | intros a b E;apply (merely_destruct (Rlt_join_either _ _ _ E)); 60 | intros [E1|E1];trivial. 61 | destruct (irreflexivity lt _ E1). 62 | Qed. 63 | 64 | Lemma metric_to_apart : forall x y : real, 0 < abs (x - y) -> 65 | apart x y. 66 | Proof. 67 | intros x y E. 68 | rewrite Rabs_is_join in E. apply (merely_destruct (Rlt_join_either _ _ _ E)). 69 | intros [E1|E1]. 70 | - rewrite <-negate_swap_r in E1. apply flip_pos_minus in E1. left;trivial. 71 | - apply flip_pos_minus in E1. right;trivial. 72 | Qed. 73 | 74 | Lemma Rabs_triangle_alt : forall x y : real, abs (abs x - abs y) <= abs (x - y). 75 | Proof. 76 | intros x y. 77 | apply R_not_lt_le_flip. 78 | intros E. apply (merely_destruct (R_archimedean_pos _ _ (Rabs_nonneg _) E)). 79 | intros [e [E1 E2]]. 80 | apply metric_to_equiv in E1. apply (non_expanding abs) in E1. 81 | apply equiv_to_metric in E1. 82 | apply (irreflexivity lt (rat (' e))). 83 | etransitivity;eauto. 84 | Qed. 85 | 86 | Instance Rabs_strong_ext : StrongExtensionality (abs (A:=real)). 87 | Proof. 88 | intros x y E. 89 | apply metric_to_apart. 90 | eapply R_lt_le_trans;[|apply Rabs_triangle_alt]. 91 | apply apart_to_metric in E. trivial. 92 | Qed. 93 | 94 | Lemma Rmult_pos_decompose_nonneg : forall x y, 0 <= x -> 95 | 0 < x * y -> 96 | 0 < y. 97 | Proof. 98 | intros x y E1 E2. 99 | assert (E3 : merely (exists e : Q+, rat (' e) < x * y)). 100 | { generalize (R_archimedean _ _ E2);apply (Trunc_ind _);intros [e [E3 E4]]. 101 | apply rat_lt_reflecting in E3. 102 | apply tr. exists (mkQpos e E3). trivial. } 103 | revert E3;apply (Trunc_ind _);intros [e E3]. 104 | apply (merely_destruct (R_Qpos_bounded x)). intros [n E4]. 105 | apply R_lt_le_trans with (rat (' (e/n)));[apply rat_lt_preserving;solve_propholds|]. 106 | apply R_not_lt_le_flip. intros E5. 107 | apply (irreflexivity lt (rat (' e))). 108 | eapply R_lt_le_trans;[apply E3|]. 109 | rewrite <-(pos_unconjugate n e). rewrite <-Qpos_mult_assoc. 110 | change (x * y <= rat (' n) * rat (' (e / n))). 111 | apply mult_le_compat;trivial. 112 | - apply R_not_lt_le_flip;intros E6. 113 | apply (irreflexivity lt 0). 114 | apply R_lt_le_trans with (x * y);trivial. 115 | apply nonneg_nonpos_mult;trivial. apply R_lt_le;trivial. 116 | - transitivity (abs x). 117 | + apply Rabs_le_raw. 118 | + apply R_lt_le;trivial. 119 | - apply R_lt_le;trivial. 120 | Qed. 121 | 122 | Lemma Rabs_mult : forall x y : real, abs (x * y) = abs x * abs y. 123 | Proof. 124 | apply unique_continuous_binary_extension. 125 | - change (Continuous (abs ∘ uncurry (@mult real _)));apply _. 126 | - change (Continuous (uncurry (@mult real _) ∘ map2 abs abs));apply _. 127 | - intros. change (rat (abs (q * r)) = rat (abs q * abs r)). 128 | exact (ap rat (Qabs_mult q r)). 129 | Qed. 130 | 131 | Lemma Rmult_lt_apart : forall z x y, z * x < z * y -> apart x y. 132 | Proof. 133 | intros z x y E. 134 | symmetry. 135 | apply metric_to_apart. 136 | apply Rmult_pos_decompose_nonneg with (abs z);[apply Rabs_nonneg|]. 137 | rewrite <-Rabs_mult. 138 | apply R_lt_le_trans with (z * (y - x));[|apply Rabs_le_raw]. 139 | rewrite plus_mult_distr_l,<-negate_mult_distr_r. 140 | apply (snd (flip_pos_minus _ _)). 141 | trivial. 142 | Qed. 143 | 144 | Global Instance real_full_pseudo_srorder : FullPseudoSemiRingOrder Rle Rlt. 145 | Proof. 146 | apply from_full_pseudo_ring_order;try apply _. 147 | apply @apartness.strong_binary_setoid_morphism_commutative;try apply _. 148 | intros z x y [E|E];apply Rmult_lt_apart in E;trivial;symmetry;trivial. 149 | Qed. 150 | -------------------------------------------------------------------------------- /theories/cauchy_reals/initial.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion. 20 | 21 | Require Export 22 | HoTTClasses.cauchy_reals.base. 23 | 24 | Local Set Universe Minimization ToSet. 25 | 26 | Section real_initial. 27 | 28 | Context `{Field F} `{!FullPseudoSemiRingOrder (A:=F) Fle Flt}. 29 | 30 | Variable F_archimedean : forall x y : F, x < y -> 31 | merely (exists q, x < rationals_to_field Q F q < y). 32 | 33 | Instance Fclose : Closeness F := fun e x y => 34 | x - y < rationals_to_field Q F (' e) /\ y - x < rationals_to_field Q F (' e). 35 | 36 | Instance rat_to_field_strict_order_embedding 37 | : StrictOrderEmbedding (rationals_to_field Q F). 38 | Proof. 39 | Admitted. 40 | 41 | Lemma F_separated : Separated F. 42 | Proof. 43 | intros x y E. 44 | apply (right_cancellation (+) (-y)). rewrite plus_negate_r. 45 | apply tight_apart. intros E'. apply apart_iff_total_lt in E'. 46 | destruct E' as [E'|E'];apply F_archimedean in E';revert E';apply (Trunc_ind _); 47 | intros [q [E1 E2]]. 48 | - assert (Eq : 0 < - q). 49 | { rewrite <-(preserves_0 (f:=rationals_to_field Q F)) in E2. 50 | apply (strictly_order_reflecting _) in E2. 51 | apply flip_neg_negate. trivial. 52 | } 53 | pose proof (E (mkQpos _ Eq)) as [E3 E4];unfold cast in E3,E4;simpl in E3, E4. 54 | rewrite (preserves_negate (f:=rationals_to_field Q F)) in E4. 55 | apply flip_lt_negate in E4;rewrite involutive,<-negate_swap_r in E4. 56 | apply (irreflexivity lt (x - y)). transitivity (rationals_to_field Q F q);trivial. 57 | - assert (Eq : 0 < q). 58 | { apply (strictly_order_reflecting _). rewrite preserves_0. trivial. } 59 | pose proof (E (mkQpos _ Eq)) as [E3 E4];unfold cast in E3,E4;simpl in E3, E4. 60 | apply (irreflexivity lt (x - y)). transitivity (rationals_to_field Q F q);trivial. 61 | Qed. 62 | 63 | Instance F_premetric : PreMetric F. 64 | Proof. 65 | split. 66 | - apply _. 67 | - intros e x. hnf. rewrite plus_negate_r. 68 | split;rewrite <-(preserves_0 (f:=rationals_to_field Q F)); 69 | apply (strictly_order_preserving _);solve_propholds. 70 | - intros e x y E. hnf. apply prod_symm,E. 71 | - apply F_separated. 72 | - intros x y z e d E1 E2. 73 | hnf. rewrite (preserves_plus (f:=_:Q -> F)). 74 | split. 75 | + assert (Hrw : x - z = (x - y) + (y - z)) 76 | by ring_tac.ring_with_integers (NatPair.Z nat); 77 | rewrite Hrw;clear Hrw. apply plus_lt_compat. 78 | * apply E1. 79 | * apply E2. 80 | + assert (Hrw : z - x = (y - x) + (z - y)) 81 | by ring_tac.ring_with_integers (NatPair.Z nat); 82 | rewrite Hrw;clear Hrw. apply plus_lt_compat. 83 | * apply E1. 84 | * apply E2. 85 | - hnf. intros e x y. split. 86 | + intros [E1 E2]. 87 | apply F_archimedean in E1;apply F_archimedean in E2. 88 | revert E1;apply (Trunc_ind _);intros [q1 [E1 E1']]; 89 | revert E2;apply (Trunc_ind _);intros [q2 [E2 E2']]. 90 | apply (strictly_order_reflecting _) in E1'; 91 | apply (strictly_order_reflecting _) in E2'. 92 | assert (E3 : exists d d', q1 < ' d /\ q2 < ' d /\ e = d + d'). 93 | { apply pos_gt_both;trivial. } 94 | destruct E3 as [d [d' [E3 [E4 E5]]]]. 95 | apply tr;exists d,d';split;trivial. 96 | hnf. split;etransitivity;eauto;apply (strictly_order_preserving _);trivial. 97 | + apply (Trunc_ind _);intros [d [d' [E1 [E2 E3]]]]. 98 | assert (rationals_to_field Q F (' d) < rationals_to_field Q F (' e)) 99 | by (apply (strictly_order_preserving _); rewrite E1; 100 | apply pos_plus_lt_compat_r; solve_propholds). 101 | split;etransitivity;eauto. 102 | Qed. 103 | 104 | Context `{!Lim F} `{!CauchyComplete F}. 105 | 106 | Definition real_embed : real -> F. 107 | Proof. 108 | simple refine (lipschitz_extend Q (rationals_to_field Q F) 1);try apply _. 109 | apply nonexpanding_lipschitz. 110 | hnf. intros e q r [E1 E2]. 111 | hnf. rewrite <-!preserves_negate,<-!preserves_plus. 112 | apply flip_lt_negate in E1. rewrite involutive,<-negate_swap_r in E1. 113 | split;apply (strictly_order_preserving _);trivial. 114 | Defined. 115 | 116 | Definition real_embed_rat q : real_embed (rat q) = rationals_to_field Q F q 117 | := idpath. 118 | 119 | (* To show that real_embed preserves plus/mult 120 | we need to know that they're continuous on F. *) 121 | 122 | End real_initial. 123 | -------------------------------------------------------------------------------- /theories/cauchy_reals/metric.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion. 20 | 21 | Require Export 22 | HoTTClasses.cauchy_reals.base 23 | HoTTClasses.cauchy_reals.abs 24 | HoTTClasses.cauchy_reals.order. 25 | 26 | Local Set Universe Minimization ToSet. 27 | 28 | Lemma equiv_0_metric' : forall e u, close e u 0 -> abs u < rat (' e). 29 | Proof. 30 | intros e u;revert u e;apply (C_ind0 _ (fun u => forall e, _ -> _)). 31 | - intros q e E. 32 | rewrite (equiv_eta_eta_def _) in E. apply Qclose_alt in E. 33 | rewrite negate_0,plus_0_r in E. 34 | apply rat_lt_preserving. trivial. 35 | - intros x IH e xi. 36 | apply rounded in xi. revert xi. 37 | apply (Trunc_ind _);intros [d [d' [He xi]]]. 38 | rewrite (equiv_lim_eta_def _) in xi. 39 | revert xi;apply (Trunc_ind _);intros [n [n' [Hd E1]]]. 40 | apply IH in E1. 41 | rewrite He,Hd. 42 | assert (Hrw : (' (n + n' + d')) = ' n' + ' (n + d')) 43 | by ring_tac.ring_with_nat. 44 | rewrite Hrw;clear Hrw. 45 | apply (Rlt_close_rat_plus _ _ E1). 46 | apply (non_expanding abs). 47 | rewrite qpos_plus_comm. apply (equiv_lim _). 48 | Qed. 49 | 50 | Definition equiv_0_metric@{} 51 | := equiv_0_metric'@{UQ UQ}. 52 | 53 | Lemma equiv_to_metric@{} : forall e u v, close e u v -> abs (u - v) < rat (' e). 54 | Proof. 55 | intros e u v xi. 56 | rewrite <-Rabs_idempotent. 57 | apply equiv_0_metric. 58 | rewrite <-(Rabs_of_0' (v - v));[|apply right_inverse]. 59 | apply (non_expanding (fun w => abs (w - v))). trivial. 60 | Qed. 61 | 62 | Lemma metric_to_equiv_rat_lim@{} (q : Q) 63 | (y : Approximation real) 64 | (IHy : forall e e0 : Q+, abs (rat q - y e) < rat (' e0) -> close e0 (rat q) (y e)) 65 | (e : Q+) 66 | (E1 : abs (rat q - lim y) < rat (' e)) 67 | : close e (rat q) (lim y). 68 | Proof. 69 | generalize (R_archimedean _ _ E1). apply (Trunc_ind _);intros [d [E2 E3]]. 70 | apply rat_lt_reflecting in E3. 71 | pose proof (snd (flip_pos_minus _ _) E3) as E4. 72 | assert (Hd : 0 < d). 73 | { revert E2;apply (Trunc_ind _). 74 | intros [s [s' [F1 [F2 F3]]]]. 75 | apply rat_le_reflecting in F3. 76 | apply lt_le_trans with s';trivial. 77 | apply le_lt_trans with s;trivial. 78 | apply rat_le_reflecting. 79 | transitivity (abs (rat q - lim y));trivial. 80 | apply Rabs_nonneg. 81 | } 82 | pose (D := mkQpos d Hd). 83 | pose (ED := mkQpos _ E4). 84 | assert (Hrw : e = D + (ED / 4 + ED / 4) + (ED / 4 + ED / 4)). 85 | { path_via (D + ED). 86 | { apply pos_eq;unfold D, ED. 87 | abstract ring_tac.ring_with_integers (NatPair.Z nat). 88 | } 89 | path_via (D + 4 / 4 * ED). 90 | { rewrite pos_recip_r,Qpos_mult_1_l;trivial. } 91 | apply pos_eq;abstract ring_tac.ring_with_nat. 92 | } 93 | rewrite Hrw. 94 | eapply (equiv_triangle _);[|apply (equiv_lim _)]. 95 | apply IHy. apply (Rlt_close_rat_plus _ _ E2). 96 | apply (non_expanding (fun u => abs (rat q - u))). 97 | apply (equiv_symm _),(equiv_lim _). 98 | Qed. 99 | 100 | Lemma metric_to_equiv_lim_lim@{} (x : Approximation real) 101 | (IHx : forall (e : Q+) (v : real) (e0 : Q+), 102 | abs (x e - v) < rat (' e0) -> close e0 (x e) v) 103 | (y : Approximation real) 104 | (IHy : forall e e0 : Q+, abs (lim x - y e) < rat (' e0) -> close e0 (lim x) (y e)) 105 | (e : Q+) 106 | (E1 : abs (lim x - lim y) < rat (' e)) 107 | : close e (lim x) (lim y). 108 | Proof. 109 | generalize (R_archimedean _ _ E1). apply (Trunc_ind _);intros [d [E2 E3]]. 110 | apply rat_lt_reflecting in E3. 111 | pose proof (snd (flip_pos_minus _ _) E3) as E4. 112 | assert (Hd : 0 < d). 113 | { revert E2;apply (Trunc_ind _). 114 | intros [s [s' [F1 [F2 F3]]]]. 115 | apply rat_le_reflecting in F3. 116 | apply lt_le_trans with s';trivial. 117 | apply le_lt_trans with s;trivial. 118 | apply rat_le_reflecting. 119 | transitivity (abs (lim x - lim y));trivial. 120 | apply Rabs_nonneg. 121 | } 122 | pose (D := mkQpos d Hd). 123 | pose (ED := mkQpos _ E4). 124 | assert (Hrw : e = D + (ED / 4 + ED / 4) + (ED / 4 + ED / 4)). 125 | { path_via (D + ED). 126 | { apply pos_eq;unfold D, ED. 127 | abstract ring_tac.ring_with_integers (NatPair.Z nat). 128 | } 129 | path_via (D + 4 / 4 * ED). 130 | { rewrite pos_recip_r,Qpos_mult_1_l;trivial. } 131 | apply pos_eq;abstract ring_tac.ring_with_nat. 132 | } 133 | rewrite Hrw. 134 | eapply (equiv_triangle _);[|apply (equiv_lim _)]. 135 | apply IHy. apply (Rlt_close_rat_plus _ _ E2). 136 | apply (non_expanding (fun u => abs (lim x - u))). 137 | apply (equiv_symm _),(equiv_lim _). 138 | Qed. 139 | 140 | Lemma metric_to_equiv@{} : forall e u v, abs (u - v) < rat (' e) -> close e u v. 141 | Proof. 142 | intros e u v;revert u v e;apply (C_ind0 _ (fun u => forall v e, _ -> _)); 143 | [intros q|intros x IHx]; 144 | (apply (C_ind0 _ (fun v => forall e, _ -> _));[intros r|intros y IHy]); 145 | intros e E1. 146 | - apply equiv_eta_eta. apply Qclose_alt. 147 | apply rat_lt_reflecting,E1. 148 | - apply metric_to_equiv_rat_lim;auto. 149 | - apply (equiv_symm _),metric_to_equiv_rat_lim. 150 | + intros n n' E;apply (equiv_symm _),IHx. 151 | rewrite Rabs_neg_flip. trivial. 152 | + rewrite Rabs_neg_flip. trivial. 153 | - apply metric_to_equiv_lim_lim;auto. 154 | Qed. 155 | 156 | Lemma equiv_metric_applied_rw' 157 | : forall e u v, close e u v = (abs (u - v) < rat (' e)). 158 | Proof. 159 | intros. apply TruncType.path_iff_ishprop_uncurried. 160 | split. 161 | - apply equiv_to_metric. 162 | - apply metric_to_equiv. 163 | Qed. 164 | 165 | Definition equiv_metric_applied_rw@{} := equiv_metric_applied_rw'@{Ularge}. 166 | 167 | Lemma equiv_metric_rw' : close = fun e u v => abs (u - v) < rat (' e). 168 | Proof. 169 | repeat (apply path_forall;intro). 170 | apply equiv_metric_applied_rw. 171 | Qed. 172 | 173 | Definition equiv_metric_rw@{} := equiv_metric_rw'. 174 | -------------------------------------------------------------------------------- /theories/cauchy_reals/order.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTTClasses.cauchy_completion. 19 | 20 | Require Export 21 | HoTTClasses.cauchy_reals.base. 22 | 23 | Local Set Universe Minimization ToSet. 24 | 25 | Lemma Rle_close_rat_rat' : forall q v e, close e (rat q) v -> 26 | v <= rat (q + ' e). 27 | Proof. 28 | intros q. 29 | apply (C_ind0 _ (fun v => forall e, _ -> _)). 30 | + intros s e E'. 31 | rewrite (equiv_eta_eta_def _) in E'. 32 | hnf in E'. apply (order_preserving rat). 33 | rewrite plus_comm. apply flip_le_minus_l. 34 | apply flip_le_negate. rewrite <-negate_swap_r. apply lt_le,E'. 35 | + intros y IH e xi. 36 | apply (equiv_rounded _) in xi. 37 | revert xi;apply (Trunc_ind _);intros [d [d' [He xi]]]. 38 | hnf. unfold join,Rjoin. rewrite lipschitz_extend_binary_lim. 39 | change (lipschitz_extend_binary _ _ (fun q r => eta (join q r)) 1 1) with join. 40 | assert (E1 : forall n n', d' = n + n' -> y n <= rat (q + ' e)). 41 | { intros n n' Hd. 42 | apply IH. rewrite He. apply (equiv_triangle _) with (lim y);trivial. 43 | apply (equiv_symm _). rewrite Hd,qpos_plus_comm. apply (equiv_lim _). 44 | } 45 | apply equiv_path. intros z. 46 | destruct (Qpos_lt_min z d') as [a [ca [cb [E2 E3]]]]. 47 | eapply (equiv_lim_eta _);[|simpl;erewrite E1;[apply (equiv_refl _)|]]. 48 | * exact E2. 49 | * rewrite <-(Qpos_mult_1_l a),pos_unconjugate. exact E3. 50 | Qed. 51 | 52 | Definition Rle_close_rat_rat@{} 53 | := Rle_close_rat_rat'@{UQ}. 54 | 55 | Lemma Rle_close_rat@{} : forall q u, u <= rat q -> forall v e, close e u v -> 56 | v <= rat (q + ' e). 57 | Proof. 58 | intros q u E v e xi. 59 | pose proof (non_expanding (join (rat q)) xi) as E1. 60 | hnf in E. rewrite Rjoin_comm in E1. 61 | rewrite E in E1. 62 | apply Rle_close_rat_rat in E1. 63 | transitivity (join (rat q) v);trivial. 64 | apply join_ub_r. 65 | Qed. 66 | 67 | Lemma Rlt_close_rat_plus@{} : forall u q, u < rat q -> 68 | forall v e, close e u v -> v < rat (q + ' e). 69 | Proof. 70 | intros u q E;apply R_archimedean in E;revert E; 71 | apply (Trunc_ind (fun _ => forall v e, _ -> _)). 72 | intros [r [E1 E2]] v e xi. 73 | apply R_lt_le in E1. pose proof (Rle_close_rat _ _ E1 _ _ xi) as E3. 74 | apply R_le_lt_trans with (rat (r + ' e));trivial. 75 | apply rat_lt_preserving. apply rat_lt_reflecting in E2. 76 | apply (strictly_order_preserving (+ (' e))). trivial. 77 | Qed. 78 | 79 | Lemma Rlt_close_plus@{} : forall u v, u < v -> 80 | forall w e, close e u w -> w < v + rat (' e). 81 | Proof. 82 | intros u v E w e xi;apply R_archimedean in E;revert E;apply (Trunc_ind _); 83 | intros [q [E1 E2]]. 84 | apply R_lt_le_trans with (rat (q + ' e)). 85 | - apply Rlt_close_rat_plus with u;trivial. 86 | - rewrite plus_comm. rewrite Rplus_comm. 87 | change (rat (' e) + rat q <= rat (' e) + v). 88 | apply (order_preserving (rat (' e) +)),R_lt_le;trivial. 89 | Qed. 90 | 91 | Lemma Rlt_cotrans_rat@{} : forall x q r, q < r -> hor (rat q < x) (x < rat r). 92 | Proof. 93 | apply (C_ind0 _ (fun x => forall q r, _ -> _)). 94 | - intros s q r E. generalize (cotransitive E s). 95 | apply (Trunc_ind _);intros [E'|E'];apply tr;[left|right]; 96 | apply rat_lt_preserving,E'. 97 | - intros x IH q r E0. 98 | destruct (Q_dense _ _ E0) as [q1 [E1 E2]]. 99 | destruct (Q_dense _ _ E2) as [r1 [E3 E4]]. 100 | clear E0 E2. 101 | destruct (Qpos_lt_min (Qpos_diff _ _ E1) (Qpos_diff _ _ E4)) 102 | as [n [n1 [n2 [Hn1 Hn2]]]]. 103 | generalize (IH n _ _ E3);apply (Trunc_ind _). 104 | intros [E5|E5];apply tr;[left|right]. 105 | + apply Rneg_lt_flip. change (- lim x < rat (- q)). 106 | assert (Hrw : - q = - q1 + ' Qpos_diff q q1 E1). 107 | { set (D := Qpos_diff q q1 E1). 108 | rewrite (Qpos_diff_pr _ _ E1). unfold D;clear D. 109 | rewrite negate_plus_distr. rewrite <-plus_assoc,plus_negate_l,plus_0_r. 110 | trivial. 111 | } 112 | rewrite Hrw;clear Hrw. 113 | apply Rlt_close_rat_plus with (- (x n)). 114 | * apply (snd (Rneg_lt_flip _ _) E5). 115 | * apply (non_expanding (-)). 116 | rewrite Hn1. rewrite qpos_plus_comm. apply (equiv_lim _). 117 | + rewrite (Qpos_diff_pr _ _ E4). 118 | apply Rlt_close_rat_plus with (x n);trivial. 119 | rewrite Hn2,qpos_plus_comm. apply (equiv_lim _). 120 | Qed. 121 | 122 | Instance Rlt_cotrans@{} : CoTransitive (@lt real _). 123 | Proof. 124 | hnf. intros x y E z;revert E;apply (Trunc_ind _);intros [q [r [E1 [E2 E3]]]]. 125 | generalize (Rlt_cotrans_rat z q r E2);apply (Trunc_ind _). 126 | intros [E4|E4];apply tr;[left|right]. 127 | - apply R_le_lt_trans with (rat q);trivial. 128 | - apply R_lt_le_trans with (rat r);trivial. 129 | Qed. 130 | 131 | Instance Rap_cotrans@{} : CoTransitive (@apart real _). 132 | Proof. 133 | hnf. intros x y [E|E] z. 134 | - apply (merely_destruct (cotransitive E z)). 135 | intros [E1|E1];apply tr;[left|right];hnf;auto. 136 | - apply (merely_destruct (cotransitive E z)). 137 | intros [E1|E1];apply tr;[right|left];hnf;auto. 138 | Qed. 139 | -------------------------------------------------------------------------------- /theories/cauchy_reals/recip.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTT.HIT.surjective_factor 20 | HoTTClasses.cauchy_completion. 21 | 22 | Require Export 23 | HoTTClasses.cauchy_reals.base 24 | HoTTClasses.cauchy_reals.abs 25 | HoTTClasses.cauchy_reals.order 26 | HoTTClasses.cauchy_reals.metric 27 | HoTTClasses.cauchy_reals.ring 28 | HoTTClasses.cauchy_reals.full_order. 29 | 30 | Local Set Universe Minimization ToSet. 31 | 32 | Definition Qpos_upper_recip (e:Q+) : real -> real 33 | := lipschitz_extend _ (rat ∘ ((/) ∘ pr1 ∘ (Qpos_upper_inject e))) _. 34 | 35 | Instance Qpos_upper_recip_lipschitz : forall e, 36 | Lipschitz (Qpos_upper_recip e) _ 37 | := _. 38 | Typeclasses Opaque Qpos_upper_recip. 39 | 40 | Definition pos_back : (exists e : Q+, exists x : real, rat (' e) <= x) -> 41 | exists x : real, 0 < x. 42 | Proof. 43 | intros s;exists (s.2.1). 44 | apply R_lt_le_trans with (rat (' s.1)). 45 | - apply rat_lt_preserving;solve_propholds. 46 | - apply s.2.2. 47 | Defined. 48 | 49 | Lemma Qpos_upper_recip_respects : forall (x : exists (e : Q+) (x : real), rat (' e) ≤ x) 50 | (y : exists (e : Q+) (x0 : real), rat (' e) ≤ x0), 51 | pos_back x = pos_back y -> 52 | Qpos_upper_recip x.1 (x.2).1 = Qpos_upper_recip y.1 (y.2).1. 53 | Proof. 54 | intros [e1 [x Ex]] [e2 [y Ey]] E. 55 | apply (ap pr1) in E. simpl in E. 56 | simpl. 57 | destruct E. 58 | pose proof (join_le _ _ _ Ex Ey) as E;clear Ex Ey. 59 | rewrite <-E;clear E. 60 | revert x. apply (unique_continuous_extension _ _ _). 61 | intros q. unfold Qpos_upper_recip;simpl. 62 | change (rat ((dec_recip ∘ pr1 ∘ Qpos_upper_inject e1) ((' e1 ⊔ ' e2) ⊔ q)) = 63 | rat ((dec_recip ∘ pr1 ∘ Qpos_upper_inject e2) ((' e1 ⊔ ' e2) ⊔ q))). 64 | apply (ap rat). unfold Compose;simpl. 65 | apply ap. 66 | rewrite <-(simple_associativity (f:=join)),(commutativity (f:=join) q). 67 | rewrite (simple_associativity (f:=join)),(commutativity (f:=join) _ (' e1)). 68 | rewrite (simple_associativity (f:=join)),(idempotency _ _). 69 | set (LEFT := (' e1 ⊔ ' e2) ⊔ q) at 1. 70 | rewrite <-(simple_associativity (f:=join)),(commutativity (f:=join) q). 71 | rewrite (simple_associativity (f:=join)). 72 | rewrite <-(simple_associativity (f:=join) (' e1)),(idempotency join (' e2)). 73 | reflexivity. 74 | Qed. 75 | 76 | Lemma Qpos_upper_recip_invariant : forall x e e', 77 | rat (' e) <= x -> rat (' e') <= x -> 78 | Qpos_upper_recip e x = Qpos_upper_recip e' x. 79 | Proof. 80 | intros x e e' E1 E2. 81 | apply (Qpos_upper_recip_respects (e; (x; E1)) (e'; (x; E2))). 82 | unfold pos_back. simpl. 83 | apply Sigma.path_sigma_hprop. simpl. reflexivity. 84 | Qed. 85 | 86 | Lemma pos_back_issurj0 : IsSurjection pos_back. 87 | Proof. 88 | apply BuildIsSurjection. intros s. 89 | generalize s.2. apply (Trunc_ind _). 90 | intros [q [r [E1 [E2 E3]]]]. 91 | apply tr. simple refine (existT _ _ _). 92 | + simple refine (existT _ _ _). 93 | * exists r. apply le_lt_trans with q;trivial. apply rat_le_reflecting;trivial. 94 | * simpl. exists s.1. unfold cast;simpl. trivial. 95 | + simpl. unfold pos_back. simpl. apply Sigma.path_sigma_hprop. reflexivity. 96 | Defined. 97 | 98 | Definition pos_back_issurj@{} : IsSurjection pos_back 99 | := Eval unfold pos_back_issurj0 in pos_back_issurj0@{Uhuge Ularge Ularge}. 100 | Existing Instance pos_back_issurj. 101 | 102 | Definition R_pos_recip@{} : (exists x : real, 0 < x) -> real. 103 | Proof. 104 | simple refine (surjective_factor@{UQ UQ UQ Uhuge Ularge 105 | Ularge Ularge Ularge UQ Ularge 106 | UQ Uhuge Ularge} _ pos_back _). 107 | - intros s. exact (Qpos_upper_recip s.1 s.2.1). 108 | - simpl. exact Qpos_upper_recip_respects. 109 | Defined. 110 | 111 | Lemma R_pos_recip_pr@{} : forall x, Qpos_upper_recip x.1 (x.2).1 = R_pos_recip (pos_back x). 112 | Proof. 113 | apply surjective_factor_pr. 114 | Qed. 115 | 116 | Lemma R_pos_recip_rat : forall q (Eq : 0 < rat q), 117 | R_pos_recip (existT _ (rat q) Eq) = rat (/ q). 118 | Proof. 119 | intros q; apply (Trunc_ind _);intros [r [s [E1 [E2 E3]]]]. 120 | set (xq := (rat q; _)). 121 | generalize (center _ (pos_back_issurj xq)). apply (Trunc_ind _). 122 | intros [[e [x a]] b]. rewrite <-b. 123 | rewrite <-R_pos_recip_pr. simpl. 124 | unfold pos_back in b. simpl in b. apply (ap pr1) in b. simpl in b. 125 | rewrite b in a |- *. 126 | change ((rat ∘ (/)) (join q (' e)) = (rat ∘ (/)) q). 127 | apply ap. apply join_l. 128 | apply rat_le_reflecting;trivial. 129 | Qed. 130 | 131 | Instance Rrecip : Recip real. 132 | Proof. 133 | intros [x [E|E]]. 134 | - apply negate,R_pos_recip;exists (- x). apply flip_neg_negate. trivial. 135 | - apply R_pos_recip;exists x;trivial. 136 | Defined. 137 | 138 | Lemma Rrecip_rat@{} : forall q (Eq : apart (rat q) 0), 139 | // (existT (fun y => apart y 0) (rat q) Eq) = rat (/ q). 140 | Proof. 141 | simpl;intros q [Eq|Eq];unfold recip;simpl. 142 | - change (- rat q) with (rat (- q)). rewrite R_pos_recip_rat@{Uhuge Ularge}. 143 | apply (ap rat). 144 | rewrite dec_recip_negate@{UQ Ularge},involutive. trivial. 145 | - apply R_pos_recip_rat@{Uhuge Ularge}. 146 | Qed. 147 | 148 | Lemma Rneg_strong_ext : StrongExtensionality (negate (A:=real)). 149 | Proof. 150 | hnf. intros x y [E|E];[right|left];apply Rneg_lt_flip,E. 151 | Defined. 152 | 153 | Instance Rneg_strong_injective : StrongInjective (negate (A:=real)). 154 | Proof. 155 | split;try apply Rneg_strong_ext. 156 | intros x y [E|E];[right|left];apply Rneg_lt_flip;rewrite !involutive;trivial. 157 | Defined. 158 | 159 | Definition R_apartzero_neg : ApartZero real -> ApartZero real. 160 | Proof. 161 | intros x. exists (- x.1). 162 | destruct (x.2) as [E|E];[right|left]. 163 | - apply flip_neg_negate;trivial. 164 | - apply flip_pos_negate;trivial. 165 | Defined. 166 | 167 | Lemma Rrecip_neg : forall x, - (// x) = // (R_apartzero_neg x). 168 | Proof. 169 | intros [x [E|E]];unfold recip;simpl. 170 | - apply involutive. 171 | - apply ap. apply ap. apply Sigma.path_sigma_hprop. simpl. 172 | symmetry;apply involutive. 173 | Qed. 174 | 175 | Lemma R_recip_upper_recip : forall x e, rat (' e) <= x -> 176 | forall (E : apart x 0), 177 | // (existT (fun y => apart y 0) x E) 178 | = Qpos_upper_recip e x. 179 | Proof. 180 | intros x e E1 [E2|E2]. 181 | - destruct (irreflexivity lt x). 182 | transitivity 0;trivial. apply R_lt_le_trans with (rat (' e));trivial. 183 | apply rat_lt_preserving;solve_propholds. 184 | - unfold recip;simpl. revert E2;apply (Trunc_ind _);intros [q [r [E2 [E3 E4]]]]. 185 | set (X := (x;_)). 186 | generalize (center _ (pos_back_issurj X)). apply (Trunc_ind _). 187 | intros [[e' [y a]] b]. 188 | rewrite <-b, <-R_pos_recip_pr. 189 | apply (ap pr1),symmetry in b;simpl in b. destruct b. 190 | simpl. clear X. 191 | apply Qpos_upper_recip_invariant;trivial. 192 | Qed. 193 | 194 | Instance real_nontrivial : PropHolds (apart (A:=real) 1 0). 195 | Proof. 196 | right. apply rat_lt_preserving;solve_propholds. 197 | Defined. 198 | 199 | Lemma R_pos_recip_inverse : forall x E, x // (existT _ x (inr E)) = 1 :> real. 200 | Proof. 201 | intros x E. 202 | apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E)). intros [e E1]. 203 | rewrite plus_0_l in E1. 204 | rewrite (R_recip_upper_recip@{Uhuge Ularge} _ _ E1). 205 | rewrite <-E1. clear E E1;revert x. 206 | apply (unique_continuous_extension _). 207 | - change (Continuous (uncurry mult ∘ 208 | map2 (join (rat (' e))) (Qpos_upper_recip e ∘ (join (rat (' e)))) ∘ 209 | BinaryDup)). 210 | repeat apply continuous_compose;apply _. 211 | - apply _. 212 | - intros q. 213 | change (rat ((' e ⊔ q) * (dec_recip ∘ pr1 ∘ Qpos_upper_inject e) (' e ⊔ q)) = 214 | rat 1). 215 | apply (ap rat). 216 | unfold Compose;simpl. 217 | rewrite (commutativity (f:=join) _ (' e)),(simple_associativity (f:=join)). 218 | rewrite (idempotency _ _). 219 | apply dec_recip_inverse. 220 | apply lt_ne_flip. 221 | apply lt_le_trans with (' e). 222 | + solve_propholds. 223 | + apply join_ub_l. 224 | Unshelve. exact 1. 225 | Qed. 226 | 227 | Lemma R_recip_inverse@{} : forall x, x.1 // x = 1 :> real. 228 | Proof. 229 | intros [x [E|E]];simpl. 230 | - rewrite <-negate_mult_negate,Rrecip_neg. unfold R_apartzero_neg. simpl. 231 | apply R_pos_recip_inverse. 232 | - apply R_pos_recip_inverse. 233 | Qed. 234 | -------------------------------------------------------------------------------- /theories/cauchy_reals/ring.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.HIT.surjective_factor 19 | HoTT.Classes.implementations.assume_rationals 20 | HoTTClasses.cauchy_completion. 21 | 22 | Require Export 23 | HoTTClasses.cauchy_reals.base 24 | HoTTClasses.cauchy_reals.abs 25 | HoTTClasses.cauchy_reals.order 26 | HoTTClasses.cauchy_reals.metric. 27 | 28 | Local Set Universe Minimization ToSet. 29 | 30 | Lemma R_Qpos_bounded@{} : forall x : real, 31 | merely (exists q : Q+, abs x < rat (' q)). 32 | Proof. 33 | apply (C_ind0 _ _). 34 | - intros q;apply tr. simple refine (existT _ _ _). 35 | + exists (abs q + 1). 36 | abstract (apply le_lt_trans with (abs q); 37 | [apply Qabs_nonneg|apply pos_plus_lt_compat_r;solve_propholds]). 38 | + simpl. apply rat_lt_preserving. change (abs q < abs q + 1). 39 | abstract (apply pos_plus_lt_compat_r;solve_propholds). 40 | - intros x IH. 41 | generalize (IH 1). 42 | apply (Trunc_ind _);intros [q E]. 43 | apply tr;exists (q + 2). 44 | change (abs (lim x) < rat (' q + ' 2)). 45 | apply Rlt_close_rat_plus with (abs (x 1)). 46 | + trivial. 47 | + apply (non_expanding abs). 48 | apply (equiv_lim _). 49 | Defined. 50 | 51 | Lemma R_bounded_2@{} : forall u v, 52 | merely (exists d : Q+, abs u < rat (' d) /\ abs v < rat (' d)). 53 | Proof. 54 | intros. 55 | apply (merely_destruct (R_Qpos_bounded u)). 56 | intros [d Ed]. 57 | apply (merely_destruct (R_Qpos_bounded v)). 58 | intros [n En]. 59 | apply tr;exists (join d n). 60 | repeat split. 61 | - apply R_lt_le_trans with (rat (' d));trivial. 62 | apply rat_le_preserving,join_ub_l. 63 | - apply R_lt_le_trans with (rat (' n));trivial. 64 | apply rat_le_preserving,join_ub_r. 65 | Qed. 66 | 67 | Definition QRmult@{} : Q -> real -> real 68 | := fun q => lipschitz_extend _ (Compose rat (q *.)) (pos_of_Q q). 69 | 70 | Instance QRmult_lipschitz : forall q, Lipschitz (QRmult q) (pos_of_Q q) 71 | := _. 72 | Typeclasses Opaque QRmult. 73 | 74 | Lemma QRmult_negate : forall q u, - QRmult q u = QRmult (- q) u. 75 | Proof. 76 | intro;apply (unique_continuous_extension _ _ _). 77 | intros r;apply (ap rat). apply negate_mult_distr_l. 78 | Qed. 79 | 80 | Lemma QRmult_plus_distr : forall q r u, QRmult q u + QRmult r u = QRmult (q + r) u. 81 | Proof. 82 | intros q r;apply (unique_continuous_extension _);try apply _. 83 | { change (Continuous (uncurry (+) ∘ map2 (QRmult q) (QRmult r) ∘ BinaryDup)). 84 | apply _. } 85 | intros s;apply (ap rat). symmetry;apply distribute_r. 86 | Qed. 87 | 88 | Lemma QRmult_lipschitz_interval_aux (a:Q+) 89 | : forall x, abs x <= rat (' a) -> 90 | forall q r : Q, abs (QRmult q x - QRmult r x) <= rat (abs (q - r) * ' a). 91 | Proof. 92 | intros x E q r. rewrite QRmult_negate,QRmult_plus_distr. 93 | change (rat (abs (q - r) * ' a)) with (QRmult (abs (q - r)) (rat (' a))). 94 | rewrite <-E. clear E. 95 | revert x;apply (unique_continuous_extension _). 96 | - change (Continuous (uncurry join ∘ 97 | map2 (abs ∘ QRmult (q - r)) (QRmult (abs (q - r)) ∘ (⊔ rat (' a)) ∘ abs) ∘ 98 | BinaryDup)). 99 | apply _. 100 | - change (Continuous (QRmult (abs (q - r)) ∘ (⊔ rat (' a)) ∘ abs)). 101 | apply _. 102 | - intros s. 103 | change (rat (abs ((q - r) * s) ⊔ abs (q - r) * (abs s ⊔ ' a)) = 104 | rat (abs (q - r) * (abs s ⊔ ' a))). 105 | apply (ap rat). 106 | apply join_r. 107 | rewrite Qabs_mult. apply mult_le_compat. 108 | + apply Qabs_nonneg. 109 | + apply Qabs_nonneg. 110 | + reflexivity. 111 | + apply join_ub_l. 112 | Qed. 113 | 114 | Instance Qbounded_lipschitz (a : Q+) 115 | : forall v : Interval (- rat (' a)) (rat (' a)), 116 | Lipschitz (fun q : Q => QRmult q (interval_proj _ _ v)) a. 117 | Proof. 118 | intros v e x y xi. 119 | apply Qclose_alt in xi. apply metric_to_equiv. 120 | eapply R_le_lt_trans. 121 | + apply (QRmult_lipschitz_interval_aux a). 122 | apply (snd (Rabs_le_pr _ _)). 123 | split;apply v.2. 124 | + apply rat_lt_preserving. rewrite mult_comm. 125 | apply pos_mult_le_lt_compat;try split;try solve_propholds. 126 | * reflexivity. 127 | * apply Qabs_nonneg. 128 | Qed. 129 | 130 | Definition Rbounded_mult@{} (a : Q+) 131 | : real -> Interval (- rat (' a)) (rat (' a)) -> real 132 | := fun u v => lipschitz_extend _ 133 | (fun q => QRmult q (interval_proj _ _ v)) a u. 134 | 135 | Instance Rbounded_mult_lipschitz : forall a v, 136 | Lipschitz (fun u => Rbounded_mult a u v) a 137 | := _. 138 | Typeclasses Opaque Rbounded_mult. 139 | 140 | Definition interval_back 141 | : sigT (fun a : Q+ => Interval (- rat (' a)) (rat (' a))) -> real 142 | := fun x => x.2.1. 143 | 144 | Instance interval_proj_issurj@{} 145 | : TrM.RSU.IsConnMap@{Uhuge Ularge UQ UQ Ularge} (trunc_S minus_two) interval_back. 146 | Proof. 147 | apply BuildIsSurjection. intros x. 148 | generalize (R_Qpos_bounded x). apply (Trunc_ind _);intros [q E]. 149 | apply tr. simple refine (existT _ _ _). 150 | - exists q. exists x. apply Rabs_le_pr. apply R_lt_le. exact E. 151 | - simpl. reflexivity. 152 | Defined. 153 | 154 | Lemma Rbounded_mult_respects : forall z x y, interval_back x = interval_back y -> 155 | Rbounded_mult x.1 z x.2 = Rbounded_mult y.1 z y.2. 156 | Proof. 157 | intros z x y E. 158 | revert z. apply (unique_continuous_extension _ _ _). 159 | intros q. unfold Rbounded_mult. 160 | exact (ap _ E). 161 | Qed. 162 | 163 | Definition Rmult@{} : Mult real 164 | := fun x => surjective_factor@{UQ UQ UQ Uhuge Ularge 165 | Ularge Ularge Ularge UQ Ularge 166 | UQ Uhuge Ularge} 167 | _ interval_back (Rbounded_mult_respects x). 168 | 169 | Global Existing Instance Rmult. 170 | 171 | Lemma Rmult_pr@{} x : (fun y => Rbounded_mult y.1 x y.2) = 172 | Compose (x *.) interval_back. 173 | Proof. 174 | apply path_forall,surjective_factor_pr. 175 | Qed. 176 | 177 | Definition Rmult_rat_rat@{} q r : (rat q) * (rat r) = rat (q * r) 178 | := idpath. 179 | 180 | Lemma Rmult_interval_proj_applied : forall a x y, 181 | x * interval_proj (rat (- ' a)) (rat (' a)) y = 182 | Rbounded_mult a x y. 183 | Proof. 184 | intros;change (Rbounded_mult a x) with 185 | ((fun y : exists a, Interval (rat (- ' a)) (rat (' a)) => 186 | Rbounded_mult y.1 x y.2) ∘ (fun s => existT _ a s)). 187 | rewrite Rmult_pr. reflexivity. 188 | Qed. 189 | 190 | Lemma Rmult_interval_proj : forall a y, 191 | (fun x => x * interval_proj (rat (- ' a)) (rat (' a)) y) = 192 | (fun x => Rbounded_mult a x y). 193 | Proof. 194 | intros. apply path_forall. intros x. 195 | apply Rmult_interval_proj_applied. 196 | Qed. 197 | 198 | Lemma Rmult_lipschitz_aux : forall a y, 199 | Lipschitz (.* (interval_proj (rat (- ' a)) (rat (' a)) y)) a. 200 | Proof. 201 | intros a y. rewrite Rmult_interval_proj. apply _. 202 | Qed. 203 | 204 | Lemma Rmult_lipschitz_aux_alt : forall a y, abs y <= rat (' a) -> 205 | Lipschitz (.* y) a. 206 | Proof. 207 | intros a y E. apply Rabs_le_pr in E. 208 | change y with (interval_proj (rat (- ' a)) (rat (' a)) (existT _ y E)). 209 | apply Rmult_lipschitz_aux. 210 | Qed. 211 | 212 | Instance Rmult_continuous_r@{} : forall y : real, Continuous (.* y). 213 | Proof. 214 | intros. red. apply (merely_destruct (R_Qpos_bounded y)). 215 | intros [a Eq]. apply R_lt_le in Eq. apply Rabs_le_pr in Eq. 216 | change (Continuous (.* y)). eapply lipschitz_continuous. 217 | change (.* y) with (.* (interval_proj (rat (- ' a)) (rat (' a)) (existT _ y Eq))). 218 | apply Rmult_lipschitz_aux. 219 | Qed. 220 | 221 | Lemma Rmult_rat_l q x : rat q * x = QRmult q x. 222 | Proof. 223 | apply (merely_destruct (R_Qpos_bounded x)). 224 | intros [d Ed]. 225 | apply R_lt_le in Ed. apply Rabs_le_pr in Ed. 226 | change (rat q * x) with 227 | (rat q * interval_proj (rat (- ' d)) (rat (' d)) (existT _ x Ed)). 228 | rewrite Rmult_interval_proj_applied. reflexivity. 229 | Qed. 230 | 231 | Lemma Rmult_abs_l : forall a b c, abs (a * b - a * c) = abs a * abs (b - c). 232 | Proof. 233 | intros a b c;revert a. apply (unique_continuous_extension _). 234 | { change (Continuous (abs ∘ uncurry plus ∘ map2 (.* b) (negate ∘ (.* c)) ∘ 235 | (@BinaryDup real))). 236 | apply _. 237 | } 238 | { change (Continuous ((.* (abs (b - c))) ∘ abs)). 239 | apply _. } 240 | intros q. 241 | change (abs (rat q)) with (rat (abs q)). 242 | rewrite !Rmult_rat_l. 243 | revert b c. apply unique_continuous_binary_extension. 244 | { change (Continuous (abs ∘ uncurry plus ∘ map2 (QRmult q) (negate ∘ QRmult q))). 245 | apply _. } 246 | { change (Continuous (QRmult (abs q) ∘ abs ∘ uncurry plus ∘ map2 id negate)). 247 | apply _. } 248 | intros r s. change (rat (abs (q * r - q * s)) = rat (abs q * abs (r - s))). 249 | apply (ap rat). 250 | rewrite negate_mult_distr_r,<-plus_mult_distr_l. 251 | apply Qabs_mult. 252 | Qed. 253 | 254 | Lemma Rmult_le_compat_abs@{} : forall a b c d : real, abs a <= abs c -> 255 | abs b <= abs d -> 256 | abs a * abs b <= abs c * abs d. 257 | Proof. 258 | intros ???? E1 E2;rewrite <-E1,<-E2. clear E1 E2. 259 | red;simpl. 260 | revert a c. apply unique_continuous_binary_extension. 261 | { change (Continuous (uncurry join ∘ map2 262 | ((.* abs b) ∘ abs ∘ fst) 263 | ((.* (join (abs b) (abs d))) ∘ uncurry join ∘ map2 abs abs) ∘ 264 | BinaryDup)). 265 | repeat apply continuous_compose. 1,3:apply _. 266 | apply map2_continuous. 1,2:apply _. 267 | { apply continuous_compose. 2:apply _. 268 | apply continuous_compose;apply _. } 269 | { apply continuous_compose;apply _. } 270 | } 271 | { change (Continuous ((.* (join (abs b) (abs d))) ∘ uncurry join ∘ map2 abs abs)). 272 | apply _. } 273 | intros q r. 274 | change (abs (rat q)) with (rat (abs q)); 275 | change (abs (rat r)) with (rat (abs r)). 276 | change (rat (abs q) ⊔ rat (abs r)) with 277 | (rat (abs q ⊔ abs r)). 278 | rewrite !Rmult_rat_l. 279 | revert b d. apply unique_continuous_binary_extension. 280 | { change (Continuous (uncurry join ∘ map2 281 | (QRmult (abs q) ∘ abs ∘ fst) 282 | (QRmult (join (abs q) (abs r)) ∘ uncurry join ∘ map2 abs abs) ∘ 283 | BinaryDup)). 284 | apply _. } 285 | { change (Continuous (QRmult (join (abs q) (abs r)) ∘ uncurry join ∘ map2 abs abs)). 286 | apply _. } 287 | intros s t. 288 | change (rat (abs q * abs s ⊔ (abs q ⊔ abs r) * (abs s ⊔ abs t)) = 289 | rat ((abs q ⊔ abs r) * (abs s ⊔ abs t))). 290 | apply (ap rat). 291 | apply join_r. apply mult_le_compat. 292 | - apply Qabs_nonneg. 293 | - apply Qabs_nonneg. 294 | - apply join_ub_l. 295 | - apply join_ub_l. 296 | Qed. 297 | 298 | Lemma Rmult_continuous@{} : Continuous (uncurry (@mult real _)). 299 | Proof. 300 | intros [u1 v1] e. 301 | apply (merely_destruct (R_bounded_2 u1 v1));intros [d [Ed1 Ed2]]. 302 | pose (k := d + 1). 303 | (* assert (Ed3 : ' d < ' k). { apply pos_plus_lt_compat_r;solve_propholds. } *) 304 | apply tr;exists (meet 1 (e / 2 / (k + 1))); 305 | intros [u2 v2] [xi1 xi2];unfold uncurry;simpl in *. 306 | rewrite (pos_split2 e). apply (triangular _ (u2 * v1)). 307 | - apply R_lt_le in Ed2. 308 | pose proof (Rmult_lipschitz_aux_alt _ _ Ed2) as E1. 309 | apply lipschitz_uniform in E1. 310 | apply E1. eapply rounded_le;[exact xi1|]. 311 | etransitivity;[apply meet_lb_r|]. 312 | apply mult_le_compat;try solve_propholds. 313 | + reflexivity. 314 | + unfold cast;simpl. apply flip_le_dec_recip. 315 | * solve_propholds. 316 | * change (' d <= ' d + 1 + 1). rewrite <-plus_assoc. 317 | apply nonneg_plus_le_compat_r. solve_propholds. 318 | - apply metric_to_equiv. rewrite Rmult_abs_l. 319 | apply R_le_lt_trans with (abs (rat (' k)) * abs (rat (' (e / 2 / (k + 1))))). 320 | + apply Rmult_le_compat_abs. 321 | * change (abs (rat (' k))) with (rat (abs (' k))). 322 | unfold abs at 2. rewrite (fst (abs_sig (' _)).2);[|solve_propholds]. 323 | unfold k. 324 | eapply Rle_close_rat;[|apply (non_expanding abs (x:=u1))]. 325 | ** apply R_lt_le;trivial. 326 | ** eapply rounded_le;[exact xi1|]. apply meet_lb_l. 327 | * change (abs (rat (' (e / 2 / (k + 1))))) with 328 | (rat (abs (' (e / 2 / (k + 1))))). 329 | unfold abs at 2. rewrite (fst (abs_sig (' _)).2);[|solve_propholds]. 330 | apply equiv_to_metric in xi2. 331 | etransitivity;[apply R_lt_le,xi2|]. 332 | apply rat_le_preserving,meet_lb_r. 333 | + apply rat_lt_preserving. 334 | rewrite <-Qabs_mult. 335 | change (' k * ' (e / 2 / (k + 1))) with 336 | (' (k * (e / 2 / (k + 1)))). 337 | unfold abs;rewrite (fst (abs_sig (' _)).2);[|solve_propholds]. 338 | assert (Hrw : e / 2 = (e / 2) * 1) 339 | by (apply pos_eq;ring_tac.ring_with_nat); 340 | rewrite Hrw;clear Hrw. 341 | assert (Hrw : k * (e / 2 * 1 / (k + 1)) = (e / 2) * (k / (k + 1))) 342 | by (apply pos_eq;ring_tac.ring_with_nat); 343 | rewrite Hrw;clear Hrw. 344 | apply pos_mult_le_lt_compat;try split;try solve_propholds. 345 | * reflexivity. 346 | * apply (strictly_order_reflecting (.* (' (k + 1)))). 347 | unfold cast;simpl. unfold cast at 2;simpl. 348 | rewrite mult_1_l. 349 | rewrite <-mult_assoc, (mult_comm (/ _)),dec_recip_inverse,mult_1_r; 350 | [|apply lt_ne_flip;solve_propholds]. 351 | apply pos_plus_le_lt_compat_r. 352 | ** solve_propholds. 353 | ** reflexivity. 354 | Qed. 355 | Global Existing Instance Rmult_continuous. 356 | 357 | Instance Rmult_continuous_l : forall x : real, Continuous (x *.). 358 | Proof. 359 | change (forall x, Continuous (uncurry (@mult real _) ∘ (pair x))). 360 | intros;apply continuous_compose; apply _. 361 | Qed. 362 | 363 | Instance real_ring@{} : Ring real. 364 | Proof. 365 | repeat (split;try apply _); 366 | unfold sg_op,mon_unit,mult_is_sg_op,one_is_mon_unit; 367 | change Rmult with mult;change R1 with one. 368 | - hnf. apply unique_continuous_ternary_extension. 369 | + change (Continuous (uncurry mult ∘ map2 (@id real) (uncurry mult) ∘ 370 | prod_assoc^-1)). 371 | (* Why does [apply _] not work here? *) 372 | repeat apply continuous_compose; apply _. 373 | + change (Continuous (uncurry mult ∘ map2 (uncurry mult) (@id real))). 374 | apply _. 375 | + intros. change (rat (q * (r * s)) = rat (q * r * s)). apply (ap rat). 376 | apply associativity. 377 | - hnf. apply (unique_continuous_extension _ _ _). 378 | intros;apply (ap rat),left_identity. 379 | - hnf. apply (unique_continuous_extension _ _ _). 380 | intros;apply (ap rat),right_identity. 381 | - hnf. apply unique_continuous_binary_extension. 382 | + apply _. 383 | + change (Continuous (uncurry (@mult real _) ∘ prod_symm)). apply _. 384 | + intros;apply (ap rat),commutativity. 385 | - hnf. apply unique_continuous_ternary_extension. 386 | + change (Continuous (uncurry mult ∘ map2 (@id real) (uncurry plus) ∘ 387 | prod_assoc^-1)). 388 | apply _. 389 | + change (Continuous (uncurry (@plus real _) ∘ 390 | map2 (uncurry mult) (uncurry mult) ∘ 391 | map2 id prod_symm ∘ prod_assoc^-1 ∘ prod_symm ∘ map2 id prod_assoc ∘ 392 | prod_assoc^-1 ∘ map2 BinaryDup id ∘ prod_assoc^-1)). 393 | repeat apply continuous_compose;apply _. 394 | + intros;change (rat (q * (r + s)) = rat (q * r + q * s)); 395 | apply (ap rat),distribute_l. 396 | Qed. 397 | 398 | Instance Rmult_nonneg_compat : forall x y : real, PropHolds (0 ≤ x) -> 399 | PropHolds (0 ≤ y) -> 400 | PropHolds (0 ≤ x * y). 401 | Proof. 402 | unfold PropHolds. 403 | intros x y E1 E2;rewrite <-E1,<-E2;clear E1 E2. 404 | revert x y;apply unique_continuous_binary_extension. 405 | - change (Continuous ((join 0) ∘ uncurry (@mult real _) ∘ map2 (join 0) (join 0))). 406 | apply continuous_compose;[|apply _]. apply continuous_compose;[apply _|]. 407 | apply _. 408 | - change (Continuous (uncurry (@mult real _) ∘ (map2 (join 0) (join 0)))). 409 | apply _. 410 | - intros. change (rat (0 ⊔ (0 ⊔ q) * (0 ⊔ r)) = rat ((0 ⊔ q) * (0 ⊔ r))). 411 | apply ap. apply join_r. 412 | apply nonneg_mult_compat;apply join_ub_l. 413 | Qed. 414 | 415 | Instance real_srorder : SemiRingOrder Rle. 416 | Proof. 417 | apply from_ring_order;apply _. 418 | Qed. 419 | -------------------------------------------------------------------------------- /theories/cauchy_reals/uniform_on_intervals.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion. 20 | 21 | Require Export 22 | HoTTClasses.cauchy_reals.base 23 | HoTTClasses.cauchy_reals.abs 24 | HoTTClasses.cauchy_reals.order 25 | HoTTClasses.cauchy_reals.metric 26 | HoTTClasses.cauchy_reals.ring. 27 | 28 | Local Set Universe Minimization ToSet. 29 | 30 | Lemma uniform_on_intervals_continuous `{Closeness A} (f:real -> A) 31 | (mu : Q+ -> Q+ -> Q+) 32 | {Emu : forall a : Q+, 33 | Uniform (f ∘ interval_proj (rat (- ' a)) (rat (' a))) (mu a)} 34 | : Continuous f. 35 | Proof. 36 | intros u e. 37 | apply (merely_destruct (R_Qpos_bounded u)). intros [a Ea]. 38 | hnf in Emu. unfold Compose in Emu. 39 | apply (merely_destruct (R_archimedean _ _ Ea)). intros [q [Eq Eq']]. 40 | apply rat_lt_reflecting in Eq'. 41 | apply tr;exists (meet (mu a e) (Qpos_diff _ _ Eq')). 42 | intros v xi. 43 | assert (xi1 : close (mu a e) u v). 44 | { eapply rounded_le;[exact xi|]. 45 | apply meet_lb_l. } 46 | assert (xi2 : close (Qpos_diff q (' a) Eq') u v). 47 | { eapply rounded_le;[exact xi|]. 48 | apply meet_lb_r. } 49 | assert (E1 : rat (- ' a) <= u /\ u <= rat (' a)). 50 | { change (rat (- ' a)) with (- (rat (' a))). apply Rabs_le_pr. 51 | transitivity (rat q);apply R_lt_le;trivial. 52 | apply rat_lt_preserving;trivial. 53 | } 54 | assert (E2 : rat (- ' a) <= v /\ v <= rat (' a)). 55 | { change (rat (- ' a)) with (- (rat (' a))). apply Rabs_le_pr. 56 | rewrite (Qpos_diff_pr _ _ Eq'). 57 | apply R_lt_le. 58 | eapply Rlt_close_rat_plus;[exact Eq|]. 59 | apply (non_expanding abs),xi2. 60 | } 61 | exact (Emu _ _ (existT _ _ E1) (existT _ _ E2) xi1). 62 | Qed. 63 | -------------------------------------------------------------------------------- /theories/cauchy_semidec.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.Classes.interfaces.abstract_algebra 5 | HoTT.Classes.interfaces.integers 6 | HoTT.Classes.interfaces.naturals 7 | HoTT.Classes.interfaces.rationals 8 | HoTT.Classes.interfaces.orders 9 | HoTT.Classes.implementations.natpair_integers 10 | HoTT.Classes.theory.rings 11 | HoTT.Classes.theory.integers 12 | HoTT.Classes.theory.dec_fields 13 | HoTT.Classes.orders.dec_fields 14 | HoTT.Classes.theory.rationals 15 | HoTT.Classes.orders.lattices 16 | HoTT.Classes.theory.additional_operations 17 | HoTT.Classes.theory.premetric 18 | HoTT.Classes.implementations.assume_rationals 19 | HoTTClasses.cauchy_completion 20 | HoTTClasses.partiality 21 | HoTTClasses.sierpinsky 22 | HoTTClasses.cauchy_reals. 23 | 24 | Section compare_cauchy_rat. 25 | 26 | Instance semidecidable_ishprop : forall (x : real) (q : Q), 27 | IsHProp (exists s : Sier, s <-> x < rat q). 28 | Proof. 29 | intros x q. apply Sigma.ishprop_sigma_disjoint. 30 | intros a b [E1 E1'] [E2 E2']. 31 | apply (antisymmetry (<=));apply imply_le;intros E3;auto. 32 | Qed. 33 | 34 | Definition semidecidable_compare_rat_sig 35 | : forall x q, exists s : Sier, s <-> x < rat q. 36 | Proof. 37 | apply (C_ind0 _ (fun x => forall q, _)). 38 | - intros q r. exists (semi_decide (q < r)). 39 | split;intros E. 40 | + apply rat_lt_preserving,semi_decidable,E. 41 | + apply rat_lt_reflecting,semi_decidable in E;apply E. 42 | - intros x IH q. 43 | exists (semi_decide@{UQ} (merely (exists e : Q+, 44 | merely (exists d : Q+, (IH e (q - ' e - ' d)).1)))). 45 | split;intros E. 46 | + apply semi_decidable in E. 47 | revert E;apply (Trunc_ind _);intros [e E]; 48 | revert E;apply (Trunc_ind _);intros [d E]. 49 | set (s := _ : exists _, _) in E;apply s.2 in E;clear s. 50 | apply (fun E => Rlt_close_rat_plus _ _ E _ _ (equiv_lim _ _ d _)) in E. 51 | assert (Hrw : q - ' e - ' d + ' (d + e) = q) 52 | by abstract ring_tac.ring_with_integers (NatPair.Z nat); 53 | rewrite Hrw in E;clear Hrw. 54 | trivial. 55 | + apply (snd semi_decidable). 56 | apply R_archimedean in E;revert E;apply (Trunc_ind _);intros [r [E1 E2]]. 57 | apply rat_lt_reflecting in E2. pose (e := Qpos_diff _ _ E2). 58 | apply tr;exists (e/4);apply tr;exists (e/4). 59 | set (s := _ : sigT _);apply s.2;clear s. 60 | pose proof (fun a b => Rlt_close_rat_plus _ _ E1 _ _ 61 | (symmetry _ _ (equiv_lim _ _ a b))) as E3. 62 | assert (Hrw : q - ' (e / 4) - ' (e / 4) = r + ' (e / 4 + e / 4)); 63 | [|rewrite Hrw;apply E3]. 64 | assert (Hrw : 4 / 4 = 1 :> Q). 65 | { apply dec_recip_inverse. apply lt_ne_flip. solve_propholds. } 66 | rewrite <-(mult_1_r q),<-(mult_1_r r),<-Hrw. 67 | unfold e;clear e. repeat (unfold cast;simpl). 68 | abstract ring_tac.ring_with_integers (NatPair.Z nat). 69 | Defined. 70 | 71 | Instance semidecide_compare_rat x q : SemiDecide (x < rat q) 72 | := (semidecidable_compare_rat_sig x q).1. 73 | Instance semidecidable_compare_rat x q : SemiDecidable (x < rat q) 74 | := (semidecidable_compare_rat_sig x q).2. 75 | 76 | Instance semidecide_compare_rat_alt x q : SemiDecide (rat q < x) 77 | := semi_decide (- x < rat (- q)). 78 | Instance semidecidable_compare_rat_alt 79 | : forall x q, SemiDecidable (rat q < x). 80 | Proof. 81 | intros x q;split;intros E. 82 | - apply flip_lt_negate,semidecidable_compare_rat,E. 83 | - apply semidecidable_compare_rat. 84 | change (- x < - rat q). apply (snd (flip_lt_negate _ _)),E. 85 | Qed. 86 | 87 | Lemma compare_rat_disjoint : forall x q, 88 | disjoint (semi_decide (rat q < x)) (semi_decide (x < rat q)). 89 | Proof. 90 | intros x q E1 E2; 91 | apply semidecidable_compare_rat_alt in E1;apply semidecidable_compare_rat in E2. 92 | generalize (conj E1 E2). apply (lt_antisym). 93 | Qed. 94 | 95 | Definition compare_cauchy_rat : real -> Q -> partial bool 96 | := fun x q => interleave _ _ (compare_rat_disjoint x q). 97 | 98 | Lemma compare_cauchy_rat_pr : forall a q b, compare_cauchy_rat a q = eta _ b <-> 99 | match b with 100 | | true => rat q < a 101 | | false => a < rat q 102 | end. 103 | Proof. 104 | intros a q b. 105 | split. 106 | - intros E;apply interleave_pr in E. 107 | destruct b;apply semi_decidable;exact E. 108 | - intros E. destruct b. 109 | + apply interleave_top_l,(snd semi_decidable),E. 110 | + apply interleave_top_r,(snd semi_decidable),E. 111 | Qed. 112 | 113 | Lemma compare_cauchy_rat_self : forall q, compare_cauchy_rat (rat q) q = bot _. 114 | Proof. 115 | intros. apply interleave_bot;apply imply_le;intros E; 116 | apply semi_decidable,(irreflexivity _) in E;destruct E. 117 | Qed. 118 | 119 | End compare_cauchy_rat. 120 | -------------------------------------------------------------------------------- /theories/inductives/ast.v: -------------------------------------------------------------------------------- 1 | Require Import HoTT.Basics HoTT.Types HoTT.HIT.Truncations. 2 | 3 | Local Open Scope list_scope. 4 | 5 | Definition ctxS := list Type. 6 | Fixpoint eval_ctx (c : ctxS) : Type := 7 | match c with 8 | | nil => Unit 9 | | A :: c => A * eval_ctx c 10 | end. 11 | 12 | Inductive varS (A : Type) : ctxS -> Type := 13 | | here : forall Γ, varS A (A :: Γ) 14 | | next : forall Γ, varS A Γ -> forall B, varS A (B :: Γ). 15 | 16 | (* Fixpoint nat_varS {A Γ} (x : @varS A Γ) : nat := *) 17 | (* match x with *) 18 | (* | here _ => 0 *) 19 | (* | next Γ x B => S (nat_varS x) *) 20 | (* end. *) 21 | 22 | Fixpoint eval_var {A Γ} (x : varS A Γ) : eval_ctx Γ -> A 23 | := match x with 24 | | here Γ => fst 25 | | next Γ x B => 26 | (eval_var x) o snd 27 | end. 28 | 29 | Inductive exprS (Γ : ctxS) : Type -> Type := 30 | | constE : forall A, A -> exprS Γ A 31 | | constfunE : forall A B, (A -> B) -> exprS Γ A -> exprS Γ B 32 | | varE : forall A, varS A Γ -> exprS Γ A 33 | | pairE : forall A B, exprS Γ A -> exprS Γ B -> exprS Γ (A * B). 34 | 35 | Fixpoint eval_expr {Γ A} (e : exprS Γ A) : eval_ctx Γ -> A := 36 | match e with 37 | | constE A x => fun _ => x 38 | | constfunE A B f a => f o (eval_expr a) 39 | | varE A x => eval_var x 40 | | pairE A B a b => fun x => (eval_expr a x, eval_expr b x) 41 | end. 42 | 43 | Fixpoint uses_truncmaps n {Γ A} (a : exprS Γ A) : Type := 44 | match a with 45 | | constE A a => forall b, IsTrunc n (a = b) 46 | | constfunE A B f a => IsTruncMap n f * uses_truncmaps n a 47 | | varE _ _ => Unit 48 | | pairE A B a b => uses_truncmaps n a * uses_truncmaps n b 49 | end. 50 | 51 | Fixpoint ishprop_uses_truncmaps `{Funext} {n Γ A} (a : exprS Γ A) : IsHProp (uses_truncmaps n a) 52 | := match a with 53 | | constE A _ => trunc_forall 54 | | constfunE A B f a => trunc_prod 55 | | varE _ _ => trunc_succ 56 | | pairE A B a b => trunc_prod 57 | end. 58 | Existing Instance ishprop_uses_truncmaps. 59 | 60 | Inductive count := Never | Once | Many. 61 | 62 | Definition incc x := 63 | match x with 64 | | Never => Once 65 | | _ => Many 66 | end. 67 | 68 | Definition merge_count x y := 69 | match x with 70 | | Never => y 71 | | Once => incc y 72 | | Many => Many 73 | end. 74 | 75 | Fixpoint counts (Γ : ctxS) : Type := 76 | match Γ with 77 | | nil => Unit 78 | | A :: Γ => count * counts Γ 79 | end. 80 | 81 | Fixpoint merge_counts {Γ} : counts Γ -> counts Γ -> counts Γ 82 | := match Γ return counts Γ -> counts Γ -> counts Γ with 83 | | nil => fun _ _ => tt 84 | | A :: Γ => 85 | fun c1 c2 => 86 | (merge_count (fst c1) (fst c2), merge_counts (snd c1) (snd c2)) 87 | end. 88 | 89 | Fixpoint counts_init (Γ : ctxS) : counts Γ 90 | := match Γ with 91 | | nil => tt 92 | | A :: Γ => (Never, counts_init Γ) 93 | end. 94 | 95 | Definition cond_of_count n A c := 96 | match c with 97 | | Never => IsTrunc n A 98 | | Once => Unit 99 | | Many => IsTrunc n.+1 A 100 | end. 101 | 102 | Definition local_of_count@{i} n (A:Type@{i}) c : Type@{i} := 103 | match c with 104 | | Many => IsTrunc n A 105 | | Never | Once => Unit 106 | end. 107 | 108 | Fixpoint cond_of_counts n {Γ} : counts Γ -> Type := 109 | match Γ return counts Γ -> Type with 110 | | nil => fun _ => Unit 111 | | A :: Γ => 112 | fun c => cond_of_count n A (fst c) * cond_of_counts n (snd c) 113 | end. 114 | 115 | Fixpoint local_of_counts n {Γ} : counts Γ -> Type := 116 | match Γ return counts Γ -> Type with 117 | | nil => fun _ => Unit 118 | | A :: Γ => 119 | fun c => local_of_count n A (fst c) * local_of_counts n (snd c) 120 | end. 121 | 122 | Definition local_unmerge_count {n A} c1 c2 (Hcs : local_of_count n A (merge_count c1 c2)) 123 | : local_of_count n A c1 * local_of_count n A c2. 124 | Proof. 125 | destruct c1,c2;simpl in *;auto. 126 | Qed. 127 | 128 | Fixpoint local_unmerge_counts {n Γ} : forall c1 c2 : counts Γ, 129 | local_of_counts n (merge_counts c1 c2) -> 130 | local_of_counts n c1 * local_of_counts n c2. 131 | Proof. 132 | destruct Γ as [|A Γ];simpl;intros c1 c2. 133 | - intros _;exact (tt,tt). 134 | - intros [HA HΓ]. 135 | apply local_unmerge_counts in HΓ. 136 | apply local_unmerge_count in HA. 137 | destruct HA as [HA1 HA2], HΓ as [HΓ1 HΓ2];auto. 138 | Qed. 139 | 140 | Fixpoint cond_implies_local {n Γ} : forall c : counts Γ, cond_of_counts n c -> local_of_counts n.+1 c. 141 | Proof. 142 | destruct Γ as [|A Γ];simpl;intros c. 143 | - intros _; exact tt. 144 | - refine (functor_prod _ (cond_implies_local _ _ (snd c))). 145 | generalize (fst c);clear c;intros c;destruct c;simpl;auto. 146 | Qed. 147 | 148 | Fixpoint counts_of_var {A Γ} (x : varS A Γ) : counts Γ := 149 | match x with 150 | | here Γ => 151 | (Once, counts_init Γ) 152 | | next Γ x B => 153 | (Never, counts_of_var x) 154 | end. 155 | 156 | Fixpoint count_expr {Γ A} (a : exprS Γ A) : counts Γ 157 | := match a with 158 | | constE A a => counts_init Γ 159 | | constfunE A B f a => count_expr a 160 | | varE A x => counts_of_var x 161 | | pairE A B a b => merge_counts (count_expr a) (count_expr b) 162 | end. 163 | 164 | Definition global_cond n {Γ A} (a : exprS Γ A) 165 | := cond_of_counts n (count_expr a). 166 | 167 | 168 | (* expressions describing functions such that we can prove the function is an embedding. *) 169 | Inductive mexpr : Type -> Type -> Type := 170 | | mconst : forall A B, B -> mexpr A B 171 | | mid : forall A, mexpr A A 172 | | mapplyl : forall A B C, (B -> C) -> mexpr A B -> mexpr A C 173 | | mapplyr : forall A B C, mexpr B C -> (A -> B) -> mexpr A C 174 | | mpair : forall A B C D, 175 | mexpr A B -> mexpr C D -> 176 | mexpr (A * C) (B * D). 177 | 178 | Fixpoint eval_mexpr {A B} (e : mexpr A B) : A -> B 179 | := match e with 180 | | mconst A B x => fun _ => x 181 | | mid A => idmap 182 | | mapplyl A B C g ef => g o (eval_mexpr ef) 183 | | mapplyr A B C eg f => (eval_mexpr eg) o f 184 | | mpair A B C D ef eg => functor_prod (eval_mexpr ef) (eval_mexpr eg) 185 | end. 186 | 187 | Fixpoint mcond n {A B} (e : mexpr A B) := 188 | match e with 189 | | mconst A B x => IsTrunc n A * forall y, IsTrunc n (x = y) 190 | | mid _ => Unit 191 | | mapplyl A B C g ef => IsTruncMap n g * mcond n ef 192 | | mapplyr A B C eg f => mcond n eg * IsTruncMap n f 193 | | mpair A B C D ef eg => mcond n ef * mcond n eg 194 | end. 195 | 196 | Definition dup A (x : A) := (x,x). 197 | 198 | Instance istruncmap_dup {n A} {Atrunc : IsTrunc n.+1 A} : IsTruncMap n (dup A). 199 | Proof. 200 | intros [y1 y2]. 201 | srefine (trunc_equiv' (y1=y2) _). 202 | srefine (equiv_adjointify _ _ _ _). 203 | - intros p;exists y1;destruct p;reflexivity. 204 | - intros [x p]. 205 | exact (ap fst p^ @ ap snd p). 206 | - intros [x p]. 207 | revert p;apply (equiv_ind (Prod.path_prod_uncurried _ _));intros [p1 p2]. 208 | simpl in * |-;destruct p1,p2. reflexivity. 209 | - intros p;destruct p. reflexivity. 210 | Defined. 211 | 212 | Instance istruncmap_S {n A B} (f : A -> B) {Hf : IsTruncMap n f} : IsTruncMap n.+1 f := fun y => _. 213 | 214 | Instance istruncmap_isequiv {n A B} (f : A -> B) `{!IsEquiv f} : IsTruncMap n f. 215 | Proof. 216 | induction n as [|n IHn]. 217 | - red;apply EquivalenceVarieties.fcontr_isequiv,_. 218 | - apply _. 219 | Qed. 220 | 221 | Fixpoint mcond_S {n A B} (e : mexpr A B) (He : mcond n e) {struct e} : mcond n.+1 e. 222 | Proof. 223 | destruct e as [A B x|A|A B C g ef|A B C eg f|A B C D ef eg];simpl in *. 224 | - destruct He;split;apply _. 225 | - trivial. 226 | - destruct He;split;[exact _|auto]. 227 | - destruct He;split;[auto|exact _]. 228 | - destruct He;auto. 229 | Qed. 230 | 231 | Fixpoint istruncmap_mcond {n A B} (e : mexpr A B) : mcond n e -> IsTruncMap n (eval_mexpr e). 232 | Proof. 233 | destruct e as [A B x|A|A B C g ef|A B C eg f|A B C D ef eg];simpl;intros Hcond. 234 | - destruct Hcond as [HA HB]. exact _. 235 | - apply _. 236 | - destruct Hcond as [Hg Hf]. 237 | apply Fibrations.istruncmap_compose. 238 | + exact Hg. 239 | + exact (istruncmap_mcond _ _ _ _ Hf). 240 | - destruct Hcond as [Hg Hf]. 241 | apply Fibrations.istruncmap_compose. 242 | + exact (istruncmap_mcond _ _ _ _ Hg). 243 | + exact Hf. 244 | - destruct Hcond as [Hf Hg]. 245 | apply Fibrations.istruncmap_functor_prod. 246 | + exact (istruncmap_mcond _ _ _ _ Hf). 247 | + exact (istruncmap_mcond _ _ _ _ Hg). 248 | Qed. 249 | 250 | Fixpoint subctx {Γ} : counts Γ -> Type := 251 | match Γ with 252 | | nil => fun _ => Unit 253 | | A :: Γ => 254 | fun c => match fst c with 255 | | Never => subctx (snd c) 256 | | _ => A * subctx (snd c) 257 | end 258 | end. 259 | 260 | Fixpoint subctx_into {Γ} : forall c : counts Γ, eval_ctx Γ -> subctx c. 261 | Proof. 262 | destruct Γ as [|A Γ]. 263 | - simpl. intros _ _;exact tt. 264 | - simpl. intros c. destruct (fst c). 265 | + exact ((subctx_into _ _) o snd). 266 | + exact (functor_prod idmap (subctx_into _ _)). 267 | + exact (functor_prod idmap (subctx_into _ _)). 268 | Defined. 269 | 270 | Lemma istruncmap_fst {n} A B `{!IsTrunc n B} : IsTruncMap n (@fst A B). 271 | Proof. 272 | intros x. 273 | refine (trunc_equiv' B _). 274 | srefine (equiv_adjointify _ _ _ _). 275 | - intros y;exists (x,y). reflexivity. 276 | - intros xy;exact (snd (xy.1)). 277 | - intros [[x' y] p]. destruct p;reflexivity. 278 | - intros y. reflexivity. 279 | Qed. 280 | 281 | Lemma istruncmap_snd {n} A B `{!IsTrunc n A} : IsTruncMap n (@snd A B). 282 | Proof. 283 | intros y. 284 | refine (trunc_equiv' A _). 285 | srefine (equiv_adjointify _ _ _ _). 286 | - intros x;exists (x,y). reflexivity. 287 | - intros xy;exact (fst (xy.1)). 288 | - intros [[x y'] p]. destruct p;reflexivity. 289 | - intros x. reflexivity. 290 | Qed. 291 | 292 | Fixpoint istruncmap_subctx_into {n Γ} : forall c : counts Γ, 293 | cond_of_counts n c -> IsTruncMap n (subctx_into c). 294 | Proof. 295 | destruct Γ as [|A Γ];simpl. 296 | - intros _ _;apply _. 297 | - intros [[] c];simpl;intros [HA HΓ]. 298 | + apply Fibrations.istruncmap_compose;[apply istruncmap_subctx_into,HΓ|]. 299 | apply istruncmap_snd,_. 300 | + apply istruncmap_subctx_into in HΓ. exact _. 301 | + apply istruncmap_subctx_into in HΓ. exact _. 302 | Qed. 303 | 304 | Definition merge_aux1 A B C D : A * B * (C * D) -> B * C * (A * D) 305 | := (equiv_prod_assoc _ _ _)^-1 o 306 | (functor_prod (equiv_prod_symm _ _) idmap) o 307 | (functor_prod (equiv_prod_assoc A B C)^-1 idmap) o 308 | (equiv_prod_assoc _ _ _). 309 | Definition merge_aux2 A B C : A * (B * C) -> B * (A * C) 310 | := (equiv_prod_assoc _ _ _)^-1 o 311 | (functor_prod (equiv_prod_symm _ _) idmap) o 312 | (equiv_prod_assoc _ _ _). 313 | 314 | Fixpoint merge_subctx {Γ} : forall c1 c2 : counts Γ, 315 | subctx (merge_counts c1 c2) -> 316 | subctx c1 * subctx c2. 317 | Proof. 318 | destruct Γ as [|A Γ];simpl;intros c1 c2. 319 | - intros _;exact (tt,tt). 320 | - destruct c1 as [[] c1], c2 as [[] c2];simpl. 321 | + exact (merge_subctx _ _ _). 322 | + exact ((merge_aux2 _ _ _) o 323 | (functor_prod (idmap:A->A) (merge_subctx _ c1 c2))). 324 | + exact ((merge_aux2 _ _ _) o 325 | (functor_prod (idmap:A->A) (merge_subctx _ c1 c2))). 326 | + refine ((equiv_prod_assoc _ _ _) o _). 327 | refine (functor_prod idmap _). 328 | exact (merge_subctx _ _ _). 329 | + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))). 330 | + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))). 331 | + exact ((equiv_prod_assoc _ _ _) o (functor_prod idmap (merge_subctx _ _ _))). 332 | + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))). 333 | + exact ((merge_aux1 _ _ _ _) o (functor_prod (dup A) (merge_subctx _ _ _))). 334 | Defined. 335 | 336 | Instance isequiv_merge_aux1 A B C D : IsEquiv (merge_aux1 A B C D). 337 | Proof. 338 | unfold merge_aux1. exact _. 339 | Qed. 340 | 341 | Instance isequiv_merge_aux2 A B C : IsEquiv (merge_aux2 A B C). 342 | Proof. 343 | unfold merge_aux2. exact _. 344 | Qed. 345 | 346 | Fixpoint init_contr Γ : Contr (subctx (counts_init Γ)). 347 | Proof. 348 | destruct Γ as [|A Γ];simpl. 349 | - exact contr_unit. 350 | - apply init_contr. 351 | Defined. 352 | 353 | Instance init_trunc {n} Γ : IsTrunc n (subctx (counts_init Γ)). 354 | Proof. 355 | induction n as [|n IHn]. 356 | - apply init_contr. 357 | - apply _. 358 | Qed. 359 | 360 | Opaque functor_prod equiv_prod_assoc equiv_prod_symm merge_aux1 merge_aux2 dup. 361 | 362 | Fixpoint istruncmap_merge_subctx {n Γ} : forall c1 c2 : counts Γ, 363 | local_of_counts n.+1 (merge_counts c1 c2) -> 364 | IsTruncMap n (merge_subctx c1 c2). 365 | Proof. 366 | destruct Γ as [|A Γ];simpl. 367 | - intros _ _ _. apply _. 368 | - intros [c1 cs1] [c2 cs2] [h hs];simpl in *. 369 | apply istruncmap_merge_subctx in hs. 370 | destruct c1,c2;simpl in *;apply _. 371 | Qed. 372 | 373 | Transparent functor_prod equiv_prod_assoc equiv_prod_symm merge_aux1 merge_aux2 dup. 374 | 375 | Fixpoint mexpr_var {A Γ} (x : varS A Γ) : mexpr (subctx (counts_of_var x)) A. 376 | Proof. 377 | destruct x as [Γ|Γ x B];simpl. 378 | - apply mapplyr with A. 379 | + apply mid. 380 | + exact fst. 381 | - apply mexpr_var. 382 | Defined. 383 | 384 | Fixpoint mexpr_of {Γ A} (e : exprS Γ A) : mexpr (subctx (count_expr e)) A. 385 | Proof. 386 | destruct e as [A x|A B f a|A x|A B a b];simpl. 387 | - apply mconst. exact x. 388 | - apply mapplyl with A. 389 | + exact f. 390 | + apply mexpr_of. 391 | - apply mexpr_var. 392 | - eapply mapplyr. 393 | + apply mpair;apply mexpr_of. 394 | + exact (merge_subctx (count_expr a) (count_expr b)). 395 | Defined. 396 | 397 | Fixpoint mcond_var_base {A Γ} (x : varS A Γ) : mcond (-2) (mexpr_var x). 398 | Proof. 399 | destruct x as [Γ|Γ x B];simpl. 400 | - apply (pair tt). 401 | apply istruncmap_fst. exact _. 402 | - apply mcond_var_base. 403 | Qed. 404 | 405 | Lemma mcond_var {n A Γ} (x : varS A Γ) : mcond n (mexpr_var x). 406 | Proof. 407 | induction n as [|n IHn]. 408 | - apply mcond_var_base. 409 | - apply mcond_S,IHn. 410 | Qed. 411 | 412 | Fixpoint mexpr_preserves_truncmaps {n Γ A} (e : exprS Γ A) 413 | : local_of_counts n.+1 (count_expr e) -> uses_truncmaps n e -> mcond n (mexpr_of e). 414 | Proof. 415 | destruct e as [A x|A B f a|A x|A B a b];simpl. 416 | - intros _ HA;split;exact _. 417 | - intros H. apply (functor_prod idmap). apply mexpr_preserves_truncmaps,H. 418 | - intros _ _. apply mcond_var. 419 | - intros HS HE. 420 | split. 421 | + apply local_unmerge_counts in HS. 422 | exact (functor_prod (mexpr_preserves_truncmaps _ _ _ _ (fst HS)) 423 | (mexpr_preserves_truncmaps _ _ _ _ (snd HS)) HE). 424 | + apply istruncmap_merge_subctx. exact HS. 425 | Qed. 426 | 427 | Fixpoint path_mexpr_var {A Γ} (x : varS A Γ) : forall y, 428 | eval_mexpr (mexpr_var x) (subctx_into (counts_of_var x) y) = eval_var x y. 429 | Proof. 430 | destruct x as [Γ|Γ x B];simpl. 431 | - auto. 432 | - intros [_ y]. auto. 433 | Qed. 434 | 435 | Fixpoint merge_subctx_into {Γ} : forall (c1 c2 : counts Γ) x, 436 | merge_subctx c1 c2 (subctx_into _ x) = (subctx_into c1 x, subctx_into c2 x). 437 | Proof. 438 | destruct Γ as [|A Γ];simpl. 439 | - intros;reflexivity. 440 | - intros [[] c1] [[] c2] [x xs];simpl;try solve [rewrite merge_subctx_into; reflexivity]. 441 | all:(unfold merge_aux1,functor_prod;simpl; 442 | rewrite merge_subctx_into; reflexivity). 443 | Qed. 444 | 445 | Fixpoint path_mexpr_of {Γ A} (e : exprS Γ A) : forall x, 446 | eval_mexpr (mexpr_of e) (subctx_into (count_expr e) x) = eval_expr e x. 447 | Proof. 448 | destruct e as [A x|A B f a|A x|A B a b];simpl. 449 | - auto. 450 | - intros x. apply ap. auto. 451 | - apply path_mexpr_var. 452 | - intros x. rewrite merge_subctx_into. unfold functor_prod. simpl. 453 | apply path_prod';apply path_mexpr_of. 454 | Qed. 455 | 456 | Lemma equiv_hfiber_right {A A' B} (f : A -> A') `{!IsEquiv f} (g : A' -> B) y 457 | : hfiber g y <~> hfiber (g o f) y. 458 | Proof. 459 | srefine (equiv_adjointify _ _ _ _);unfold hfiber. 460 | - intros [x ex];exists (f^-1 x). 461 | path_via (g x). apply ap,eisretr. 462 | - intros [x ex];exists (f x). 463 | exact ex. 464 | - intros [x ex]. destruct ex. 465 | rewrite concat_p1. 466 | apply (path_sigma' _ (eissect _ _)). 467 | rewrite transport_paths_Fl. 468 | rewrite ap_compose,eisadj. 469 | apply concat_Vp. 470 | - intros [x ex]. destruct ex. 471 | rewrite concat_p1. 472 | apply (path_sigma' _ (eisretr _ _)). 473 | rewrite transport_paths_Fl. 474 | apply concat_Vp. 475 | Qed. 476 | 477 | Lemma equiv_hfiber_left {A B B'} (f : A -> B) (g : B -> B') `{!IsEmbedding g} y 478 | : hfiber f y <~> hfiber (g o f) (g y). 479 | Proof. 480 | srefine (equiv_adjointify _ _ _ _);unfold hfiber. 481 | - intros [x ex]. exists x. apply ap,ex. 482 | - intros [x ex]; exists x. exact ((ap g)^-1 ex). 483 | - intros [x ex]. apply ap,eisretr. 484 | - intros [x ex]. apply ap,eissect. 485 | Qed. 486 | 487 | Lemma istruncmap_full_homotopic {n A B A' B'} (fA : A <~> A') (fB : B <~> B') 488 | (f : A -> B) (g : A' -> B') 489 | : IsTruncMap n f -> fB o f o fA^-1 == g -> IsTruncMap n g. 490 | Proof. 491 | intros Hf He y. 492 | apply (trunc_equiv' (hfiber f (fB^-1 y)));[|exact _]. 493 | refine (_ oE _). 494 | { symmetry. exact (equiv_hfiber_right fA g y). } 495 | refine (_ oE _). 496 | 2:exact (equiv_hfiber_left _ fB _). 497 | rewrite eisretr. 498 | apply Fibrations.equiv_hfiber_homotopic;clear y. 499 | intros x. rewrite <-He,eissect. reflexivity. 500 | Qed. 501 | 502 | Lemma istruncmap_homotopic {n A B} (f : A -> B) {g} `{!IsTruncMap n f} : f == g -> IsTruncMap n g. 503 | Proof. 504 | intros Heq. 505 | intros y. apply (trunc_equiv' (hfiber f y));[|exact _]. 506 | apply Fibrations.equiv_hfiber_homotopic. exact Heq. 507 | Defined. 508 | 509 | Theorem istruncmap_eval_expr {n Γ A} (e : exprS Γ A) 510 | : global_cond n e -> uses_truncmaps n e -> IsTruncMap n (eval_expr e). 511 | Proof. 512 | intros H1 H2. 513 | refine (istruncmap_homotopic _ (path_mexpr_of e)). 514 | apply Fibrations.istruncmap_compose. 515 | - apply istruncmap_mcond. apply mexpr_preserves_truncmaps. 516 | + apply cond_implies_local,H1. 517 | + exact H2. 518 | - apply istruncmap_subctx_into. exact H1. 519 | Qed. 520 | -------------------------------------------------------------------------------- /theories/partiality.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.HSet 5 | HoTT.Classes.interfaces.abstract_algebra 6 | HoTT.Classes.interfaces.orders 7 | HoTT.Classes.interfaces.monad 8 | HoTT.Classes.implementations.peano_naturals. 9 | 10 | Local Set Universe Minimization ToSet. 11 | 12 | Record IncreasingSequence A {Ale : Le A} := 13 | { seq : nat -> A 14 | ; seq_increasing : forall n, seq n <= seq (S n) }. 15 | Coercion seq : IncreasingSequence >-> Funclass. 16 | 17 | Arguments Build_IncreasingSequence {A Ale} seq seq_increasing. 18 | Arguments seq {A Ale} _ _. 19 | Arguments seq_increasing {A Ale} _ _. 20 | 21 | Global Instance seq_increasing_le `{PartialOrder A} (s : IncreasingSequence A) 22 | : OrderPreserving (seq s). 23 | Proof. 24 | hnf. intros a b E;induction E as [|b IH]. 25 | - reflexivity. 26 | - transitivity (s b);trivial. apply seq_increasing. 27 | Qed. 28 | 29 | Module Export Partial. 30 | 31 | Section VarSec. 32 | Universe i. 33 | Variable A : Type@{i}. 34 | 35 | Private Inductive partial@{} : Type@{i} := 36 | | eta : A -> partial 37 | | bot : Bottom partial 38 | | sup : IncreasingSequence partial -> partial 39 | 40 | with partialLe@{} : Le partial := 41 | | partial_refl : Reflexive partialLe 42 | | bot_least : forall x, bot <= x 43 | | sup_le_l : forall f x, sup f <= x -> forall n, f n <= x 44 | | sup_le_r : forall f x, (forall n, seq f n <= x) -> sup f <= x 45 | . 46 | Axiom partial_antisymm : AntiSymmetric partialLe. 47 | Axiom partialLe_hprop : is_mere_relation partial partialLe. 48 | 49 | Global Existing Instance partialLe. 50 | Global Existing Instance partialLe_hprop. 51 | 52 | Section Induction. 53 | Universe UP UQ. 54 | Variables (P : partial -> Type@{UP}) 55 | (Q : forall x y (u : P x) (v : P y), x <= y -> Type@{UQ}). 56 | 57 | Record Inductors@{} := 58 | { ind_eta : forall x, P (eta x) 59 | ; ind_bot : P bot 60 | ; ind_sup : forall (s : IncreasingSequence partial) (If : forall n, P (s n)) 61 | (Ip : forall n, Q (s n) (s (S n)) (If n) (If (S n)) (seq_increasing s n)), 62 | P (sup s) 63 | ; ind_refl : forall x u, Q x x u u (partial_refl x) 64 | ; ind_bot_least : forall x v, Q bot x ind_bot v (bot_least x) 65 | ; ind_sup_le_l : forall f x E If Ip u, Q (sup f) x (ind_sup f If Ip) u E -> 66 | forall n, Q (f n) x (If n) u (sup_le_l f x E n) 67 | ; ind_sup_le_r : forall f x E If Ip u, (forall n, Q (seq f n) x (If n) u (E n)) -> 68 | Q (sup f) x (ind_sup f If Ip) u (sup_le_r f x E) 69 | 70 | ; ind_antisymm : forall x y u v E1 E2, Q x y u v E1 -> Q y x v u E2 -> 71 | partial_antisymm x y E1 E2 # u = v 72 | ; ind_prop : forall x y u v E, IsHProp (Q x y u v E) 73 | }. 74 | 75 | Definition partial_rect@{} : Inductors -> forall x, P x := 76 | fix partial_rect (I : Inductors) (x : partial) {struct x} : P x := 77 | match x return (Inductors -> P x) with 78 | | eta x => fun I => ind_eta I x 79 | | bot => fun I => ind_bot I 80 | | sup f => fun I => ind_sup I f 81 | (fun n => partial_rect I (f n)) 82 | (fun n => partialLe_rect I _ _ (seq_increasing f n)) 83 | end I 84 | 85 | with partialLe_rect (I : Inductors) (x y : partial) (E : x <= y) {struct E} 86 | : Q x y (partial_rect I x) (partial_rect I y) E := 87 | match E in partialLe x' y' 88 | return (forall I : Inductors, Q x' y' (partial_rect I x') (partial_rect I y') E) 89 | with 90 | | partial_refl x => fun I => ind_refl I x (partial_rect I x) 91 | | bot_least x => fun I => 92 | ind_bot_least I x (partial_rect I x) 93 | | sup_le_l f x E n => fun I => 94 | ind_sup_le_l I f x E 95 | (fun n => partial_rect I (f n)) 96 | (fun n => partialLe_rect I _ _ (seq_increasing f n)) 97 | (partial_rect I x) 98 | (partialLe_rect I _ _ E) n 99 | | sup_le_r f x E => fun I => 100 | ind_sup_le_r I f x E 101 | (fun n => partial_rect I (f n)) 102 | (fun n => partialLe_rect I _ _ (seq_increasing f n)) 103 | (partial_rect I x) 104 | (fun n => partialLe_rect I _ _ (E n)) 105 | end I 106 | 107 | for partial_rect. 108 | 109 | Definition partialLe_rect@{} : forall (I : Inductors) (x y : partial) (E : x <= y), 110 | Q x y (partial_rect I x) (partial_rect I y) E 111 | := 112 | fix partial_rect (I : Inductors) (x : partial) {struct x} : P x := 113 | match x return (Inductors -> P x) with 114 | | eta x => fun I => ind_eta I x 115 | | bot => fun I => ind_bot I 116 | | sup f => fun I => ind_sup I f 117 | (fun n => partial_rect I (f n)) 118 | (fun n => partialLe_rect I _ _ (seq_increasing f n)) 119 | end I 120 | 121 | with partialLe_rect (I : Inductors) (x y : partial) (E : x <= y) {struct E} 122 | : Q x y (partial_rect I x) (partial_rect I y) E := 123 | match E in partialLe x' y' 124 | return (forall I : Inductors, Q x' y' (partial_rect I x') (partial_rect I y') E) 125 | with 126 | | partial_refl x => fun I => ind_refl I x (partial_rect I x) 127 | | bot_least x => fun I => 128 | ind_bot_least I x (partial_rect I x) 129 | | sup_le_l f x E n => fun I => 130 | ind_sup_le_l I f x E 131 | (fun n => partial_rect I (f n)) 132 | (fun n => partialLe_rect I _ _ (seq_increasing f n)) 133 | (partial_rect I x) 134 | (partialLe_rect I _ _ E) n 135 | | sup_le_r f x E => fun I => 136 | ind_sup_le_r I f x E 137 | (fun n => partial_rect I (f n)) 138 | (fun n => partialLe_rect I _ _ (seq_increasing f n)) 139 | (partial_rect I x) 140 | (fun n => partialLe_rect I _ _ (E n)) 141 | end I 142 | 143 | for partialLe_rect. 144 | 145 | Definition partial_rect_sup (I : Inductors) s : partial_rect I (sup s) = 146 | ind_sup I s (fun n => partial_rect I (s n)) 147 | (fun n => partialLe_rect I _ _ _) 148 | := idpath. 149 | 150 | End Induction. 151 | 152 | End VarSec. 153 | 154 | End Partial. 155 | 156 | Section contents. 157 | Context `{Funext} `{Univalence}. 158 | 159 | Section basics. 160 | Universe UA. 161 | Variable A : Type@{UA}. 162 | Context `{IsHSet A}. 163 | 164 | Section Recursion. 165 | Universe UT UTle. 166 | Variables (T : Type@{UT}) (Tle : T -> T -> Type@{UTle}). 167 | 168 | Record Recursors@{} := 169 | { rec_eta : A -> T 170 | ; rec_bot : T 171 | ; rec_sup : forall (f : nat -> T) (p : forall n, Tle (f n) (f (S n))), T 172 | 173 | ; rec_refl : forall x : T, Tle x x 174 | ; rec_bot_least : forall x : T, Tle rec_bot x 175 | ; rec_sup_le_l : forall s p x, Tle (rec_sup s p) x -> forall n, Tle (s n) x 176 | ; rec_sup_le_r : forall s p x, (forall n, Tle (s n) x) -> Tle (rec_sup s p) x 177 | 178 | ; rec_antisymm : AntiSymmetric Tle 179 | ; rec_prop : is_mere_relation T Tle }. 180 | 181 | Definition recursors_inductors@{} 182 | : Recursors -> Inductors A (fun _ => T) (fun _ _ x y _ => Tle x y). 183 | Proof. 184 | intros R. simple refine (Build_Inductors A _ _ 185 | (rec_eta R) (rec_bot R) (fun _ => rec_sup R) _ _ _ _ _ _);simpl. 186 | - intros _;exact (rec_refl R). 187 | - intros _;exact (rec_bot_least R). 188 | - intros _ _ _. exact (rec_sup_le_l R). 189 | - intros _ _ _. exact (rec_sup_le_r R). 190 | - intros. rewrite PathGroupoids.transport_const. apply (rec_antisymm R);trivial. 191 | - intros _ _ ?? _;exact (rec_prop R _ _). 192 | Defined. 193 | 194 | Definition partial_rec@{} : Recursors -> partial A -> T 195 | := fun R => partial_rect _ _ _ (recursors_inductors R). 196 | 197 | Definition partialLe_rec@{} : forall (R : Recursors) (x y : partial A) (E : x <= y), 198 | Tle (partial_rec R x) (partial_rec R y) 199 | := fun R => partialLe_rect _ _ _ (recursors_inductors R). 200 | 201 | Definition partial_rec_eta (R : Recursors) (a : A) 202 | : partial_rec R (eta A a) = rec_eta R a 203 | := idpath. 204 | 205 | Definition partial_rec_sup (R : Recursors) (s : IncreasingSequence (partial A)) 206 | : partial_rec R (sup A s) = 207 | rec_sup R (fun n => partial_rec R (s n)) 208 | (fun n => partialLe_rec R _ _ (seq_increasing s n)) 209 | := idpath. 210 | 211 | End Recursion. 212 | 213 | Definition partialLe_rect0@{UP} (P : forall x y : partial A, x <= y -> Type@{UP}) 214 | {sP : forall x y E, IsHProp (P x y E)} 215 | (val_refl : forall x, P x x (partial_refl A x)) 216 | (val_bot_least : forall x, P _ _ (bot_least A x)) 217 | (val_sup_le_l : forall f x E 218 | (Ip : forall n, P (seq f n) (f (S n)) (seq_increasing f n)), 219 | P (sup A f) x E -> forall n, P (f n) x (sup_le_l A f x E n)) 220 | (val_sup_le_r : forall f x E 221 | (Ip : forall n, P (seq f n) (f (S n)) (seq_increasing f n)), 222 | (forall n, P (f n) x (E n)) -> P (sup A f) x (sup_le_r@{UA} A f x E)) 223 | : forall x y E, P x y E. 224 | Proof. 225 | apply (partialLe_rect@{UA Set UP} A (fun _ => Unit) (fun x y _ _ E => P x y E)). 226 | split;simpl;auto;simpl. 227 | intros. 228 | apply path_ishprop. 229 | Defined. 230 | 231 | Lemma partialLe_trans@{} : Transitive (@le (partial@{UA} A) _). 232 | Proof. 233 | hnf. intros x y z E;revert x y E z. 234 | apply (partialLe_rect0 (fun x y _ => forall z, _ -> _)). 235 | - auto. 236 | - intros;apply bot_least. 237 | - intros;eapply sup_le_l;eauto. 238 | - intros;apply sup_le_r;auto. 239 | Qed. 240 | 241 | Global Instance partial_set@{} : IsHSet (partial@{UA} A). 242 | Proof. 243 | apply (@HSet.isset_hrel_subpaths _ (fun x y => x <= y /\ y <= x)). 244 | - intros x;split;apply partial_refl. 245 | - apply _. 246 | - intros x y E;apply partial_antisymm;apply E. 247 | Qed. 248 | 249 | Global Instance partial_order@{} : PartialOrder (@le (partial A) _). 250 | Proof. 251 | repeat (split;try apply _). 252 | - apply partial_refl. 253 | - apply partialLe_trans. 254 | Qed. 255 | 256 | Definition partial_ind0@{UP} (P : partial@{UA} A -> Type@{UP}) 257 | {sP : forall x, IsHProp (P x)} 258 | (val_eta : forall x, P (eta A x)) 259 | (val_bot : P (bot A)) 260 | (val_sup : forall f, (forall n, P (seq f n)) -> P (sup A f)) 261 | : forall x, P x. 262 | Proof. 263 | apply (partial_rect@{UA UP Set} A _ (fun _ _ _ _ _ => Unit)). 264 | split;simpl;auto. 265 | - intros; 266 | apply path_ishprop. 267 | - apply _. 268 | Defined. 269 | 270 | Definition partialLe_ind0@{UP} 271 | (P : forall a b : partial@{UA} A, a <= b -> Type@{UP}) 272 | {sP : forall a b E, IsHProp (P a b E)} 273 | (val_refl : forall a, P a a (partial_refl A a)) 274 | (val_bot_least : forall b, P (bot A) b (bot_least A b)) 275 | (val_sup_le_l : forall f x E, P _ _ E -> forall n, P _ _ (sup_le_l A f x E n)) 276 | (val_sup_le_r : forall f x E, (forall n, P _ _ (E n)) -> 277 | P _ _ (sup_le_r A f x E)) 278 | : forall a b E, P a b E. 279 | Proof. 280 | apply (partialLe_rect@{UA Set UP} A (fun _ => Unit) (fun a b _ _ E => P a b E)). 281 | split;simpl;auto. 282 | intros. 283 | apply path_ishprop. 284 | Defined. 285 | 286 | Definition eta_le_recursors' (a : A) 287 | : Recursors@{Ularge Ularge} hProp (fun P Q => P -> Q). 288 | Proof. 289 | simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _);simpl. 290 | - intros b. exists (a = b). apply _. 291 | - exists Empty;apply _. 292 | - intros f p. exact (merely (exists n, f n)). 293 | - trivial. 294 | - intros _ []. 295 | - simpl. intros s p x E n En. apply E. apply tr;exists n;trivial. 296 | - simpl. intros s p x E. apply (Trunc_ind _);intros [n En]. apply (E n En). 297 | - hnf. intros. apply TruncType.path_iff_hprop_uncurried. split;trivial. 298 | Defined. 299 | 300 | Definition eta_le_recursors := eta_le_recursors'@{Uhuge}. 301 | 302 | Definition sim_le_recursors' 303 | : Recursors@{Uhuge Ularge} (partial@{UA} A -> hProp) 304 | (fun P Q => forall x, Q x -> P x). 305 | Proof. 306 | simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _);simpl. 307 | - intros a. apply (partial_rec _ _ (eta_le_recursors a)). 308 | - intros _;exists Unit. apply trunc_succ. 309 | - intros f p x. exists (forall n, f n x). apply _. 310 | - trivial. 311 | - simpl. trivial. 312 | - simpl. auto. 313 | - simpl. auto. 314 | - hnf;intros. apply path_forall. intros ?. 315 | apply TruncType.path_iff_hprop_uncurried. split;auto. 316 | Defined. 317 | 318 | Definition sim_le_recursors@{} := sim_le_recursors'@{Ularge Uhuge}. 319 | 320 | Definition sim_le@{} : partial A -> partial A -> hProp 321 | := partial_rec _ _ sim_le_recursors. 322 | 323 | Lemma sim_to_le@{} : forall a b, sim_le a b -> a <= b. 324 | Proof. 325 | apply (partial_ind0 (fun a => forall b, _ -> _)). 326 | - intros a. apply (partial_ind0 (fun b => _ -> _)). 327 | + intros b;simpl. intros []. reflexivity. 328 | + simpl. intros []. 329 | + intros f E1. 330 | change (merely (exists n, sim_le (eta A a) (f n)) -> eta A a <= sup A f). 331 | apply (Trunc_ind _);intros [n E2]. 332 | apply E1 in E2. transitivity (f n);trivial. 333 | apply sup_le_l. reflexivity. 334 | - simpl. intros b _;apply bot_least. 335 | - intros f IH b. change ((forall n, sim_le (f n) b) -> sup A f <= b). 336 | intros E. apply sup_le_r. intros n;apply IH;trivial. 337 | Qed. 338 | 339 | Lemma le_sim_le_trans@{} : forall a b, a <= b -> forall c, sim_le b c -> sim_le a c. 340 | Proof. 341 | exact (partialLe_rec _ _ sim_le_recursors). 342 | Qed. 343 | 344 | Lemma sim_le_sup@{} : forall f x n, sim_le x (seq f n) -> sim_le x (sup A f). 345 | Proof. 346 | intros f;apply (partial_ind0@{Ularge} (fun x => forall n, _ -> _)). 347 | - intros a n E. apply tr;exists n;apply E. 348 | - simpl. trivial. 349 | - intros g IH n E. 350 | change (forall m, sim_le (g m) (sup A f)). intros m. 351 | apply IH with n. apply le_sim_le_trans with (sup A g). 352 | + apply sup_le_l. reflexivity. 353 | + trivial. 354 | Qed. 355 | 356 | Lemma sim_le_refl@{} : forall a, sim_le a a. 357 | Proof. 358 | apply (partial_ind0 _). 359 | - reflexivity. 360 | - simpl;trivial. 361 | - intros f IH. change (forall n, sim_le (f n) (sup A f)). 362 | intros n. apply sim_le_sup with n. trivial. 363 | Qed. 364 | 365 | Lemma le_to_sim@{} : forall a b, a <= b -> sim_le a b. 366 | Proof. 367 | apply (partialLe_ind0 _). 368 | - apply sim_le_refl. 369 | - simpl. trivial. 370 | - intros f x E IH;exact IH. 371 | - intros f x E IH;exact IH. 372 | Qed. 373 | 374 | Lemma le_sim_rw : @le (partial A) _ = sim_le. 375 | Proof. 376 | apply path_forall;intros a;apply path_forall;intros b. 377 | apply (ap trunctype_type). 378 | apply TruncType.path_iff_hprop_uncurried. simpl. split. 379 | - apply le_to_sim. 380 | - apply sim_to_le. 381 | Qed. 382 | 383 | Lemma not_eta_le_bot@{} : forall a, ~ eta@{UA} A a <= bot A. 384 | Proof. 385 | intros a E. apply le_to_sim in E;trivial. 386 | Qed. 387 | 388 | Lemma eta_le_eta@{} : forall a b, eta@{UA} A a <= eta A b -> a = b. 389 | Proof. 390 | intros a b;apply le_to_sim. 391 | Qed. 392 | 393 | Global Instance eta_injective@{} : Injective (eta@{UA} A). 394 | Proof. 395 | intros a b E. apply eta_le_eta. rewrite E;reflexivity. 396 | Qed. 397 | 398 | Lemma eta_le_sup@{} : forall a f, eta A a <= sup A f -> 399 | merely@{UA} (exists n, eta@{UA} A a <= f n). 400 | Proof. 401 | intros a f E. apply le_to_sim in E. 402 | change (trunctype_type (merely (exists n, sim_le (eta A a) (f n)))) in E. 403 | revert E;apply (Trunc_ind _);intros [n E]. 404 | apply tr;exists n;apply sim_to_le;trivial. 405 | Qed. 406 | 407 | Lemma sup_is_ub@{} : forall f n, seq f n <= sup@{UA} A f. 408 | Proof. 409 | intros f n;apply sup_le_l. reflexivity. 410 | Qed. 411 | 412 | Lemma eta_is_greatest : forall x a, eta@{UA} A a <= x -> x = eta A a. 413 | Proof. 414 | apply (partial_ind0 (fun x => forall a, _ -> _)). 415 | - intros ?? E;apply ap. symmetry. apply eta_le_eta. trivial. 416 | - intros a E. apply le_to_sim in E. destruct E. 417 | - intros s IH a E. 418 | apply (antisymmetry le). 419 | + apply sup_le_r. intros n. 420 | apply eta_le_sup in E. revert E;apply (Trunc_ind _);intros [k E]. 421 | destruct (total le n k) as [E1|E1]. 422 | apply IH in E. 423 | * transitivity (s k). 424 | { apply (order_preserving _). trivial. } 425 | { rewrite E;reflexivity. } 426 | * rewrite (IH n a);[reflexivity|]. 427 | transitivity (s k);trivial. 428 | apply (order_preserving _). trivial. 429 | + trivial. 430 | Qed. 431 | 432 | Lemma eta_eq_sup_iff : forall a s, sup@{UA} A s = eta A a <-> 433 | merely (exists n, s n = eta A a). 434 | Proof. 435 | intros a s;split. 436 | - intros E. 437 | assert (E' : eta A a <= sup A s) 438 | by (rewrite E;reflexivity). 439 | generalize (eta_le_sup a s E'). 440 | apply (Trunc_ind _);intros [n En]. 441 | apply tr;exists n. apply (antisymmetry le). 442 | + apply sup_le_l. rewrite E;reflexivity. 443 | + trivial. 444 | - apply (Trunc_ind _);intros [n En]. 445 | apply eta_is_greatest. rewrite <-En. apply sup_is_ub. 446 | Qed. 447 | 448 | End basics. 449 | 450 | Section monad. 451 | 452 | Global Instance partial_ret@{i} : Return partial@{i} := eta. 453 | 454 | Definition partial_bind_recursors@{i j} {A:Type@{i} } {B : Type@{j} } 455 | : (A -> partial@{j} B) -> 456 | Recursors A (partial@{j} B) le. 457 | Proof. 458 | intros f. 459 | simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl. 460 | - exact f. 461 | - exact (bot B). 462 | - intros s p. exact (sup B (Build_IncreasingSequence s p)). 463 | - reflexivity. 464 | - apply bot_least. 465 | - simpl. intros s p; apply sup_le_l. 466 | - simpl. intros s p; exact (sup_le_r _ (Build_IncreasingSequence _ _)). 467 | Defined. 468 | 469 | Definition partial_bind {A B : Type} 470 | := fun x (f : A -> partial B) => 471 | partial_rec _ _ _ (partial_bind_recursors f) x. 472 | 473 | Definition partial_bind_le {A B:Type} : forall (f : A -> partial B) a b, a <= b -> 474 | partial_bind a f <= partial_bind b f 475 | := fun f a b E => partialLe_rec _ _ _ (partial_bind_recursors f) a b E. 476 | 477 | Definition partial_bind_eta_l {A B:Type} : forall a f, 478 | partial_bind (B:=B) (eta A a) f = f a 479 | := fun _ _ => idpath. 480 | 481 | Definition partial_bind_bot_l {A B:Type} : forall f, 482 | partial_bind (bot A) f = bot B 483 | := fun _ => idpath. 484 | 485 | Definition partial_bind_seq {A B:Type} (f : A -> partial B) s := 486 | Build_IncreasingSequence (fun n => partial_bind (seq s n) f) 487 | (fun n => partial_bind_le f _ _ (seq_increasing s n)). 488 | 489 | Definition partial_bind_sup_l {A B:Type} : forall f s, 490 | partial_bind (sup A s) f = 491 | sup B (partial_bind_seq f s). 492 | Proof. 493 | intros f s. change s with (Build_IncreasingSequence (seq s) (seq_increasing s)). 494 | exact idpath. 495 | Defined. 496 | 497 | Lemma sup_extensionality {A} : forall f g, (forall n, seq f n = seq g n) -> 498 | sup A f = sup A g. 499 | Proof. 500 | intros f g E. 501 | apply (antisymmetry le). 502 | - apply sup_le_r. intros n. rewrite E. apply sup_is_ub. 503 | - apply sup_le_r. intros n. rewrite <-E. apply sup_is_ub. 504 | Qed. 505 | 506 | Lemma sup_extensionality_tail {A} : forall f g, (forall n, seq f (S n) = seq g n) -> 507 | sup A f = sup A g. 508 | Proof. 509 | intros f g E. 510 | apply (antisymmetry le). 511 | - apply sup_le_r. intros n. transitivity (f (S n)). 512 | + apply seq_increasing. 513 | + rewrite E. apply sup_is_ub. 514 | - apply sup_le_r. intros n. transitivity (f (S n)). 515 | + rewrite E. reflexivity. 516 | + apply sup_is_ub. 517 | Qed. 518 | 519 | Definition partial_bind_eta_r {A:Type} : forall x, partial_bind x (eta A) = x. 520 | Proof. 521 | apply (partial_ind0 _ _);try reflexivity. 522 | intros f IH. 523 | change (partial_bind (sup A f) (eta A)) with 524 | (sup A (Build_IncreasingSequence 525 | (fun n : nat => bind (f n) (eta A)) 526 | (fun n : nat => partial_bind_le (eta A) (f n) (f (S n)) (seq_increasing f n)))). 527 | apply sup_extensionality. trivial. 528 | Defined. 529 | 530 | Lemma partial_bind_assoc {A B C:Type} : forall x f g, 531 | partial_bind (B:=C) (partial_bind (A:=A) (B:=B) x f) g = 532 | partial_bind x (fun a => partial_bind (f a) g). 533 | Proof. 534 | intros x f g;revert x;apply (partial_ind0 _ _). 535 | - reflexivity. 536 | - reflexivity. 537 | - intros s IH. 538 | change (sup C (partial_bind_seq g (partial_bind_seq f s)) = 539 | sup C (partial_bind_seq (fun a : A => partial_bind (f a) g) s)). 540 | apply sup_extensionality. apply IH. 541 | Defined. 542 | 543 | (* map of the partiality monad. *) 544 | Definition partial_map@{i j} {A:Type@{i} } {B:Type@{j} } 545 | (f : A -> B) : partial@{i} A -> partial@{j} B 546 | := fun x => partial_bind x (eta _ ∘ f). 547 | 548 | End monad. 549 | 550 | Section Fix. 551 | 552 | Record MonotoneTransformer (A B : Type) := 553 | { transform : (A -> partial B) -> A -> partial B 554 | ; transform_monotone : forall g1 g2, (forall x, g1 x <= g2 x) -> 555 | forall x, transform g1 x <= transform g2 x }. 556 | 557 | Coercion transform : MonotoneTransformer >-> Funclass. 558 | 559 | Context {A B : Type}. 560 | 561 | Variable f : MonotoneTransformer A B. 562 | 563 | Definition seq_transform : (A -> IncreasingSequence (partial B)) -> 564 | A -> IncreasingSequence (partial B). 565 | Proof. 566 | intros s x. exists (fun n => f (fun y => s y n) x). 567 | intros n. apply transform_monotone. intros y. apply seq_increasing. 568 | Defined. 569 | 570 | Lemma repeat_increasing : forall n x, 571 | Peano.nat_iter n f (fun _ => bot _) x <= Peano.nat_iter (S n) f (fun _ => bot _) x. 572 | Proof. 573 | induction n. 574 | - simpl;intros. apply bot_least. 575 | - simpl. apply transform_monotone. trivial. 576 | Defined. 577 | 578 | Definition Fix_sequence : A -> IncreasingSequence (partial B). 579 | Proof. 580 | intros x. exists (fun n => Peano.nat_iter n f (fun _ => bot _) x). 581 | intros;apply repeat_increasing. 582 | Defined. 583 | 584 | Definition Fix : A -> partial B := fun x => sup _ (Fix_sequence x). 585 | 586 | End Fix. 587 | 588 | Section Fix_pr. 589 | 590 | Record ContinuousTransformer A B := 591 | { cont_transform : MonotoneTransformer A B 592 | ; transform_continuous : forall (s : A -> IncreasingSequence (partial B)) x, 593 | cont_transform (Compose (sup _) s) x = 594 | sup _ (seq_transform cont_transform s x) }. 595 | Coercion cont_transform : ContinuousTransformer >-> MonotoneTransformer. 596 | 597 | Context {A B : Type}. 598 | 599 | Lemma Fix_pr : forall f : ContinuousTransformer A B, Fix f = f (Fix f). 600 | Proof. 601 | intros f. unfold Fix. apply path_forall. intros x. 602 | rewrite transform_continuous. apply sup_extensionality_tail. 603 | intros n. reflexivity. 604 | Qed. 605 | 606 | End Fix_pr. 607 | 608 | End contents. 609 | -------------------------------------------------------------------------------- /theories/sierpinsky.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | HoTT.Types.Universe 3 | HoTT.Basics.Decidable 4 | HoTT.HSet 5 | HoTT.Basics.PathGroupoids 6 | HoTT.Classes.interfaces.abstract_algebra 7 | HoTT.Classes.interfaces.orders 8 | HoTT.Classes.orders.lattices 9 | HoTT.Classes.theory.lattices 10 | HoTTClasses.partiality 11 | HoTT.Classes.implementations.peano_naturals. 12 | 13 | Local Set Universe Minimization ToSet. 14 | 15 | Definition Sier := partial Unit. 16 | 17 | Global Instance SierLe : Le Sier := _. 18 | Arguments SierLe _ _ /. 19 | 20 | Global Instance SierBot : Bottom Sier := bot _. 21 | 22 | Global Instance SierTop : Top Sier := eta _ tt. 23 | 24 | Definition IsTop (s : Sier) : Type0 := top <= s. 25 | Coercion IsTop : Sier >-> Sortclass. 26 | 27 | Section contents. 28 | Context `{Funext} `{Univalence}. 29 | 30 | Instance Sier_order : PartialOrder SierLe := partial_order _. 31 | 32 | Lemma top_greatest : forall x : Sier, x <= top. 33 | Proof. 34 | apply (partial_ind0 _ _). 35 | - intros [];reflexivity. 36 | - apply bot_least. 37 | - intros f IH. apply sup_le_r. exact IH. 38 | Qed. 39 | 40 | (* We need this for the bot_least case. *) 41 | Definition SierJoin_aux : forall y : Sier, Sier -> sigT (fun j : Sier => y <= j). 42 | Proof. 43 | intros y. apply (partial_rec Unit _ (fun a b => a.1 <= b.1)). 44 | simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl. 45 | - intros _;exists top. apply top_greatest. 46 | - exists y;reflexivity. 47 | - intros f IH. simpl in IH. simple refine (existT _ _ _);simpl. 48 | + apply sup. exists (fun n => (f n).1). 49 | exact IH. 50 | + transitivity ((f O).1). 51 | * apply ((f O).2). 52 | * exact (sup_is_ub _ {| seq := fun n : nat => (f n).1; seq_increasing := IH |} O). 53 | - intros;reflexivity. 54 | - simpl. apply pr2. 55 | - simpl. intros s p x. apply sup_le_l. 56 | - simpl. intros s p x IH. apply sup_le_r. 57 | apply IH. 58 | - intros a b E1 E2. apply Sigma.path_sigma_hprop. 59 | apply (antisymmetry le);trivial. 60 | Defined. 61 | 62 | Global Instance SierJoin : Join Sier 63 | := fun x y => (SierJoin_aux y x).1. 64 | 65 | Definition SierJoin_top : forall x : Sier, join top x = top 66 | := fun _ => idpath. 67 | 68 | Definition SierJoin_bot : forall x : Sier, join bottom x = x 69 | := fun _ => idpath. 70 | 71 | Instance SierJoin_preserve_le_l : forall y, OrderPreserving (fun x => join x y) 72 | := fun y => partialLe_rec _ _ (fun a b => a.1 <= b.1) _. 73 | 74 | Definition SierJoin_seq_l : IncreasingSequence Sier -> Sier -> 75 | IncreasingSequence Sier. 76 | Proof. 77 | intros s y;exists (fun n => join (s n) y). 78 | intros n;apply (order_preserving (fun x => join x y)). apply seq_increasing. 79 | Defined. 80 | 81 | Definition SierJoin_sup : forall s (y : Sier), 82 | join (sup _ s) y = sup _ (SierJoin_seq_l s y) 83 | := fun _ _ => idpath. 84 | 85 | Definition SierJoin_ub_r : forall x y : Sier, y <= join x y 86 | := fun x y => (SierJoin_aux y x).2. 87 | 88 | Instance SierJoin_is_join : JoinSemiLatticeOrder SierLe. 89 | Proof. 90 | split. 91 | - apply _. 92 | - intros x y;revert x;apply (partial_ind0 _ _). 93 | + intros [];reflexivity. 94 | + apply bot_least. 95 | + intros s IH. apply sup_le_r. 96 | intros n. change (join (sup Unit s) y) with (sup Unit (SierJoin_seq_l s y)). 97 | etransitivity;[apply IH|]. 98 | exact (sup_is_ub _ (SierJoin_seq_l s y) _). 99 | - apply SierJoin_ub_r. 100 | - apply (partial_ind0 _ (fun x => forall y z, _ -> _ -> _)). 101 | + intros [] y z E1 E2. apply E1. 102 | + intros y z E1 E2. apply E2. 103 | + intros s IH y z E1 E2. 104 | apply (sup_le_r _ (SierJoin_seq_l s y)). 105 | intros n. apply IH;trivial. 106 | apply sup_le_l. trivial. 107 | Qed. 108 | 109 | Global Instance SierMeet : Meet Sier. 110 | Proof. 111 | intros x y;revert x;apply (partial_rec Unit _ le). 112 | simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl. 113 | - intros _;exact y. 114 | - exact bottom. 115 | - intros f IH;simpl in IH. 116 | apply sup. exists f. exact IH. 117 | - reflexivity. 118 | - apply bot_least. 119 | - intros s p x IH;apply (sup_le_l _ _ _ IH). 120 | - intros s p x IH;apply sup_le_r. apply IH. 121 | Defined. 122 | 123 | Definition SierMeet_top : forall x : Sier, meet top x = x 124 | := fun _ => idpath. 125 | 126 | Definition SierMeet_bot : forall x : Sier, meet bottom x = bottom 127 | := fun _ => idpath. 128 | 129 | Instance SierMeet_preserve_le_l : forall y, OrderPreserving (fun x => meet x y) 130 | := fun y => partialLe_rec _ _ le _. 131 | 132 | Definition SierMeet_seq_l : IncreasingSequence Sier -> Sier -> 133 | IncreasingSequence Sier. 134 | Proof. 135 | intros s y;exists (fun n => meet (s n) y). 136 | intros n;apply (order_preserving (fun x => meet x y)). apply seq_increasing. 137 | Defined. 138 | 139 | Definition SierMeet_sup : forall s (y : Sier), 140 | meet (sup _ s) y = sup _ (SierMeet_seq_l s y) 141 | := fun _ _ => idpath. 142 | 143 | Lemma SierMeet_is_meet@{} : MeetSemiLatticeOrder SierLe. 144 | Proof. 145 | split. 146 | - apply _. 147 | - intros x y;revert x. apply (partial_ind0 _ _). 148 | + intros []. apply top_greatest. 149 | + intros;apply bot_least. 150 | + intros s IH. 151 | change (sup Unit s ⊓ y) with (sup _ (SierMeet_seq_l s y)). 152 | apply sup_le_r. intros n. simpl. 153 | etransitivity;[apply IH|]. apply sup_is_ub. 154 | - intros x y;revert x. apply (partial_ind0 _ _). 155 | + reflexivity. 156 | + apply bot_least. 157 | + intros s IH. 158 | change (sup Unit s ⊓ y) with (sup _ (SierMeet_seq_l s y)). 159 | apply sup_le_r. simpl. intros n;apply IH. 160 | - apply (partial_ind0 _ (fun x => forall y z, _ -> _ -> _)). 161 | + intros [] y z E1 E2. apply E2. 162 | + intros y z E1 E2. apply E1. 163 | + intros s IH y z;revert z y. 164 | apply (partial_ind0 _ (fun z => forall y, _ -> _ -> _)). 165 | * intros [] y E1 E2. 166 | apply (eta_le_sup _) in E1. 167 | revert E1;apply (Trunc_ind _);intros [n E1]. 168 | transitivity (meet (s n) y);auto. 169 | exact (sup_is_ub _ (SierMeet_seq_l _ _) _). 170 | * intros;apply bot_least. 171 | * intros s' IH' y E1 E2. 172 | apply sup_le_r. intros n. 173 | apply IH';(transitivity (sup _ s');[apply sup_is_ub|]);trivial. 174 | Qed. 175 | Existing Instance SierMeet_is_meet. 176 | 177 | Section distrib_lattice. 178 | 179 | Local Instance Sier_lattice_order : LatticeOrder SierLe := {}. 180 | Local Existing Instance join_sl_order_join_sl. 181 | Local Existing Instance meet_sl_order_meet_sl. 182 | 183 | Global Instance Sier_distributive_lattice : DistributiveLattice Sier. 184 | Proof. 185 | repeat (split;try apply _). 186 | - hnf. intros a b. apply (antisymmetry le). 187 | + apply join_le. 188 | * reflexivity. 189 | * apply meet_lb_l. 190 | + apply join_ub_l. 191 | - hnf. intros a b. apply (antisymmetry le). 192 | + apply meet_lb_l. 193 | + apply meet_le. 194 | * reflexivity. 195 | * apply join_ub_l. 196 | - hnf. intros a b c. apply (antisymmetry le). 197 | + apply join_le; apply meet_le. 198 | * apply join_ub_l. 199 | * apply join_ub_l. 200 | * transitivity b. 201 | { apply meet_lb_l. } 202 | { apply join_ub_r. } 203 | * transitivity c. 204 | { apply meet_lb_r. } 205 | { apply join_ub_r. } 206 | + revert a b c. apply (partial_ind0 _ (fun a => forall b c, _)). 207 | * intros [] b c. reflexivity. 208 | * reflexivity. 209 | * intros s IH b c. 210 | rewrite !SierJoin_sup,SierMeet_sup. 211 | apply sup_le_r. intros n. 212 | simpl. rewrite (commutativity (f:=meet)),SierMeet_sup;simpl. 213 | apply sup_le_r;intros m. 214 | simpl. 215 | assert (E : exists k, n <= k /\ m <= k) 216 | by (destruct (total le n m) as [E|E];eauto). 217 | destruct E as [k [En Em]]. 218 | etransitivity;[|apply (sup_is_ub _ _ k)]. 219 | simpl. etransitivity;[|apply IH]. 220 | apply meet_le. 221 | { etransitivity;[apply meet_lb_r|]. 222 | apply join_le;[|apply join_ub_r]. 223 | transitivity (s k);[|apply join_ub_l]. 224 | apply (order_preserving s). trivial. } 225 | { etransitivity;[apply meet_lb_l|]. 226 | apply join_le;[|apply join_ub_r]. 227 | transitivity (s k);[|apply join_ub_l]. 228 | apply (order_preserving s). trivial. } 229 | Qed. 230 | 231 | End distrib_lattice. 232 | Local Existing Instance join_sl_order_join_sl. 233 | Local Existing Instance meet_sl_order_meet_sl. 234 | 235 | Fixpoint joined_seq_aux (f : nat -> Sier) (n : nat) : Sier := 236 | match n with 237 | | O => f O 238 | | S k => join (joined_seq_aux f k) (f n) 239 | end. 240 | 241 | Definition joined_seq (f : nat -> Sier) : IncreasingSequence Sier. 242 | Proof. 243 | exists (joined_seq_aux f). 244 | intros;simpl. apply join_ub_l. 245 | Defined. 246 | 247 | Definition CountableSup (f : nat -> Sier) : Sier 248 | := sup _ (joined_seq f). 249 | 250 | Lemma joined_seq_ub_n : forall f n, f n <= joined_seq f n. 251 | Proof. 252 | intros f [|n]. 253 | - reflexivity. 254 | - simpl. apply join_ub_r. 255 | Qed. 256 | 257 | Lemma countable_sup_ub : forall f n, f n <= CountableSup f. 258 | Proof. 259 | intros. transitivity (joined_seq f n). 260 | - apply joined_seq_ub_n. 261 | - unfold CountableSup. apply sup_is_ub. 262 | Qed. 263 | 264 | Lemma joined_seq_least_ub_n' : forall f n x, (forall m, m <= n -> f m <= x) -> 265 | joined_seq f n <= x. 266 | Proof. 267 | intros f;induction n as [|n IHn];intros x E. 268 | - simpl. apply E. reflexivity. 269 | - simpl. apply join_le. 270 | + apply IHn. intros m Em;apply E. 271 | constructor;trivial. 272 | + apply E. reflexivity. 273 | Qed. 274 | 275 | Definition joined_seq_least_ub_n@{} := joined_seq_least_ub_n'@{Set Ularge Set}. 276 | 277 | Lemma countable_sup_least_ub : forall f x, (forall n, f n <= x) -> 278 | CountableSup f <= x. 279 | Proof. 280 | intros f x E. apply sup_le_r. 281 | intros n. apply joined_seq_least_ub_n. intros m _;apply E. 282 | Qed. 283 | 284 | Lemma top_le_meet : forall a b : Sier, meet a b <-> a /\ b. 285 | Proof. 286 | unfold IsTop. intros a b;split. 287 | - intros E;split;transitivity (meet a b);trivial. 288 | + apply meet_lb_l. 289 | + apply meet_lb_r. 290 | - intros [E1 E2]. apply meet_le;trivial. 291 | Qed. 292 | 293 | Lemma top_le_join@{} : forall a b : Sier, join a b <-> hor a b. 294 | Proof. 295 | unfold IsTop. intros a b;split. 296 | - revert a b;apply (partial_ind0 _ (fun a => forall b, _ -> _)). 297 | + intros [] ? E;apply tr;left;apply E. 298 | + intros b E;apply tr;right;apply E. 299 | + intros s IH b E. 300 | change (top <= sup _ (SierJoin_seq_l s b)) in E. 301 | apply (eta_le_sup _) in E. revert E. apply (Trunc_ind _). 302 | intros [n E]. simpl in E. 303 | apply IH in E. revert E;apply (Trunc_ind _). 304 | intros [E|E];apply tr;[left|right;trivial]. 305 | transitivity (s n);trivial. apply sup_is_ub. 306 | - apply (Trunc_ind _);intros [E|E]. 307 | + transitivity a;auto. apply join_ub_l. 308 | + transitivity b;auto. apply join_ub_r. 309 | Qed. 310 | 311 | Lemma top_le_joined_seq_n' : forall f n, joined_seq f n <-> 312 | merely (exists m, m <= n /\ f m). 313 | Proof. 314 | unfold IsTop. intros f;induction n as [|n IHn];simpl; 315 | (split;[intros E|apply (Trunc_ind _);intros [m [Em E]]]). 316 | - apply tr;exists 0;split;trivial. reflexivity. 317 | - rewrite (antisymmetry le m 0 Em (zero_least m)) in E. trivial. 318 | - apply top_le_join in E. revert E;apply (Trunc_ind _);intros [E|E]. 319 | + apply IHn in E;revert E;apply (Trunc_ind _);intros [m [E1 E2]]. 320 | apply tr;exists m;split;trivial. constructor;trivial. 321 | + apply tr;exists (S n);split;trivial. reflexivity. 322 | - apply le_S_either in Em. destruct Em as [Em|Em]. 323 | + transitivity (joined_seq f n);[|apply join_ub_l]. 324 | apply IHn. apply tr;exists m;auto. 325 | + rewrite <-Em. transitivity (f m);auto. apply join_ub_r. 326 | Qed. 327 | 328 | Definition top_le_joined_seq_n@{} := top_le_joined_seq_n'@{Set Ularge Set Set}. 329 | 330 | Lemma top_le_sup@{} : forall (s : IncreasingSequence Sier), 331 | IsTop (sup Unit s) <-> merely@{Set} (exists n, s n). 332 | Proof. 333 | intros s;split. 334 | - intros E. 335 | apply (eta_le_sup _) in E. 336 | exact E. 337 | - apply (Trunc_ind _);intros [n E]. 338 | red;transitivity (s n);trivial. 339 | apply sup_is_ub. 340 | Qed. 341 | 342 | Lemma top_le_countable_sup@{} : forall f, CountableSup f <-> 343 | merely (exists n, f n). 344 | Proof. 345 | unfold IsTop. intros f;split. 346 | - intros E. 347 | apply (eta_le_sup _) in E. 348 | revert E;apply (Trunc_ind _);intros [n E]. 349 | apply top_le_joined_seq_n in E. revert E;apply (Trunc_ind _);intros [m [_ E]]. 350 | apply tr;exists m;trivial. 351 | - apply (Trunc_ind _);intros [n E]. 352 | transitivity (f n);trivial. apply countable_sup_ub. 353 | Qed. 354 | 355 | Lemma countable_sup_meet_distr_r : forall a f, 356 | meet (CountableSup f) a = CountableSup (fun n => meet (f n) a). 357 | Proof. 358 | intros a f. 359 | unfold CountableSup at 1. rewrite SierMeet_sup. 360 | apply sup_extensionality;simpl. 361 | induction n as [|n IHn];simpl. 362 | - reflexivity. 363 | - simpl in IHn. rewrite <-IHn. 364 | apply meet_join_distr_r. 365 | Qed. 366 | 367 | Lemma countable_sup_meet_distr_l : forall a f, 368 | meet a (CountableSup f) = CountableSup (fun n => meet a (f n)). 369 | Proof. 370 | intros. rewrite (commutativity (f:=meet)),countable_sup_meet_distr_r. 371 | apply ap,path_forall. intros n. apply commutativity. 372 | Qed. 373 | 374 | Section enumerable_sup. 375 | Universe UA. 376 | Variable A : Type@{UA}. 377 | 378 | Context `{Enumerable A}. 379 | 380 | Definition EnumerableSup@{} (f : A -> Sier) : Sier 381 | := CountableSup (f ∘ (enumerator A)). 382 | 383 | Lemma enumerable_sup_ub' : forall (f:A->Sier) (x:A), f x <= EnumerableSup f. 384 | Proof. 385 | intros f x. 386 | generalize (center _ (enumerator_issurj _ x)). apply (Trunc_ind _). 387 | intros [a []]. clear x. unfold EnumerableSup. 388 | apply (countable_sup_ub (Compose _ _) a). 389 | Qed. 390 | 391 | Definition enumerable_sup_ub@{} := enumerable_sup_ub'@{Uhuge Ularge}. 392 | 393 | Lemma enumerable_sup_least_ub@{} : forall (f:A->Sier) s, (forall x, f x <= s) -> 394 | EnumerableSup f <= s. 395 | Proof. 396 | intros f s E. apply countable_sup_least_ub. 397 | intros;apply E. 398 | Qed. 399 | 400 | Lemma top_le_enumerable_sup' : forall f, iff@{Set UA UA} (EnumerableSup f) 401 | (merely (exists x, f x)). 402 | Proof. 403 | intros f;split. 404 | - intros E. apply top_le_countable_sup in E;revert E; 405 | apply (Trunc_ind _);intros [n E]. 406 | apply tr;econstructor;apply E. 407 | - apply (Trunc_ind _);intros [x E]. 408 | generalize (center _ (enumerator_issurj _ x)). apply (Trunc_ind _). 409 | intros [a Ea]. destruct Ea. 410 | apply top_le_countable_sup. apply tr;exists a;apply E. 411 | Qed. 412 | 413 | Definition top_le_enumerable_sup@{} := top_le_enumerable_sup'@{Uhuge Ularge}. 414 | 415 | Lemma enumerable_sup_meet_distr_l : forall a f, 416 | meet a (EnumerableSup f) = EnumerableSup (fun n => meet a (f n)). 417 | Proof. 418 | intros. apply countable_sup_meet_distr_l. 419 | Qed. 420 | 421 | Lemma enumerable_sup_meet_distr_r : forall a f, 422 | meet (EnumerableSup f) a = EnumerableSup (fun n => meet (f n) a). 423 | Proof. 424 | intros. apply countable_sup_meet_distr_r. 425 | Qed. 426 | 427 | End enumerable_sup. 428 | 429 | Lemma not_bot : ~ (@bottom Sier _). 430 | Proof. 431 | intros E. 432 | apply (not_eta_le_bot@{Set} _ tt). apply E. 433 | Qed. 434 | 435 | Lemma SierLe_imply : forall a b : Sier, a <= b -> a -> b. 436 | Proof. 437 | intros a b E E';red;transitivity a;trivial. 438 | Qed. 439 | 440 | Definition meet_top_l : forall a : Sier, meet top a = a 441 | := fun _ => idpath. 442 | 443 | Lemma meet_top_r : forall a : Sier, meet a top = a. 444 | Proof. 445 | intros. etransitivity;[|apply meet_top_l]. apply commutativity. 446 | Qed. 447 | 448 | Definition meet_bot_l : forall a : Sier, meet bottom a = bottom 449 | := fun _ => idpath. 450 | 451 | Lemma meet_bot_r : forall a : Sier, meet a bottom = bottom. 452 | Proof. 453 | intros. etransitivity;[|apply meet_bot_l]. apply commutativity. 454 | Qed. 455 | 456 | Definition join_top_l : forall a : Sier, join top a = top 457 | := fun _ => idpath. 458 | 459 | Lemma join_top_r : forall a : Sier, join a top = top. 460 | Proof. 461 | intros. etransitivity;[|apply join_top_l]. apply commutativity. 462 | Qed. 463 | 464 | Definition join_bot_l : forall a : Sier, join bottom a = a 465 | := fun _ => idpath. 466 | 467 | Lemma join_bot_r : forall a : Sier, join a bottom = a. 468 | Proof. 469 | intros. etransitivity;[|apply join_bot_l]. apply commutativity. 470 | Qed. 471 | 472 | Lemma top_le_eq : forall a : Sier, a -> a = top. 473 | Proof. 474 | intros a E. apply (antisymmetry le);trivial. 475 | apply top_greatest. 476 | Qed. 477 | 478 | Lemma bot_eq : forall a : Sier, a <= bottom -> a = bottom. 479 | Proof. 480 | intros a E. apply (antisymmetry le);trivial. 481 | apply bot_least. 482 | Qed. 483 | 484 | Lemma imply_le : forall a b : Sier, (a -> b) -> a <= b. 485 | Proof. 486 | apply (partial_ind0 _ (fun a => forall b, _ -> _)). 487 | - intros [] b E. apply E. apply top_greatest. 488 | - intros;apply bot_least. 489 | - intros s IH b E. apply sup_le_r. intros n. 490 | apply IH. intros En. apply E. 491 | red. transitivity (s n);trivial. apply sup_is_ub. 492 | Qed. 493 | 494 | Class SemiDecide@{i} (A : Type@{i}) := semi_decide : Sier. 495 | Arguments semi_decide A {_}. 496 | 497 | Class SemiDecidable@{i} (A : Type@{i}) `{SemiDecide A} 498 | := semi_decidable : iff@{Set i i} (semi_decide A) A. 499 | 500 | Global Instance decidable_semi_decide@{i} (A:Type@{i}) `{Decidable A} 501 | : SemiDecide A. 502 | Proof. 503 | red. exact (if dec A then top else bottom). 504 | Defined. 505 | Arguments decidable_semi_decide _ {_} /. 506 | 507 | Global Instance decidable_semi_decidable@{i} (A:Type@{i}) `{Decidable A} 508 | : SemiDecidable@{i} A. 509 | Proof. 510 | red. unfold semi_decide;simpl. destruct (dec A) as [E|E];split;intros E'. 511 | - trivial. 512 | - apply top_greatest. 513 | - apply not_bot in E'. destruct E'. 514 | - destruct (E E'). 515 | Qed. 516 | 517 | Lemma semidecidable_top@{i} {A:Type@{i} } `{SemiDecidable@{i} A} 518 | : A -> semi_decide A = top. 519 | Proof. 520 | intros E. apply top_le_eq. apply semi_decidable. trivial. 521 | Qed. 522 | 523 | Lemma semidecidable_bot@{i} {A:Type@{i} } `{SemiDecidable@{i} A} 524 | : ~ A -> semi_decide A = bottom. 525 | Proof. 526 | intros E'. apply bot_eq,imply_le. intros E. apply semi_decidable in E. 527 | destruct (E' E). 528 | Qed. 529 | 530 | Lemma semi_decide_meet_le@{i} (A:Type@{i}) `{SemiDecidable@{i} A} 531 | : forall b c, iff@{Set i i} (meet (semi_decide A) b <= c) (A -> b <= c). 532 | Proof. 533 | intros. split. 534 | - intros E Ea. rewrite (semidecidable_top Ea),meet_top_l in E. trivial. 535 | - intros E. apply imply_le;intros E'. 536 | apply top_le_meet in E';destruct E' as [E1 E2]. 537 | apply semi_decidable in E1. apply SierLe_imply with b;trivial. 538 | apply E;trivial. 539 | Qed. 540 | 541 | Global Instance semi_decide_conj@{i j k} (A:Type@{i}) `{SemiDecide A} 542 | (B:Type@{j}) `{SemiDecide B} 543 | : SemiDecide@{k} (A /\ B) 544 | := meet (semi_decide A) (semi_decide B). 545 | Arguments semi_decide_conj _ {_} _ {_} /. 546 | 547 | Global Instance semi_decidable_conj@{i j k} (A:Type@{i}) `{SemiDecidable@{i} A} 548 | (B:Type@{j}) `{SemiDecidable@{j} B} 549 | : SemiDecidable@{k} (A /\ B). 550 | Proof. 551 | split. 552 | - intros E;apply top_le_meet in E;destruct E as [E1 E2]; 553 | apply semi_decidable in E1;apply semi_decidable in E2;split;trivial. 554 | - intros [E1 E2];apply top_le_meet;split;apply semi_decidable;trivial. 555 | Qed. 556 | 557 | Global Instance semi_decide_disj@{i j k} (A:Type@{i}) `{SemiDecide@{i} A} 558 | (B:Type@{j}) `{SemiDecide@{j} B} 559 | : SemiDecide@{k} (hor@{i j k} A B) 560 | := join (semi_decide A) (semi_decide B). 561 | Arguments semi_decide_disj _ {_} _ {_} /. 562 | 563 | Global Instance semi_decidable_disj@{i j k} (A:Type@{i}) `{SemiDecidable@{i} A} 564 | (B:Type@{j}) `{SemiDecidable@{j} B} 565 | : SemiDecidable@{k} (hor@{i j k} A B). 566 | Proof. 567 | split. 568 | - intros E;apply top_le_join in E;revert E;apply (Trunc_ind _);intros [E|E]; 569 | apply semi_decidable in E;apply tr;auto. 570 | - apply (Trunc_ind _);intros [E|E];apply top_le_join,tr;[left|right]; 571 | apply semi_decidable;trivial. 572 | Qed. 573 | 574 | Global Instance semi_decide_exists@{i j k} (A : Type@{i}) `{Enumerable@{i} A} 575 | (B : A -> Type@{j}) `{forall x, SemiDecide@{j} (B x)} 576 | : SemiDecide@{k} (merely@{k} (exists x, B x)) 577 | := EnumerableSup A (fun x => semi_decide (B x)). 578 | Arguments semi_decide_exists A {_} B {_} /. 579 | 580 | Global Instance semi_decidable_exists@{i j k} (A : Type@{i}) `{Enumerable@{i} A} 581 | (B : A -> Type@{j}) `{!forall x, SemiDecide (B x)} 582 | `{!forall x, SemiDecidable@{j} (B x)} 583 | : SemiDecidable (merely@{k} (exists x, B x)). 584 | Proof. 585 | red;unfold semi_decide;simpl. 586 | split. 587 | - intros E;apply top_le_enumerable_sup in E. 588 | revert E;apply (Trunc_ind _);intros [x E];apply tr;exists x; 589 | apply semi_decidable,E. 590 | - apply (Trunc_ind _);intros [x E];apply top_le_enumerable_sup,tr;exists x. 591 | apply (snd semi_decidable),E. 592 | Qed. 593 | 594 | Global Instance semi_decide_sier (a : Sier) : SemiDecide a 595 | := a. 596 | Arguments semi_decide_sier _ /. 597 | 598 | Global Instance semi_decidable_sier (a : Sier) : SemiDecidable a. 599 | Proof. 600 | red. split;trivial. 601 | Qed. 602 | 603 | Section interleave. 604 | 605 | Definition disjoint (a b : Sier) := a -> b -> Empty. 606 | 607 | Lemma disjoint_top_l : forall b, disjoint top b -> b = bottom. 608 | Proof. 609 | intros b E. apply bot_eq. apply imply_le. 610 | intros Eb. apply Empty_ind,E;trivial. apply top_greatest. 611 | Qed. 612 | 613 | Lemma disjoint_sup_l : forall s b, disjoint (sup _ s) b -> 614 | forall n, disjoint (s n) b. 615 | Proof. 616 | intros s b E n E1 E2. 617 | apply E;trivial. apply top_le_sup. apply tr;eauto. 618 | Qed. 619 | 620 | Lemma disjoint_le_l : forall a b, disjoint a b -> forall a', a' <= a -> 621 | disjoint a' b. 622 | Proof. 623 | intros a b E a' Ea E1 E2;apply E;trivial. red; transitivity a';trivial. 624 | Qed. 625 | 626 | Definition interleave_aux_seq (s : IncreasingSequence Sier) 627 | (Is : forall (n : nat) (b : Sier), 628 | disjoint (s n) b -> partial bool) 629 | (Isle : forall (n : nat) (b : Sier) (Ea : disjoint (s n) b) 630 | (Ea' : disjoint (s (S n)) b), (Is n b Ea) ≤ (Is (S n) b Ea')) 631 | (b : Sier) 632 | (E : disjoint (sup Unit s) b) 633 | : IncreasingSequence (partial bool). 634 | Proof. 635 | simple refine (Build_IncreasingSequence _ _). 636 | - intros n. apply (Is n b). 637 | apply disjoint_sup_l;trivial. 638 | - simpl. auto. 639 | Defined. 640 | 641 | Definition interleave_inductors : Inductors Unit 642 | (fun a => forall b, disjoint a b -> sigT (fun s : partial bool => 643 | partial_map (const false) b <= s)) 644 | (fun a a' f g E => forall b Ea Ea', (f b Ea).1 <= (g b Ea').1). 645 | Proof. 646 | simple refine (Build_Inductors _ _ _ _ _ _ _ _ _ _ _ _);simpl. 647 | - intros [] b E. exists (eta _ true). 648 | rewrite (disjoint_top_l _ E). apply bot_least. 649 | - intros b _. exists (partial_map (const false) b). 650 | reflexivity. 651 | - intros s Is Isle b E. 652 | simple refine (existT _ _ _);simpl; 653 | [apply sup;apply (interleave_aux_seq s (fun n b E => (Is n b E).1) Isle b E)|]. 654 | etransitivity;[|apply (sup_is_ub _ _ 0)]. 655 | simpl. apply Is. 656 | - intros a f b Ea Ea'. 657 | assert (Hrw : Ea = Ea') by apply path_ishprop. 658 | apply (ap (f b)) in Hrw. apply (ap pr1) in Hrw. rewrite Hrw;reflexivity. 659 | - simpl. intros x f b _ E. 660 | apply f. 661 | - simpl;intros s x Ex fs fs_increasing fb Eb n a Ea Ea'. 662 | pose proof (fun b Ea Ea' => sup_le_l _ _ _ (Eb b Ea Ea')) as E; 663 | simpl in E. 664 | etransitivity;[|simple refine (E _ _ _ n);eapply disjoint_le_l;eauto]. 665 | set (Esup := disjoint_sup_l _ _ _ _). 666 | assert (Hrw : Ea = Esup) by apply path_ishprop. 667 | apply (ap (fs n a)),(ap pr1) in Hrw. rewrite <-Hrw;reflexivity. 668 | - simpl. intros s x Ex fs fs_incr fx IHs b ??. 669 | apply sup_le_r. intros n;simpl. 670 | auto. 671 | - simpl. intros x y fx fy Ex Ey. 672 | destruct (partial_antisymm Unit x y Ex Ey);simpl;clear Ex Ey. 673 | intros Efx Efy. 674 | apply path_forall;intros b;apply path_forall;intros Eb; 675 | apply Sigma.path_sigma_hprop. 676 | apply (antisymmetry le);trivial. 677 | Defined. 678 | 679 | Definition interleave : forall a b : Sier, disjoint a b -> partial bool 680 | := fun a b E => (partial_rect _ _ _ interleave_inductors a b E).1. 681 | 682 | Definition interleave_top_l_rw : forall b E, interleave top b E = eta _ true 683 | := fun _ _ => idpath. 684 | 685 | Definition interleave_le : forall a a', a <= a' -> forall b E E', 686 | interleave a b E <= interleave a' b E' 687 | := partialLe_rect _ _ _ interleave_inductors. 688 | 689 | Definition interleave_sup_l : forall s b E, interleave (sup _ s) b E = 690 | sup _ (Build_IncreasingSequence 691 | (fun n => interleave (s n) b (disjoint_sup_l _ _ E _ )) 692 | (fun n => interleave_le _ _ (seq_increasing _ _) _ _ _)) 693 | := fun _ _ _ => idpath. 694 | 695 | Lemma interleave_top_r_rw : forall a E, interleave a top E = eta _ false. 696 | Proof. 697 | apply (partial_ind0 _ (fun a => forall E, _)). 698 | - intros [] E. apply Empty_ind. apply E;apply reflexivity. 699 | - intros E. reflexivity. 700 | - intros s Es E. 701 | rewrite interleave_sup_l. 702 | apply (snd (eta_eq_sup_iff bool _ (Build_IncreasingSequence _ _))). 703 | apply tr;exists 0. simpl. 704 | apply Es. 705 | Qed. 706 | 707 | Lemma interleave_top_l : forall (a b : Sier) E, a -> 708 | interleave a b E = eta _ true. 709 | Proof. 710 | intros a b E Ea. 711 | apply top_le_eq in Ea. 712 | symmetry in Ea. destruct Ea. reflexivity. 713 | Qed. 714 | 715 | Lemma interleave_top_r : forall(a b : Sier) E, b -> 716 | interleave a b E = eta _ false. 717 | Proof. 718 | intros a b E Eb. 719 | apply top_le_eq in Eb. 720 | symmetry in Eb. destruct Eb. apply interleave_top_r_rw. 721 | Qed. 722 | 723 | Definition interleave_bot_rw : forall E, interleave bottom bottom E = bot _ 724 | := fun _ => idpath. 725 | 726 | Lemma interleave_bot : forall a b E, a <= bottom -> b <= bottom -> 727 | interleave a b E = bot _. 728 | Proof. 729 | intros a b E E1 E2. 730 | apply bot_eq in E1;apply bot_eq in E2. 731 | symmetry in E1;symmetry in E2. destruct E1,E2. 732 | reflexivity. 733 | Qed. 734 | 735 | Lemma interleave_le_const_r : forall a b E, 736 | partial_map (const false) b <= interleave a b E. 737 | Proof. 738 | intros. apply ((partial_rect _ _ _ interleave_inductors a b E).2). 739 | Qed. 740 | 741 | Lemma interleave_pr : forall a b E v, interleave a b E = eta _ v -> 742 | match v with true => a | false => b end. 743 | Proof. 744 | apply (partial_ind0 _ (fun a => forall b E v, _ -> _)). 745 | - intros [] b E v Ev. 746 | apply (injective (eta _)) in Ev. 747 | rewrite <-Ev;apply top_greatest. 748 | - intros b E v Ev. 749 | change (partial_map (const false) b = eta _ v) in Ev. 750 | clear E;revert b v Ev. apply (partial_ind0 _ (fun b => forall v, _ -> _)). 751 | + intros [] v E. apply (injective (eta _)) in E. 752 | rewrite <-E;apply top_greatest. 753 | + intros v E. change (bot _ = eta _ v) in E. 754 | apply Empty_ind,(not_eta_le_bot bool v). rewrite E;reflexivity. 755 | + intros s IHs v E. 756 | unfold partial_map in E;rewrite partial_bind_sup_l in E. 757 | apply (eta_eq_sup_iff _) in E. 758 | revert E;apply (Trunc_ind _);intros [n E]. 759 | simpl in E. apply IHs in E. 760 | destruct v;trivial. 761 | apply top_le_sup. apply tr;exists n;trivial. 762 | - intros s IHs b E v Ev. 763 | rewrite interleave_sup_l in Ev. 764 | apply (eta_eq_sup_iff _) in Ev. simpl in Ev. 765 | revert Ev;apply (Trunc_ind _);intros [n Ev]. 766 | apply IHs in Ev. destruct v;trivial. 767 | apply top_le_sup. apply tr;exists n;trivial. 768 | Qed. 769 | 770 | End interleave. 771 | 772 | End contents. 773 | 774 | Arguments semi_decide A {_}. 775 | Arguments decidable_semi_decide _ {_} /. 776 | Arguments semi_decide_conj {_} _ {_} _ {_} /. 777 | Arguments semi_decide_disj {_} _ {_} _ {_} /. 778 | Arguments semi_decide_sier _ /. 779 | Arguments semi_decide_exists {_} A {_} B {_} /. 780 | --------------------------------------------------------------------------------